{-# LANGUAGE DataKinds #-}
module Swarm.Game.World.Load where
import Control.Algebra (Has)
import Control.Arrow (left)
import Control.Carrier.Accum.FixedStrict (Accum)
import Control.Carrier.Lift (Lift, sendIO)
import Control.Carrier.Reader (runReader)
import Control.Effect.Throw (Throw, liftEither)
import Data.Map qualified as M
import Data.Maybe (catMaybes)
import Data.Sequence (Seq)
import Data.Text (Text)
import Swarm.Game.Entity (EntityMap)
import Swarm.Game.Failure (Asset (..), AssetData (..), LoadingFailure (..), SystemFailure (..))
import Swarm.Game.ResourceLoading (getDataDirSafe)
import Swarm.Game.World.Parse (parseWExp, runParser)
import Swarm.Game.World.Typecheck
import Swarm.Language.Pretty (prettyText)
import Swarm.Util (acquireAllWithExt)
import Swarm.Util.Effect (throwToWarning, withThrow)
import System.FilePath (dropExtension, joinPath, splitPath)
import Witch (into)
loadWorlds ::
(Has (Accum (Seq SystemFailure)) sig m, Has (Lift IO) sig m) =>
EntityMap ->
m WorldMap
loadWorlds :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Accum (Seq SystemFailure)) sig m, Has (Lift IO) sig m) =>
EntityMap -> m WorldMap
loadWorlds EntityMap
em = do
Maybe FilePath
res <- forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Accum (Seq e)) sig m =>
ThrowC e m a -> m (Maybe a)
throwToWarning @SystemFailure forall a b. (a -> b) -> a -> b
$ forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
AssetData -> FilePath -> m FilePath
getDataDirSafe AssetData
Worlds FilePath
"worlds"
case Maybe FilePath
res of
Maybe FilePath
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall k a. Map k a
M.empty
Just FilePath
dir -> do
[(FilePath, FilePath)]
worldFiles <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Lift IO) sig m =>
IO a -> m a
sendIO forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> IO [(FilePath, FilePath)]
acquireAllWithExt FilePath
dir FilePath
"world"
[Maybe (Text, Some (TTerm '[]))]
ws <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Accum (Seq e)) sig m =>
ThrowC e m a -> m (Maybe a)
throwToWarning @SystemFailure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw SystemFailure) sig m =>
FilePath
-> EntityMap -> (FilePath, FilePath) -> m (Text, Some (TTerm '[]))
loadWorld FilePath
dir EntityMap
em) [(FilePath, FilePath)]
worldFiles
forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ [Maybe (Text, Some (TTerm '[]))]
ws
loadWorld ::
(Has (Throw SystemFailure) sig m) =>
FilePath ->
EntityMap ->
(FilePath, String) ->
m (Text, Some (TTerm '[]))
loadWorld :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw SystemFailure) sig m =>
FilePath
-> EntityMap -> (FilePath, FilePath) -> m (Text, Some (TTerm '[]))
loadWorld FilePath
dir EntityMap
em (FilePath
fp, FilePath
src) = do
WExp
wexp <-
forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
Either e a -> m a
liftEither forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left (Asset -> FilePath -> LoadingFailure -> SystemFailure
AssetNotLoaded (AssetData -> Asset
Data AssetData
Worlds) FilePath
fp forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParserError -> LoadingFailure
CanNotParseMegaparsec) forall a b. (a -> b) -> a -> b
$
forall a. Parser a -> Text -> Either ParserError a
runParser Parser WExp
parseWExp (forall target source. From source target => source -> target
into @Text FilePath
src)
Some (TTerm '[])
t <-
forall e2 (sig :: (* -> *) -> * -> *) (m :: * -> *) e1 a.
Has (Throw e2) sig m =>
(e1 -> e2) -> ThrowC e1 m a -> m a
withThrow (Asset -> FilePath -> LoadingFailure -> SystemFailure
AssetNotLoaded (AssetData -> Asset
Data AssetData
Worlds) FilePath
fp forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> LoadingFailure
DoesNotTypecheck forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. PrettyPrec a => a -> Text
prettyText @CheckErr) forall a b. (a -> b) -> a -> b
$
forall r (m :: * -> *) a. r -> ReaderC r m a -> m a
runReader EntityMap
em forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r (m :: * -> *) a. r -> ReaderC r m a -> m a
runReader @WorldMap forall k a. Map k a
M.empty forall a b. (a -> b) -> a -> b
$
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) (g :: [*]).
(Has (Throw CheckErr) sig m, Has (Reader EntityMap) sig m,
Has (Reader WorldMap) sig m) =>
Ctx g -> WExp -> m (Some (TTerm g))
infer Ctx '[]
CNil WExp
wexp
forall (m :: * -> *) a. Monad m => a -> m a
return (forall target source. From source target => source -> target
into @Text (FilePath -> FilePath
dropExtension (FilePath -> FilePath -> FilePath
stripDir FilePath
dir FilePath
fp)), Some (TTerm '[])
t)
stripDir :: FilePath -> FilePath -> FilePath
stripDir :: FilePath -> FilePath -> FilePath
stripDir FilePath
dir FilePath
fp = [FilePath] -> FilePath
joinPath (forall a. Int -> [a] -> [a]
drop (forall (t :: * -> *) a. Foldable t => t a -> Int
length (FilePath -> [FilePath]
splitPath FilePath
dir)) (FilePath -> [FilePath]
splitPath FilePath
fp))