{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RecordWildCards #-}

-- |
-- Module      : Slab.Execute
-- Description : Run external commands referenced by an AST
--
-- @Slab.Execute@ implements the execution stage of Slab, i.e. running external
-- commands (for instance referenced by the @run@ syntax). This is done after
-- the evaluation stage (implemented in "Slab.Evaluate").
--
-- After execution, the resulting blocks can be rendered to HTML by
-- "Slab.Render".
module Slab.Execute
  ( Context (..)
  , executeFile
  , execute
  ) where

import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE)
import Data.Text qualified as T
import Slab.Command qualified as Command
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.Exit (ExitCode (..))
import System.Process (readCreateProcessWithExitCode, shell)

--------------------------------------------------------------------------------
data Context = Context
  { Context -> String
ctxPath :: FilePath
  , Context -> RunMode
ctxRunMode :: Command.RunMode
  }

-- | Similar to `evaluateFile` but run external commands.
executeFile :: Context -> IO (Either Error.Error [Syntax.Block])
executeFile :: Context -> IO (Either Error [Block])
executeFile ctx :: Context
ctx@(Context {String
RunMode
ctxPath :: Context -> String
ctxRunMode :: Context -> RunMode
ctxPath :: String
ctxRunMode :: RunMode
..}) =
  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
$
    String -> ExceptT Error IO [Block]
PreProcess.preprocessFileE String
ctxPath
      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
>>= Context -> [Block] -> ExceptT Error IO [Block]
execute Context
ctx

--------------------------------------------------------------------------------
execute
  :: Context
  -> [Syntax.Block]
  -> ExceptT Error.Error IO [Syntax.Block]
execute :: Context -> [Block] -> ExceptT Error IO [Block]
execute Context
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 (Context -> Block -> ExceptT Error IO Block
exec Context
ctx)

exec :: Context -> Syntax.Block -> ExceptT Error.Error IO Syntax.Block
exec :: Context -> Block -> ExceptT Error IO Block
exec ctx :: Context
ctx@(Context {String
RunMode
ctxPath :: Context -> String
ctxRunMode :: Context -> RunMode
ctxPath :: String
ctxRunMode :: RunMode
..}) = \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' <- Context -> [Block] -> ExceptT Error IO [Block]
execute Context
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 String
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 (Context -> [Block] -> ExceptT Error IO [Block]
execute Context
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 -> String -> Maybe [Block] -> Block
Syntax.BlockInclude Maybe Text
mname String
path Maybe [Block]
mbody'
  Syntax.BlockFragmentDef DefinitionUse
usage Text
name [Text]
params [Block]
nodes -> do
    [Block]
nodes' <- Context -> [Block] -> ExceptT Error IO [Block]
execute Context
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
$ DefinitionUse -> Text -> [Text] -> [Block] -> Block
Syntax.BlockFragmentDef DefinitionUse
usage Text
name [Text]
params [Block]
nodes'
  Syntax.BlockFragmentCall Text
name TrailingSym
mdot [Attr]
attrs [Expr]
values [Block]
nodes -> do
    [Block]
nodes' <- Context -> [Block] -> ExceptT Error IO [Block]
execute Context
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' <- Context -> [Block] -> ExceptT Error IO [Block]
execute Context
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 String
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 (Context -> [Block] -> ExceptT Error IO [Block]
execute Context
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
$ String -> Maybe [Block] -> [Block] -> Block
Syntax.BlockImport String
path Maybe [Block]
mbody' [Block]
args
  node :: Block
node@(Syntax.BlockRun Text
_ Maybe 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 Text
minput Maybe [Block]
Nothing -> do
    (ExitCode
code, String
out, String
err) <-
      IO (ExitCode, String, String)
-> ExceptT Error IO (ExitCode, String, String)
forall a. IO a -> ExceptT Error IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ExitCode, String, String)
 -> ExceptT Error IO (ExitCode, String, String))
-> IO (ExitCode, String, String)
-> ExceptT Error IO (ExitCode, String, String)
forall a b. (a -> b) -> a -> b
$
        CreateProcess -> String -> IO (ExitCode, String, String)
readCreateProcessWithExitCode (String -> CreateProcess
shell (String -> CreateProcess) -> String -> CreateProcess
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
cmd) (String -> IO (ExitCode, String, String))
-> String -> IO (ExitCode, String, String)
forall a b. (a -> b) -> a -> b
$ String -> (Text -> String) -> Maybe Text -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" Text -> String
T.unpack Maybe Text
minput
    case ExitCode
code of
      ExitCode
ExitSuccess ->
        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 Text -> Maybe [Block] -> Block
Syntax.BlockRun Text
cmd Maybe Text
minput (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
$ String -> Text
T.pack String
out]]
      ExitFailure Int
_ -> case RunMode
ctxRunMode of
        RunMode
Command.RunNormal ->
          Error -> ExceptT Error IO Block
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Error -> ExceptT Error IO Block)
-> Error -> ExceptT Error IO Block
forall a b. (a -> b) -> a -> b
$
            Text -> Error
Error.ExecuteError (Text -> Error) -> Text -> Error
forall a b. (a -> b) -> a -> b
$
              String -> Text
T.pack String
err Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
out
        RunMode
Command.RunPassthrough ->
          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 Text -> Maybe [Block] -> Block
Syntax.BlockRun Text
cmd Maybe Text
minput (Maybe [Block] -> Block) -> Maybe [Block] -> Block
forall a b. (a -> b) -> a -> b
$
              [Block] -> Maybe [Block]
forall a. a -> Maybe a
Just ([Block] -> Maybe [Block]) -> [Block] -> Maybe [Block]
forall a b. (a -> b) -> a -> b
$
                [ Elem -> TrailingSym -> [Attr] -> [Block] -> Block
Syntax.BlockElem
                    Elem
Syntax.Pre
                    TrailingSym
Syntax.NoSym
                    []
                    [ Elem -> TrailingSym -> [Attr] -> [Block] -> Block
Syntax.BlockElem
                        Elem
Syntax.Code
                        TrailingSym
Syntax.HasDot
                        []
                        [TextSyntax -> [Inline] -> Block
Syntax.BlockText TextSyntax
Syntax.RunOutput [Text -> Inline
Syntax.Lit (Text -> Inline) -> Text -> Inline
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String
err String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
out)]]
                    ]
                ]
  node :: Block
node@(Syntax.BlockAssignVars [(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' <- Context -> [Block] -> ExceptT Error IO [Block]
execute Context
ctx [Block]
as
    [Block]
bs' <- Context -> [Block] -> ExceptT Error IO [Block]
execute Context
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' <- Context -> [Block] -> ExceptT Error IO [Block]
execute Context
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