Evaluate.hs

{-# LANGUAGE RecordWildCards #-}

-- |
-- Module      : Slab.Evaluate
-- Description : Evaluate an AST (to a non-reducible AST)
--
-- @Slab.Evaluate@ implements the evaluation stage of Slab, following both the
-- parsing and pre-processing stages. This is responsible of reducing for
-- instance @1 + 2@ to @3@, or transforming a loop construct to an actual list
-- of HTML blocks.
--
-- Evaluation works on an abstract syntax tree (defined in "Slab.Syntax") and
-- currently reuses the sames types for its result.
--
-- The stage following evaluation is "Slab.Execute", responsible of running
-- external commands.
module Slab.Evaluate
  ( evaluateFile
  , evaluate
  , evalExpr
  , defaultEnv
  , simplify
  ) where

import Control.Monad (forM)
import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE)
import Data.List ((\\))
import Data.Maybe (isJust)
import Data.Text (Text)
import Data.Text qualified as T
import Slab.Error qualified as Error
import Slab.PreProcess qualified as PreProcess
import Slab.Syntax

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

-- | Similar to `preprocessFile` but evaluate the template.
evaluateFile :: FilePath -> IO (Either Error.Error [Block])
evaluateFile = runExceptT . evaluateFileE

evaluateFileE :: FilePath -> ExceptT Error.Error IO [Block]
evaluateFileE path =
  PreProcess.preprocessFileE path >>= evaluate defaultEnv [T.pack path]

--------------------------------------------------------------------------------
defaultEnv :: Env
defaultEnv =
  Env
    [ ("true", Bool True)
    , ("false", Bool False)
    , ("show", BuiltIn "show")
    , ("null", BuiltIn "null")
    , mkElem "div" Div
    , mkElem "html" Html
    , mkElem "body" Body
    , mkElem "span" Span
    , mkElem "h1" H1
    , mkElem "h2" H2
    , mkElem "h3" H3
    , mkElem "h4" H4
    , mkElem "h5" H5
    , mkElem "h6" H6
    , mkElem "header" Header
    , mkElem "head" Head
    , mkElem "main" Main
    , mkElem "audio" Audio
    , mkElem "a" A
    , mkElem "code" Code
    , mkElem "iframe" IFrame
    , mkElem "i" I
    , mkElem "pre" Pre
    , mkElem "p" P
    , mkElem "em" Em
    , mkElem "ul" Ul
    , mkElem "li" Li
    , mkElem "title" Title
    , mkElem "table" Table
    , mkElem "thead" Thead
    , mkElem "tbody" Tbody
    , mkElem "tr" Tr
    , mkElem "td" Td
    , mkElem "dl" Dl
    , mkElem "dt" Dt
    , mkElem "dd" Dd
    , mkElem "footer" Footer
    , mkElem "figure" Figure
    , mkElem "form" Form
    , mkElem "label" Label
    , mkElem "blockquote" Blockquote
    , mkElem "button" Button
    , mkElem "figcaption" Figcaption
    , mkElem "script" Script
    , mkElem "style" Style
    , mkElem "small" Small
    , mkElem "svg" Svg
    , mkElem "textarea" Textarea
    , mkElem "canvas" Canvas
    , -- Elements with no content.
      ("br", Block (BlockElem Br NoSym [] []))
    , ("hr", Block (BlockElem Hr NoSym [] []))
    , ("meta", Block (BlockElem Meta NoSym [] []))
    , ("link", Block (BlockElem Link NoSym [] []))
    , ("source", Block (BlockElem Source NoSym [] []))
    , ("img", Block (BlockElem Img NoSym [] []))
    , ("input", Block (BlockElem Input NoSym [] []))
    ]
 where
  mkElem name el =
    (name, Frag ["content"] emptyEnv [BlockElem el NoSym [] [BlockDefault "content" []]])

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

-- Process mixin calls. This should be done after processing the include statement
-- since mixins may be defined in included files.
evaluate :: Monad m => Env -> [Text] -> [Block] -> ExceptT Error.Error m [Block]
evaluate env stack nodes = do
  -- Note that we pass the environment that we are constructing, so that each
  -- definition sees all definitions (including later ones and itself).
  let vars = extractVariables env' nodes
      env' = augmentVariables env vars
  mapM (eval env' stack) nodes

eval :: Monad m => Env -> [Text] -> Block -> ExceptT Error.Error m Block
eval env stack b
  | length stack > 100 =
      throwE $
        Error.EvaluateError $
          "Stack overflow. Is there an infinite loop?"
            <> " "
            <> T.pack (show $ reverse stack)
            <> " "
            <> displayEnv env
eval env stack bl = case bl of
  node@BlockDoctype -> pure node
  BlockElem name mdot attrs nodes -> do
    attrs' <- evalAttrs env stack attrs
    nodes' <- evaluate env stack nodes
    pure $ BlockElem name mdot attrs' nodes'
  BlockText syn template -> do
    template' <- evalTemplate env template
    pure $ BlockText syn template'
  BlockInclude mname path mnodes -> do
    case mnodes of
      Just nodes -> do
        nodes' <- evaluate env ("include" : stack) nodes
        pure $ BlockInclude mname path (Just nodes')
      Nothing ->
        pure $ BlockInclude mname path Nothing
  node@(BlockFragmentDef _ _ _ _) -> pure node
  BlockFragmentCall name mdot attrs values args -> do
    attrs' <- evalAttrs env stack attrs
    body <- call env stack name values args
    let body' = setAttrs attrs' body
    pure $ BlockFragmentCall name mdot attrs' values body'
  BlockFor name mindex values nodes -> do
    -- Re-use BlockFor to construct a single node to return.
    let zero :: Int
        zero = 0
    values' <- evalExpr env values
    collection <- case values' of
      List xs -> pure $ zip xs $ map Int [zero ..]
      Object xs -> pure $ map (\(k, v) -> (v, k)) xs
      _ -> throwE $ Error.EvaluateError $ "Iterating on something that is not a collection"
    nodes' <- forM collection $ \(value, index) -> do
      let env' = case mindex of
            Just idxname -> augmentVariables env [(name, value), (idxname, index)]
            Nothing -> augmentVariables env [(name, value)]
      evaluate env' ("each" : stack) nodes
    pure $ BlockFor name mindex values $ concat nodes'
  node@(BlockComment _ _) -> pure node
  node@(BlockFilter _ _) -> pure node
  node@(BlockRawElem _ _) -> pure node
  BlockDefault name nodes -> do
    -- If the fragment is not given as an argument, we return the default block,
    -- but recursively trying to replace the blocks found within its own body.
    case lookupVariable name env of
      Nothing -> do
        nodes' <- evaluate env ("?block" : stack) nodes
        pure $ BlockDefault name nodes'
      Just (Frag _ capturedEnv nodes') -> do
        nodes'' <- evaluate capturedEnv ("default block " <> name : stack) nodes'
        pure $ BlockDefault name nodes''
      Just _ -> throwE $ Error.EvaluateError $ "Calling something that is not a fragment \"" <> name <> "\" in " <> T.pack (show stack)
  BlockImport path _ args -> do
    body <- call env stack (T.pack path) [] args
    pure $ BlockImport path (Just body) args
  node@(BlockRun _ _ _) -> pure node
  node@(BlockAssignVars _) -> pure node
  BlockIf cond as bs -> do
    cond' <- evalExpr env cond
    case cond' of
      Bool True -> do
        as' <- evaluate env ("then" : stack) as
        pure $ BlockIf cond as' []
      Bool False -> do
        bs' <- evaluate env ("else" : stack) bs
        pure $ BlockIf cond [] bs'
      _ ->
        throwE . Error.EvaluateError $
          "Conditional is not a boolean: " <> T.pack (show cond')
  BlockList nodes -> do
    nodes' <- evaluate env stack nodes
    pure $ BlockList nodes'
  BlockCode code -> do
    code' <- evalExpr env code
    pure $ BlockCode code'

call :: Monad m => Env -> [Text] -> Text -> [Expr] -> [Block] -> ExceptT Error.Error m [Block]
call env stack name values args =
  case lookupVariable name env of
    Just frag@(Frag _ _ _) -> evalFrag env stack name values args frag
    Just (Block x) -> pure [x]
    Just _ -> throwE $ Error.EvaluateError $ "Calling something that is not a fragment \"" <> name <> "\" in " <> T.pack (show stack)
    Nothing -> throwE $ Error.EvaluateError $ "Can't find fragment \"" <> name <> "\" while evaluating " <> T.pack (show $ reverse stack) <> " with environment " <> displayEnv env

lookupVariable :: Text -> Env -> Maybe Expr
lookupVariable name Env {..} = lookup name envVariables

augmentVariables :: Env -> [(Text, Expr)] -> Env
augmentVariables Env {..} xs = Env {envVariables = xs <> envVariables}

evalFrag :: Monad m => Env -> [Text] -> Text -> [Expr] -> [Block] -> Expr -> ExceptT Error.Error m [Block]
evalFrag env stack name values args (Frag names capturedEnv body) = do
  env' <- extractVariables' env args
  case map fst env' \\ names of
    [] -> pure ()
    ["content"] -> pure ()
    ns -> throwE . Error.EvaluateError $
      "Unnecessary arguments to " <> name <> ": " <> T.pack (show ns)
  let env'' = augmentVariables (removeFormalParams names capturedEnv) env'
      arguments = zip names (map (thunk env) values)
      env''' = augmentVariables env'' arguments
  body' <- evaluate env''' ("frag " <> name : stack) body
  pure body'

removeFormalParams names Env {..} = Env { envVariables = vars' }
 where
  vars' = filter (not . (`elem` names) . fst) envVariables

evalAttrs :: Monad m => Env -> [Text] -> [Attr] -> ExceptT Error.Error m [Attr]
evalAttrs env stack attrs = mapM f attrs
 where
  f (Attr a b) = do
    b' <- evalExpr env b
    pure $ Attr a b'
  f attr = pure attr

evalExpr :: Monad m => Env -> Expr -> ExceptT Error.Error m Expr
evalExpr env = \case
  Variable name ->
    case lookupVariable name env of
      Just val -> evalExpr env val
      Nothing -> throwE $ Error.EvaluateError $ "Can't find variable \"" <> name <> "\""
  Lookup name key ->
    case lookupVariable name env of
      Just (Object obj) -> do
        -- key' <- evalExpr env key
        case lookup key obj of
          Just val -> evalExpr env val
          Nothing -> pure $ Bool False -- TODO Either crash, or we have to implement on option type.
      Just _ -> throwE $ Error.EvaluateError $ "Variable \"" <> name <> "\" is not an object"
      Nothing -> throwE $ Error.EvaluateError $ "Can't find variable \"" <> name <> "\""
  Add a b -> do
    a' <- evalExpr env a
    b' <- evalExpr env b
    case (a', b') of
      (Int i, Int j) -> pure . Int $ i + j
      (SingleQuoteString s, SingleQuoteString t) ->
        pure . SingleQuoteString $ s <> t
      (Block a, Block b) ->
        pure . Block $ pasteBlocks a b
      _ -> throwE $ Error.EvaluateError $ "Unimplemented (add): " <> T.pack (show (Add a' b'))
  Sub a b -> do
    a' <- evalExpr env a
    b' <- evalExpr env b
    case (a', b') of
      (Int i, Int j) -> pure . Int $ i - j
      _ -> throwE $ Error.EvaluateError $ "Unimplemented (sub): " <> T.pack (show (Sub a' b'))
  Times a b -> do
    a' <- evalExpr env a
    b' <- evalExpr env b
    case (a', b') of
      (Int i, Int j) -> pure . Int $ i * j
      _ -> throwE $ Error.EvaluateError $ "Unimplemented (times): " <> T.pack (show (Times a' b'))
  Divide a b -> do
    a' <- evalExpr env a
    b' <- evalExpr env b
    case (a', b') of
      (Int i, Int j) -> pure . Int $ i `div` j
      _ -> throwE $ Error.EvaluateError $ "Unimplemented (divide): " <> T.pack (show (Divide a' b'))
  GreaterThan a b -> do
    a' <- evalExpr env a
    b' <- evalExpr env b
    case (a', b') of
      (Int i, Int j) -> pure . Bool $ i > j
      _ -> throwE $ Error.EvaluateError $ "Unimplemented (greater-than): " <> T.pack (show (GreaterThan a' b'))
  LesserThan a b -> do
    a' <- evalExpr env a
    b' <- evalExpr env b
    case (a', b') of
      (Int i, Int j) -> pure . Bool $ i < j
      _ -> throwE $ Error.EvaluateError $ "Unimplemented (lesser-than): " <> T.pack (show (LesserThan a' b'))
  Equal a b -> do
    a' <- evalExpr env a
    b' <- evalExpr env b
    case (a', b') of
      (Bool i, Bool j) -> pure . Bool $ i == j
      (Int i, Int j) -> pure . Bool $ i == j
      (SingleQuoteString s, SingleQuoteString t) -> pure . Bool $ s == t
      _ -> throwE $ Error.EvaluateError $ "Unimplemented (equal): " <> T.pack (show (Equal a' b'))
  Cons a b -> do
    a' <- evalExpr env a
    b' <- evalExpr env b
    case (a', b') of
      (Block bl, Block c) ->
        pure . Block $ setContent [c] bl
      (Block bl, SingleQuoteString s) ->
        pure . Block $ setContent [BlockText Normal [Lit s]] bl
      _ -> throwE $ Error.EvaluateError $ "Unimplemented (cons): " <> T.pack (show (Cons a' b'))
  Application a b -> do
    a' <- evalExpr env a
    b' <- evalExpr env b
    evalApplication env a' b'
  Thunk capturedEnv code ->
    evalExpr capturedEnv code
  frag@(Frag _ _ _) -> do
    blocks <- evalFrag env ["frag"] "-" [] [] frag
    case blocks of
      [bl] -> pure $ Block bl
      _ -> pure . Block $ BlockList blocks
  Block b -> do
    b' <- eval env ["block"] b
    pure $ Block b'
  code -> pure code

evalApplication :: Monad m => Env -> Expr -> Expr -> ExceptT Error.Error m Expr
evalApplication env a b =
  case a of
    BuiltIn "show" -> case b of
      Int i -> pure . SingleQuoteString . T.pack $ show i
      _ -> throwE $ Error.EvaluateError $ "Cannot apply show to: " <> T.pack (show b)
    BuiltIn "null" -> case b of
      SingleQuoteString s -> pure . Bool $ T.null s
      -- TODO Lookup returns False when the key is not present,
      -- but I have this code around:
      --   if null entry['journal']
      -- We need something like:
      --   if 'journal' in entry
      --   if elem 'journal' (keys entry)
      --   ...
      Bool False -> pure . Bool $ True
      _ -> throwE $ Error.EvaluateError $ "Cannot apply null to: " <> T.pack (show b)
    _ -> throwE $ Error.EvaluateError $ "Cannot apply: " <> T.pack (show a)

evalTemplate :: Monad m => Env -> [Inline] -> ExceptT Error.Error m [Inline]
evalTemplate env inlines =
  traverse (evalInline env) inlines

evalInline :: Monad m => Env -> Inline -> ExceptT Error.Error m Inline
evalInline env = \case
  Lit s -> pure $ Lit s
  Place code -> do
    code' <- evalExpr env code
    case code' of
      SingleQuoteString _ -> pure $ Place code'
      Bool _ -> pure $ Place code'
      Int _ -> pure $ Place code'
      Block _ -> pure $ Place code'
      -- Variable x -> context x -- Should not happen after evalExpr
      x -> error $ "evalInline: unhandled value: " <> show x

-- | Same as `extractVariables` plus an implicit @content@ block.
-- Note that unlike `extractVariables`, this version takes also care of
-- passing the environment being constructed to each definition.
extractVariables' :: Monad m => Env -> [Block] -> ExceptT Error.Error m [(Text, Expr)]
extractVariables' env nodes = do
  let named = extractVariables env' nodes
      unnamed = concatMap unnamedBlock nodes
      content = if null unnamed then [] else [("content", Frag [] env' unnamed)]
      env' = augmentVariables env named -- Note we don't add the implicit "content" entry.
      args = extractArguments env' nodes
      vars = args <> content
  if isJust (lookup "content" args) && not (null unnamed)
    then
      throwE $
        Error.EvaluateError $
          "A block of content and a content argument are provided"
    else pure vars

unnamedBlock :: Block -> [Block]
unnamedBlock (BlockImport path _ args) = [BlockFragmentCall (T.pack path) NoSym [] [] args]
unnamedBlock (BlockFragmentDef DefinitionArg _ _ _) = []
unnamedBlock node = [node]

-- Extract both fragments and assignments.
-- TODO This should be merged with extractVariables'.
-- TODO We could filter the env, keeping only the free variables that appear
-- in the bodies.
extractVariables :: Env -> [Block] -> [(Text, Expr)]
extractVariables env = concatMap (extractVariable env)

extractVariable :: Env -> Block -> [(Text, Expr)]
extractVariable env = \case
  BlockDoctype -> []
  (BlockElem _ _ _ _) -> []
  (BlockText _ _) -> []
  (BlockInclude _ _ children) -> maybe [] (extractVariables env) children
  (BlockFor _ _ _ _) -> []
  (BlockFragmentDef DefinitionNormal name names children) ->
    [(name, Frag names env children)]
  (BlockFragmentDef DefinitionArg name names children) ->
    []
  (BlockFragmentCall _ _ _ _ _) -> []
  (BlockComment _ _) -> []
  (BlockFilter _ _) -> []
  (BlockRawElem _ _) -> []
  (BlockDefault _ _) -> []
  (BlockImport path (Just body) _) -> [(T.pack path, Frag [] env body)]
  (BlockImport _ _ _) -> []
  (BlockRun _ _ _) -> []
  (BlockAssignVars pairs) -> pairs
  (BlockIf _ _ _) -> []
  (BlockList _) -> []
  (BlockCode _) -> []

-- Extract fragments used as arguments of fragment calls.
extractArguments :: Env -> [Block] -> [(Text, Expr)]
extractArguments env = concatMap (extractArgument env)

extractArgument :: Env -> Block -> [(Text, Expr)]
extractArgument env = \case
  BlockDoctype -> []
  (BlockElem _ _ _ _) -> []
  (BlockText _ _) -> []
  (BlockInclude _ _ _) -> []
  (BlockFor _ _ _ _) -> []
  (BlockFragmentDef DefinitionNormal _ _ _) ->
    []
  (BlockFragmentDef DefinitionArg name names children) ->
    [(name, Frag names env children)]
  (BlockFragmentCall _ _ _ _ _) -> []
  (BlockComment _ _) -> []
  (BlockFilter _ _) -> []
  (BlockRawElem _ _) -> []
  (BlockDefault _ _) -> []
  (BlockImport _ _ _) -> []
  (BlockRun _ _ _) -> []
  (BlockAssignVars _) -> []
  (BlockIf _ _ _) -> []
  (BlockList _) -> []
  (BlockCode _) -> []

--------------------------------------------------------------------------------
simplify :: [Block] -> [Block]
simplify = concatMap simplify'

simplify' :: Block -> [Block]
simplify' = \case
  node@BlockDoctype -> [node]
  BlockElem name mdot attrs nodes -> [BlockElem name mdot attrs $ simplify nodes]
  node@(BlockText _ _) -> [node]
  BlockInclude mfilter path mnodes -> [BlockInclude mfilter path $ simplify <$> mnodes]
  BlockFragmentDef _ _ _ _ -> []
  BlockFragmentCall _ _ _ _ args -> simplify args
  BlockFor _ _ _ nodes -> simplify nodes
  node@(BlockComment _ _) -> [node]
  node@(BlockFilter _ _) -> [node]
  node@(BlockRawElem _ _) -> [node]
  BlockDefault _ nodes -> simplify nodes
  BlockImport _ mbody _ -> maybe [] simplify mbody
  BlockRun _ _ mbody -> maybe [] simplify mbody
  BlockAssignVars _ -> []
  BlockIf _ [] bs -> simplify bs
  BlockIf _ as _ -> simplify as
  BlockList nodes -> simplify nodes
  node@(BlockCode _) -> [node]