{-# 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
  }

--------------------------------------------------------------------------------

-- | Similar to `parseFile` but pre-process the include statements.
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

--------------------------------------------------------------------------------

-- Process include statements (i.e. read the given path and parse its content
-- recursively).
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
            -- Include the file content as-is.
            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
            -- Parse and process the .slab file.
            [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 [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 -> [Expr] -> [Block] -> Block
BlockFragmentCall Text
name [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
    -- An import is treated like an include used to define a fragment, then
    -- directly calling that fragment.
    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
            -- Parse and process the .slab file.
            [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
    -- File inclusion is done right away, without checking the condition.
    [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