{-# LANGUAGE OverloadedStrings #-}

-- |
-- SPDX-License-Identifier: BSD-3-Clause
--
-- Terrain types and properties.
module Swarm.Game.Terrain (
  TerrainType (..),
  TerrainObj (..),
  TerrainMap (..),
  blankTerrainIndex,
  getTerrainDefaultPaletteChar,
  getTerrainWord,
  terrainFromText,
  loadTerrain,
  mkTerrainMap,
  validateTerrainAttrRefs,
) where

import Control.Algebra (Has)
import Control.Arrow (first, (&&&))
import Control.Effect.Lift (Lift, sendIO)
import Control.Effect.Throw (Throw, liftEither, throwError)
import Control.Monad (forM, unless, (<=<))
import Data.Char (toUpper)
import Data.Hashable (Hashable)
import Data.IntMap (IntMap)
import Data.IntMap qualified as IM
import Data.Map (Map)
import Data.Map qualified as M
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Text (Text)
import Data.Text qualified as T
import Data.Tuple (swap)
import Data.Yaml
import GHC.Generics (Generic)
import Swarm.Failure
import Swarm.Game.Display
import Swarm.Game.Entity.Cosmetic (WorldAttr (..))
import Swarm.ResourceLoading (getDataFileNameSafe)
import Swarm.Util (enumeratedMap, quote)
import Swarm.Util.Effect (withThrow)

data TerrainType = BlankT | TerrainType Text
  deriving (TerrainType -> TerrainType -> Bool
(TerrainType -> TerrainType -> Bool)
-> (TerrainType -> TerrainType -> Bool) -> Eq TerrainType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TerrainType -> TerrainType -> Bool
== :: TerrainType -> TerrainType -> Bool
$c/= :: TerrainType -> TerrainType -> Bool
/= :: TerrainType -> TerrainType -> Bool
Eq, Eq TerrainType
Eq TerrainType =>
(TerrainType -> TerrainType -> Ordering)
-> (TerrainType -> TerrainType -> Bool)
-> (TerrainType -> TerrainType -> Bool)
-> (TerrainType -> TerrainType -> Bool)
-> (TerrainType -> TerrainType -> Bool)
-> (TerrainType -> TerrainType -> TerrainType)
-> (TerrainType -> TerrainType -> TerrainType)
-> Ord TerrainType
TerrainType -> TerrainType -> Bool
TerrainType -> TerrainType -> Ordering
TerrainType -> TerrainType -> TerrainType
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: TerrainType -> TerrainType -> Ordering
compare :: TerrainType -> TerrainType -> Ordering
$c< :: TerrainType -> TerrainType -> Bool
< :: TerrainType -> TerrainType -> Bool
$c<= :: TerrainType -> TerrainType -> Bool
<= :: TerrainType -> TerrainType -> Bool
$c> :: TerrainType -> TerrainType -> Bool
> :: TerrainType -> TerrainType -> Bool
$c>= :: TerrainType -> TerrainType -> Bool
>= :: TerrainType -> TerrainType -> Bool
$cmax :: TerrainType -> TerrainType -> TerrainType
max :: TerrainType -> TerrainType -> TerrainType
$cmin :: TerrainType -> TerrainType -> TerrainType
min :: TerrainType -> TerrainType -> TerrainType
Ord, Int -> TerrainType -> ShowS
[TerrainType] -> ShowS
TerrainType -> String
(Int -> TerrainType -> ShowS)
-> (TerrainType -> String)
-> ([TerrainType] -> ShowS)
-> Show TerrainType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TerrainType -> ShowS
showsPrec :: Int -> TerrainType -> ShowS
$cshow :: TerrainType -> String
show :: TerrainType -> String
$cshowList :: [TerrainType] -> ShowS
showList :: [TerrainType] -> ShowS
Show, (forall x. TerrainType -> Rep TerrainType x)
-> (forall x. Rep TerrainType x -> TerrainType)
-> Generic TerrainType
forall x. Rep TerrainType x -> TerrainType
forall x. TerrainType -> Rep TerrainType x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. TerrainType -> Rep TerrainType x
from :: forall x. TerrainType -> Rep TerrainType x
$cto :: forall x. Rep TerrainType x -> TerrainType
to :: forall x. Rep TerrainType x -> TerrainType
Generic, [TerrainType] -> Value
[TerrainType] -> Encoding
TerrainType -> Bool
TerrainType -> Value
TerrainType -> Encoding
(TerrainType -> Value)
-> (TerrainType -> Encoding)
-> ([TerrainType] -> Value)
-> ([TerrainType] -> Encoding)
-> (TerrainType -> Bool)
-> ToJSON TerrainType
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: TerrainType -> Value
toJSON :: TerrainType -> Value
$ctoEncoding :: TerrainType -> Encoding
toEncoding :: TerrainType -> Encoding
$ctoJSONList :: [TerrainType] -> Value
toJSONList :: [TerrainType] -> Value
$ctoEncodingList :: [TerrainType] -> Encoding
toEncodingList :: [TerrainType] -> Encoding
$comitField :: TerrainType -> Bool
omitField :: TerrainType -> Bool
ToJSON, Eq TerrainType
Eq TerrainType =>
(Int -> TerrainType -> Int)
-> (TerrainType -> Int) -> Hashable TerrainType
Int -> TerrainType -> Int
TerrainType -> Int
forall a. Eq a => (Int -> a -> Int) -> (a -> Int) -> Hashable a
$chashWithSalt :: Int -> TerrainType -> Int
hashWithSalt :: Int -> TerrainType -> Int
$chash :: TerrainType -> Int
hash :: TerrainType -> Int
Hashable)

blankTerrainIndex :: Int
blankTerrainIndex :: Int
blankTerrainIndex = Int
0

terrainFromText :: Text -> TerrainType
terrainFromText :: Text -> TerrainType
terrainFromText Text
"blank" = TerrainType
BlankT
terrainFromText Text
x = Text -> TerrainType
TerrainType Text
x

getTerrainWord :: TerrainType -> Text
getTerrainWord :: TerrainType -> Text
getTerrainWord TerrainType
BlankT = Text
"blank"
getTerrainWord (TerrainType Text
x) = Text
x

instance FromJSON TerrainType where
  parseJSON :: Value -> Parser TerrainType
parseJSON =
    String
-> (Text -> Parser TerrainType) -> Value -> Parser TerrainType
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"TerrainType" ((Text -> Parser TerrainType) -> Value -> Parser TerrainType)
-> (Text -> Parser TerrainType) -> Value -> Parser TerrainType
forall a b. (a -> b) -> a -> b
$
      TerrainType -> Parser TerrainType
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (TerrainType -> Parser TerrainType)
-> (Text -> TerrainType) -> Text -> Parser TerrainType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> TerrainType
terrainFromText

instance Semigroup TerrainType where
  TerrainType
t <> :: TerrainType -> TerrainType -> TerrainType
<> TerrainType
BlankT = TerrainType
t
  TerrainType
_ <> TerrainType
t = TerrainType
t

instance Monoid TerrainType where
  mempty :: TerrainType
mempty = TerrainType
BlankT

getTerrainDefaultPaletteChar :: TerrainType -> Char
getTerrainDefaultPaletteChar :: TerrainType -> Char
getTerrainDefaultPaletteChar = Char -> Char
toUpper (Char -> Char) -> (TerrainType -> Char) -> TerrainType -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Char
Text -> Char
T.head (Text -> Char) -> (TerrainType -> Text) -> TerrainType -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TerrainType -> Text
getTerrainWord

-- | Representation for parsing only. Not exported.
data TerrainItem = TerrainItem
  { TerrainItem -> TerrainType
name :: TerrainType
  , TerrainItem -> Text
attr :: Text
  , TerrainItem -> Text
description :: Text
  }
  deriving (TerrainItem -> TerrainItem -> Bool
(TerrainItem -> TerrainItem -> Bool)
-> (TerrainItem -> TerrainItem -> Bool) -> Eq TerrainItem
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TerrainItem -> TerrainItem -> Bool
== :: TerrainItem -> TerrainItem -> Bool
$c/= :: TerrainItem -> TerrainItem -> Bool
/= :: TerrainItem -> TerrainItem -> Bool
Eq, Eq TerrainItem
Eq TerrainItem =>
(TerrainItem -> TerrainItem -> Ordering)
-> (TerrainItem -> TerrainItem -> Bool)
-> (TerrainItem -> TerrainItem -> Bool)
-> (TerrainItem -> TerrainItem -> Bool)
-> (TerrainItem -> TerrainItem -> Bool)
-> (TerrainItem -> TerrainItem -> TerrainItem)
-> (TerrainItem -> TerrainItem -> TerrainItem)
-> Ord TerrainItem
TerrainItem -> TerrainItem -> Bool
TerrainItem -> TerrainItem -> Ordering
TerrainItem -> TerrainItem -> TerrainItem
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: TerrainItem -> TerrainItem -> Ordering
compare :: TerrainItem -> TerrainItem -> Ordering
$c< :: TerrainItem -> TerrainItem -> Bool
< :: TerrainItem -> TerrainItem -> Bool
$c<= :: TerrainItem -> TerrainItem -> Bool
<= :: TerrainItem -> TerrainItem -> Bool
$c> :: TerrainItem -> TerrainItem -> Bool
> :: TerrainItem -> TerrainItem -> Bool
$c>= :: TerrainItem -> TerrainItem -> Bool
>= :: TerrainItem -> TerrainItem -> Bool
$cmax :: TerrainItem -> TerrainItem -> TerrainItem
max :: TerrainItem -> TerrainItem -> TerrainItem
$cmin :: TerrainItem -> TerrainItem -> TerrainItem
min :: TerrainItem -> TerrainItem -> TerrainItem
Ord, Int -> TerrainItem -> ShowS
[TerrainItem] -> ShowS
TerrainItem -> String
(Int -> TerrainItem -> ShowS)
-> (TerrainItem -> String)
-> ([TerrainItem] -> ShowS)
-> Show TerrainItem
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TerrainItem -> ShowS
showsPrec :: Int -> TerrainItem -> ShowS
$cshow :: TerrainItem -> String
show :: TerrainItem -> String
$cshowList :: [TerrainItem] -> ShowS
showList :: [TerrainItem] -> ShowS
Show, (forall x. TerrainItem -> Rep TerrainItem x)
-> (forall x. Rep TerrainItem x -> TerrainItem)
-> Generic TerrainItem
forall x. Rep TerrainItem x -> TerrainItem
forall x. TerrainItem -> Rep TerrainItem x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. TerrainItem -> Rep TerrainItem x
from :: forall x. TerrainItem -> Rep TerrainItem x
$cto :: forall x. Rep TerrainItem x -> TerrainItem
to :: forall x. Rep TerrainItem x -> TerrainItem
Generic, Maybe TerrainItem
Value -> Parser [TerrainItem]
Value -> Parser TerrainItem
(Value -> Parser TerrainItem)
-> (Value -> Parser [TerrainItem])
-> Maybe TerrainItem
-> FromJSON TerrainItem
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser TerrainItem
parseJSON :: Value -> Parser TerrainItem
$cparseJSONList :: Value -> Parser [TerrainItem]
parseJSONList :: Value -> Parser [TerrainItem]
$comittedField :: Maybe TerrainItem
omittedField :: Maybe TerrainItem
FromJSON, [TerrainItem] -> Value
[TerrainItem] -> Encoding
TerrainItem -> Bool
TerrainItem -> Value
TerrainItem -> Encoding
(TerrainItem -> Value)
-> (TerrainItem -> Encoding)
-> ([TerrainItem] -> Value)
-> ([TerrainItem] -> Encoding)
-> (TerrainItem -> Bool)
-> ToJSON TerrainItem
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: TerrainItem -> Value
toJSON :: TerrainItem -> Value
$ctoEncoding :: TerrainItem -> Encoding
toEncoding :: TerrainItem -> Encoding
$ctoJSONList :: [TerrainItem] -> Value
toJSONList :: [TerrainItem] -> Value
$ctoEncodingList :: [TerrainItem] -> Encoding
toEncodingList :: [TerrainItem] -> Encoding
$comitField :: TerrainItem -> Bool
omitField :: TerrainItem -> Bool
ToJSON)

data TerrainObj = TerrainObj
  { TerrainObj -> TerrainType
terrainName :: TerrainType
  , TerrainObj -> Text
terrainDesc :: Text
  , TerrainObj -> Display
terrainDisplay :: Display
  }
  deriving (Int -> TerrainObj -> ShowS
[TerrainObj] -> ShowS
TerrainObj -> String
(Int -> TerrainObj -> ShowS)
-> (TerrainObj -> String)
-> ([TerrainObj] -> ShowS)
-> Show TerrainObj
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TerrainObj -> ShowS
showsPrec :: Int -> TerrainObj -> ShowS
$cshow :: TerrainObj -> String
show :: TerrainObj -> String
$cshowList :: [TerrainObj] -> ShowS
showList :: [TerrainObj] -> ShowS
Show)

promoteTerrainObjects :: [TerrainItem] -> [TerrainObj]
promoteTerrainObjects :: [TerrainItem] -> [TerrainObj]
promoteTerrainObjects =
  (TerrainItem -> TerrainObj) -> [TerrainItem] -> [TerrainObj]
forall a b. (a -> b) -> [a] -> [b]
map (\(TerrainItem TerrainType
n Text
a Text
d) -> TerrainType -> Text -> Display -> TerrainObj
TerrainObj TerrainType
n Text
d (Display -> TerrainObj) -> Display -> TerrainObj
forall a b. (a -> b) -> a -> b
$ Attribute -> Display
defaultTerrainDisplay (Text -> Attribute
AWorld Text
a))

invertedIndexMap :: IntMap TerrainObj -> Map TerrainType Int
invertedIndexMap :: IntMap TerrainObj -> Map TerrainType Int
invertedIndexMap = [(TerrainType, Int)] -> Map TerrainType Int
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(TerrainType, Int)] -> Map TerrainType Int)
-> (IntMap TerrainObj -> [(TerrainType, Int)])
-> IntMap TerrainObj
-> Map TerrainType Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, TerrainObj) -> (TerrainType, Int))
-> [(Int, TerrainObj)] -> [(TerrainType, Int)]
forall a b. (a -> b) -> [a] -> [b]
map ((TerrainObj -> TerrainType)
-> (TerrainObj, Int) -> (TerrainType, Int)
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first TerrainObj -> TerrainType
terrainName ((TerrainObj, Int) -> (TerrainType, Int))
-> ((Int, TerrainObj) -> (TerrainObj, Int))
-> (Int, TerrainObj)
-> (TerrainType, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, TerrainObj) -> (TerrainObj, Int)
forall a b. (a, b) -> (b, a)
swap) ([(Int, TerrainObj)] -> [(TerrainType, Int)])
-> (IntMap TerrainObj -> [(Int, TerrainObj)])
-> IntMap TerrainObj
-> [(TerrainType, Int)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntMap TerrainObj -> [(Int, TerrainObj)]
forall a. IntMap a -> [(Int, a)]
IM.toList

-- | Each terrain type shall have a unique
-- integral index. The indices should
-- be consecutive by parse order.
data TerrainMap = TerrainMap
  { TerrainMap -> Map TerrainType TerrainObj
terrainByName :: Map TerrainType TerrainObj
  , TerrainMap -> IntMap TerrainObj
terrainByIndex :: IntMap TerrainObj
  , TerrainMap -> Map TerrainType Int
terrainIndexByName :: Map TerrainType Int
  -- ^ basically the inverse of 'terrainByIndex'.
  -- This needs to be (is) recomputed upon every update to
  -- the other fields in 'TerrainMap'.
  }
  deriving (Int -> TerrainMap -> ShowS
[TerrainMap] -> ShowS
TerrainMap -> String
(Int -> TerrainMap -> ShowS)
-> (TerrainMap -> String)
-> ([TerrainMap] -> ShowS)
-> Show TerrainMap
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TerrainMap -> ShowS
showsPrec :: Int -> TerrainMap -> ShowS
$cshow :: TerrainMap -> String
show :: TerrainMap -> String
$cshowList :: [TerrainMap] -> ShowS
showList :: [TerrainMap] -> ShowS
Show)

instance Semigroup TerrainMap where
  TerrainMap Map TerrainType TerrainObj
oldByName IntMap TerrainObj
oldByIndex Map TerrainType Int
_ <> :: TerrainMap -> TerrainMap -> TerrainMap
<> TerrainMap Map TerrainType TerrainObj
newByName IntMap TerrainObj
newByIndex Map TerrainType Int
_ =
    Map TerrainType TerrainObj
-> IntMap TerrainObj -> Map TerrainType Int -> TerrainMap
TerrainMap
      (Map TerrainType TerrainObj
oldByName Map TerrainType TerrainObj
-> Map TerrainType TerrainObj -> Map TerrainType TerrainObj
forall a. Semigroup a => a -> a -> a
<> Map TerrainType TerrainObj
newByName)
      IntMap TerrainObj
combinedTerrainByIndex
      (IntMap TerrainObj -> Map TerrainType Int
invertedIndexMap IntMap TerrainObj
combinedTerrainByIndex)
   where
    combinedTerrainByIndex :: IntMap TerrainObj
combinedTerrainByIndex = IntMap TerrainObj
oldByIndex IntMap TerrainObj -> IntMap TerrainObj -> IntMap TerrainObj
forall a. Semigroup a => a -> a -> a
<> Int -> [TerrainObj] -> IntMap TerrainObj
forall a. Int -> [a] -> IntMap a
enumeratedMap (IntMap TerrainObj -> Int
forall a. IntMap a -> Int
IM.size IntMap TerrainObj
oldByIndex) (IntMap TerrainObj -> [TerrainObj]
forall a. IntMap a -> [a]
IM.elems IntMap TerrainObj
newByIndex)

instance Monoid TerrainMap where
  mempty :: TerrainMap
mempty = Map TerrainType TerrainObj
-> IntMap TerrainObj -> Map TerrainType Int -> TerrainMap
TerrainMap Map TerrainType TerrainObj
forall a. Monoid a => a
mempty IntMap TerrainObj
forall a. Monoid a => a
mempty Map TerrainType Int
forall a. Monoid a => a
mempty

mkTerrainMap :: [TerrainObj] -> TerrainMap
mkTerrainMap :: [TerrainObj] -> TerrainMap
mkTerrainMap [TerrainObj]
items =
  TerrainMap
    { terrainByName :: Map TerrainType TerrainObj
terrainByName = [(TerrainType, TerrainObj)] -> Map TerrainType TerrainObj
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(TerrainType, TerrainObj)] -> Map TerrainType TerrainObj)
-> [(TerrainType, TerrainObj)] -> Map TerrainType TerrainObj
forall a b. (a -> b) -> a -> b
$ (TerrainObj -> (TerrainType, TerrainObj))
-> [TerrainObj] -> [(TerrainType, TerrainObj)]
forall a b. (a -> b) -> [a] -> [b]
map (TerrainObj -> TerrainType
terrainName (TerrainObj -> TerrainType)
-> (TerrainObj -> TerrainObj)
-> TerrainObj
-> (TerrainType, TerrainObj)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& TerrainObj -> TerrainObj
forall a. a -> a
id) [TerrainObj]
items
    , terrainByIndex :: IntMap TerrainObj
terrainByIndex = IntMap TerrainObj
byIndex
    , terrainIndexByName :: Map TerrainType Int
terrainIndexByName = IntMap TerrainObj -> Map TerrainType Int
invertedIndexMap IntMap TerrainObj
byIndex
    }
 where
  byIndex :: IntMap TerrainObj
byIndex = Int -> [TerrainObj] -> IntMap TerrainObj
forall a. Int -> [a] -> IntMap a
enumeratedMap Int
blankTerrainIndex [TerrainObj]
items

-- | Validates references to 'Display' attributes
validateTerrainAttrRefs :: Has (Throw LoadingFailure) sig m => Set WorldAttr -> [TerrainItem] -> m [TerrainObj]
validateTerrainAttrRefs :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw LoadingFailure) sig m =>
Set WorldAttr -> [TerrainItem] -> m [TerrainObj]
validateTerrainAttrRefs Set WorldAttr
validAttrs [TerrainItem]
rawTerrains =
  [TerrainItem] -> (TerrainItem -> m TerrainObj) -> m [TerrainObj]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [TerrainItem]
rawTerrains ((TerrainItem -> m TerrainObj) -> m [TerrainObj])
-> (TerrainItem -> m TerrainObj) -> m [TerrainObj]
forall a b. (a -> b) -> a -> b
$ \(TerrainItem TerrainType
n Text
a Text
d) -> do
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (WorldAttr -> Set WorldAttr -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member (String -> WorldAttr
WorldAttr (String -> WorldAttr) -> String -> WorldAttr
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
a) Set WorldAttr
validAttrs)
      (m () -> m ()) -> (Text -> m ()) -> Text -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LoadingFailure -> m ()
forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
e -> m a
throwError
      (LoadingFailure -> m ())
-> (Text -> LoadingFailure) -> Text -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SystemFailure -> LoadingFailure
SystemFailure
      (SystemFailure -> LoadingFailure)
-> (Text -> SystemFailure) -> Text -> LoadingFailure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> SystemFailure
CustomFailure
      (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unwords
        [ Text
"Nonexistent attribute"
        , Text -> Text
quote Text
a
        , Text
"referenced by terrain"
        , Text -> Text
quote (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ TerrainType -> Text
getTerrainWord TerrainType
n
        ]

    TerrainObj -> m TerrainObj
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (TerrainObj -> m TerrainObj) -> TerrainObj -> m TerrainObj
forall a b. (a -> b) -> a -> b
$ TerrainType -> Text -> Display -> TerrainObj
TerrainObj TerrainType
n Text
d (Display -> TerrainObj) -> Display -> TerrainObj
forall a b. (a -> b) -> a -> b
$ Attribute -> Display
defaultTerrainDisplay (Text -> Attribute
AWorld Text
a)

-- | Load terrain from a data file called @terrains.yaml@, producing
--   either an 'TerrainMap' or a parse error.
loadTerrain ::
  (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
  m TerrainMap
loadTerrain :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
m TerrainMap
loadTerrain = do
  String
fileName <- AssetData -> String -> m String
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
AssetData -> String -> m String
getDataFileNameSafe AssetData
Terrain String
terrainFile
  [TerrainItem]
decoded <-
    (ParseException -> SystemFailure)
-> ThrowC ParseException m [TerrainItem] -> m [TerrainItem]
forall e2 (sig :: (* -> *) -> * -> *) (m :: * -> *) e1 a.
Has (Throw e2) sig m =>
(e1 -> e2) -> ThrowC e1 m a -> m a
withThrow (LoadingFailure -> SystemFailure
terrainFailure (LoadingFailure -> SystemFailure)
-> (ParseException -> LoadingFailure)
-> ParseException
-> SystemFailure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseException -> LoadingFailure
CanNotParseYaml) (ThrowC ParseException m [TerrainItem] -> m [TerrainItem])
-> (IO (Either ParseException [TerrainItem])
    -> ThrowC ParseException m [TerrainItem])
-> IO (Either ParseException [TerrainItem])
-> m [TerrainItem]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either ParseException [TerrainItem]
-> ThrowC ParseException m [TerrainItem]
forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
Either e a -> m a
liftEither (Either ParseException [TerrainItem]
 -> ThrowC ParseException m [TerrainItem])
-> (IO (Either ParseException [TerrainItem])
    -> ThrowC ParseException m (Either ParseException [TerrainItem]))
-> IO (Either ParseException [TerrainItem])
-> ThrowC ParseException m [TerrainItem]
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< IO (Either ParseException [TerrainItem])
-> ThrowC ParseException m (Either ParseException [TerrainItem])
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Lift IO) sig m =>
IO a -> m a
sendIO) (IO (Either ParseException [TerrainItem]) -> m [TerrainItem])
-> IO (Either ParseException [TerrainItem]) -> m [TerrainItem]
forall a b. (a -> b) -> a -> b
$
      String -> IO (Either ParseException [TerrainItem])
forall a. FromJSON a => String -> IO (Either ParseException a)
decodeFileEither String
fileName

  let terrainObjs :: [TerrainObj]
terrainObjs = [TerrainItem] -> [TerrainObj]
promoteTerrainObjects [TerrainItem]
decoded
  -- Ensures that the blank terrain gets index 0
  TerrainMap -> m TerrainMap
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (TerrainMap -> m TerrainMap) -> TerrainMap -> m TerrainMap
forall a b. (a -> b) -> a -> b
$ [TerrainObj] -> TerrainMap
mkTerrainMap ([TerrainObj] -> TerrainMap) -> [TerrainObj] -> TerrainMap
forall a b. (a -> b) -> a -> b
$ TerrainObj
blankTerrainObj TerrainObj -> [TerrainObj] -> [TerrainObj]
forall a. a -> [a] -> [a]
: [TerrainObj]
terrainObjs
 where
  terrainFile :: String
terrainFile = String
"terrains.yaml"
  terrainFailure :: LoadingFailure -> SystemFailure
terrainFailure = Asset -> String -> LoadingFailure -> SystemFailure
AssetNotLoaded (AssetData -> Asset
Data AssetData
Terrain) String
terrainFile

  blankTerrainObj :: TerrainObj
blankTerrainObj = TerrainType -> Text -> Display -> TerrainObj
TerrainObj TerrainType
BlankT Text
"Blank terrain" (Display -> TerrainObj) -> Display -> TerrainObj
forall a b. (a -> b) -> a -> b
$ Attribute -> Display
defaultTerrainDisplay Attribute
ADefault