{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RecordWildCards #-}
module Slab.Execute
( executeFile
, execute
) where
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Except (ExceptT, runExceptT)
import Data.Text qualified as T
import Slab.Error qualified as Error
import Slab.Evaluate qualified as Evaluate
import Slab.PreProcess qualified as PreProcess
import Slab.Syntax qualified as Syntax
import System.Process (cwd, readCreateProcess, shell)
executeFile :: FilePath -> IO (Either Error.Error [Syntax.Block])
executeFile :: FilePath -> IO (Either Error [Block])
executeFile FilePath
path =
ExceptT Error IO [Block] -> IO (Either Error [Block])
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT Error IO [Block] -> IO (Either Error [Block]))
-> ExceptT Error IO [Block] -> IO (Either Error [Block])
forall a b. (a -> b) -> a -> b
$
FilePath -> ExceptT Error IO [Block]
PreProcess.preprocessFileE FilePath
path
ExceptT Error IO [Block]
-> ([Block] -> ExceptT Error IO [Block])
-> ExceptT Error IO [Block]
forall a b.
ExceptT Error IO a
-> (a -> ExceptT Error IO b) -> ExceptT Error IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Env -> [Text] -> [Block] -> ExceptT Error IO [Block]
forall (m :: * -> *).
Monad m =>
Env -> [Text] -> [Block] -> ExceptT Error m [Block]
Evaluate.evaluate Env
Evaluate.defaultEnv [Text
"toplevel"]
ExceptT Error IO [Block]
-> ([Block] -> ExceptT Error IO [Block])
-> ExceptT Error IO [Block]
forall a b.
ExceptT Error IO a
-> (a -> ExceptT Error IO b) -> ExceptT Error IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FilePath -> [Block] -> ExceptT Error IO [Block]
execute FilePath
path
execute
:: FilePath
-> [Syntax.Block]
-> ExceptT Error.Error IO [Syntax.Block]
execute :: FilePath -> [Block] -> ExceptT Error IO [Block]
execute FilePath
ctx = (Block -> ExceptT Error IO Block)
-> [Block] -> ExceptT Error IO [Block]
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 -> Block -> ExceptT Error IO Block
exec FilePath
ctx)
exec :: FilePath -> Syntax.Block -> ExceptT Error.Error IO Syntax.Block
exec :: FilePath -> Block -> ExceptT Error IO Block
exec FilePath
ctx = \case
node :: Block
node@Block
Syntax.BlockDoctype -> Block -> ExceptT Error IO Block
forall a. a -> ExceptT Error IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Block
node
Syntax.BlockElem Elem
name TrailingSym
mdot [Attr]
attrs [Block]
nodes -> do
[Block]
nodes' <- FilePath -> [Block] -> ExceptT Error IO [Block]
execute FilePath
ctx [Block]
nodes
Block -> ExceptT Error IO Block
forall a. a -> ExceptT Error IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Block -> ExceptT Error IO Block)
-> Block -> ExceptT Error IO Block
forall a b. (a -> b) -> a -> b
$ Elem -> TrailingSym -> [Attr] -> [Block] -> Block
Syntax.BlockElem Elem
name TrailingSym
mdot [Attr]
attrs [Block]
nodes'
node :: Block
node@(Syntax.BlockText TextSyntax
_ [Inline]
_) -> Block -> ExceptT Error IO Block
forall a. a -> ExceptT Error IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Block
node
Syntax.BlockInclude Maybe Text
mname FilePath
path Maybe [Block]
mbody -> do
Maybe [Block]
mbody' <- ([Block] -> ExceptT Error IO [Block])
-> Maybe [Block] -> ExceptT Error IO (Maybe [Block])
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse (FilePath -> [Block] -> ExceptT Error IO [Block]
execute FilePath
ctx) Maybe [Block]
mbody
Block -> ExceptT Error IO Block
forall a. a -> ExceptT Error IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Block -> ExceptT Error IO Block)
-> Block -> ExceptT Error IO Block
forall a b. (a -> b) -> a -> b
$ Maybe Text -> FilePath -> Maybe [Block] -> Block
Syntax.BlockInclude Maybe Text
mname FilePath
path Maybe [Block]
mbody'
Syntax.BlockFragmentDef Text
name [Text]
params [Block]
nodes -> do
[Block]
nodes' <- FilePath -> [Block] -> ExceptT Error IO [Block]
execute FilePath
ctx [Block]
nodes
Block -> ExceptT Error IO Block
forall a. a -> ExceptT Error IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Block -> ExceptT Error IO Block)
-> Block -> ExceptT Error IO Block
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> [Block] -> Block
Syntax.BlockFragmentDef Text
name [Text]
params [Block]
nodes'
Syntax.BlockFragmentCall Text
name TrailingSym
mdot [Attr]
attrs [Expr]
values [Block]
nodes -> do
[Block]
nodes' <- FilePath -> [Block] -> ExceptT Error IO [Block]
execute FilePath
ctx [Block]
nodes
Block -> ExceptT Error IO Block
forall a. a -> ExceptT Error IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Block -> ExceptT Error IO Block)
-> Block -> ExceptT Error IO Block
forall a b. (a -> b) -> a -> b
$ Text -> TrailingSym -> [Attr] -> [Expr] -> [Block] -> Block
Syntax.BlockFragmentCall Text
name TrailingSym
mdot [Attr]
attrs [Expr]
values [Block]
nodes'
node :: Block
node@(Syntax.BlockFor Text
_ Maybe Text
_ Expr
_ [Block]
_) -> Block -> ExceptT Error IO Block
forall a. a -> ExceptT Error IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Block
node
node :: Block
node@(Syntax.BlockComment CommentType
_ Text
_) -> Block -> ExceptT Error IO Block
forall a. a -> ExceptT Error IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Block
node
node :: Block
node@(Syntax.BlockFilter Text
_ Text
_) -> Block -> ExceptT Error IO Block
forall a. a -> ExceptT Error IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Block
node
node :: Block
node@(Syntax.BlockRawElem Text
_ [Block]
_) -> Block -> ExceptT Error IO Block
forall a. a -> ExceptT Error IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Block
node
Syntax.BlockDefault Text
name [Block]
nodes -> do
[Block]
nodes' <- FilePath -> [Block] -> ExceptT Error IO [Block]
execute FilePath
ctx [Block]
nodes
Block -> ExceptT Error IO Block
forall a. a -> ExceptT Error IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Block -> ExceptT Error IO Block)
-> Block -> ExceptT Error IO Block
forall a b. (a -> b) -> a -> b
$ Text -> [Block] -> Block
Syntax.BlockDefault Text
name [Block]
nodes'
Syntax.BlockImport FilePath
path Maybe [Block]
mbody [Block]
args -> do
Maybe [Block]
mbody' <- ([Block] -> ExceptT Error IO [Block])
-> Maybe [Block] -> ExceptT Error IO (Maybe [Block])
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse (FilePath -> [Block] -> ExceptT Error IO [Block]
execute FilePath
ctx) Maybe [Block]
mbody
Block -> ExceptT Error IO Block
forall a. a -> ExceptT Error IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Block -> ExceptT Error IO Block)
-> Block -> ExceptT Error IO Block
forall a b. (a -> b) -> a -> b
$ FilePath -> Maybe [Block] -> [Block] -> Block
Syntax.BlockImport FilePath
path Maybe [Block]
mbody' [Block]
args
node :: Block
node@(Syntax.BlockRun Text
_ (Just [Block]
_)) -> Block -> ExceptT Error IO Block
forall a. a -> ExceptT Error IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Block
node
Syntax.BlockRun Text
cmd Maybe [Block]
Nothing -> do
FilePath
out <-
IO FilePath -> ExceptT Error IO FilePath
forall a. IO a -> ExceptT Error IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> ExceptT Error IO FilePath)
-> IO FilePath -> ExceptT Error IO FilePath
forall a b. (a -> b) -> a -> b
$
CreateProcess -> FilePath -> IO FilePath
readCreateProcess ((FilePath -> CreateProcess
shell (FilePath -> CreateProcess) -> FilePath -> CreateProcess
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
T.unpack Text
cmd) {cwd = Just "/tmp/"}) FilePath
""
Block -> ExceptT Error IO Block
forall a. a -> ExceptT Error IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Block -> ExceptT Error IO Block)
-> Block -> ExceptT Error IO Block
forall a b. (a -> b) -> a -> b
$
Text -> Maybe [Block] -> Block
Syntax.BlockRun Text
cmd (Maybe [Block] -> Block) -> Maybe [Block] -> Block
forall a b. (a -> b) -> a -> b
$
[Block] -> Maybe [Block]
forall a. a -> Maybe a
Just [TextSyntax -> [Inline] -> Block
Syntax.BlockText TextSyntax
Syntax.RunOutput [Text -> Inline
Syntax.Lit (Text -> Inline) -> Text -> Inline
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack FilePath
out]]
node :: Block
node@(Syntax.BlockReadJson Text
_ FilePath
_ Maybe Value
_) -> Block -> ExceptT Error IO Block
forall a. a -> ExceptT Error IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Block
node
node :: Block
node@(Syntax.BlockAssignVar Text
_ Expr
_) -> Block -> ExceptT Error IO Block
forall a. a -> ExceptT Error IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Block
node
Syntax.BlockIf Expr
cond [Block]
as [Block]
bs -> do
[Block]
as' <- FilePath -> [Block] -> ExceptT Error IO [Block]
execute FilePath
ctx [Block]
as
[Block]
bs' <- FilePath -> [Block] -> ExceptT Error IO [Block]
execute FilePath
ctx [Block]
bs
Block -> ExceptT Error IO Block
forall a. a -> ExceptT Error IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Block -> ExceptT Error IO Block)
-> Block -> ExceptT Error IO Block
forall a b. (a -> b) -> a -> b
$ Expr -> [Block] -> [Block] -> Block
Syntax.BlockIf Expr
cond [Block]
as' [Block]
bs'
Syntax.BlockList [Block]
nodes -> do
[Block]
nodes' <- FilePath -> [Block] -> ExceptT Error IO [Block]
execute FilePath
ctx [Block]
nodes
Block -> ExceptT Error IO Block
forall a. a -> ExceptT Error IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Block -> ExceptT Error IO Block)
-> Block -> ExceptT Error IO Block
forall a b. (a -> b) -> a -> b
$ [Block] -> Block
Syntax.BlockList [Block]
nodes'
node :: Block
node@(Syntax.BlockCode Expr
_) -> Block -> ExceptT Error IO Block
forall a. a -> ExceptT Error IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Block
node