{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RecordWildCards #-}
module Slab.PreProcess
( Context (..)
, preprocessFile
, preprocessFileE
) where
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE)
import Data.Aeson qualified as Aeson
import Data.ByteString.Lazy qualified as BL
import Data.Text qualified as T
import Data.Text.IO qualified as T
import Slab.Error qualified as Error
import Slab.Parse qualified as Parse
import Slab.Syntax
import System.Directory (doesFileExist)
import System.FilePath (takeDirectory, takeExtension, (</>))
data Context = Context
{ Context -> FilePath
ctxStartPath :: FilePath
}
preprocessFile :: FilePath -> IO (Either Error.Error [Block])
preprocessFile :: FilePath -> IO (Either Error [Block])
preprocessFile = 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]))
-> (FilePath -> ExceptT Error IO [Block])
-> FilePath
-> IO (Either Error [Block])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> ExceptT Error IO [Block]
preprocessFileE
preprocessFileE :: FilePath -> ExceptT Error.Error IO [Block]
preprocessFileE :: FilePath -> ExceptT Error IO [Block]
preprocessFileE FilePath
path = do
[Block]
nodes <- FilePath -> ExceptT Error IO [Block]
Parse.parseFileE FilePath
path
let ctx :: Context
ctx =
Context
{ ctxStartPath :: FilePath
ctxStartPath = FilePath
path
}
Context -> [Block] -> ExceptT Error IO [Block]
preprocess Context
ctx [Block]
nodes
preprocess :: Context -> [Block] -> ExceptT Error.Error IO [Block]
preprocess :: Context -> [Block] -> ExceptT Error IO [Block]
preprocess Context
ctx [Block]
nodes = (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
preproc Context
ctx) [Block]
nodes
preproc :: Context -> Block -> ExceptT Error.Error IO Block
preproc :: Context -> Block -> ExceptT Error IO Block
preproc ctx :: Context
ctx@Context {FilePath
ctxStartPath :: Context -> FilePath
ctxStartPath :: FilePath
..} = \case
node :: Block
node@Block
BlockDoctype -> Block -> ExceptT Error IO Block
forall a. a -> ExceptT Error IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Block
node
BlockElem Elem
name TrailingSym
mdot [Attr]
attrs [Block]
nodes -> do
[Block]
nodes' <- Context -> [Block] -> ExceptT Error IO [Block]
preprocess 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
BlockElem Elem
name TrailingSym
mdot [Attr]
attrs [Block]
nodes'
node :: Block
node@(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
BlockInclude Maybe Text
mname FilePath
path Maybe [Block]
_ -> do
let includedPath :: FilePath
includedPath = FilePath -> FilePath
takeDirectory FilePath
ctxStartPath FilePath -> FilePath -> FilePath
</> FilePath
path
slabExt :: Bool
slabExt = FilePath -> FilePath
takeExtension FilePath
includedPath FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
".slab"
Bool
exists <- IO Bool -> ExceptT Error IO Bool
forall a. IO a -> ExceptT Error IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT Error IO Bool)
-> IO Bool -> ExceptT Error IO Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesFileExist FilePath
includedPath
if
| Bool
exists Bool -> Bool -> Bool
&& (Bool -> Bool
not Bool
slabExt Bool -> Bool -> Bool
|| Maybe Text
mname Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"escape-html") -> do
Text
content <- IO Text -> ExceptT Error IO Text
forall a. IO a -> ExceptT Error IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> ExceptT Error IO Text)
-> IO Text -> ExceptT Error IO Text
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Text
T.readFile FilePath
includedPath
let node :: Block
node = Text -> Block
Parse.parserTextInclude Text
content
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
BlockInclude Maybe Text
mname FilePath
path ([Block] -> Maybe [Block]
forall a. a -> Maybe a
Just [Block
node])
| Bool
exists -> do
[Block]
nodes' <- FilePath -> ExceptT Error IO [Block]
preprocessFileE FilePath
includedPath
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
BlockInclude Maybe Text
mname FilePath
path ([Block] -> Maybe [Block]
forall a. a -> Maybe a
Just [Block]
nodes')
| Bool
otherwise ->
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.PreProcessError (Text -> Error) -> Text -> Error
forall a b. (a -> b) -> a -> b
$ Text
"File " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
includedPath Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" doesn't exist"
BlockFragmentDef Text
name [Text]
params [Block]
nodes -> do
[Block]
nodes' <- Context -> [Block] -> ExceptT Error IO [Block]
preprocess 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 -> [Text] -> [Block] -> Block
BlockFragmentDef Text
name [Text]
params [Block]
nodes'
BlockFragmentCall Text
name TrailingSym
mdot [Attr]
attrs [Expr]
values [Block]
nodes -> do
[Block]
nodes' <- Context -> [Block] -> ExceptT Error IO [Block]
preprocess 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
BlockFragmentCall Text
name TrailingSym
mdot [Attr]
attrs [Expr]
values [Block]
nodes'
node :: Block
node@(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@(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@(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@(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
BlockDefault Text
name [Block]
nodes -> do
[Block]
nodes' <- Context -> [Block] -> ExceptT Error IO [Block]
preprocess 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
BlockDefault Text
name [Block]
nodes'
BlockImport FilePath
path Maybe [Block]
_ [Block]
args -> do
let includedPath :: FilePath
includedPath = FilePath -> FilePath
takeDirectory FilePath
ctxStartPath FilePath -> FilePath -> FilePath
</> FilePath
path
slabExt :: Bool
slabExt = FilePath -> FilePath
takeExtension FilePath
includedPath FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
".slab"
Bool
exists <- IO Bool -> ExceptT Error IO Bool
forall a. IO a -> ExceptT Error IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT Error IO Bool)
-> IO Bool -> ExceptT Error IO Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesFileExist FilePath
includedPath
if
| Bool
exists Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
slabExt ->
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.PreProcessError (Text -> Error) -> Text -> Error
forall a b. (a -> b) -> a -> b
$ Text
"Extends requires a .slab file"
| Bool
exists -> do
[Block]
body <- FilePath -> ExceptT Error IO [Block]
preprocessFileE FilePath
includedPath
[Block]
args' <- (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
preproc Context
ctx) [Block]
args
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
BlockImport FilePath
path ([Block] -> Maybe [Block]
forall a. a -> Maybe a
Just [Block]
body) [Block]
args'
| Bool
otherwise ->
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.PreProcessError (Text -> Error) -> Text -> Error
forall a b. (a -> b) -> a -> b
$ Text
"File " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
includedPath Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" doesn't exist"
node :: Block
node@(BlockRun Text
_ Maybe [Block]
_) -> Block -> ExceptT Error IO Block
forall a. a -> ExceptT Error IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Block
node
BlockReadJson Text
name FilePath
path Maybe Value
_ -> do
let path' :: FilePath
path' = FilePath -> FilePath
takeDirectory FilePath
ctxStartPath FilePath -> FilePath -> FilePath
</> FilePath
path
ByteString
content <- IO ByteString -> ExceptT Error IO ByteString
forall a. IO a -> ExceptT Error IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> ExceptT Error IO ByteString)
-> IO ByteString -> ExceptT Error IO ByteString
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ByteString
BL.readFile FilePath
path'
case ByteString -> Either FilePath Value
forall a. FromJSON a => ByteString -> Either FilePath a
Aeson.eitherDecode ByteString
content of
Right Value
val ->
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 -> FilePath -> Maybe Value -> Block
BlockReadJson Text
name FilePath
path (Maybe Value -> Block) -> Maybe Value -> Block
forall a b. (a -> b) -> a -> b
$ Value -> Maybe Value
forall a. a -> Maybe a
Just Value
val
Left FilePath
err ->
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.PreProcessError (Text -> Error) -> Text -> Error
forall a b. (a -> b) -> a -> b
$ Text
"Can't decode JSON: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
err
node :: Block
node@(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
BlockIf Expr
cond [Block]
as [Block]
bs -> do
[Block]
as' <- Context -> [Block] -> ExceptT Error IO [Block]
preprocess Context
ctx [Block]
as
[Block]
bs' <- Context -> [Block] -> ExceptT Error IO [Block]
preprocess 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
BlockIf Expr
cond [Block]
as' [Block]
bs'
BlockList [Block]
nodes -> do
[Block]
nodes' <- Context -> [Block] -> ExceptT Error IO [Block]
preprocess 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
BlockList [Block]
nodes'
node :: Block
node@(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