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

-- |
-- Module      : Slab.PreProcess
-- Description : Parse and process included and imported files
--
-- @Slab.PreProcess@ recursively parses files, following includes and imports.
-- This is also responsible of reading JSON files referenced in the expression
-- language.
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.Aeson.Key qualified as Aeson.Key
import Data.Aeson.KeyMap qualified as Aeson.KeyMap
import Data.ByteString.Lazy qualified as BL
import Data.Text qualified as T
import Data.Text.IO qualified as T
import Data.Vector qualified as V
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 -> [Char]
ctxStartPath :: FilePath
  }

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

-- | Similar to `parseFile` but pre-process the include statements.
preprocessFile :: FilePath -> IO (Either Error.Error [Block])
preprocessFile :: [Char] -> 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]))
-> ([Char] -> ExceptT Error IO [Block])
-> [Char]
-> IO (Either Error [Block])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ExceptT Error IO [Block]
preprocessFileE

preprocessFileE :: FilePath -> ExceptT Error.Error IO [Block]
preprocessFileE :: [Char] -> ExceptT Error IO [Block]
preprocessFileE [Char]
path = do
  [Block]
nodes <- [Char] -> ExceptT Error IO [Block]
Parse.parseFileE [Char]
path
  let ctx :: Context
ctx =
        Context
          { ctxStartPath :: [Char]
ctxStartPath = [Char]
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 {[Char]
ctxStartPath :: Context -> [Char]
ctxStartPath :: [Char]
..} = \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 [Char]
path Maybe [Block]
_ -> do
    let includedPath :: [Char]
includedPath = [Char] -> [Char]
takeDirectory [Char]
ctxStartPath [Char] -> [Char] -> [Char]
</> [Char]
path
        slabExt :: Bool
slabExt = [Char] -> [Char]
takeExtension [Char]
includedPath [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
".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
$ [Char] -> IO Bool
doesFileExist [Char]
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
$ [Char] -> IO Text
T.readFile [Char]
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 -> [Char] -> Maybe [Block] -> Block
BlockInclude Maybe Text
mname [Char]
path ([Block] -> Maybe [Block]
forall a. a -> Maybe a
Just [Block
node])
        | Bool
exists -> do
            -- Parse and process the .slab file.
            [Block]
nodes' <- [Char] -> ExceptT Error IO [Block]
preprocessFileE [Char]
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 -> [Char] -> Maybe [Block] -> Block
BlockInclude Maybe Text
mname [Char]
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
<> [Char] -> Text
T.pack [Char]
includedPath Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" doesn't exist"
  BlockFragmentDef DefinitionUse
usage 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
$ DefinitionUse -> Text -> [Text] -> [Block] -> Block
BlockFragmentDef DefinitionUse
usage 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 [Char]
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 :: [Char]
includedPath = [Char] -> [Char]
takeDirectory [Char]
ctxStartPath [Char] -> [Char] -> [Char]
</> [Char]
path
        slabExt :: Bool
slabExt = [Char] -> [Char]
takeExtension [Char]
includedPath [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
".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
$ [Char] -> IO Bool
doesFileExist [Char]
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 <- [Char] -> ExceptT Error IO [Block]
preprocessFileE [Char]
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
$ [Char] -> Maybe [Block] -> [Block] -> Block
BlockImport [Char]
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
<> [Char] -> Text
T.pack [Char]
includedPath Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" doesn't exist"
  node :: Block
node@(BlockRun Text
_ Maybe 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
  BlockAssignVars [(Text, Expr)]
pairs -> do
    let f :: (a, Expr) -> ExceptT Error m (a, Expr)
f (a
name, JsonPath [Char]
path) = do
          let path' :: [Char]
path' = [Char] -> [Char]
takeDirectory [Char]
ctxStartPath [Char] -> [Char] -> [Char]
</> [Char]
path
          ByteString
content <- IO ByteString -> ExceptT Error m ByteString
forall a. IO a -> ExceptT Error m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> ExceptT Error m ByteString)
-> IO ByteString -> ExceptT Error m ByteString
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ByteString
BL.readFile [Char]
path'
          case ByteString -> Either [Char] Value
forall a. FromJSON a => ByteString -> Either [Char] a
Aeson.eitherDecode ByteString
content of
            Right Value
val ->
              (a, Expr) -> ExceptT Error m (a, Expr)
forall a. a -> ExceptT Error m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
name, Value -> Expr
jsonToExpr Value
val)
            Left [Char]
err ->
              Error -> ExceptT Error m (a, Expr)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Error -> ExceptT Error m (a, Expr))
-> Error -> ExceptT Error m (a, Expr)
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
<> [Char] -> Text
T.pack [Char]
err
        f (a, Expr)
pair = (a, Expr) -> ExceptT Error m (a, Expr)
forall a. a -> ExceptT Error m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a, Expr)
pair
    [(Text, Expr)]
pairs' <- ((Text, Expr) -> ExceptT Error IO (Text, Expr))
-> [(Text, Expr)] -> ExceptT Error IO [(Text, Expr)]
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 (Text, Expr) -> ExceptT Error IO (Text, Expr)
forall {m :: * -> *} {a}.
MonadIO m =>
(a, Expr) -> ExceptT Error m (a, Expr)
f [(Text, Expr)]
pairs
    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
BlockAssignVars [(Text, Expr)]
pairs'
  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

jsonToExpr :: Aeson.Value -> Expr
jsonToExpr :: Value -> Expr
jsonToExpr = \case
  Aeson.String Text
s -> Text -> Expr
SingleQuoteString Text
s
  Aeson.Array Array
xs ->
    [Expr] -> Expr
List ([Expr] -> Expr) -> [Expr] -> Expr
forall a b. (a -> b) -> a -> b
$ (Value -> Expr) -> [Value] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map Value -> Expr
jsonToExpr (Array -> [Value]
forall a. Vector a -> [a]
V.toList Array
xs)
  Aeson.Object Object
kvs ->
    let f :: (Key, Value) -> (Expr, Expr)
f (Key
k, Value
v) = (Text -> Expr
SingleQuoteString (Text -> Expr) -> Text -> Expr
forall a b. (a -> b) -> a -> b
$ Key -> Text
Aeson.Key.toText Key
k, Value -> Expr
jsonToExpr Value
v)
     in [(Expr, Expr)] -> Expr
Object ([(Expr, Expr)] -> Expr) -> [(Expr, Expr)] -> Expr
forall a b. (a -> b) -> a -> b
$ ((Key, Value) -> (Expr, Expr)) -> [(Key, Value)] -> [(Expr, Expr)]
forall a b. (a -> b) -> [a] -> [b]
map (Key, Value) -> (Expr, Expr)
f (Object -> [(Key, Value)]
forall v. KeyMap v -> [(Key, v)]
Aeson.KeyMap.toList Object
kvs)
  Value
x -> [Char] -> Expr
forall a. HasCallStack => [Char] -> a
error ([Char] -> Expr) -> [Char] -> Expr
forall a b. (a -> b) -> a -> b
$ [Char]
"jsonToExpr: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Value -> [Char]
forall a. Show a => a -> [Char]
show Value
x