{-# 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.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)

-- | 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) =>
  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

-- | 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 ->
  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)

-- | Strip a leading directory from a 'FilePath'.
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))