slab 0.0.2.0 → 0.0.3.0

raw patch · 15 files changed

+656/−227 lines, 15 filesdep +servant-websocketsdep +websocketsPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: servant-websockets, websockets

API changes (from Hackage documentation)

Files

• slab.cabal +3/−1
• src/Slab/Build.hs +22/−18
• src/Slab/Command.hs +61/−12
• src/Slab/Evaluate.hs +68/−34
• src/Slab/Execute.hs +49/−21
• src/Slab/Generate/Haskell.hs +1/−1
• src/Slab/Parse.hs +134/−42
• src/Slab/PreProcess.hs +28/−12
• src/Slab/Render.hs +18/−21
• src/Slab/Report.hs +65/−3
• src/Slab/Run.hs +24/−14
• src/Slab/Serve.hs +107/−17
• src/Slab/Syntax.hs +72/−29
• src/Slab/Watch.hs +1/−1
• tests/Slab/Runner.hs +3/−1

@@ -1,6 +1,6 @@ cabal-version:      2.2 name:               slab-version:            0.0.2.0+version:            0.0.3.0 license:            BSD-2-Clause license-file:       LICENSE copyright:          2024 Võ Minh Thu, Hypered SRL@@ -68,6 +68,7 @@     , servant     , servant-blaze     , servant-server+    , servant-websockets     , stm     , text     , transformers@@ -75,6 +76,7 @@     , wai     , wai-app-static     , warp+    , websockets   exposed-modules:     Slab.Build     Slab.Command

@@ -34,19 +34,20 @@ import System.FilePath.Glob qualified as Glob  ---------------------------------------------------------------------------------buildDir :: FilePath -> Command.RenderMode -> FilePath -> IO ()-buildDir srcDir mode distDir = do+buildDir :: FilePath -> Command.RenderMode -> Command.RunMode -> FilePath -> IO ()+buildDir srcDir mode passthrough distDir = do   templates <- listTemplates srcDir-  mapM_ (buildFile srcDir mode distDir) templates+  mapM_ (buildFile srcDir mode passthrough distDir) templates -buildFile :: FilePath -> Command.RenderMode -> FilePath -> FilePath -> IO ()-buildFile srcDir mode distDir path = do+buildFile :: FilePath -> Command.RenderMode -> Command.RunMode -> FilePath -> FilePath -> IO ()+buildFile srcDir mode passthrough distDir path = do   let path' = distDir </> replaceExtension (makeRelative srcDir path) ".html"       dir' = takeDirectory path'+      ctx = Execute.Context path passthrough   putStrLn $ "Building " <> path' <> "..."   createDirectoryIfMissing True dir' -  nodes <- Execute.executeFile path >>= Error.unwrap+  nodes <- Execute.executeFile ctx >>= Error.unwrap   if Evaluate.simplify nodes == []     then putStrLn $ "No generated content for " <> path     else case mode of@@ -57,36 +58,39 @@  -------------------------------------------------------------------------------- -type Store = M.Map FilePath [Syntax.Block]+type Store = M.Map FilePath (Either Error.Error [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+buildDirInMemory :: FilePath -> Command.RenderMode -> Command.RunMode -> StmStore -> IO ()+buildDirInMemory srcDir mode passthrough store = do   templates <- listTemplates srcDir-  mapM_ (buildFileInMemory srcDir mode store) templates+  mapM_ (buildFileInMemory srcDir mode passthrough store) templates -buildFileInMemory :: FilePath -> Command.RenderMode -> StmStore -> FilePath -> IO ()-buildFileInMemory srcDir mode store path = do+buildFileInMemory :: FilePath -> Command.RenderMode -> Command.RunMode -> StmStore -> FilePath -> IO ()+buildFileInMemory srcDir mode passthrough store path = do   let path' = replaceExtension (makeRelative srcDir path) ".html"+      ctx = Execute.Context path passthrough   putStrLn $ "Building " <> path' <> "..." -  mnodes <- Execute.executeFile path+  mnodes <- Execute.executeFile ctx   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)+            atomically $ STM.modifyTVar store (writeStore path' $ Right nodes)           Command.RenderPretty ->-            atomically $ STM.modifyTVar store (writeStore path' nodes)-    Left err -> Error.display err+            atomically $ STM.modifyTVar store (writeStore path' $ Right nodes)+    Left err -> do+      Error.display err+      atomically $ STM.modifyTVar store (writeStore path' $ Left err) -writeStore :: FilePath -> [Syntax.Block] -> Store -> Store-writeStore path blocks = M.insert path blocks+writeStore :: FilePath -> Either Error.Error [Syntax.Block] -> Store -> Store+writeStore path mblocks = M.insert path mblocks  -------------------------------------------------------------------------------- listTemplates :: FilePath -> IO [FilePath]

@@ -15,6 +15,7 @@   , CommandWithPath (..)   , RenderMode (..)   , ParseMode (..)+  , RunMode (..)   , parserInfo   ) where @@ -24,19 +25,21 @@  -------------------------------------------------------------------------------- data Command-  = Build FilePath RenderMode FilePath-  | Watch FilePath RenderMode FilePath+  = Build FilePath RenderMode RunMode FilePath+  | Watch FilePath RenderMode RunMode FilePath   | Serve FilePath FilePath-  | Report FilePath+  | ReportPages FilePath+  | ReportHeadings FilePath   | -- | Generate code. Only Haskell for now.     Generate FilePath   | CommandWithPath FilePath ParseMode CommandWithPath  -- | Commands operating on a path. data CommandWithPath-  = Render RenderMode-  | Execute+  = Render RenderMode RunMode   | -- | If True, simplify the evaluated AST.+    Execute Bool RunMode+  | -- | If True, simplify the evaluated AST.     Evaluate Bool   | Parse   | -- | List the classes used in a template. TODO Later, we want to list (or create a tree) of extends/includes.@@ -52,6 +55,13 @@   | -- | Process the include statements, creating a complete template.     ParseDeep +data RunMode+  = -- | A failing external command fails the template.+    RunNormal+  | -- | A failing external command doesn't fail the template and its output is+    -- rendered in the template.+    RunPassthrough+ -------------------------------------------------------------------------------- parserInfo :: A.ParserInfo Command parserInfo =@@ -81,7 +91,7 @@           "serve"           ( A.info (parserServe <**> A.helper) $               A.progDesc-                "Watch and serve a library of Slab templates to HTML"+                "Watch and serve a library of Slab templates"           )         <> A.command           "report"@@ -146,6 +156,7 @@       RenderPretty       ( A.long "pretty" <> A.help "Use pretty-printing"       )+  passthrough <- parserPassthroughFlag   distDir <-     A.strOption       ( A.long "dist"@@ -154,7 +165,7 @@           <> A.help             "A destination directory for the generated HTML files."       )-  pure $ Build srcDir mode distDir+  pure $ Build srcDir mode passthrough distDir  parserServe :: A.Parser Command parserServe = do@@ -173,13 +184,35 @@   pure $ Serve srcDir distDir  parserReport :: A.Parser Command-parserReport = do+parserReport =+  A.subparser+    ( A.command+        "pages"+        ( A.info (parserReportPages <**> A.helper) $+            A.progDesc+              "Report pages found in a directory"+        )+        <> A.command+          "headings"+          ( A.info (parserReportHeadings <**> A.helper) $+              A.progDesc+                "Report the headings of a page"+          )+    )++parserReportPages :: A.Parser Command+parserReportPages = do   srcDir <-     A.argument       A.str       (A.metavar "DIR" <> A.action "file" <> A.help "Directory of Slab templates to analyse.")-  pure $ Report srcDir+  pure $ ReportPages srcDir +parserReportHeadings :: A.Parser Command+parserReportHeadings = do+  path <- parserTemplatePath+  pure $ ReportHeadings path+ parserWatch :: A.Parser Command parserWatch = do   srcDir <-@@ -192,6 +225,7 @@       RenderPretty       ( A.long "pretty" <> A.help "Use pretty-printing"       )+  passthrough <- parserPassthroughFlag   distDir <-     A.strOption       ( A.long "dist"@@ -200,12 +234,17 @@           <> A.help             "A destination directory for the generated HTML files."       )-  pure $ Watch srcDir mode distDir+  pure $ Watch srcDir mode passthrough distDir  parserExectue :: A.Parser Command parserExectue = do   pathAndmode <- parserWithPath-  pure $ uncurry CommandWithPath pathAndmode $ Execute+  simpl <-+    A.switch+      ( A.long "simplify" <> A.help "Simplify the AST"+      )+  passthrough <- parserPassthroughFlag+  pure $ uncurry CommandWithPath pathAndmode $ Execute simpl passthrough  parserRender :: A.Parser Command parserRender = do@@ -216,7 +255,8 @@       ( A.long "pretty" <> A.help "Use pretty-printing"       )   pathAndmode <- parserWithPath-  pure $ uncurry CommandWithPath pathAndmode $ Render mode+  passthrough <- parserPassthroughFlag+  pure $ uncurry CommandWithPath pathAndmode $ Render mode passthrough  parserEvaluate :: A.Parser Command parserEvaluate = do@@ -268,4 +308,13 @@     ParseDeep     ParseShallow     ( A.long "shallow" <> A.help "Don't parse recursively the included Slab files"+    )++--------------------------------------------------------------------------------+parserPassthroughFlag :: A.Parser RunMode+parserPassthroughFlag =+  A.flag+    RunNormal+    RunPassthrough+    ( A.long "passthrough" <> A.help "Allow external command failures"     )

@@ -24,13 +24,10 @@  import Control.Monad (forM) 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.List ((\\)) import Data.Maybe (isJust) import Data.Text (Text) import Data.Text qualified as T-import Data.Vector qualified as V import Slab.Error qualified as Error import Slab.PreProcess qualified as PreProcess import Slab.Syntax@@ -73,6 +70,7 @@     , mkElem "i" I     , mkElem "pre" Pre     , mkElem "p" P+    , mkElem "em" Em     , mkElem "ul" Ul     , mkElem "li" Li     , mkElem "title" Title@@ -135,8 +133,9 @@ 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'+    pure $ BlockElem name mdot attrs' nodes'   BlockText syn template -> do     template' <- evalTemplate env template     pure $ BlockText syn template'@@ -147,11 +146,12 @@         pure $ BlockInclude mname path (Just nodes')       Nothing ->         pure $ BlockInclude mname path Nothing-  node@(BlockFragmentDef _ _ _) -> pure node+  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'+    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@@ -184,9 +184,8 @@   BlockImport path _ args -> do     body <- call env stack (T.pack path) [] args     pure $ BlockImport path (Just body) args-  node@(BlockRun _ _) -> pure node-  node@(BlockReadJson _ _ _) -> pure node-  node@(BlockAssignVar _ _) -> pure node+  node@(BlockRun _ _ _) -> pure node+  node@(BlockAssignVars _) -> pure node   BlockIf cond as bs -> do     cond' <- evalExpr env cond     case cond' of@@ -223,12 +222,29 @@ 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'+  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 ->@@ -361,9 +377,10 @@   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)+      args = extractArguments env' nodes+      vars = args <> content+  if isJust (lookup "content" args) && not (null unnamed)     then       throwE $         Error.EvaluateError $@@ -372,7 +389,7 @@  unnamedBlock :: Block -> [Block] unnamedBlock (BlockImport path _ args) = [BlockFragmentCall (T.pack path) NoSym [] [] args]-unnamedBlock (BlockFragmentDef _ _ _) = []+unnamedBlock (BlockFragmentDef DefinitionArg _ _ _) = [] unnamedBlock node = [node]  -- Extract both fragments and assignments.@@ -389,7 +406,10 @@   (BlockText _ _) -> []   (BlockInclude _ _ children) -> maybe [] (extractVariables env) children   (BlockFor _ _ _ _) -> []-  (BlockFragmentDef name names children) -> [(name, Frag names env children)]+  (BlockFragmentDef DefinitionNormal name names children) ->+    [(name, Frag names env children)]+  (BlockFragmentDef DefinitionArg name names children) ->+    []   (BlockFragmentCall _ _ _ _ _) -> []   (BlockComment _ _) -> []   (BlockFilter _ _) -> []@@ -397,24 +417,39 @@   (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)]+  (BlockRun _ _ _) -> []+  (BlockAssignVars pairs) -> pairs   (BlockIf _ _ _) -> []   (BlockList _) -> []   (BlockCode _) -> [] -jsonToExpr :: Aeson.Value -> Expr-jsonToExpr = \case-  Aeson.String s -> SingleQuoteString s-  Aeson.Array xs ->-    List $ map jsonToExpr (V.toList xs)-  Aeson.Object kvs ->-    let f (k, v) = (SingleQuoteString $ Aeson.Key.toText k, jsonToExpr v)-     in Object $ map f (Aeson.KeyMap.toList kvs)-  x -> error $ "jsonToExpr: " <> show x+-- 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'@@ -424,8 +459,8 @@   node@BlockDoctype -> [node]   BlockElem name mdot attrs nodes -> [BlockElem name mdot attrs $ simplify nodes]   node@(BlockText _ _) -> [node]-  BlockInclude _ _ mnodes -> maybe [] simplify mnodes-  BlockFragmentDef _ _ _ -> []+  BlockInclude mfilter path mnodes -> [BlockInclude mfilter path $ simplify <$> mnodes]+  BlockFragmentDef _ _ _ _ -> []   BlockFragmentCall _ _ _ _ args -> simplify args   BlockFor _ _ _ nodes -> simplify nodes   node@(BlockComment _ _) -> [node]@@ -433,9 +468,8 @@   node@(BlockRawElem _ _) -> [node]   BlockDefault _ nodes -> simplify nodes   BlockImport _ mbody _ -> maybe [] simplify mbody-  BlockRun _ mbody -> maybe [] simplify mbody-  BlockReadJson _ _ _ -> []-  BlockAssignVar _ _ -> []+  BlockRun _ _ mbody -> maybe [] simplify mbody+  BlockAssignVars _ -> []   BlockIf _ [] bs -> simplify bs   BlockIf _ as _ -> simplify as   BlockList nodes -> simplify nodes

@@ -12,38 +12,45 @@ -- After execution, the resulting blocks can be rendered to HTML by -- "Slab.Render". module Slab.Execute-  ( executeFile+  ( Context (..)+  , executeFile   , execute   ) where  import Control.Monad.IO.Class (liftIO)-import Control.Monad.Trans.Except (ExceptT, runExceptT)+import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE) import Data.Text qualified as T+import Slab.Command qualified as Command import Slab.Error qualified as Error import Slab.Evaluate qualified as Evaluate import Slab.PreProcess qualified as PreProcess import Slab.Syntax qualified as Syntax-import System.Process (cwd, readCreateProcess, shell)+import System.Exit (ExitCode (..))+import System.Process (readCreateProcessWithExitCode, shell)  --------------------------------------------------------------------------------+data Context = Context+  { ctxPath :: FilePath+  , ctxRunMode :: Command.RunMode+  }  -- | Similar to `evaluateFile` but run external commands.-executeFile :: FilePath -> IO (Either Error.Error [Syntax.Block])-executeFile path =+executeFile :: Context -> IO (Either Error.Error [Syntax.Block])+executeFile ctx@(Context {..}) =   runExceptT $-    PreProcess.preprocessFileE path+    PreProcess.preprocessFileE ctxPath       >>= Evaluate.evaluate Evaluate.defaultEnv ["toplevel"]-      >>= execute path+      >>= execute ctx  -------------------------------------------------------------------------------- execute-  :: FilePath+  :: Context   -> [Syntax.Block]   -> ExceptT Error.Error IO [Syntax.Block] execute ctx = mapM (exec ctx) -exec :: FilePath -> Syntax.Block -> ExceptT Error.Error IO Syntax.Block-exec ctx = \case+exec :: Context -> Syntax.Block -> ExceptT Error.Error IO Syntax.Block+exec ctx@(Context {..}) = \case   node@Syntax.BlockDoctype -> pure node   Syntax.BlockElem name mdot attrs nodes -> do     nodes' <- execute ctx nodes@@ -52,9 +59,9 @@   Syntax.BlockInclude mname path mbody -> do     mbody' <- traverse (execute ctx) mbody     pure $ Syntax.BlockInclude mname path mbody'-  Syntax.BlockFragmentDef name params nodes -> do+  Syntax.BlockFragmentDef usage name params nodes -> do     nodes' <- execute ctx nodes-    pure $ Syntax.BlockFragmentDef name params nodes'+    pure $ Syntax.BlockFragmentDef usage name params nodes'   Syntax.BlockFragmentCall name mdot attrs values nodes -> do     nodes' <- execute ctx nodes     pure $ Syntax.BlockFragmentCall name mdot attrs values nodes'@@ -68,16 +75,37 @@   Syntax.BlockImport path mbody args -> do     mbody' <- traverse (execute ctx) mbody     pure $ Syntax.BlockImport path mbody' args-  node@(Syntax.BlockRun _ (Just _)) -> pure node-  Syntax.BlockRun cmd Nothing -> do-    out <-+  node@(Syntax.BlockRun _ _ (Just _)) -> pure node+  Syntax.BlockRun cmd minput Nothing -> do+    (code, out, err) <-       liftIO $-        readCreateProcess ((shell $ T.unpack cmd) {cwd = Just "/tmp/"}) ""-    pure $-      Syntax.BlockRun cmd $-        Just [Syntax.BlockText Syntax.RunOutput [Syntax.Lit $ T.pack out]]-  node@(Syntax.BlockReadJson _ _ _) -> pure node-  node@(Syntax.BlockAssignVar _ _) -> pure node+        readCreateProcessWithExitCode (shell $ T.unpack cmd) $ maybe "" T.unpack minput+    case code of+      ExitSuccess ->+        pure $+          Syntax.BlockRun cmd minput $+            Just [Syntax.BlockText Syntax.RunOutput [Syntax.Lit $ T.pack out]]+      ExitFailure _ -> case ctxRunMode of+        Command.RunNormal ->+          throwE $+            Error.ExecuteError $+              T.pack err <> T.pack out+        Command.RunPassthrough ->+          pure $+            Syntax.BlockRun cmd minput $+              Just $+                [ Syntax.BlockElem+                    Syntax.Pre+                    Syntax.NoSym+                    []+                    [ Syntax.BlockElem+                        Syntax.Code+                        Syntax.HasDot+                        []+                        [Syntax.BlockText Syntax.RunOutput [Syntax.Lit $ T.pack (err <> out)]]+                    ]+                ]+  node@(Syntax.BlockAssignVars _) -> pure node   Syntax.BlockIf cond as bs -> do     as' <- execute ctx as     bs' <- execute ctx bs

@@ -102,7 +102,7 @@ prettyAttr (Syntax.Id t) = pretty $ "A.id (H.toValue (\"" <> t <> "\" :: Text))" prettyAttr (Syntax.Class t) = pretty $ "A.class_ (H.toValue (\"" <> t <> "\" :: Text))" prettyAttr (Syntax.Attr a b) =-  "H.customAttribute" <+> pretty a <+> maybe (pretty a) prettyExpr b+  "H.customAttribute" <+> pretty a <+> prettyExpr b  prettyExpr :: Syntax.Expr -> Doc ann prettyExpr _ = "TODO"

@@ -24,13 +24,13 @@   , parseInlines   ) where -import Control.Monad (void)+import Control.Monad (guard, void) import Control.Monad.Combinators.Expr import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Except (ExceptT, except, runExceptT, withExceptT) import Data.Char (isSpace) import Data.Functor (($>))-import Data.List (intercalate)+import Data.List (intercalate, isSuffixOf) import Data.Maybe (isJust) import Data.Text (Text) import Data.Text qualified as T@@ -63,7 +63,7 @@ --     Parse.parseExpr "1 + 2 * a" -- @ parseExpr :: Text -> Either (ParseErrorBundle Text Void) Expr-parseExpr = runParser (sc *> parserExpr <* eof) ""+parseExpr = runParser (sc *> (getSourcePos >>= parserExprInd) <* eof) ""  -------------------------------------------------------------------------------- type Parser = Parsec Void Text@@ -79,6 +79,7 @@         , parserPipe         , parserExpr'         , parserFragmentDef+        , parserFragmentArg         , parserComment         , parserFilter         , parserRawElement@@ -122,10 +123,8 @@       template <- parseInlines       case template of         [] -> do-          scn-          items <- textBlock ref parserText -- TODO Use parseInlines-          let items' = realign items-          pure $ L.IndentNone $ header [BlockText Dot [Lit $ T.intercalate "\n" items']]+          s <-  parserDotText ref+          pure $ L.IndentNone $ header [BlockText Dot [Lit s]]         _ -> pure $ L.IndentNone $ header [BlockText Dot template]     HasEqual -> do       mcontent <- optional parserExpr@@ -141,6 +140,14 @@         [] -> pure $ L.IndentMany Nothing (pure . header) parserBlock         _ -> pure $ L.IndentNone $ header [BlockText Normal template] +-- | Parse indented text following a dot, or a run block.+parserDotText :: Pos -> Parser Text+parserDotText ref = do+  scn+  items <- textBlock ref parserText -- TODO Use parseInlines+  let items' = realign items+  pure $ T.intercalate "\n" items'+ -- | Parse lines of text, indented more than `ref`. -- E.g.: --     a@@ -215,6 +222,7 @@   content <- parserExpr   pure $ L.IndentNone $ BlockCode content +-- | Parse an expression on a single line. parserExpr :: Parser Expr parserExpr = makeExprParser pApp operatorTable  where@@ -233,6 +241,28 @@       <|> parens parserExpr   parens = between (lexeme $ char '(') (lexeme $ char ')') +-- | Same as "parserExpr" but allow expressions to be written on multiple lines.+-- Subsequent lines must be indented compared to the first line.+parserExprInd :: SourcePos -> Parser Expr+parserExprInd initialIndent = makeExprParser pApp (operatorTable' initialIndent)+ where+  pApp = do+    a <- pTerm+    mb <- optional $ pTerm+    case mb of+      Nothing -> pure a+      Just b -> pure $ Application a b+  pTerm =+    lx (Int <$> parserNumber)+      <|> lx (SingleQuoteString <$> parserSingleQuoteString)+      <|> lx (SingleQuoteString <$> parserDoubleQuoteString) -- TODO Double+      <|> lx parserVariable'+      <|> lx (Object <$> parserObject)+      <|> lx (JsonPath <$> try parserPath) -- TODO Force the .json extension.+      <|> parens (parserExprInd initialIndent)+  parens = between (lx $ char '(') (lx $ char ')')+  lx = lexeme' initialIndent+ parserVariable :: Parser Text parserVariable = parserName @@ -247,6 +277,18 @@     [InfixR (symbol "|" $> Cons)]   ] +operatorTable' :: SourcePos -> [[Operator Parser Expr]]+operatorTable' initialIndent =+  [ [InfixL (sym "*" $> Times), InfixL (sym "/" $> Divide)]+  , [InfixL (sym "+" $> Add), InfixL (sym "-" $> Sub)]+  , [InfixL (sym ">" $> GreaterThan), InfixL (sym "<" $> LesserThan)]+  , [InfixL (sym "==" $> Equal)]+  , -- I'd like to use : instead, but it is already used for objects...+    [InfixR (sym "|" $> Cons)]+  ]+ where+  sym = symbol' initialIndent+ parserVariable' :: Parser Expr parserVariable' = do   name <- parserName@@ -339,29 +381,30 @@     <$> (char '.' *> some (alphaNumChar <|> oneOf ("-_" :: String)))     <?> "class name" +-- | Parse both attributes and arguments. -- E.g. (), (class='a') parserAttrList :: Parser [Attr] parserAttrList = (<?> "attribute") $ do   _ <- string "("-  pairs <- many parserPair+  pairs <- sepBy+    (uncurry Attr <$> try parserPair <|> Arg <$> parserExpr)+    (lexeme $ string ",")   _ <- string ")"-  pure $ map (uncurry Attr) pairs+  pure pairs -parserPair :: Parser (Text, Maybe Expr)+parserPair :: Parser (Text, Expr) parserPair = do   a <- T.pack <$> (some (noneOf (",()= \n" :: String))) <?> "key"-  mb <- optional $ do-    _ <- string "="-    b <- lexeme parserValue-    pure b-  _ <- optional (lexeme $ string ",")-  pure (a, mb)+  _ <- string "="+  b <- lexeme parserValue+  pure (a, b)  parserValue :: Parser Expr parserValue =   SingleQuoteString <$> parserSingleQuoteString     <|> SingleQuoteString <$> parserDoubleQuoteString     <|> Int <$> parserNumber+    <|> Variable <$> parserVariable  parserSingleQuoteString :: Parser Text parserSingleQuoteString = do@@ -385,7 +428,7 @@ parserText = T.pack <$> lexeme (some (noneOf ['\n'])) <?> "text content"  parserIdentifier :: Parser Text-parserIdentifier = T.pack <$> (some (noneOf (" .=#(){}\n" :: String))) <?> "identifier"+parserIdentifier = T.pack <$> (some (noneOf (" ,.=#(){}\n" :: String))) <?> "identifier"  -------------------------------------------------------------------------------- parserInclude :: Parser (L.IndentOpt Parser Block Block)@@ -399,20 +442,49 @@   pure $ L.IndentNone $ BlockInclude mname path Nothing  parserPath :: Parser FilePath-parserPath = lexeme (some (noneOf ("'\"\n" :: String))) <?> "path"+parserPath = do+  path <- lexeme (some (noneOf ("'\"\n" :: String))) <?> "path"+  -- TODO Simply require a slash.+  guard+    ( ".slab"+        `isSuffixOf` path+        || ".json"+        `isSuffixOf` path+        || ".html"+        `isSuffixOf` path+        || ".txt"+        `isSuffixOf` path+        || ".svg"+        `isSuffixOf` path+    )+  pure path  -------------------------------------------------------------------------------- parserFragmentDef :: Parser (L.IndentOpt Parser Block Block) parserFragmentDef = do   _ <- lexeme (string "fragment" <|> string "frag")+  parserFragmentDef' DefinitionNormal++parserFragmentArg :: Parser (L.IndentOpt Parser Block Block)+parserFragmentArg = do+  _ <- lexeme (string "with")+  parserFragmentDef' DefinitionArg++parserFragmentDef' :: DefinitionUse -> Parser (L.IndentOpt Parser Block Block)+parserFragmentDef' use = do   name <- lexeme parserIdentifier   params <- maybe [] id <$> optional parserParameters-  pure $ L.IndentMany Nothing (pure . BlockFragmentDef name params) parserBlock+  kwparams <- maybe [] id <$> optional parserKwParameters+  pure $ L.IndentMany Nothing (pure . BlockFragmentDef use name (params <> kwparams)) parserBlock  -- E.g. {}, {a, b} parserParameters :: Parser [Text]-parserParameters = parserList' "{" "}" (lexeme parserIdentifier) <?> "arguments"+parserParameters = parserList' "(" ")" (lexeme parserIdentifier) <?> "parameters" +-- E.g. {}, {a, b}+parserKwParameters :: Parser [Text]+parserKwParameters = parserList' "{" "}" (lexeme parserIdentifier) <?> "named parameters"+ -------------------------------------------------------------------------------- parserFragmentCall :: Parser (L.IndentOpt Parser Block Block) parserFragmentCall = do@@ -425,9 +497,10 @@   -- TODO Use parserNameWithAttrs.   (name, attrs, trailing, args) <- lexeme $ do     name <- parserIdentifier-    attrs <- concat <$> many parserAttrs'+    attrs_ <- concat <$> many parserAttrs'+    let (attrs, args) = splitAttrsAndArgs attrs_     trailing <- parserTrailingSym-    args <- maybe [] id <$> optional parserArguments+    kwargs <- maybe [] id <$> optional parserArguments     pure (name, attrs, trailing, args)   pure $ BlockFragmentCall name trailing attrs args @@ -564,41 +637,39 @@ -------------------------------------------------------------------------------- parserRun :: Parser (L.IndentOpt Parser Block Block) parserRun = do+  ref <- L.indentLevel   _ <- lexeme (string "run")   cmd <- parserText-  pure $ L.IndentNone $ BlockRun cmd Nothing+  s <- parserDotText ref+  pure . L.IndentNone $ BlockRun cmd (Just s) Nothing  -------------------------------------------------------------------------------- parserLet :: Parser (L.IndentOpt Parser Block Block) parserLet = do   _ <- lexeme (string "let")-  name <- lexeme parserName-  _ <- lexeme (string "=")-  choice-    [ parserAssignVar name-    , parserReadJson name-    ]--parserAssignVar :: Text -> Parser (L.IndentOpt Parser Block Block)-parserAssignVar name = do-  val <- parserExpr-  pure $ L.IndentNone $ BlockAssignVar name val--parserReadJson :: Text -> Parser (L.IndentOpt Parser Block Block)-parserReadJson name = do-  path <- parserPath-  pure $ L.IndentNone $ BlockReadJson name path Nothing+  scn+  blockIndent <- getSourcePos+  pairs <- some $ do+    initialIndent <- getSourcePos+    guard+      ( sourceColumn blockIndent == sourceColumn initialIndent+      )+    name <- lexeme' initialIndent parserName+    _ <- lexeme' initialIndent (string "=")+    val <- parserExprInd initialIndent+    pure (name, val)+  pure $ L.IndentNone $ BlockAssignVars pairs  ---------------------------------------------------------------------------------scn :: Parser ()-scn = L.space space1 empty empty- -- Similar to space, but counts newlines space' :: Parser Int space' = do   s <- takeWhileP (Just "white space") isSpace   pure . length $ filter (== '\n') $ T.unpack s +scn :: Parser ()+scn = L.space space1 empty empty+ sc :: Parser () sc = L.space (void $ some (char ' ' <|> char '\t')) empty empty @@ -607,6 +678,27 @@  symbol :: Text -> Parser Text symbol = L.symbol sc++--------------------------------------------------------------------------------+-- Custom lexeme that checks against the passed indentation.+lexeme' :: SourcePos -> Parser a -> Parser a+lexeme' initialIndent p = do+  currentIndent <- getSourcePos+  guard+    ( sourceLine currentIndent == sourceLine initialIndent+        || sourceColumn currentIndent > sourceColumn initialIndent+    )+  L.lexeme scn p++-- Custom symbol that checks against the passed indentation.+symbol' :: SourcePos -> Text -> Parser Text+symbol' initialIndent s = do+  currentIndent <- getSourcePos+  guard+    ( sourceLine currentIndent == sourceLine initialIndent+        || sourceColumn currentIndent > sourceColumn initialIndent+    )+  L.symbol scn s  -------------------------------------------------------------------------------- 

@@ -17,9 +17,12 @@ 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@@ -76,9 +79,9 @@             pure $ BlockInclude mname path (Just nodes')         | otherwise ->             throwE $ Error.PreProcessError $ "File " <> T.pack includedPath <> " doesn't exist"-  BlockFragmentDef name params nodes -> do+  BlockFragmentDef usage name params nodes -> do     nodes' <- preprocess ctx nodes-    pure $ BlockFragmentDef name params nodes'+    pure $ BlockFragmentDef usage name params nodes'   BlockFragmentCall name mdot attrs values nodes -> do     nodes' <- preprocess ctx nodes     pure $ BlockFragmentCall name mdot attrs values nodes'@@ -105,16 +108,19 @@             pure $ BlockImport path (Just body) args'         | otherwise ->             throwE $ Error.PreProcessError $ "File " <> T.pack includedPath <> " doesn't exist"-  node@(BlockRun _ _) -> pure node-  BlockReadJson name path _ -> do-    let path' = takeDirectory ctxStartPath </> path-    content <- liftIO $ BL.readFile path'-    case Aeson.eitherDecode content of-      Right val ->-        pure $ BlockReadJson name path $ Just val-      Left err ->-        throwE $ Error.PreProcessError $ "Can't decode JSON: " <> T.pack err-  node@(BlockAssignVar _ _) -> pure node+  node@(BlockRun _ _ _) -> pure node+  BlockAssignVars pairs -> do+    let f (name, JsonPath path) = do+          let path' = takeDirectory ctxStartPath </> path+          content <- liftIO $ BL.readFile path'+          case Aeson.eitherDecode content of+            Right val ->+              pure (name, jsonToExpr val)+            Left err ->+              throwE $ Error.PreProcessError $ "Can't decode JSON: " <> T.pack err+        f pair = pure pair+    pairs' <- mapM f pairs+    pure $ BlockAssignVars pairs'   BlockIf cond as bs -> do     -- File inclusion is done right away, without checking the condition.     as' <- preprocess ctx as@@ -124,3 +130,13 @@     nodes' <- preprocess ctx nodes     pure $ BlockList nodes'   node@(BlockCode _) -> pure node++jsonToExpr :: Aeson.Value -> Expr+jsonToExpr = \case+  Aeson.String s -> SingleQuoteString s+  Aeson.Array xs ->+    List $ map jsonToExpr (V.toList xs)+  Aeson.Object kvs ->+    let f (k, v) = (SingleQuoteString $ Aeson.Key.toText k, jsonToExpr v)+     in Object $ map f (Aeson.KeyMap.toList kvs)+  x -> error $ "jsonToExpr: " <> show x

@@ -9,6 +9,7 @@   , renderHtmls   , renderHtmlsUtf8   , renderBlocks+  , extractTexts   ) where  import Data.ByteString.Lazy qualified as BSL@@ -54,12 +55,10 @@  where   mAddId :: H.Html -> H.Html   mAddId e =-    if idNames == []-      then e-      else e ! A.id (H.toValue idNames')-  idNames = Syntax.idNamesFromAttrs attrs-  idNames' :: Text-  idNames' = T.intercalate "-" idNames -- TODO Refuse multiple Ids in some kind of validation step after parsing ?+    case idNames of+      Nothing -> e+      Just names -> e ! A.id (H.toValue names)+  idNames = Syntax.idNamesFromAttrs' attrs   mAddClass :: H.Html -> H.Html   mAddClass e =     if classNames == []@@ -84,7 +83,7 @@   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.BlockFragmentDef _ _ _ _) = mempty renderBlock (Syntax.BlockFragmentCall _ _ _ _ nodes) = mapM_ renderBlock nodes renderBlock (Syntax.BlockFor _ _ _ nodes) = mapM_ renderBlock nodes renderBlock (Syntax.BlockComment b content) =@@ -99,11 +98,10 @@   mapM_ renderBlock children renderBlock (Syntax.BlockDefault _ nodes) = mapM_ renderBlock nodes renderBlock (Syntax.BlockImport _ (Just nodes) _) = mapM_ renderBlock nodes-renderBlock (Syntax.BlockRun _ (Just nodes)) = mapM_ renderBlock nodes-renderBlock (Syntax.BlockRun cmd _) = H.textComment $ "run " <> cmd+renderBlock (Syntax.BlockRun _ _ (Just nodes)) = mapM_ renderBlock nodes+renderBlock (Syntax.BlockRun cmd _ _) = H.textComment $ "run " <> cmd renderBlock (Syntax.BlockImport path Nothing _) = H.stringComment $ "extends " <> path-renderBlock (Syntax.BlockReadJson _ _ _) = mempty-renderBlock (Syntax.BlockAssignVar _ _) = mempty+renderBlock (Syntax.BlockAssignVars _) = mempty renderBlock (Syntax.BlockIf _ as bs) = do   -- The evaluation code transforms a BlockIf into a BlockList, so this should   -- not be called.@@ -124,15 +122,14 @@ renderBlock (Syntax.BlockCode c) = error $ "renderBlock called on BlockCode " <> show c  renderTexts :: [Syntax.Block] -> H.Html-renderTexts xs = H.preEscapedText xs'- where-  xs' = T.intercalate "\n" $ map extractText xs+renderTexts = H.preEscapedText . extractTexts  escapeTexts :: [Syntax.Block] -> H.Html-escapeTexts xs = H.text xs'- where-  xs' = T.intercalate "\n" $ map extractText xs+escapeTexts = H.text . extractTexts +extractTexts :: [Syntax.Block] -> Text+extractTexts = T.intercalate "\n" . map extractText+ extractText :: Syntax.Block -> Text extractText = f  where@@ -141,7 +138,7 @@   f (Syntax.BlockText _ [Syntax.Lit s]) = s   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.BlockFragmentDef _ _ _ _) = error "extractTexts called on a BlockFragmentDef"   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"@@ -149,9 +146,8 @@   f (Syntax.BlockRawElem _ _) = error "extractTexts called on a BlockRawElem"   f (Syntax.BlockDefault _ _) = error "extractTexts called on a BlockDefault"   f (Syntax.BlockImport _ _ _) = error "extractTexts called on a BlockImport"-  f (Syntax.BlockRun _ _) = error "extractTexts called on a BlockRun"-  f (Syntax.BlockReadJson _ _ _) = error "extractTexts called on a BlockReadJson"-  f (Syntax.BlockAssignVar _ _) = error "extractTexts called on a BlockAssignVar"+  f (Syntax.BlockRun _ _ _) = error "extractTexts called on a BlockRun"+  f (Syntax.BlockAssignVars _) = error "extractTexts called on a BlockAssignVars"   f (Syntax.BlockIf _ _ _) = error "extractTexts called on a BlockIf"   f (Syntax.BlockList _) = error "extractTexts called on a BlockList"   f (Syntax.BlockCode _) = error "extractTexts called on a BlockCode"@@ -194,6 +190,7 @@   Syntax.Link -> const H.link   Syntax.A -> H.a   Syntax.P -> H.p+  Syntax.Em -> H.em   Syntax.Ul -> H.ul   Syntax.Li -> H.li   Syntax.Title -> H.title

@@ -5,17 +5,22 @@ -- 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+  ( reportPages+  , reportHeadings   ) where +import Data.Text (Text)+import Data.Text qualified as T+import Data.Tree (Tree (..), drawForest) import Slab.Build qualified as Build import Slab.Error qualified as Error import Slab.Evaluate qualified as Evaluate+import Slab.Render qualified as Render import Slab.Syntax qualified as Syntax  ---------------------------------------------------------------------------------run :: FilePath -> IO ()-run srcDir = do+reportPages :: FilePath -> IO ()+reportPages srcDir = do   modules <- buildDir srcDir   putStrLn $ "Read " <> show (length modules) <> " modules."   let pages = filter isPage modules@@ -33,6 +38,14 @@ isPage _ = False  --------------------------------------------------------------------------------+reportHeadings :: FilePath -> IO ()+reportHeadings path = do+  modl <- buildFile path+  let headings = extractHeadings . Evaluate.simplify $ moduleNodes modl+      f (Heading level _ t) = show level <> " " <> T.unpack t+  putStrLn . drawForest . map (fmap f) $ buildTrees headings++-------------------------------------------------------------------------------- -- 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@. @@ -50,3 +63,52 @@       { modulePath = path       , moduleNodes = nodes       }++--------------------------------------------------------------------------------++buildTrees :: [Heading] -> [Tree Heading]+buildTrees [] = []+buildTrees (h : hs) =+  let (children, rest) = span ((> headingLevel h) . headingLevel) hs+      childTrees = buildTrees children+      tree = Node h childTrees+   in tree : buildTrees rest++data Heading = Heading+  { headingLevel :: Int+  , headingId :: Maybe Text+  , headingText :: Text+  }+  deriving (Show, Eq)++extractHeadings :: [Syntax.Block] -> [Heading]+extractHeadings = concatMap f+ where+  f Syntax.BlockDoctype = []+  f (Syntax.BlockElem el _ attrs children) =+    let i = Syntax.idNamesFromAttrs' attrs+        t = Render.extractTexts children+     in case el of+          Syntax.H1 -> [Heading 1 i t]+          Syntax.H2 -> [Heading 2 i t]+          Syntax.H3 -> [Heading 3 i t]+          Syntax.H4 -> [Heading 4 i t]+          Syntax.H5 -> [Heading 5 i t]+          Syntax.H6 -> [Heading 6 i t]+          _ -> extractHeadings children+  f (Syntax.BlockText _ _) = []+  f (Syntax.BlockInclude _ _ children) = maybe [] extractHeadings children+  f (Syntax.BlockFragmentDef _ _ _ _) = []+  f (Syntax.BlockFragmentCall _ _ _ _ children) =+    extractHeadings children+  f (Syntax.BlockFor _ _ _ children) = extractHeadings children+  f (Syntax.BlockComment _ _) = []+  f (Syntax.BlockFilter _ _) = []+  f (Syntax.BlockRawElem _ _) = []+  f (Syntax.BlockDefault _ children) = extractHeadings children+  f (Syntax.BlockImport _ children args) = maybe [] extractHeadings children <> extractHeadings args+  f (Syntax.BlockRun _ _ _) = []+  f (Syntax.BlockAssignVars _) = []+  f (Syntax.BlockIf _ as bs) = extractHeadings as <> extractHeadings bs+  f (Syntax.BlockList children) = extractHeadings children+  f (Syntax.BlockCode _) = []

@@ -12,6 +12,7 @@   , calc   ) where +import Control.Monad (when) import Control.Monad.Trans.Except (ExceptT, except, runExceptT, withExceptT) import Data.Text (Text) import Data.Text qualified as T@@ -30,25 +31,32 @@ import Slab.Serve qualified as Serve import Slab.Syntax qualified as Syntax import Slab.Watch qualified as Watch+import System.FilePath (takeExtension) 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.Build srcDir renderMode passthrough distDir) =+  Build.buildDir srcDir renderMode passthrough distDir+run (Command.Watch srcDir renderMode passthrough distDir) =+  Watch.run srcDir $ \path -> do+    when (takeExtension path == ".slab") $+      Build.buildFile srcDir renderMode passthrough distDir path run (Command.Serve srcDir distDir) = Serve.run srcDir distDir-run (Command.Report srcDir) = Report.run srcDir+run (Command.ReportPages srcDir) = Report.reportPages srcDir+run (Command.ReportHeadings path) = Report.reportHeadings path run (Command.Generate path) = Generate.renderHs path-run (Command.CommandWithPath path pmode (Command.Render Command.RenderNormal)) = do-  nodes <- executeWithMode path pmode >>= Error.unwrap+run (Command.CommandWithPath path pmode (Command.Render Command.RenderNormal passthrough)) = do+  nodes <- executeWithMode path pmode passthrough >>= Error.unwrap   TL.putStrLn . Render.renderHtmls $ Render.renderBlocks nodes-run (Command.CommandWithPath path pmode (Command.Render Command.RenderPretty)) = do-  nodes <- executeWithMode path pmode >>= Error.unwrap+run (Command.CommandWithPath path pmode (Command.Render Command.RenderPretty passthrough)) = do+  nodes <- executeWithMode path pmode passthrough >>= Error.unwrap   T.putStr . Render.prettyHtmls $ Render.renderBlocks nodes-run (Command.CommandWithPath path pmode Command.Execute) = do-  nodes <- executeWithMode path pmode >>= Error.unwrap-  TL.putStrLn $ pShowNoColor nodes+run (Command.CommandWithPath path pmode (Command.Execute simpl passthrough)) = do+  nodes <- executeWithMode path pmode passthrough >>= Error.unwrap+  if simpl+    then TL.putStrLn $ pShowNoColor $ Evaluate.simplify nodes+    else TL.putStrLn $ pShowNoColor nodes run (Command.CommandWithPath path pmode (Command.Evaluate simpl)) = do   nodes <- evaluateWithMode path pmode >>= Error.unwrap   if simpl@@ -85,8 +93,9 @@ executeWithMode   :: FilePath   -> Command.ParseMode+  -> Command.RunMode   -> IO (Either Error.Error [Syntax.Block])-executeWithMode path pmode = runExceptT $ executeWithModeE path pmode+executeWithMode path pmode passthrough = runExceptT $ executeWithModeE path pmode passthrough  -------------------------------------------------------------------------------- parseWithModeE@@ -109,9 +118,10 @@ executeWithModeE   :: FilePath   -> Command.ParseMode+  -> Command.RunMode   -> ExceptT Error.Error IO [Syntax.Block]-executeWithModeE path pmode =-  evaluateWithModeE path pmode >>= Execute.execute path+executeWithModeE path pmode passthrough =+  evaluateWithModeE path pmode >>= Execute.execute (Execute.Context path passthrough)  -------------------------------------------------------------------------------- -- Play with the whole language.

@@ -7,26 +7,40 @@ -- 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.+-- as they change, and runs a web server to serve them. Pages containing a+-- @head@ element are modified to include a bit of JavaScript. It serves at+-- auto-reloading the page when it is rebuilt (by connecting to a websocket). module Slab.Serve   ( run   ) where +import Control.Concurrent.Chan qualified as Chan import Control.Concurrent.STM qualified as STM import Data.Map qualified as M import Data.Text qualified as T+import Data.Text.Lazy.Encoding qualified as TLE import Network.HTTP.Types (status200) import Network.Wai qualified as Wai import Network.Wai.Handler.Warp qualified as Warp+import Network.WebSockets.Connection+  ( Connection+  , sendTextData+  , withPingThread+  ) import Protolude hiding (Handler) import Servant hiding (serve)+import Servant.API.WebSocket (WebSocket) 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.Evaluate qualified as Evaluate import Slab.Render qualified as Render+import Slab.Syntax qualified as Syntax import Slab.Watch qualified as Watch+import System.FilePath (takeExtension) import Text.Blaze.Html5 (Html)+import Text.Pretty.Simple (pShowNoColor) import WaiAppStatic.Storage.Filesystem   ( defaultWebAppSettings   )@@ -35,21 +49,29 @@ 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.+  chan <- Chan.newChan+  -- Initial build to populate the store...+  Build.buildDirInMemory srcDir Command.RenderNormal Command.RunPassthrough store+  -- ...then rebuild individual files upon change, and notify the channel.   _ <-     forkIO $-      Watch.run srcDir (Build.buildFileInMemory srcDir Command.RenderNormal store)-  Warp.run 9000 $ serve distDir store+      Watch.run srcDir $ \path -> do+        when (takeExtension path == ".slab") $+          Build.buildFileInMemory srcDir Command.RenderNormal Command.RunPassthrough store path+        when (takeExtension path /= ".slab") $+          -- Rebuild everything. TODO create a dependency graph and rebuild+          -- only what is needed.+          Build.buildDirInMemory srcDir Command.RenderNormal Command.RunPassthrough store+        Chan.writeChan chan path+  Warp.run 9000 $ serve distDir store chan  -- | Turn our `serverT` implementation into a Wai application, suitable for -- Warp.run.-serve :: FilePath -> Build.StmStore -> Wai.Application-serve root store =+serve :: FilePath -> Build.StmStore -> Chan FilePath -> Wai.Application+serve root store chan =   Servant.serveWithContext appProxy Server.EmptyContext $     Server.hoistServerWithContext appProxy settingsProxy identity $-      serverT root store+      serverT root store chan  ------------------------------------------------------------------------------ type ServerSettings = '[]@@ -60,15 +82,17 @@ ------------------------------------------------------------------------------ type App =   "hello" :> Get '[B.HTML] Html+    :<|> WebSocketApi     :<|> Servant.Raw -- Fallback handler for the static files.  appProxy :: Proxy App appProxy = Proxy  -------------------------------------------------------------------------------serverT :: FilePath -> Build.StmStore -> ServerT App Handler-serverT root store =+serverT :: FilePath -> Build.StmStore -> Chan FilePath -> ServerT App Handler+serverT root store chan =   showHelloPage+    :<|> websocket chan     :<|> app root store  ------------------------------------------------------------------------------@@ -89,12 +113,21 @@       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)+    Just mblocks -> do+      case mblocks of+        Right blocks -> do+          let blocks' = Syntax.addScript autoreloadScript $ Evaluate.simplify blocks+          sendRes $+            Wai.responseLBS+              status200+              [("Content-Type", "text/html")]+              (Render.renderHtmlsUtf8 $ Render.renderBlocks blocks')+        Left err -> do+          sendRes $+            Wai.responseLBS+              status200+              [("Content-Type", "text/plain")]+              (TLE.encodeUtf8 $ pShowNoColor err)     Nothing -> do       let Tagged staticApp = serveStatic root       staticApp req sendRes@@ -104,3 +137,60 @@ serveStatic root = Servant.serveDirectoryWith settings  where   settings = defaultWebAppSettings root++------------------------------------------------------------------------------+-- Accept websocket connections, and keep them alive.+type WebSocketApi = "ws" :> WebSocket++-- | Sends messages to the browser whenever a message is written to the channel.+websocket :: Chan FilePath -> Connection -> Handler ()+websocket chan con =+  liftIO $ do+    chan' <- dupChan chan+    withPingThread con 30 (pure ()) $+      liftIO . forever $ do+        path <- Chan.readChan chan'+        sendTextData con (T.pack $ "updated: " <> path)++-- | The auto-reload script. It connects to a websocket and refreshes the+-- current page when it receives a message from the server. Such a message is+-- sent whenever a @.slab@ file is rebuilt.+autoreloadScript :: Text+autoreloadScript =+  "function connect(isInitialConnection) {\n\+  \  // Create WebSocket connection.\n\+  \  var ws = new WebSocket('ws://' + location.host + '/ws');\n\+  \\n\+  \  // Connection opened\n\+  \  ws.onopen = function() {\n\+  \    ws.send('Hello server.');\n\+  \    if (isInitialConnection) {\n\+  \      console.log('autoreload: Initial connection.');\n\+  \    } else {\n\+  \      console.log('autoreload: Reconnected.');\n\+  \      location.reload();\n\+  \    }\n\+  \  };\n\+  \\n\+  \  // Listen for messages.\n\+  \  ws.onmessage = function(ev) {\n\+  \    console.log('autoreload: Message from server:', ev.data);\n\+  \    if (ev.data.startsWith('updated:')) {\n\+  \      location.reload();\n\+  \    }\n\+  \  };\n\+  \\n\+  \  // Trying to reconnect when the socket is closed.\n\+  \  ws.onclose = function(ev) {\n\+  \    console.log('autoreload: Socket closed. Trying to reconnect in 0.5 second.');\n\+  \    setTimeout(function() { connect(false); }, 500);\n\+  \  };\n\+  \\n\+  \  // Close the socker upon error.\n\+  \  ws.onerror = function(err) {\n\+  \    console.log('autoreload: Socket errored. Closing socket.');\n\+  \    ws.close();\n\+  \  };\n\+  \}\n\+  \\n\+  \connect(true);\n"

@@ -12,10 +12,13 @@   , pasteBlocks   , setAttrs   , setContent+  , addScript   , CommentType (..)   , Elem (..)+  , DefinitionUse (..)   , TrailingSym (..)   , Attr (..)+  , splitAttrsAndArgs   , TextSyntax (..)   , Expr (..)   , Inline (..)@@ -29,13 +32,13 @@   , extractFragments   , findFragment   , idNamesFromAttrs+  , idNamesFromAttrs'   , classNamesFromAttrs   , namesFromAttrs   , groupAttrs   ) where -import Data.Aeson qualified as Aeson-import Data.List (nub, sort)+import Data.List (nub, partition, sort) import Data.Text (Text) import Data.Text qualified as T @@ -49,9 +52,7 @@     -- preprocessing (i.e. actually running the include statement).     -- The filter name follows the same behavior as BlockFilter.     BlockInclude (Maybe Text) FilePath (Maybe [Block])-  | -- | 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]+  | BlockFragmentDef DefinitionUse Text [Text] [Block]   | BlockFragmentCall Text TrailingSym [Attr] [Expr] [Block]   | BlockFor Text (Maybe Text) Expr [Block]   | -- TODO Should we allow string interpolation here ?@@ -64,11 +65,9 @@   | -- | Similar to an anonymous fragment call, where the fragment body is the     -- content of the referenced file.     BlockImport FilePath (Maybe [Block]) [Block]-  | BlockRun Text (Maybe [Block])-  | -- | Allow to assign the content of a JSON file to a variable. The syntax-    -- is specific to how Struct has a @require@ function in scope.-    BlockReadJson Text FilePath (Maybe Aeson.Value)-  | BlockAssignVar Text Expr+  | -- | Run an external command, with maybe some stdin input.+    BlockRun Text (Maybe Text) (Maybe [Block])+  | BlockAssignVars [(Text, Expr)]   | BlockIf Expr [Block] [Block]   | BlockList [Block]   | BlockCode Expr@@ -103,6 +102,17 @@   BlockElem name mdot attrs nodes setContent _ b = b +-- | Find the head element and add a script element at its end.  TODO This+-- doesn't go through all children to find the head. It's best to use+-- "Evaluate.simplify" before using this function.+addScript :: Text -> [Block] -> [Block]+addScript t = map f+ where+  f (BlockElem Head mdot attrs children) = BlockElem Head mdot attrs (children <> [s])+  f (BlockElem name mdot attrs children) = BlockElem name mdot attrs (map f children)+  f block = block+  s = BlockElem Script NoSym [] [BlockText Dot [Lit t]]+ -- | A "passthrough" comment will be included in the generated HTML. data CommentType = NormalComment | PassthroughComment   deriving (Show, Eq)@@ -127,6 +137,7 @@   | Link   | A   | P+  | Em   | Ul   | Li   | Title@@ -163,13 +174,32 @@     Elem Text   deriving (Show, Eq) +-- | Specifies if a fragment definition is a normal definition, or one meant to+-- be an argument of a fragment call.+data DefinitionUse = DefinitionNormal | DefinitionArg+  deriving (Show, Eq)+ data TrailingSym = HasDot | HasEqual | NoSym   deriving (Show, Eq) +-- | Represent an attribute or an argument of an element. Attributes can be+-- IDs, classes, or arbitrary keys. Arguments are expressions with no key. -- The Code must already be evaluated.-data Attr = Id Text | Class Text | Attr Text (Maybe Expr)+data Attr = Id Text | Class Text | Attr Text Expr | Arg Expr   deriving (Show, Eq) +splitAttrsAndArgs :: [Attr] -> ([Attr], [Expr])+splitAttrsAndArgs = g . partition f+ where+  f = \case+    Id _ -> True+    Class _ -> True+    Attr _ _ -> True+    Arg _ -> False+  g (a, b) = (a, map h b)+  h (Arg e) = e+  h _ = error "Can't happen"+ -- Tracks the syntax used to enter the text. data TextSyntax   = -- | The text follows an element on the same line.@@ -212,6 +242,8 @@     Frag [Text] Env [Block]   | -- Same for Expr instead of Block.     Thunk Env Expr+  | -- | Allow to assign the content of a JSON file to a variable.+    JsonPath FilePath   | BuiltIn Text   deriving (Show, Eq) @@ -275,7 +307,7 @@   f (BlockElem _ _ attrs children) = concatMap g attrs <> extractClasses children   f (BlockText _ _) = []   f (BlockInclude _ _ children) = maybe [] extractClasses children-  f (BlockFragmentDef _ _ _) = [] -- We extract them in BlockFragmentCall instead.+  f (BlockFragmentDef _ _ _ _) = [] -- We extract them in BlockFragmentCall instead.   f (BlockFragmentCall _ _ attrs _ children) = concatMap g attrs <> extractClasses children   f (BlockFor _ _ _ children) = extractClasses children   f (BlockComment _ _) = []@@ -284,9 +316,8 @@   f (BlockRawElem _ _) = []   f (BlockDefault _ children) = extractClasses children   f (BlockImport _ children blocks) = maybe [] extractClasses children <> extractClasses blocks-  f (BlockRun _ _) = []-  f (BlockReadJson _ _ _) = []-  f (BlockAssignVar _ _) = []+  f (BlockRun _ _ _) = []+  f (BlockAssignVars _) = []   f (BlockIf _ as bs) = extractClasses as <> extractClasses bs   f (BlockList children) = extractClasses children   f (BlockCode _) = []@@ -294,7 +325,7 @@   g (Id _) = []   g (Class c) = [c]   g (Attr a b) = h a b-  h "class" (Just (SingleQuoteString c)) = [c]+  h "class" (SingleQuoteString c) = [c]   h "class" _ = error "The class is not a string"   h _ _ = [] @@ -311,7 +342,8 @@   f (BlockElem _ _ _ children) = extractFragments children   f (BlockText _ _) = []   f (BlockInclude _ _ children) = maybe [] extractFragments children-  f (BlockFragmentDef name _ children) = [BlockFragmentDef' name children]+  f (BlockFragmentDef DefinitionNormal name _ children) = [BlockFragmentDef' name children]+  f (BlockFragmentDef DefinitionArg _ _ _) = []   f (BlockFragmentCall name _ _ _ children) =     [BlockFragmentCall' name] <> extractFragments children   f (BlockFor _ _ _ children) = extractFragments children@@ -320,9 +352,8 @@   f (BlockRawElem _ _) = []   f (BlockDefault _ children) = extractFragments children   f (BlockImport _ children args) = maybe [] extractFragments children <> extractFragments args-  f (BlockRun _ _) = []-  f (BlockReadJson _ _ _) = []-  f (BlockAssignVar _ _) = []+  f (BlockRun _ _ _) = []+  f (BlockAssignVars _) = []   f (BlockIf _ as bs) = extractFragments as <> extractFragments bs   f (BlockList children) = extractFragments children   f (BlockCode _) = []@@ -345,10 +376,20 @@         Attr a b -> f a b     )  where-  f "id" (Just (SingleQuoteString x)) = [x]-  f "id" (Just _) = error "The id is not a string"+  f "id" (SingleQuoteString x) = [x]+  f "id" _ = error "The id is not a string"   f _ _ = [] +idNamesFromAttrs' :: [Attr] -> Maybe Text+idNamesFromAttrs' attrs =+  if idNames == []+    then Nothing+    else Just idNames'+ where+  idNames = idNamesFromAttrs attrs+  -- TODO Refuse multiple Ids in some kind of validation step after parsing ?+  idNames' = T.intercalate "-" idNames+ classNamesFromAttrs :: [Attr] -> [Text] classNamesFromAttrs =   concatMap@@ -358,8 +399,8 @@         Attr a b -> f a b     )  where-  f "class" (Just (SingleQuoteString x)) = [x]-  f "class" (Just _) = error "The class is not a string"+  f "class" (SingleQuoteString x) = [x]+  f "class" _ = error "The class is not a string"   f _ _ = []  namesFromAttrs :: [Attr] -> [(Text, Text)]@@ -373,10 +414,12 @@  where   f "id" _ = []   f "class" _ = []-  f a (Just (SingleQuoteString b)) = [(a, b)]-  f a (Just (Int b)) = [(a, T.pack $ show b)]-  f _ (Just _) = error "The attribute is not a string"-  f a Nothing = [(a, a)]+  f a (SingleQuoteString b) = [(a, b)]+  f a (Int b) = [(a, T.pack $ show b)]+  f a (Bool True) = [(a, a)]+  f a (Bool False) = []+  f a (Variable _) = error "The attribute is not evaluated"+  f _ _ = error "The attribute is not a string"  -- | Group multiple classes or IDs in a single class or ID, and transform the -- other attributes in 'SingleQuoteString's.@@ -400,4 +443,4 @@       else [Class classNames']    attrs' = namesFromAttrs attrs-  elemAttrs = map (\(a, b) -> Attr a (Just $ SingleQuoteString b)) attrs'+  elemAttrs = map (\(a, b) -> Attr a (SingleQuoteString b)) attrs'

@@ -29,7 +29,7 @@         srcDir         ( \e -> do             case e of-              Modified path _ _ | takeExtension path == ".slab" -> True+              Modified path _ _ | takeExtension path `elem` [".slab", ".pikchr"] -> True               _ -> False         )         ( \e -> do

@@ -5,6 +5,7 @@  import Data.List (sort) import Data.Text (Text)+import Slab.Command qualified as Command import Slab.Execute qualified as Execute import Slab.Render qualified as Render import System.FilePath@@ -52,7 +53,8 @@  where   action :: IO Text   action = do-    evaluated <- Execute.executeFile path+    let ctx = Execute.Context path Command.RunNormal+    evaluated <- Execute.executeFile ctx     case evaluated of       Left _ -> pure "TODO"       Right nodes -> do