{-# 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.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.Failure (Asset (..), AssetData (..), LoadingFailure (..), SystemFailure (..))
import Swarm.Game.Land
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)

-- | Load and typecheck all world descriptions from `worlds/*.world`.
--   Emit a warning for each one which fails to parse or typecheck.
loadWorlds ::
  (Has (Accum (Seq SystemFailure)) sig m, Has (Lift IO) sig m) =>
  TerrainEntityMaps ->
  m WorldMap
loadWorlds :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Accum (Seq SystemFailure)) sig m, Has (Lift IO) sig m) =>
TerrainEntityMaps -> m WorldMap
loadWorlds TerrainEntityMaps
tem = do
  Maybe FilePath
res <- forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Accum (Seq e)) sig m =>
ThrowC e m a -> m (Maybe a)
throwToWarning @SystemFailure (ThrowC SystemFailure m FilePath -> m (Maybe FilePath))
-> ThrowC SystemFailure m FilePath -> m (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ AssetData -> FilePath -> ThrowC SystemFailure m FilePath
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 -> WorldMap -> m WorldMap
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return WorldMap
forall k a. Map k a
M.empty
    Just FilePath
dir -> do
      [(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"
      [Maybe (Text, Some (TTerm '[]))]
ws <- ((FilePath, FilePath) -> m (Maybe (Text, Some (TTerm '[]))))
-> [(FilePath, FilePath)] -> m [Maybe (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 (forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Accum (Seq e)) sig m =>
ThrowC e m a -> m (Maybe a)
throwToWarning @SystemFailure (ThrowC SystemFailure m (Text, Some (TTerm '[]))
 -> m (Maybe (Text, Some (TTerm '[]))))
-> ((FilePath, FilePath)
    -> ThrowC SystemFailure m (Text, Some (TTerm '[])))
-> (FilePath, FilePath)
-> m (Maybe (Text, Some (TTerm '[])))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath
-> TerrainEntityMaps
-> (FilePath, FilePath)
-> ThrowC SystemFailure 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)
-> ([Maybe (Text, Some (TTerm '[]))] -> WorldMap)
-> [Maybe (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 '[]))] -> WorldMap)
-> ([Maybe (Text, Some (TTerm '[]))] -> [(Text, Some (TTerm '[]))])
-> [Maybe (Text, Some (TTerm '[]))]
-> WorldMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe (Text, Some (TTerm '[]))] -> [(Text, Some (TTerm '[]))]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (Text, Some (TTerm '[]))] -> m WorldMap)
-> [Maybe (Text, Some (TTerm '[]))] -> m WorldMap
forall a b. (a -> b) -> a -> b
$ [Maybe (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
. ParserError -> LoadingFailure
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
. Text -> LoadingFailure
DoesNotTypecheck (Text -> LoadingFailure)
-> (CheckErr -> Text) -> CheckErr -> LoadingFailure
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))