slab 0.0.1.0 → 0.0.2.0

raw patch · 16 files changed

+715/−251 lines, 16 filesdep +http-typesdep +stmPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: http-types, stm

API changes (from Hackage documentation)

Files

• slab.cabal +4/−2
• src/Slab/Build.hs +50/−0
• src/Slab/Command.hs +7/−3
• src/Slab/Error.hs +19/−5
• src/Slab/Evaluate.hs +237/−82
• src/Slab/Execute.hs +12/−2
• src/Slab/Generate/Haskell.hs +8/−0
• src/Slab/Parse.hs +142/−132
• src/Slab/PreProcess.hs +9/−2
• src/Slab/Render.hs +39/−6
• src/Slab/Report.hs +7/−0
• src/Slab/Run.hs +59/−4
• src/Slab/Serve.hs +56/−10
• src/Slab/Syntax.hs +58/−3
• src/Slab/Watch.hs +6/−0
• tests/Slab/GHCi.hs +2/−0

@@ -1,6 +1,6 @@ cabal-version:      2.2 name:               slab-version:            0.0.1.0+version:            0.0.2.0 license:            BSD-2-Clause license-file:       LICENSE copyright:          2024 Võ Minh Thu, Hypered SRL@@ -11,7 +11,7 @@ description:     Slab is an alternative syntax for writing HTML, plus some programming     language features (often found in templating languages, like conditionals-    and loops).+    and loops). You can visit the project homepage at <https://slab-lang.org>. category:           text  source-repository head@@ -59,6 +59,7 @@     , filepath     , fsnotify     , Glob+    , http-types     , megaparsec     , parser-combinators     , prettyprinter@@ -67,6 +68,7 @@     , servant     , servant-blaze     , servant-server+    , stm     , text     , transformers     , vector

@@ -1,10 +1,26 @@+-- |+-- Module      : Slab.Build+-- Description : Build Slab templates to HTML+--+-- @Slab.Build@ provides types and functions to easily build Slab templates.+-- There are mostly two ways to build templates: by writing the resulting HTML+-- to files, or by writing them to an @STM@-based store.+--+-- Writing to disk is used by the @slab watch@ command. Writing to the @STM@+-- store is used by the @slab serve@ command. module Slab.Build   ( buildDir   , buildFile+  , StmStore+  , buildDirInMemory+  , buildFileInMemory   , listTemplates   ) where +import Control.Concurrent.STM (atomically)+import Control.Concurrent.STM qualified as STM import Data.List (sort)+import Data.Map qualified as M import Data.Text.IO qualified as T import Data.Text.Lazy.IO qualified as TL import Slab.Command qualified as Command@@ -12,6 +28,7 @@ import Slab.Evaluate qualified as Evaluate import Slab.Execute qualified as Execute import Slab.Render qualified as Render+import Slab.Syntax qualified as Syntax import System.Directory (createDirectoryIfMissing) import System.FilePath (makeRelative, replaceExtension, takeDirectory, (</>)) import System.FilePath.Glob qualified as Glob@@ -37,6 +54,39 @@         TL.writeFile path' . Render.renderHtmls $ Render.renderBlocks nodes       Command.RenderPretty ->         T.writeFile path' . Render.prettyHtmls $ Render.renderBlocks nodes++--------------------------------------------------------------------------------++type Store = M.Map FilePath [Syntax.Block]++type StmStore = STM.TVar Store++-- | A version of `buildDir` that doesn't write files to disk, but instead+-- record the generated `Syntax.Block`s in STM.+buildDirInMemory :: FilePath -> Command.RenderMode -> StmStore -> IO ()+buildDirInMemory srcDir mode store = do+  templates <- listTemplates srcDir+  mapM_ (buildFileInMemory srcDir mode store) templates++buildFileInMemory :: FilePath -> Command.RenderMode -> StmStore -> FilePath -> IO ()+buildFileInMemory srcDir mode store path = do+  let path' = replaceExtension (makeRelative srcDir path) ".html"+  putStrLn $ "Building " <> path' <> "..."++  mnodes <- Execute.executeFile path+  case mnodes of+    Right nodes ->+      if Evaluate.simplify nodes == []+        then putStrLn $ "No generated content for " <> path+        else case mode of+          Command.RenderNormal ->+            atomically $ STM.modifyTVar store (writeStore path' nodes)+          Command.RenderPretty ->+            atomically $ STM.modifyTVar store (writeStore path' nodes)+    Left err -> Error.display err++writeStore :: FilePath -> [Syntax.Block] -> Store -> Store+writeStore path blocks = M.insert path blocks  -------------------------------------------------------------------------------- listTemplates :: FilePath -> IO [FilePath]

@@ -26,7 +26,7 @@ data Command   = Build FilePath RenderMode FilePath   | Watch FilePath RenderMode FilePath-  | Serve FilePath+  | Serve FilePath FilePath   | Report FilePath   | -- | Generate code. Only Haskell for now.     Generate FilePath@@ -158,15 +158,19 @@  parserServe :: A.Parser Command parserServe = do+  srcDir <-+    A.argument+      A.str+      (A.metavar "DIR" <> A.action "file" <> A.help "Directory of Slab templates to build.")   distDir <-     A.strOption       ( A.long "dist"           <> A.value "./_site"           <> A.metavar "DIR"           <> A.help-            "A destination directory for the generated HTML files."+            "A directory with existing static files."       )-  pure $ Serve distDir+  pure $ Serve srcDir distDir  parserReport :: A.Parser Command parserReport = do

@@ -1,6 +1,14 @@+-- |+-- Module      : Slab.Error+-- Description : Errors that the different Slab stages can produce+--+-- @Slab.Error@ provides a data type to represent all the errors emitted by+-- Slab. It also provides helper functions to report errors in a human-readable+-- way. module Slab.Error   ( Error (..)   , unwrap+  , display   ) where  import Data.List.NonEmpty qualified as NE (toList)@@ -30,15 +38,21 @@ -- | Extract a Right value, or die, emitting an error message. unwrap :: Either Error a -> IO a unwrap = \case-  Left (ParseError err) -> do+  Left err -> do+    display err+    exitFailure+  Right a -> pure a++display :: Error -> IO ()+display = \case+  ParseError err ->     -- Our custom function seems actually worse than errorBundlePretty.     -- T.putStrLn . parseErrorPretty $ err     T.putStrLn . T.pack $ errorBundlePretty err-    exitFailure-  Left err -> do+  EvaluateError err ->+    T.putStrLn $ "Error during evaluation: " <> err+  err ->     TL.putStrLn $ pShowNoColor err-    exitFailure-  Right a -> pure a  -------------------------------------------------------------------------------- -- Convert parse errors to a user-friendly message.

@@ -1,8 +1,23 @@ {-# 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@@ -28,10 +43,75 @@  evaluateFileE :: FilePath -> ExceptT Error.Error IO [Block] evaluateFileE path =-  PreProcess.preprocessFileE path >>= evaluate defaultEnv ["toplevel"]+  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 "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]@@ -43,7 +123,16 @@   mapM (eval env' stack) nodes  eval :: Monad m => Env -> [Text] -> Block -> ExceptT Error.Error m Block-eval env stack = \case+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     nodes' <- evaluate env stack nodes@@ -59,9 +148,10 @@       Nothing ->         pure $ BlockInclude mname path Nothing   node@(BlockFragmentDef _ _ _) -> pure node-  BlockFragmentCall name values args -> do+  BlockFragmentCall name mdot attrs values args -> do     body <- call env stack name values args-    pure $ BlockFragmentCall name values body+    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@@ -88,7 +178,7 @@         nodes' <- evaluate env ("?block" : stack) nodes         pure $ BlockDefault name nodes'       Just (Frag _ capturedEnv nodes') -> do-        nodes'' <- evaluate capturedEnv ("+block" : stack) nodes'+        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@@ -100,17 +190,15 @@   BlockIf cond as bs -> do     cond' <- evalExpr env cond     case cond' of-      SingleQuoteString s-        | not (T.null s) -> do-            as' <- evaluate env ("then" : stack) as-            pure $ BlockIf cond as' []-      Int n-        | n /= 0 -> do-            as' <- evaluate env ("then" : stack) as-            pure $ BlockIf cond as' []-      _ -> do+      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'@@ -121,18 +209,10 @@ 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 names capturedEnv body) -> do-      env' <- map (\(a, (as, b)) -> (a, Frag as env b)) <$> namedBlocks args-      let env'' = augmentVariables capturedEnv env'-          arguments = zip names (map (thunk env) values)-          env''' = augmentVariables env'' arguments-      body' <- evaluate env''' ("frag" : stack) body-      pure body'+    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 <> "\""--defaultEnv :: Env-defaultEnv = Env [("true", Int 1), ("false", Int 0)]+    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@@ -140,25 +220,14 @@ augmentVariables :: Env -> [(Text, Expr)] -> Env augmentVariables Env {..} xs = Env {envVariables = xs <> envVariables} -namedBlocks :: Monad m => [Block] -> ExceptT Error.Error m [(Text, ([Text], [Block]))]-namedBlocks nodes = do-  named <- concat <$> mapM namedBlock nodes-  unnamed <- concat <$> mapM unnamedBlock nodes-  let content = if null unnamed then [] else [("content", ([], unnamed))]-  if isJust (lookup "content" named) && not (null unnamed)-    then throwE $ Error.EvaluateError $ "A block of content and a content argument are provided"-    else pure $ named <> content--namedBlock :: Monad m => Block -> ExceptT Error.Error m [(Text, ([Text], [Block]))]-namedBlock (BlockImport path (Just body) _) = pure [(T.pack path, ([], body))]-namedBlock (BlockFragmentDef name names content) = pure [(name, (names, content))]-namedBlock _ = pure []--unnamedBlock :: Monad m => Block -> ExceptT Error.Error m [Block]-unnamedBlock (BlockImport path _ args) =-  pure [BlockFragmentCall (T.pack path) [] args]-unnamedBlock (BlockFragmentDef _ _ _) = pure []-unnamedBlock node = pure [node]+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+  let env'' = augmentVariables capturedEnv env'+      arguments = zip names (map (thunk env) values)+      env''' = augmentVariables env'' arguments+  body' <- evaluate env''' ("frag " <> name : stack) body+  pure body'  evalExpr :: Monad m => Env -> Expr -> ExceptT Error.Error m Expr evalExpr env = \case@@ -172,8 +241,7 @@         -- key' <- evalExpr env key         case lookup key obj of           Just val -> evalExpr env val-          Nothing ->-            pure $ Variable "false"+          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@@ -181,75 +249,162 @@     b' <- evalExpr env b     case (a', b') of       (Int i, Int j) -> pure . Int $ i + j-      (Int i, SingleQuoteString s) -> pure . SingleQuoteString $ T.pack (show i) <> s+      (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 (Add a' b'))+      _ -> 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 (Add a' b'))+      _ -> 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 (Add a' b'))+      _ -> 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 --- After evaluation, the template should be either empty or contain a single literal.+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 = do-  t <- T.concat <$> traverse (evalInline env) inlines-  pure [Lit t]+evalTemplate env inlines =+  traverse (evalInline env) inlines -evalInline :: Monad m => Env -> Inline -> ExceptT Error.Error m Text+evalInline :: Monad m => Env -> Inline -> ExceptT Error.Error m Inline evalInline env = \case-  Lit s -> pure s+  Lit s -> pure $ Lit s   Place code -> do     code' <- evalExpr env code     case code' of-      SingleQuoteString s -> pure s-      Int x -> pure . T.pack $ show x+      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)]+      vars = named <> content+      env' = augmentVariables env named -- Note we don't add the implicit "content" entry.+  if isJust (lookup "content" named) && 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 _ _ _) = []+unnamedBlock node = [node]+ -- Extract both fragments and assignments.--- TODO This should be merged with namedBlocks.+-- 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 f- where-  f BlockDoctype = []-  f (BlockElem _ _ _ _) = []-  f (BlockText _ _) = []-  f (BlockInclude _ _ children) = maybe [] (extractVariables env) children-  f (BlockFor _ _ _ _) = []-  f (BlockFragmentDef name names children) = [(name, Frag names env children)]-  f (BlockFragmentCall _ _ _) = []-  f (BlockComment _ _) = []-  f (BlockFilter _ _) = []-  f (BlockRawElem _ _) = []-  f (BlockDefault _ _) = []-  f (BlockImport path (Just body) _) = [(T.pack path, Frag [] env body)]-  f (BlockImport _ _ _) = []-  f (BlockRun _ _) = []-  f (BlockReadJson name _ (Just val)) = [(name, jsonToExpr val)]-  f (BlockReadJson _ _ Nothing) = []-  f (BlockAssignVar name val) = [(name, val)]-  f (BlockIf _ _ _) = []-  f (BlockList _) = []-  f (BlockCode _) = []+extractVariables env = concatMap (extractVariable env) +extractVariable :: Env -> Block -> [(Text, Expr)]+extractVariable env = \case+  BlockDoctype -> []+  (BlockElem _ _ _ _) -> []+  (BlockText _ _) -> []+  (BlockInclude _ _ children) -> maybe [] (extractVariables env) children+  (BlockFor _ _ _ _) -> []+  (BlockFragmentDef name names children) -> [(name, Frag names env children)]+  (BlockFragmentCall _ _ _ _ _) -> []+  (BlockComment _ _) -> []+  (BlockFilter _ _) -> []+  (BlockRawElem _ _) -> []+  (BlockDefault _ _) -> []+  (BlockImport path (Just body) _) -> [(T.pack path, Frag [] env body)]+  (BlockImport _ _ _) -> []+  (BlockRun _ _) -> []+  (BlockReadJson name _ (Just val)) -> [(name, jsonToExpr val)]+  (BlockReadJson _ _ Nothing) -> []+  (BlockAssignVar name val) -> [(name, val)]+  (BlockIf _ _ _) -> []+  (BlockList _) -> []+  (BlockCode _) -> []+ jsonToExpr :: Aeson.Value -> Expr jsonToExpr = \case   Aeson.String s -> SingleQuoteString s@@ -271,7 +426,7 @@   node@(BlockText _ _) -> [node]   BlockInclude _ _ mnodes -> maybe [] simplify mnodes   BlockFragmentDef _ _ _ -> []-  BlockFragmentCall _ _ args -> simplify args+  BlockFragmentCall _ _ _ _ args -> simplify args   BlockFor _ _ _ nodes -> simplify nodes   node@(BlockComment _ _) -> [node]   node@(BlockFilter _ _) -> [node]

@@ -1,6 +1,16 @@ {-# 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   ( executeFile   , execute@@ -45,9 +55,9 @@   Syntax.BlockFragmentDef name params nodes -> do     nodes' <- execute ctx nodes     pure $ Syntax.BlockFragmentDef name params nodes'-  Syntax.BlockFragmentCall name values nodes -> do+  Syntax.BlockFragmentCall name mdot attrs values nodes -> do     nodes' <- execute ctx nodes-    pure $ Syntax.BlockFragmentCall name values nodes'+    pure $ Syntax.BlockFragmentCall name mdot attrs values nodes'   node@(Syntax.BlockFor _ _ _ _) -> pure node   node@(Syntax.BlockComment _ _) -> pure node   node@(Syntax.BlockFilter _ _) -> pure node

@@ -1,3 +1,11 @@+-- |+-- Module      : Slab.Generate.Haskell+-- Description : Translate from the Slab syntax to Haskell+--+-- @Slab.Generate.Haskell@ is an attempt to translate Slab to Haskell. This+-- could make it possible to use Slab within Haskell projects without needing+-- to interpret Slab templates at runtime. If this proves useful, other+-- languages could also be supported. module Slab.Generate.Haskell   ( renderHs   ) where

@@ -1,5 +1,13 @@ {-# LANGUAGE RecordWildCards #-} +-- |+-- Module      : Slab.Parse+-- Description : Parse the concrete Slab syntax to an AST+--+-- @Slab.Parse@ provides parsers to read text and construct an abstract syntax+-- tree, as represented by "Slab.Syntax".+--+-- Parsers are written using the @megaparsec@ library. module Slab.Parse   ( parseFile   , parseFileE@@ -47,12 +55,12 @@ --------------------------------------------------------------------------------  parse :: FilePath -> Text -> Either (ParseErrorBundle Text Void) [Block]-parse fn = runParser (many parserNode <* eof) fn+parse fn = runParser (many parserBlock <* eof) fn  -- | We expose the expression parser for development: -- -- @---     print $ Parse.parseExpr "1 + 2 * a"+--     Parse.parseExpr "1 + 2 * a" -- @ parseExpr :: Text -> Either (ParseErrorBundle Text Void) Expr parseExpr = runParser (sc *> parserExpr <* eof) ""@@ -60,8 +68,8 @@ -------------------------------------------------------------------------------- type Parser = Parsec Void Text -parserNode :: Parser Block-parserNode = do+parserBlock :: Parser Block+parserBlock = do   node <-     L.indentBlock scn $       choice@@ -79,7 +87,7 @@         , parserRun         , parserLet         , try parserEach-        , parserIf+        , try parserIf         , parserFragmentCall         ]   case node of@@ -90,19 +98,25 @@  parserIf :: Parser (L.IndentOpt Parser Block Block) parserIf = do-  _ <- lexeme $ string "if"+  _ <- string "if"+  _ <- some (char ' ' <|> char '\t')   cond <- parserExpr-  pure $ L.IndentMany Nothing (pure . (\as -> BlockIf cond as [])) parserNode+  pure $ L.IndentMany Nothing (pure . (\as -> BlockIf cond as [])) parserBlock  parserElse :: Parser (L.IndentOpt Parser [Block] Block) parserElse = do   _ <- lexeme $ string "else"-  pure $ L.IndentMany Nothing pure parserNode+  pure $ L.IndentMany Nothing pure parserBlock  parserElement :: Parser (L.IndentOpt Parser Block Block) parserElement = do   ref <- L.indentLevel   header <- parserDiv+  parserElemBody ref header++-- | Parse the indented content of an HTML element or a fragment call.+parserElemBody :: Pos -> ([Block] -> Block) -> Parser (L.IndentOpt Parser Block Block)+parserElemBody ref header =   case trailingSym $ header [] of     HasDot -> do       template <- parseInlines@@ -124,7 +138,7 @@     NoSym -> do       template <- parseInlines       case template of-        [] -> pure $ L.IndentMany Nothing (pure . header) parserNode+        [] -> pure $ L.IndentMany Nothing (pure . header) parserBlock         _ -> pure $ L.IndentNone $ header [BlockText Normal template]  -- | Parse lines of text, indented more than `ref`.@@ -149,7 +163,7 @@             l <- p             ls <- go             let prefix = T.replicate (unPos pos - unPos ref) " "-                n' = replicate (n - 1) prefix+                n' = replicate (n - 1) ""                 l' = prefix <> l             pure $ n' <> (l' : ls) @@ -159,7 +173,7 @@ realign :: [Text] -> [Text] realign xs = map (T.drop n) xs  where-  n = minimum $ map (T.length . T.takeWhile (== ' ')) xs+  n = minimum $ map (T.length . T.takeWhile (== ' ')) $ filter (not . T.null) xs  -- | Parse multiple lines starting each with a pipe prefix. Most of our parsers -- parse a single line (and optional indented child lines) and most nodes map@@ -202,28 +216,35 @@   pure $ L.IndentNone $ BlockCode content  parserExpr :: Parser Expr-parserExpr =-  parserExpression-    <|> (Object <$> parserObject)--parserVariable :: Parser Text-parserVariable = parserName--parserExpression :: Parser Expr-parserExpression = makeExprParser pTerm operatorTable+parserExpr = makeExprParser pApp operatorTable  where+  pApp = do+    a <- pTerm+    mb <- optional $ pTerm+    case mb of+      Nothing -> pure a+      Just b -> pure $ Application a b   pTerm =     lexeme (Int <$> parserNumber)       <|> lexeme (SingleQuoteString <$> parserSingleQuoteString)+      <|> lexeme (SingleQuoteString <$> parserDoubleQuoteString) -- TODO Double       <|> lexeme parserVariable'-      <|> parens parserExpression-  parens = between (char '(') (char ')')+      <|> lexeme (Object <$> parserObject)+      <|> parens parserExpr+  parens = between (lexeme $ char '(') (lexeme $ char ')') +parserVariable :: Parser Text+parserVariable = parserName+ -- An operator table to define precedence and associativity operatorTable :: [[Operator Parser Expr]] operatorTable =   [ [InfixL (symbol "*" $> Times), InfixL (symbol "/" $> Divide)]   , [InfixL (symbol "+" $> Add), InfixL (symbol "-" $> Sub)]+  , [InfixL (symbol ">" $> GreaterThan), InfixL (symbol "<" $> LesserThan)]+  , [InfixL (symbol "==" $> Equal)]+  , -- I'd like to use : instead, but it is already used for objects...+    [InfixR (symbol "|" $> Cons)]   ]  parserVariable' :: Parser Expr@@ -254,89 +275,23 @@ -- E.g. div, div.a, div() parserElemWithAttrs :: Parser ([Block] -> Block) parserElemWithAttrs = do-  (name, attrs, mdot) <--    lexeme-      ( do-          a <- parserElem-          -- `try` because we want to backtrack if there is a dot-          -- not followed by a class name, for mdot to succeed.-          b <- many parserAttrs'-          mtrailing <--            optional $-              choice-                [ string "." >> pure HasDot-                , string "=" >> pure HasEqual-                ]-          pure (a, concat b, maybe NoSym id mtrailing)-      )-      <?> "div tag"+  (name, attrs, mdot) <- parserNameWithAttrs   pure $ BlockElem name mdot attrs +parserNameWithAttrs :: Parser (Elem, [Attr], TrailingSym)+parserNameWithAttrs =+  lexeme+    ( do+        el <- parserElem+        attrs <- concat <$> many parserAttrs'+        trailing <- parserTrailingSym+        pure (el, attrs, trailing)+    )+    <?> "element"+ parserElem :: Parser Elem parserElem =-  ( try $ do-      name <--        T.pack-          <$> ( do-                  a <- letterChar-                  as <- many (alphaNumChar <|> oneOf ("-_" :: String))-                  pure (a : as)-              )-          <?> "identifier"-      case name of-        "html" -> pure Html-        "body" -> pure Body-        "div" -> pure Div-        "span" -> pure Span-        "br" -> pure Br-        "hr" -> pure Hr-        "h1" -> pure H1-        "h2" -> pure H2-        "h3" -> pure H3-        "h4" -> pure H4-        "h5" -> pure H5-        "h6" -> pure H6-        "header" -> pure Header-        "head" -> pure Head-        "meta" -> pure Meta-        "main" -> pure Main-        "audio" -> pure Audio-        "a" -> pure A-        "code" -> pure Code-        "img" -> pure Img-        "iframe" -> pure IFrame-        "input" -> pure Input-        "i" -> pure I-        "pre" -> pure Pre-        "p" -> pure P-        "ul" -> pure Ul-        "link" -> pure Link-        "li" -> pure Li-        "title" -> pure Title-        "table" -> pure Table-        "thead" -> pure Thead-        "tbody" -> pure Tbody-        "tr" -> pure Tr-        "td" -> pure Td-        "dl" -> pure Dl-        "dt" -> pure Dt-        "dd" -> pure Dd-        "footer" -> pure Footer-        "figure" -> pure Figure-        "form" -> pure Form-        "label" -> pure Label-        "blockquote" -> pure Blockquote-        "button" -> pure Button-        "figcaption" -> pure Figcaption-        "script" -> pure Script-        "style" -> pure Style-        "small" -> pure Small-        "source" -> pure Source-        "svg" -> pure Svg-        "textarea" -> pure Textarea-        "canvas" -> pure Canvas-        _ -> fail "invalid element name"-  )+  (lexeme (string "el") *> (Elem <$> lexeme parserName))     <?> "element name"  -- E.g. .a, ()@@ -345,9 +300,9 @@   (attrs, mdot) <-     lexeme       ( do-          attrs <- some parserAttrs'+          attrs <- concat <$> some parserAttrs'           mdot <- optional (string ".")-          pure (concat attrs, maybe NoSym (const HasDot) mdot)+          pure (attrs, maybe NoSym (const HasDot) mdot)       )       <?> "attributes"   pure $ BlockElem Div mdot attrs@@ -358,6 +313,16 @@   -- not followed by a class name, for mdot to succeed.   ((: []) <$> parserId) <|> try ((: []) <$> parserClass) <|> parserAttrList +parserTrailingSym :: Parser TrailingSym+parserTrailingSym = do+  ms <-+    optional $+      choice+        [ string "." >> pure HasDot+        , string "=" >> pure HasEqual+        ]+  pure $ maybe NoSym id ms+ -- E.g. #a parserId :: Parser Attr parserId =@@ -401,14 +366,14 @@ parserSingleQuoteString :: Parser Text parserSingleQuoteString = do   _ <- string "'"-  s <- T.pack <$> (some (noneOf ("'\n" :: String))) <?> "string"+  s <- T.pack <$> (many (noneOf ("'\n" :: String))) <?> "string"   _ <- string "'"   pure s  parserDoubleQuoteString :: Parser Text parserDoubleQuoteString = do   _ <- string "\""-  s <- T.pack <$> (some (noneOf ("\"\n" :: String))) <?> "string"+  s <- T.pack <$> (many (noneOf ("\"\n" :: String))) <?> "string"   _ <- string "\""   pure s @@ -420,7 +385,7 @@ parserText = T.pack <$> lexeme (some (noneOf ['\n'])) <?> "text content"  parserIdentifier :: Parser Text-parserIdentifier = T.pack <$> lexeme (some (noneOf (" {}\n" :: String))) <?> "identifier"+parserIdentifier = T.pack <$> (some (noneOf (" .=#(){}\n" :: String))) <?> "identifier"  -------------------------------------------------------------------------------- parserInclude :: Parser (L.IndentOpt Parser Block Block)@@ -434,27 +399,38 @@   pure $ L.IndentNone $ BlockInclude mname path Nothing  parserPath :: Parser FilePath-parserPath = lexeme (some (noneOf ['\n'])) <?> "path"+parserPath = lexeme (some (noneOf ("'\"\n" :: String))) <?> "path"  -------------------------------------------------------------------------------- parserFragmentDef :: Parser (L.IndentOpt Parser Block Block) parserFragmentDef = do   _ <- lexeme (string "fragment" <|> string "frag")-  name <- parserIdentifier+  name <- lexeme parserIdentifier   params <- maybe [] id <$> optional parserParameters-  pure $ L.IndentMany Nothing (pure . BlockFragmentDef name params) parserNode+  pure $ L.IndentMany Nothing (pure . BlockFragmentDef name params) parserBlock  -- E.g. {}, {a, b} parserParameters :: Parser [Text]-parserParameters = parserList' "{" "}" parserIdentifier <?> "arguments"+parserParameters = parserList' "{" "}" (lexeme parserIdentifier) <?> "arguments"  -------------------------------------------------------------------------------- parserFragmentCall :: Parser (L.IndentOpt Parser Block Block) parserFragmentCall = do-  name <- parserIdentifier-  args <- maybe [] id <$> optional parserArguments-  pure $ L.IndentMany Nothing (pure . BlockFragmentCall name args) parserNode+  ref <- L.indentLevel+  header <- parserCall+  parserElemBody ref header +parserCall :: Parser ([Block] -> Block)+parserCall = do+  -- TODO Use parserNameWithAttrs.+  (name, attrs, trailing, args) <- lexeme $ do+    name <- parserIdentifier+    attrs <- concat <$> many parserAttrs'+    trailing <- parserTrailingSym+    args <- maybe [] id <$> optional parserArguments+    pure (name, attrs, trailing, args)+  pure $ BlockFragmentCall name trailing attrs args+ -- E.g. {}, {1, 'a'} parserArguments :: Parser [Expr] parserArguments = parserList' "{" "}" parserExpr <?> "arguments"@@ -462,7 +438,8 @@ -------------------------------------------------------------------------------- parserEach :: Parser (L.IndentOpt Parser Block Block) parserEach = do-  _ <- lexeme (string "for")+  _ <- string "for"+  _ <- some (char ' ' <|> char '\t')   name <- lexeme parserName   mindex <- optional $ do     _ <- lexeme $ string ","@@ -470,7 +447,7 @@   _ <- lexeme (string "in")   collection <-     (List <$> parserList) <|> (Object <$> parserObject) <|> (Variable <$> parserVariable)-  pure $ L.IndentMany Nothing (pure . BlockFor name mindex collection) parserNode+  pure $ L.IndentMany Nothing (pure . BlockFor name mindex collection) parserBlock  parserList :: Parser [Expr] parserList = parserList' "[" "]" parserExpr@@ -562,7 +539,7 @@ parserRawElement :: Parser (L.IndentOpt Parser Block Block) parserRawElement = do   header <- parserAngleBracket-  pure $ L.IndentMany Nothing (pure . header) parserNode+  pure $ L.IndentMany Nothing (pure . header) parserBlock  parserAngleBracket :: Parser ([Block] -> Block) parserAngleBracket = do@@ -575,14 +552,14 @@ parserDefault = do   _ <- lexeme (string "default")   name <- parserText-  pure $ L.IndentMany Nothing (pure . BlockDefault name) parserNode+  pure $ L.IndentMany Nothing (pure . BlockDefault name) parserBlock  -------------------------------------------------------------------------------- parserImport :: Parser (L.IndentOpt Parser Block Block) parserImport = do   _ <- lexeme (string "import")   path <- parserPath-  pure $ L.IndentMany Nothing (pure . BlockImport path Nothing) parserNode+  pure $ L.IndentMany Nothing (pure . BlockImport path Nothing) parserBlock  -------------------------------------------------------------------------------- parserRun :: Parser (L.IndentOpt Parser Block Block)@@ -604,7 +581,7 @@  parserAssignVar :: Text -> Parser (L.IndentOpt Parser Block Block) parserAssignVar name = do-  val <- lexeme parserValue+  val <- parserExpr   pure $ L.IndentNone $ BlockAssignVar name val  parserReadJson :: Text -> Parser (L.IndentOpt Parser Block Block)@@ -637,12 +614,15 @@  -- Text interpolation modeled on the @template@ library by Johan Tibell. -- - This uses Megaparsec instead of an internal State monad parser.--- - This uses @#@ instead of @$@.+-- - This uses @#@ instead of @$@, and both @()@ and @{}@.+--   - @()@ uses the expression syntax.+--   - @{}@ uses the block syntax (although limited). -- - Only the safe parsers are provided. -- - Only the applicative interface is provided.--- - We don't support #name, but only #{name}, because # can appear+-- - We don't support #name, but only #(name), because # can appear --   in character entities, URLs, ... -- TODO Mention the BSD-3 license and Johan.+-- TODO Actually support #name.  -------------------------------------------------------------------------------- @@ -684,31 +664,61 @@ -------------------------------------------------------------------------------- -- Template parser +-- | Record whether we are parsing a template within the normal block syntax,+-- or within an inline block syntax (introduced by #{...}). This is allow a+-- closing curly bracket in the normal case without requiring to escape it, and+-- disallowing it in the inline case (since it is used to end the inline case).+data InlineContext = NormalBlock | InlineBlock+ parseInlines :: Parser [Inline]-parseInlines = combineLits <$> M.many parseInline+parseInlines = parseInlines' NormalBlock -parseInline :: Parser Inline-parseInline =+parseInlines' :: InlineContext -> Parser [Inline]+parseInlines' ctx = combineLits <$> M.many (parseInline ctx)++parseInline :: InlineContext -> Parser Inline+parseInline ctx =   M.choice-    [ parseLit-    , parsePlace+    [ parseLit ctx+    , parsePlaceExpr+    , parsePlaceBlock     , parseEscape     , parseSharpLit     ]  -- TODO The \n condition could be optional if we want this module to be useful -- outside Slab.-parseLit :: Parser Inline-parseLit = do-  s <- M.takeWhile1P (Just "literal") (\c -> c /= '#' && c /= '\n')+parseLit :: InlineContext -> Parser Inline+parseLit ctx = do+  s <- case ctx of+    NormalBlock -> M.takeWhile1P (Just "literal") (\c -> c /= '#' && c /= '\n')+    InlineBlock -> M.takeWhile1P (Just "literal") (\c -> c /= '#' && c /= '\n' && c /= '}')   pure $ Lit s -parsePlace :: Parser Inline-parsePlace = do-  _ <- string $ T.pack "#{"+parsePlaceExpr :: Parser Inline+parsePlaceExpr = do+  _ <- string $ T.pack "#("   e <- parserExpr+  _ <- string $ T.pack ")"+  pure $ Place e++parsePlaceBlock :: Parser Inline+parsePlaceBlock = do+  _ <- string $ T.pack "#{"+  e <- Block <$> parseInlineBlock   _ <- string $ T.pack "}"   pure $ Place e++-- | Equivalent to `parserBlock` but in an inline context.+parseInlineBlock :: Parser Block+parseInlineBlock = do+  header <- parserDiv <|> parserCall+  template <- parseInlines' InlineBlock+  -- Don't return anything of the template is empty. to avoid a newline when+  -- rendering.+  if null template+    then pure $ header []+    else pure $ header [BlockText Dot template]  parseEscape :: Parser Inline parseEscape = do

@@ -1,6 +1,13 @@ {-# 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@@ -72,9 +79,9 @@   BlockFragmentDef name params nodes -> do     nodes' <- preprocess ctx nodes     pure $ BlockFragmentDef name params nodes'-  BlockFragmentCall name values nodes -> do+  BlockFragmentCall name mdot attrs values nodes -> do     nodes' <- preprocess ctx nodes-    pure $ BlockFragmentCall name values nodes'+    pure $ BlockFragmentCall name mdot attrs values nodes'   node@(BlockFor _ _ _ _) -> pure node   node@(BlockComment _ _) -> pure node   node@(BlockFilter _ _) -> pure node

@@ -1,9 +1,17 @@+-- |+-- Module      : Slab.Render+-- Description : Render an AST to HTML+--+-- @Slab.Render@ transforms an evaluated syntax tree to HTML. In practice this+-- can be @blaze-html@'s @Html@, or @Text@ and lazy @ByteString@. module Slab.Render   ( prettyHtmls   , renderHtmls+  , renderHtmlsUtf8   , renderBlocks   ) where +import Data.ByteString.Lazy qualified as BSL import Data.String (fromString) import Data.Text (Text) import Data.Text qualified as T@@ -11,9 +19,11 @@ import Slab.Syntax qualified as Syntax import Text.Blaze.Html.Renderer.Pretty qualified as Pretty (renderHtml) import Text.Blaze.Html.Renderer.Text (renderHtml)+import Text.Blaze.Html.Renderer.Utf8 qualified as Utf8 (renderHtml) import Text.Blaze.Html5 (Html, (!)) import Text.Blaze.Html5 qualified as H import Text.Blaze.Html5.Attributes qualified as A+import Text.Blaze.Internal qualified as I import Text.Blaze.Svg11 qualified as S  --------------------------------------------------------------------------------@@ -23,6 +33,9 @@ renderHtmls :: [Html] -> TL.Text renderHtmls = TL.concat . map renderHtml +renderHtmlsUtf8 :: [Html] -> BSL.ByteString+renderHtmlsUtf8 = BSL.concat . map Utf8.renderHtml+ -------------------------------------------------------------------------------- renderBlocks :: [Syntax.Block] -> [H.Html] renderBlocks = map renderBlock@@ -62,16 +75,17 @@   attrs' = Syntax.namesFromAttrs attrs renderBlock (Syntax.BlockText _ []) =   H.preEscapedText "\n" -- This allows to force some whitespace.-renderBlock (Syntax.BlockText _ [Syntax.Lit s])-  | s == T.empty = H.preEscapedText "\n" -- This allows to force some whitespace.-  | otherwise = H.preEscapedText s -- TODO-renderBlock (Syntax.BlockText _ _) = error "Template is not rendered."+renderBlock (Syntax.BlockText _ t) =+  let s = renderTemplate t+   in if s == T.empty+        then H.preEscapedText "\n" -- This allows to force some whitespace.+        else H.preEscapedText s -- TODO renderBlock (Syntax.BlockInclude (Just "escape-html") _ (Just nodes)) =   escapeTexts nodes renderBlock (Syntax.BlockInclude _ _ (Just nodes)) = mapM_ renderBlock nodes renderBlock (Syntax.BlockInclude _ path Nothing) = H.stringComment $ "include " <> path renderBlock (Syntax.BlockFragmentDef _ _ _) = mempty-renderBlock (Syntax.BlockFragmentCall _ _ nodes) = mapM_ renderBlock nodes+renderBlock (Syntax.BlockFragmentCall _ _ _ _ nodes) = mapM_ renderBlock nodes renderBlock (Syntax.BlockFor _ _ _ nodes) = mapM_ renderBlock nodes renderBlock (Syntax.BlockComment b content) =   case b of@@ -106,6 +120,7 @@   H.string $ show i renderBlock (Syntax.BlockCode (Syntax.Object _)) =   H.text "<Object>"+renderBlock (Syntax.BlockCode (Syntax.Block x)) = renderBlock x renderBlock (Syntax.BlockCode c) = error $ "renderBlock called on BlockCode " <> show c  renderTexts :: [Syntax.Block] -> H.Html@@ -127,7 +142,7 @@   f (Syntax.BlockText _ _) = error "extractTexts called on unevaluated BlockText"   f (Syntax.BlockInclude _ _ _) = error "extractTexts called on a BlockInclude"   f (Syntax.BlockFragmentDef _ _ _) = error "extractTexts called on a BlockFragmentDef"-  f (Syntax.BlockFragmentCall _ _ _) = error "extractTexts called on a BlockFragmentCall"+  f (Syntax.BlockFragmentCall _ _ _ _ _) = error "extractTexts called on a BlockFragmentCall"   f (Syntax.BlockFor _ _ _ _) = error "extractTexts called on a BlockFor"   f (Syntax.BlockComment _ _) = error "extractTexts called on a BlockComment"   f (Syntax.BlockFilter _ _) = error "extractTexts called on a BlockFilter"@@ -141,6 +156,23 @@   f (Syntax.BlockList _) = error "extractTexts called on a BlockList"   f (Syntax.BlockCode _) = error "extractTexts called on a BlockCode" +-- After evaluation, we should have only reduced values (e.g. no variables).+renderTemplate :: [Syntax.Inline] -> Text+renderTemplate inlines =+  let t = map renderInline inlines+   in T.concat t++renderInline :: Syntax.Inline -> Text+renderInline = \case+  Syntax.Lit s -> s+  Syntax.Place code -> do+    case code of+      Syntax.SingleQuoteString s -> s+      Syntax.Bool x -> T.pack $ show x+      Syntax.Int x -> T.pack $ show x+      Syntax.Block b -> TL.toStrict . renderHtml $ renderBlock b+      x -> error $ "renderInline: unhandled value: " <> show x+ renderElem :: Syntax.Elem -> Html -> Html renderElem = \case   Syntax.Html -> H.html@@ -194,3 +226,4 @@   Syntax.Svg -> S.svg   Syntax.Textarea -> H.textarea   Syntax.Canvas -> H.canvas+  Syntax.Elem name -> I.customParent (H.textTag name)

@@ -1,3 +1,9 @@+-- |+-- Module      : Slab.Report+-- Description : Report information about Slab templates (mostly empty for now)+--+-- This module serves as a way to explore new Slab features, e.g. creating a+-- module system, or analyzing a growing HTML code base to help refactor it. module Slab.Report   ( run   ) where@@ -28,6 +34,7 @@  -------------------------------------------------------------------------------- -- Similar to Build.buildDir and buildFile, but don't render HTML to disk.+-- TODO Move this code to (and combine it with) with @Slab.Build@.  buildDir :: FilePath -> IO [Module] buildDir srcDir = do

@@ -6,9 +6,15 @@ -- runs them. module Slab.Run   ( run+  , parse+  , eval+  , render+  , calc   ) where -import Control.Monad.Trans.Except (ExceptT, runExceptT)+import Control.Monad.Trans.Except (ExceptT, except, runExceptT, withExceptT)+import Data.Text (Text)+import Data.Text qualified as T import Data.Text.IO qualified as T import Data.Text.Lazy.IO qualified as TL import Slab.Build qualified as Build@@ -24,14 +30,14 @@ import Slab.Serve qualified as Serve import Slab.Syntax qualified as Syntax import Slab.Watch qualified as Watch-import Text.Pretty.Simple (pShowNoColor)+import Text.Pretty.Simple (pPrintNoColor, pShowNoColor)  -------------------------------------------------------------------------------- run :: Command.Command -> IO () run (Command.Build srcDir renderMode distDir) = Build.buildDir srcDir renderMode distDir run (Command.Watch srcDir renderMode distDir) =   Watch.run srcDir (Build.buildFile srcDir renderMode distDir)-run (Command.Serve distDir) = Serve.run distDir+run (Command.Serve srcDir distDir) = Serve.run srcDir distDir run (Command.Report srcDir) = Report.run srcDir run (Command.Generate path) = Generate.renderHs path run (Command.CommandWithPath path pmode (Command.Render Command.RenderNormal)) = do@@ -98,7 +104,7 @@   -> ExceptT Error.Error IO [Syntax.Block] evaluateWithModeE path pmode = do   parsed <- parseWithModeE path pmode-  Evaluate.evaluate Evaluate.defaultEnv ["toplevel"] parsed+  Evaluate.evaluate Evaluate.defaultEnv [T.pack path] parsed  executeWithModeE   :: FilePath@@ -106,3 +112,52 @@   -> ExceptT Error.Error IO [Syntax.Block] executeWithModeE path pmode =   evaluateWithModeE path pmode >>= Execute.execute path++--------------------------------------------------------------------------------+-- Play with the whole language.++parse :: Text -> IO ()+parse s = do+  blocks <- runExceptT $ withExceptT Error.ParseError . except $ Parse.parse "-" s+  pPrintNoColor blocks++-- | "eval" parses a string as a "Syntax.Syntax", and evaluates it. This doesn't+-- run the proprocessing stage.+--+-- @+--     Run.eval "p= 1 + 2 * 3"+-- @+eval :: Text -> IO ()+eval s = do+  x <- runExceptT $ parseAndEvaluateBlocks s+  pPrintNoColor x++-- | Run "eval" and render the result.+render :: Text -> IO ()+render s = do+  x <- runExceptT (parseAndEvaluateBlocks s) >>= Error.unwrap+  T.putStr . Render.prettyHtmls $ Render.renderBlocks x++parseAndEvaluateBlocks :: Text -> ExceptT Error.Error IO [Syntax.Block]+parseAndEvaluateBlocks s = do+  blocks <- withExceptT Error.ParseError . except $ Parse.parse "-" s+  Evaluate.evaluate Evaluate.defaultEnv [] blocks++--------------------------------------------------------------------------------+-- Play with the expression language.++-- | "calc" parses a string as a "Syntax.Expr", and evaluates it. I.e. it+-- doens't use the fragment syntax, or imports and includes.+--+-- @+--     Run.calc "1 + 2 * 3"+-- @+calc :: Text -> IO ()+calc s = do+  x <- runExceptT $ parseAndEvaluateExpr s+  pPrintNoColor x++parseAndEvaluateExpr :: Text -> ExceptT Error.Error IO Syntax.Expr+parseAndEvaluateExpr s = do+  expr <- withExceptT Error.ParseError . except $ Parse.parseExpr s+  Evaluate.evalExpr Evaluate.defaultEnv expr

@@ -1,33 +1,55 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-} +-- |+-- Module      : Slab.Serve+-- Description : Run a development server to preview Slab templates+--+-- @Slab.Serve@ watches a set of Slab templates, continuously rebuilding them+-- as they change, and runs a web server to serve them. module Slab.Serve   ( run   ) where +import Control.Concurrent.STM qualified as STM+import Data.Map qualified as M+import Data.Text qualified as T+import Network.HTTP.Types (status200) import Network.Wai qualified as Wai import Network.Wai.Handler.Warp qualified as Warp import Protolude hiding (Handler) import Servant hiding (serve) import Servant.HTML.Blaze qualified as B import Servant.Server qualified as Server+import Slab.Build qualified as Build+import Slab.Command qualified as Command+import Slab.Render qualified as Render+import Slab.Watch qualified as Watch import Text.Blaze.Html5 (Html) import WaiAppStatic.Storage.Filesystem   ( defaultWebAppSettings   )  -------------------------------------------------------------------------------run :: FilePath -> IO ()-run distDir =-  Warp.run 9000 $ serve distDir+run :: FilePath -> FilePath -> IO ()+run srcDir distDir = do+  store <- atomically $ STM.newTVar M.empty+  -- Initial build to populate the store.+  Build.buildDirInMemory srcDir Command.RenderNormal store+  -- Then rebuild one file upon change.+  _ <-+    forkIO $+      Watch.run srcDir (Build.buildFileInMemory srcDir Command.RenderNormal store)+  Warp.run 9000 $ serve distDir store  -- | Turn our `serverT` implementation into a Wai application, suitable for -- Warp.run.-serve :: FilePath -> Wai.Application-serve root =+serve :: FilePath -> Build.StmStore -> Wai.Application+serve root store =   Servant.serveWithContext appProxy Server.EmptyContext $     Server.hoistServerWithContext appProxy settingsProxy identity $-      serverT root+      serverT root store  ------------------------------------------------------------------------------ type ServerSettings = '[]@@ -38,20 +60,44 @@ ------------------------------------------------------------------------------ type App =   "hello" :> Get '[B.HTML] Html-    :<|> Servant.Raw -- Fallback handler for the static files, in particular the+    :<|> Servant.Raw -- Fallback handler for the static files.  appProxy :: Proxy App appProxy = Proxy  -------------------------------------------------------------------------------serverT :: FilePath -> ServerT App Handler-serverT root =+serverT :: FilePath -> Build.StmStore -> ServerT App Handler+serverT root store =   showHelloPage-    :<|> serveStatic root+    :<|> app root store  ------------------------------------------------------------------------------ showHelloPage :: Handler Html showHelloPage = pure "Hello."++------------------------------------------------------------------------------++-- | Try to serve a built page, and fallback to static files if the page+-- doesn't exist.+app :: FilePath -> Build.StmStore -> Server.Tagged Handler Server.Application+app root store = Tagged $ \req sendRes -> app' root store req sendRes++app' :: FilePath -> Build.StmStore -> Application+app' root store req sendRes = do+  templates <- liftIO . atomically $ STM.readTVar store+  let path = T.intercalate "/" $ Wai.pathInfo req+      path' = if T.null path then "index.html" else path+  -- TODO Check requestMethod is GET.+  case M.lookup (T.unpack path') templates of+    Just blocks ->+      sendRes $+        Wai.responseLBS+          status200+          [("Content-Type", "text/html")]+          (Render.renderHtmlsUtf8 $ Render.renderBlocks blocks)+    Nothing -> do+      let Tagged staticApp = serveStatic root+      staticApp req sendRes  ------------------------------------------------------------------------------ serveStatic :: FilePath -> Server.Tagged Handler Server.Application

@@ -1,8 +1,17 @@ {-# LANGUAGE RecordWildCards #-} +-- |+-- Module      : Slab.Syntax+-- Description : The abstract syntax used by Slab+--+-- @Slab.Syntax@ provides data types to represent the syntax used by the Slab+-- language. It also provides small helpers functions to operate on the syntax. module Slab.Syntax   ( Block (..)   , isDoctype+  , pasteBlocks+  , setAttrs+  , setContent   , CommentType (..)   , Elem (..)   , TrailingSym (..)@@ -12,6 +21,7 @@   , Inline (..)   , Env (..)   , emptyEnv+  , displayEnv   , trailingSym   , freeVariables   , thunk@@ -42,7 +52,7 @@   | -- | This doesn't exist in Pug. This is like a mixin than receive block arguments.     -- Or like a parent template that can be @extended@ by a child template.     BlockFragmentDef Text [Text] [Block]-  | BlockFragmentCall Text [Expr] [Block]+  | BlockFragmentCall Text TrailingSym [Attr] [Expr] [Block]   | BlockFor Text (Maybe Text) Expr [Block]   | -- TODO Should we allow string interpolation here ?     BlockComment CommentType Text@@ -70,8 +80,29 @@  trailingSym :: Block -> TrailingSym trailingSym (BlockElem _ sym _ _) = sym+trailingSym (BlockFragmentCall _ sym _ _ _) = sym trailingSym _ = NoSym +-- | Takes two blocks and returns a BlockList containing both, but peel the+-- outer list of a and b if they are themselves BlockList.+pasteBlocks :: Block -> Block -> Block+pasteBlocks a b = BlockList $ peel a <> peel b+ where+  peel (BlockList xs) = xs+  peel x = [x]++-- | Set attrs on a the first block, if it is a BlockElem.+setAttrs :: [Attr] -> [Block] -> [Block]+setAttrs attrs (BlockElem name mdot attrs' nodes : bs) =+  BlockElem name mdot (attrs' <> attrs) nodes : bs+setAttrs _ bs = bs++-- | Set the content on a block, if it is a BlockElem.+setContent :: [Block] -> Block -> Block+setContent nodes (BlockElem name mdot attrs _) =+  BlockElem name mdot attrs nodes+setContent _ b = b+ -- | A "passthrough" comment will be included in the generated HTML. data CommentType = NormalComment | PassthroughComment   deriving (Show, Eq)@@ -128,6 +159,8 @@   | Svg   | Textarea   | Canvas+  | -- | Arbitrary element name, using the @el@ keyword.+    Elem Text   deriving (Show, Eq)  data TrailingSym = HasDot | HasEqual | NoSym@@ -155,21 +188,31 @@ -- | Simple expression language. data Expr   = Variable Text+  | Bool Bool   | Int Int   | SingleQuoteString Text   | List [Expr]   | Object [(Expr, Expr)]   | -- The object[key] lookup. This is quite restrive as a start.     Lookup Text Expr+  | Application Expr Expr   | Add Expr Expr   | Sub Expr Expr   | Times Expr Expr   | Divide Expr Expr+  | GreaterThan Expr Expr+  | LesserThan Expr Expr+  | Equal Expr Expr+  | -- Not really a cons for lists, but instead to add content to an element.+    -- E.g. p : "Hello."+    Cons Expr Expr+  | Block Block   | -- Expr can be a fragment, so we can manipulate them with code later.     -- We also capture the current environment.     Frag [Text] Env [Block]   | -- Same for Expr instead of Block.     Thunk Env Expr+  | BuiltIn Text   deriving (Show, Eq)  -- | A representation of a 'Data.Text' template is a list of Inline, supporting@@ -187,11 +230,22 @@ emptyEnv :: Env emptyEnv = Env [] +-- Similar to `show`, but makes the environment capture by "Frag" and "Thunk"+-- empty to avoid an infinite data structure.+displayEnv :: Env -> Text+displayEnv = T.pack . show . map (\(a, b) -> (a, f b)) . envVariables+ where+  f = \case+    Frag names _ children -> Frag names emptyEnv children+    Thunk _ expr -> Thunk emptyEnv expr+    expr -> expr+ -------------------------------------------------------------------------------- freeVariables :: Expr -> [Text] freeVariables =   nub . \case     Variable a -> [a]+    Bool _ -> []     Int _ -> []     SingleQuoteString _ -> []     List as -> concatMap freeVariables as@@ -222,7 +276,7 @@   f (BlockText _ _) = []   f (BlockInclude _ _ children) = maybe [] extractClasses children   f (BlockFragmentDef _ _ _) = [] -- We extract them in BlockFragmentCall instead.-  f (BlockFragmentCall _ _ children) = extractClasses children+  f (BlockFragmentCall _ _ attrs _ children) = concatMap g attrs <> extractClasses children   f (BlockFor _ _ _ children) = extractClasses children   f (BlockComment _ _) = []   f (BlockFilter _ _) = []@@ -258,7 +312,8 @@   f (BlockText _ _) = []   f (BlockInclude _ _ children) = maybe [] extractFragments children   f (BlockFragmentDef name _ children) = [BlockFragmentDef' name children]-  f (BlockFragmentCall name _ children) = [BlockFragmentCall' name] <> extractFragments children+  f (BlockFragmentCall name _ _ _ children) =+    [BlockFragmentCall' name] <> extractFragments children   f (BlockFor _ _ _ children) = extractFragments children   f (BlockComment _ _) = []   f (BlockFilter _ _) = []

@@ -1,3 +1,9 @@+-- |+-- Module      : Slab.Watch+-- Description : Continuously build a set of Slab templates+--+-- @Slab.Watch@ watches a set of Slab templates, continuously rebuilding them+-- as they change. module Slab.Watch   ( run   ) where

@@ -8,9 +8,11 @@   (   ) where +import Data.Text (Text) import Data.Text qualified as T import Slab.Build qualified as Build import Slab.Command qualified as Command+import Slab.Error qualified as Error import Slab.Evaluate qualified as Evaluate import Slab.Execute qualified as Execute import Slab.Generate.Haskell qualified as Generate