{-# LANGUAGE DataKinds #-}

-- |
-- SPDX-License-Identifier: BSD-3-Clause
--
-- Loading world descriptions from `worlds/*.world`.
module Swarm.Game.World.Load where

import Control.Algebra (Has)
import Control.Arrow (left)
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.Text (Text)
import Swarm.Failure (Asset (..), AssetData (..), LoadingFailure (..), SystemFailure (..))
import Swarm.Game.Land
import Swarm.Game.World.Parse (parseWExp, runParser)
import Swarm.Game.World.Typecheck
import Swarm.Pretty (prettyText)
import Swarm.ResourceLoading (getDataDirSafe)
import Swarm.Util (acquireAllWithExt)
import Swarm.Util.Effect (withThrow)
import System.FilePath (dropExtension, joinPath, splitPath)
import Witch (into)

-- | Load and typecheck all world descriptions from `worlds/*.world`.
--   Throw an exception if any fail to parse or typecheck.
loadWorlds ::
  (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
  TerrainEntityMaps ->
  m WorldMap
loadWorlds :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
TerrainEntityMaps -> m WorldMap
loadWorlds TerrainEntityMaps
tem = do
  FilePath
dir <- AssetData -> FilePath -> m FilePath
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
AssetData -> FilePath -> m FilePath
getDataDirSafe AssetData
Worlds FilePath
"worlds"
  [(FilePath, FilePath)]
worldFiles <- IO [(FilePath, FilePath)] -> m [(FilePath, FilePath)]
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Lift IO) sig m =>
IO a -> m a
sendIO (IO [(FilePath, FilePath)] -> m [(FilePath, FilePath)])
-> IO [(FilePath, FilePath)] -> m [(FilePath, FilePath)]
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> IO [(FilePath, FilePath)]
acquireAllWithExt FilePath
dir FilePath
"world"
  [(Text, Some (TTerm '[]))]
ws <- ((FilePath, FilePath) -> m (Text, Some (TTerm '[])))
-> [(FilePath, FilePath)] -> m [(Text, Some (TTerm '[]))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (FilePath
-> TerrainEntityMaps
-> (FilePath, FilePath)
-> m (Text, Some (TTerm '[]))
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw SystemFailure) sig m =>
FilePath
-> TerrainEntityMaps
-> (FilePath, FilePath)
-> m (Text, Some (TTerm '[]))
loadWorld FilePath
dir TerrainEntityMaps
tem) [(FilePath, FilePath)]
worldFiles
  WorldMap -> m WorldMap
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (WorldMap -> m WorldMap)
-> ([(Text, Some (TTerm '[]))] -> WorldMap)
-> [(Text, Some (TTerm '[]))]
-> m WorldMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Text, Some (TTerm '[]))] -> WorldMap
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Text, Some (TTerm '[]))] -> m WorldMap)
-> [(Text, Some (TTerm '[]))] -> m WorldMap
forall a b. (a -> b) -> a -> b
$ [(Text, Some (TTerm '[]))]
ws

-- | Load a file containing a world DSL term, throwing an exception if
--   it fails to parse or typecheck.
loadWorld ::
  (Has (Throw SystemFailure) sig m) =>
  FilePath ->
  TerrainEntityMaps ->
  (FilePath, String) ->
  m (Text, Some (TTerm '[]))
loadWorld :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw SystemFailure) sig m =>
FilePath
-> TerrainEntityMaps
-> (FilePath, FilePath)
-> m (Text, Some (TTerm '[]))
loadWorld FilePath
dir TerrainEntityMaps
tem (FilePath
fp, FilePath
src) = do
  WExp
wexp <-
    Either SystemFailure WExp -> m WExp
forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
Either e a -> m a
liftEither (Either SystemFailure WExp -> m WExp)
-> (Either ParserError WExp -> Either SystemFailure WExp)
-> Either ParserError WExp
-> m WExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ParserError -> SystemFailure)
-> Either ParserError WExp -> Either SystemFailure WExp
forall b c d. (b -> c) -> Either b d -> Either c d
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 (LoadingFailure -> SystemFailure)
-> (ParserError -> LoadingFailure) -> ParserError -> SystemFailure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SystemFailure -> LoadingFailure
SystemFailure (SystemFailure -> LoadingFailure)
-> (ParserError -> SystemFailure) -> ParserError -> LoadingFailure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParserError -> SystemFailure
CanNotParseMegaparsec) (Either ParserError WExp -> m WExp)
-> Either ParserError WExp -> m WExp
forall a b. (a -> b) -> a -> b
$
      Parser WExp -> Text -> Either ParserError WExp
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 <-
    (CheckErr -> SystemFailure)
-> ThrowC CheckErr m (Some (TTerm '[])) -> m (Some (TTerm '[]))
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 (LoadingFailure -> SystemFailure)
-> (CheckErr -> LoadingFailure) -> CheckErr -> SystemFailure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SystemFailure -> LoadingFailure
SystemFailure (SystemFailure -> LoadingFailure)
-> (CheckErr -> SystemFailure) -> CheckErr -> LoadingFailure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> SystemFailure
DoesNotTypecheck (Text -> SystemFailure)
-> (CheckErr -> Text) -> CheckErr -> SystemFailure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. PrettyPrec a => a -> Text
prettyText @CheckErr) (ThrowC CheckErr m (Some (TTerm '[])) -> m (Some (TTerm '[])))
-> ThrowC CheckErr m (Some (TTerm '[])) -> m (Some (TTerm '[]))
forall a b. (a -> b) -> a -> b
$
      TerrainEntityMaps
-> ReaderC TerrainEntityMaps (ThrowC CheckErr m) (Some (TTerm '[]))
-> ThrowC CheckErr m (Some (TTerm '[]))
forall r (m :: * -> *) a. r -> ReaderC r m a -> m a
runReader TerrainEntityMaps
tem (ReaderC TerrainEntityMaps (ThrowC CheckErr m) (Some (TTerm '[]))
 -> ThrowC CheckErr m (Some (TTerm '[])))
-> (ReaderC
      WorldMap
      (ReaderC TerrainEntityMaps (ThrowC CheckErr m))
      (Some (TTerm '[]))
    -> ReaderC
         TerrainEntityMaps (ThrowC CheckErr m) (Some (TTerm '[])))
-> ReaderC
     WorldMap
     (ReaderC TerrainEntityMaps (ThrowC CheckErr m))
     (Some (TTerm '[]))
-> ThrowC CheckErr m (Some (TTerm '[]))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r (m :: * -> *) a. r -> ReaderC r m a -> m a
runReader @WorldMap WorldMap
forall k a. Map k a
M.empty (ReaderC
   WorldMap
   (ReaderC TerrainEntityMaps (ThrowC CheckErr m))
   (Some (TTerm '[]))
 -> ThrowC CheckErr m (Some (TTerm '[])))
-> ReaderC
     WorldMap
     (ReaderC TerrainEntityMaps (ThrowC CheckErr m))
     (Some (TTerm '[]))
-> ThrowC CheckErr m (Some (TTerm '[]))
forall a b. (a -> b) -> a -> b
$
        Ctx '[]
-> WExp
-> ReaderC
     WorldMap
     (ReaderC TerrainEntityMaps (ThrowC CheckErr m))
     (Some (TTerm '[]))
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) (g :: [*]).
(Has (Throw CheckErr) sig m, Has (Reader TerrainEntityMaps) sig m,
 Has (Reader WorldMap) sig m) =>
Ctx g -> WExp -> m (Some (TTerm g))
infer Ctx '[]
CNil WExp
wexp
  (Text, Some (TTerm '[])) -> m (Text, Some (TTerm '[]))
forall a. a -> m a
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)

-- | Strip a leading directory from a 'FilePath'.
stripDir :: FilePath -> FilePath -> FilePath
stripDir :: FilePath -> FilePath -> FilePath
stripDir FilePath
dir FilePath
fp = [FilePath] -> FilePath
joinPath (Int -> [FilePath] -> [FilePath]
forall a. Int -> [a] -> [a]
drop ([FilePath] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (FilePath -> [FilePath]
splitPath FilePath
dir)) (FilePath -> [FilePath]
splitPath FilePath
fp))