packages feed

slab (empty) → 0.0.1.0

raw patch · 20 files changed

+2757/−0 lines, 20 filesdep +Globdep +QuickCheckdep +aeson

Dependencies added: Glob, QuickCheck, aeson, base, blaze-html, blaze-markup, blaze-svg, bytestring, containers, directory, filepath, fsnotify, hspec, lens, megaparsec, optparse-applicative, parser-combinators, pretty-simple, prettyprinter, process, protolude, servant, servant-blaze, servant-server, slab, tasty, tasty-silver, text, transformers, vector, wai, wai-app-static, warp

Files

+ LICENSE view
@@ -0,0 +1,25 @@+Copyright 2024 Võ Minh Thu, Hypered SRL+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright notice,+   this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION).+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF+SUCH DAMAGE.
+ bin/slab.hs view
@@ -0,0 +1,11 @@+module Main+  ( main+  ) where++import Options.Applicative qualified as A+import Slab.Command qualified as Command+import Slab.Run qualified as Run++--------------------------------------------------------------------------------+main :: IO ()+main = A.execParser Command.parserInfo >>= Run.run
+ slab.cabal view
@@ -0,0 +1,123 @@+cabal-version:      2.2+name:               slab+version:            0.0.1.0+license:            BSD-2-Clause+license-file:       LICENSE+copyright:          2024 Võ Minh Thu, Hypered SRL+author:             Võ Minh Thu+maintainer:         thu@hypered.be+homepage:           https://slab-lang.org+synopsis:           A programmable markup language to generate HTML+description:+    Slab is an alternative syntax for writing HTML, plus some programming+    language features (often found in templating languages, like conditionals+    and loops).+category:           text++source-repository head+  type: git+  location: https://github.com/hypered/slab++common common-extensions+  default-language: Haskell2010+  default-extensions:+    ImportQualifiedPost+    LambdaCase+    OverloadedStrings+    RecordWildCards+    StrictData+    TypeApplications+    TypeOperators++common common-options+  default-language: Haskell2010+  ghc-options:+    -Wall+    -Wmissing-export-lists+    -fno-warn-unused-do-bind+    +RTS -A256m -n4m -qg -RTS++-- Generating version bounds can be done with+--     nix-shell --run 'cabal freeze'+common common-dependencies+  build-depends:+      base >=4.7 && <5+    , optparse-applicative+    , protolude++library+  import: common-extensions, common-options, common-dependencies+  hs-source-dirs: src+  build-depends:+      aeson+    , blaze-html+    , blaze-markup+    , blaze-svg+    , bytestring+    , containers+    , directory+    , filepath+    , fsnotify+    , Glob+    , megaparsec+    , parser-combinators+    , prettyprinter+    , pretty-simple+    , process+    , servant+    , servant-blaze+    , servant-server+    , text+    , transformers+    , vector+    , wai+    , wai-app-static+    , warp+  exposed-modules:+    Slab.Build+    Slab.Command+    Slab.Error+    Slab.Execute+    Slab.Evaluate+    Slab.Generate.Haskell+    Slab.Parse+    Slab.PreProcess+    Slab.Render+    Slab.Report+    Slab.Run+    Slab.Serve+    Slab.Syntax+    Slab.Watch++executable slab+  import: common-extensions, common-options, common-dependencies+  main-is: slab.hs+  hs-source-dirs: bin+  build-depends:+    slab+  ghc-options:+    -threaded++test-suite slab-examples+  import: common-extensions, common-options, common-dependencies+  build-depends:+    , hspec+    , slab+    , filepath+    , Glob+    , lens+    , pretty-simple+    , process+    , QuickCheck+    , tasty+    , tasty-silver+    , text+  other-modules:+    -- The GHCi module is not really used in the test-suite but is mentioned+    -- here to please Fourmolu.+    Slab.GHCi+    Slab.Runner+  type: exitcode-stdio-1.0+  main-is: run-examples.hs+  hs-source-dirs:+      tests
+ src/Slab/Build.hs view
@@ -0,0 +1,45 @@+module Slab.Build+  ( buildDir+  , buildFile+  , listTemplates+  ) where++import Data.List (sort)+import Data.Text.IO qualified as T+import Data.Text.Lazy.IO qualified as TL+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.Render qualified as Render+import System.Directory (createDirectoryIfMissing)+import System.FilePath (makeRelative, replaceExtension, takeDirectory, (</>))+import System.FilePath.Glob qualified as Glob++--------------------------------------------------------------------------------+buildDir :: FilePath -> Command.RenderMode -> FilePath -> IO ()+buildDir srcDir mode distDir = do+  templates <- listTemplates srcDir+  mapM_ (buildFile srcDir mode distDir) templates++buildFile :: FilePath -> Command.RenderMode -> FilePath -> FilePath -> IO ()+buildFile srcDir mode distDir path = do+  let path' = distDir </> replaceExtension (makeRelative srcDir path) ".html"+      dir' = takeDirectory path'+  putStrLn $ "Building " <> path' <> "..."+  createDirectoryIfMissing True dir'++  nodes <- Execute.executeFile path >>= Error.unwrap+  if Evaluate.simplify nodes == []+    then putStrLn $ "No generated content for " <> path+    else case mode of+      Command.RenderNormal ->+        TL.writeFile path' . Render.renderHtmls $ Render.renderBlocks nodes+      Command.RenderPretty ->+        T.writeFile path' . Render.prettyHtmls $ Render.renderBlocks nodes++--------------------------------------------------------------------------------+listTemplates :: FilePath -> IO [FilePath]+listTemplates templatesDir = sort <$> Glob.globDir1 pat templatesDir+ where+  pat = Glob.compile "**/*.slab"
+ src/Slab/Command.hs view
@@ -0,0 +1,267 @@+{-# LANGUAGE ApplicativeDo #-}++-- |+-- Module      : Slab.Command+-- Description : Command-line interface to Slab+--+-- @Slab.Command@ provides a command line interface for the Slab program.+--+-- Commands and options are defined by parsers written using the+-- @optparse-applicative@ library.+--+-- The implementation of each command can be found in the "Slab.Run" module.+module Slab.Command+  ( Command (..)+  , CommandWithPath (..)+  , RenderMode (..)+  , ParseMode (..)+  , parserInfo+  ) where++import Data.Text (Text)+import Options.Applicative ((<**>))+import Options.Applicative qualified as A++--------------------------------------------------------------------------------+data Command+  = Build FilePath RenderMode FilePath+  | Watch FilePath RenderMode FilePath+  | Serve FilePath+  | Report FilePath+  | -- | Generate code. Only Haskell for now.+    Generate FilePath+  | CommandWithPath FilePath ParseMode CommandWithPath++-- | Commands operating on a path.+data CommandWithPath+  = Render RenderMode+  | Execute+  | -- | 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.+    Classes+  | -- | List the fragments used in a template. If a name is given, extract that definition.+    Fragments (Maybe Text)++data RenderMode = RenderNormal | RenderPretty++data ParseMode+  = -- | Don't process include statements.+    ParseShallow+  | -- | Process the include statements, creating a complete template.+    ParseDeep++--------------------------------------------------------------------------------+parserInfo :: A.ParserInfo Command+parserInfo =+  A.info (parser <**> A.helper) $+    A.fullDesc+      <> A.header "slab - A programmable markup language to generate HTML"+      <> A.progDesc+        "Slab is a programmable markup language to generate HTML."++--------------------------------------------------------------------------------+parser :: A.Parser Command+parser =+  A.subparser+    ( A.command+        "build"+        ( A.info (parserBuild <**> A.helper) $+            A.progDesc+              "Build a library of Slab templates to HTML"+        )+        <> A.command+          "watch"+          ( A.info (parserWatch <**> A.helper) $+              A.progDesc+                "Watch and build a library of Slab templates to HTML"+          )+        <> A.command+          "serve"+          ( A.info (parserServe <**> A.helper) $+              A.progDesc+                "Watch and serve a library of Slab templates to HTML"+          )+        <> A.command+          "report"+          ( A.info (parserReport <**> A.helper) $+              A.progDesc+                "Analyse a library of Slab templates"+          )+        <> A.command+          "render"+          ( A.info (parserRender <**> A.helper) $+              A.progDesc+                "Render a Slab template to HTML"+          )+        <> A.command+          "run"+          ( A.info (parserExectue <**> A.helper) $+              A.progDesc+                "Execute a Slab template"+          )+        <> A.command+          "evaluate"+          ( A.info (parserEvaluate <**> A.helper) $+              A.progDesc+                "Evaluate a Slab template"+          )+        <> A.command+          "parse"+          ( A.info (parserParse <**> A.helper) $+              A.progDesc+                "Parse a Slab template to AST"+          )+        <> A.command+          "generate"+          ( A.info (parserGenerate <**> A.helper) $+              A.progDesc+                "Generate code corresponding to a Slab template"+          )+        <> A.command+          "classes"+          ( A.info (parserClasses <**> A.helper) $+              A.progDesc+                "Parse a Slab template and report its CSS classes"+          )+        <> A.command+          "fragments"+          ( A.info (parserFragments <**> A.helper) $+              A.progDesc+                "Parse a Slab template and report its fragments"+          )+    )++--------------------------------------------------------------------------------+parserBuild :: A.Parser Command+parserBuild = do+  srcDir <-+    A.argument+      A.str+      (A.metavar "DIR" <> A.action "file" <> A.help "Directory of Slab templates to build.")+  mode <-+    A.flag+      RenderNormal+      RenderPretty+      ( A.long "pretty" <> A.help "Use pretty-printing"+      )+  distDir <-+    A.strOption+      ( A.long "dist"+          <> A.value "./_site"+          <> A.metavar "DIR"+          <> A.help+            "A destination directory for the generated HTML files."+      )+  pure $ Build srcDir mode distDir++parserServe :: A.Parser Command+parserServe = do+  distDir <-+    A.strOption+      ( A.long "dist"+          <> A.value "./_site"+          <> A.metavar "DIR"+          <> A.help+            "A destination directory for the generated HTML files."+      )+  pure $ Serve distDir++parserReport :: A.Parser Command+parserReport = do+  srcDir <-+    A.argument+      A.str+      (A.metavar "DIR" <> A.action "file" <> A.help "Directory of Slab templates to analyse.")+  pure $ Report srcDir++parserWatch :: A.Parser Command+parserWatch = do+  srcDir <-+    A.argument+      A.str+      (A.metavar "DIR" <> A.action "file" <> A.help "Directory of Slab templates to watch.")+  mode <-+    A.flag+      RenderNormal+      RenderPretty+      ( A.long "pretty" <> A.help "Use pretty-printing"+      )+  distDir <-+    A.strOption+      ( A.long "dist"+          <> A.value "./_site"+          <> A.metavar "DIR"+          <> A.help+            "A destination directory for the generated HTML files."+      )+  pure $ Watch srcDir mode distDir++parserExectue :: A.Parser Command+parserExectue = do+  pathAndmode <- parserWithPath+  pure $ uncurry CommandWithPath pathAndmode $ Execute++parserRender :: A.Parser Command+parserRender = do+  mode <-+    A.flag+      RenderNormal+      RenderPretty+      ( A.long "pretty" <> A.help "Use pretty-printing"+      )+  pathAndmode <- parserWithPath+  pure $ uncurry CommandWithPath pathAndmode $ Render mode++parserEvaluate :: A.Parser Command+parserEvaluate = do+  pathAndmode <- parserWithPath+  simpl <-+    A.switch+      ( A.long "simplify" <> A.help "Simplify the AST"+      )+  pure $ uncurry CommandWithPath pathAndmode $ Evaluate simpl++parserParse :: A.Parser Command+parserParse = do+  pathAndmode <- parserWithPath+  pure $ uncurry CommandWithPath pathAndmode Parse++parserGenerate :: A.Parser Command+parserGenerate = do+  path <- parserTemplatePath+  pure $ Generate path++parserClasses :: A.Parser Command+parserClasses = do+  pathAndmode <- parserWithPath+  pure $ uncurry CommandWithPath pathAndmode Classes++parserFragments :: A.Parser Command+parserFragments = do+  pathAndmode <- parserWithPath+  mname <-+    A.optional $+      A.argument+        A.str+        (A.metavar "NAME" <> A.help "Fragment name to extract.")+  pure $ uncurry CommandWithPath pathAndmode $ Fragments mname++--------------------------------------------------------------------------------+parserWithPath :: A.Parser (FilePath, ParseMode)+parserWithPath = (,) <$> parserTemplatePath <*> parserShallowFlag++parserTemplatePath :: A.Parser FilePath+parserTemplatePath =+  A.argument+    A.str+    (A.metavar "FILE" <> A.action "file" <> A.help "Slab template to parse.")++parserShallowFlag :: A.Parser ParseMode+parserShallowFlag =+  A.flag+    ParseDeep+    ParseShallow+    ( A.long "shallow" <> A.help "Don't parse recursively the included Slab files"+    )
+ src/Slab/Error.hs view
@@ -0,0 +1,80 @@+module Slab.Error+  ( Error (..)+  , unwrap+  ) where++import Data.List.NonEmpty qualified as NE (toList)+import Data.Set qualified as S (toList)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.IO qualified as T+import Data.Text.Lazy qualified as TL+import Data.Text.Lazy.IO qualified as TL+import Data.Void (Void)+import System.Exit (exitFailure)+import Text.Megaparsec hiding (Label, label, parse, parseErrorPretty, unexpected)+import Text.Megaparsec qualified as M+import Text.Pretty.Simple (pShowNoColor)++--------------------------------------------------------------------------------++-- | Represent all errors emitted by Slab. I.e. this is used in each stage+-- (`Slab.Parse`, `Slab.PreProcess`, `Slab.Evaluate`, `Slab.ExecuteError`).+data Error+  = ParseError (ParseErrorBundle Text Void)+  | PreProcessError Text -- TODO Add specific variants instead of using Text.+  | EvaluateError Text -- TODO Add specific variants instead of using Text.+  | ExecuteError Text -- TODO Add specific variants instead of using Text.+  deriving (Show, Eq)++-- | Extract a Right value, or die, emitting an error message.+unwrap :: Either Error a -> IO a+unwrap = \case+  Left (ParseError err) -> do+    -- Our custom function seems actually worse than errorBundlePretty.+    -- T.putStrLn . parseErrorPretty $ err+    T.putStrLn . T.pack $ errorBundlePretty err+    exitFailure+  Left err -> do+    TL.putStrLn $ pShowNoColor err+    exitFailure+  Right a -> pure a++--------------------------------------------------------------------------------+-- Convert parse errors to a user-friendly message.+parseErrorPretty :: ParseErrorBundle Text Void -> Text+parseErrorPretty (ParseErrorBundle errors posState) =+  case NE.toList errors of+    [] -> "Unknown error"+    (e : _) -> case e of+      TrivialError offset unexpected expected ->+        let+          pos = pstateSourcePos $ reachOffsetNoLine offset posState+          errorPos =+            T.pack (show (unPos (sourceLine pos)))+              <> ":"+              <> T.pack (show (unPos (sourceColumn pos)))+          unexpectedMsg =+            maybe+              "Unexpected end of input."+              (\u -> "Unexpected " <> errorItemPretty u <> ".")+              unexpected+          expectedMsg =+            if null expected+              then ""+              else "Expected " <> (T.intercalate ", " . map errorItemPretty . S.toList $ expected) <> "."+         in+          T.unwords+            [ "Error at"+            , errorPos+            , "-"+            , unexpectedMsg+            , if T.null expectedMsg then "." else expectedMsg+            ]+      FancyError offset err -> "Complex error at position " <> T.pack (show offset) <> ": " <> TL.toStrict (pShowNoColor err)++errorItemPretty :: ErrorItem Char -> Text+errorItemPretty = \case+  Tokens ts -> "character '" <> T.pack (NE.toList ts) <> "'"+  M.Label label -> T.pack (NE.toList label)+  EndOfInput -> "end of input"
+ src/Slab/Evaluate.hs view
@@ -0,0 +1,287 @@+{-# LANGUAGE RecordWildCards #-}++module Slab.Evaluate+  ( evaluateFile+  , evaluate+  , defaultEnv+  , simplify+  ) where++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.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++--------------------------------------------------------------------------------++-- | Similar to `preprocessFile` but evaluate the template.+evaluateFile :: FilePath -> IO (Either Error.Error [Block])+evaluateFile = runExceptT . evaluateFileE++evaluateFileE :: FilePath -> ExceptT Error.Error IO [Block]+evaluateFileE path =+  PreProcess.preprocessFileE path >>= evaluate defaultEnv ["toplevel"]++--------------------------------------------------------------------------------++-- Process mixin calls. This should be done after processing the include statement+-- since mixins may be defined in included files.+evaluate :: Monad m => Env -> [Text] -> [Block] -> ExceptT Error.Error m [Block]+evaluate env stack nodes = do+  -- Note that we pass the environment that we are constructing, so that each+  -- definition sees all definitions (including later ones and itself).+  let vars = extractVariables env' nodes+      env' = augmentVariables env vars+  mapM (eval env' stack) nodes++eval :: Monad m => Env -> [Text] -> Block -> ExceptT Error.Error m Block+eval env stack = \case+  node@BlockDoctype -> pure node+  BlockElem name mdot attrs nodes -> do+    nodes' <- evaluate env stack nodes+    pure $ BlockElem name mdot attrs nodes'+  BlockText syn template -> do+    template' <- evalTemplate env template+    pure $ BlockText syn template'+  BlockInclude mname path mnodes -> do+    case mnodes of+      Just nodes -> do+        nodes' <- evaluate env ("include" : stack) nodes+        pure $ BlockInclude mname path (Just nodes')+      Nothing ->+        pure $ BlockInclude mname path Nothing+  node@(BlockFragmentDef _ _ _) -> pure node+  BlockFragmentCall name values args -> do+    body <- call env stack name values args+    pure $ BlockFragmentCall name values body+  BlockFor name mindex values nodes -> do+    -- Re-use BlockFor to construct a single node to return.+    let zero :: Int+        zero = 0+    values' <- evalExpr env values+    collection <- case values' of+      List xs -> pure $ zip xs $ map Int [zero ..]+      Object xs -> pure $ map (\(k, v) -> (v, k)) xs+      _ -> throwE $ Error.EvaluateError $ "Iterating on something that is not a collection"+    nodes' <- forM collection $ \(value, index) -> do+      let env' = case mindex of+            Just idxname -> augmentVariables env [(name, value), (idxname, index)]+            Nothing -> augmentVariables env [(name, value)]+      evaluate env' ("each" : stack) nodes+    pure $ BlockFor name mindex values $ concat nodes'+  node@(BlockComment _ _) -> pure node+  node@(BlockFilter _ _) -> pure node+  node@(BlockRawElem _ _) -> pure node+  BlockDefault name nodes -> do+    -- If the fragment is not given as an argument, we return the default block,+    -- but recursively trying to replace the blocks found within its own body.+    case lookupVariable name env of+      Nothing -> do+        nodes' <- evaluate env ("?block" : stack) nodes+        pure $ BlockDefault name nodes'+      Just (Frag _ capturedEnv nodes') -> do+        nodes'' <- evaluate capturedEnv ("+block" : stack) nodes'+        pure $ BlockDefault name nodes''+      Just _ -> throwE $ Error.EvaluateError $ "Calling something that is not a fragment \"" <> name <> "\" in " <> T.pack (show stack)+  BlockImport path _ args -> do+    body <- call env stack (T.pack path) [] args+    pure $ BlockImport path (Just body) args+  node@(BlockRun _ _) -> pure node+  node@(BlockReadJson _ _ _) -> pure node+  node@(BlockAssignVar _ _) -> pure node+  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+        bs' <- evaluate env ("else" : stack) bs+        pure $ BlockIf cond [] bs'+  BlockList nodes -> do+    nodes' <- evaluate env stack nodes+    pure $ BlockList nodes'+  BlockCode code -> do+    code' <- evalExpr env code+    pure $ BlockCode code'++call :: Monad m => Env -> [Text] -> Text -> [Expr] -> [Block] -> ExceptT Error.Error m [Block]+call env stack name values args =+  case lookupVariable name env of+    Just (Frag 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 _ -> 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)]++lookupVariable :: Text -> Env -> Maybe Expr+lookupVariable name Env {..} = lookup name envVariables++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]++evalExpr :: Monad m => Env -> Expr -> ExceptT Error.Error m Expr+evalExpr env = \case+  Variable name ->+    case lookupVariable name env of+      Just val -> evalExpr env val+      Nothing -> throwE $ Error.EvaluateError $ "Can't find variable \"" <> name <> "\""+  Lookup name key ->+    case lookupVariable name env of+      Just (Object obj) -> do+        -- key' <- evalExpr env key+        case lookup key obj of+          Just val -> evalExpr env val+          Nothing ->+            pure $ Variable "false"+      Just _ -> throwE $ Error.EvaluateError $ "Variable \"" <> name <> "\" is not an object"+      Nothing -> throwE $ Error.EvaluateError $ "Can't find variable \"" <> name <> "\""+  Add a b -> do+    a' <- evalExpr env a+    b' <- evalExpr env b+    case (a', b') of+      (Int i, Int j) -> pure . Int $ i + j+      (Int i, SingleQuoteString s) -> pure . SingleQuoteString $ T.pack (show i) <> s+      _ -> 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'))+  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'))+  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'))+  Thunk capturedEnv code ->+    evalExpr capturedEnv code+  code -> pure code++-- After evaluation, the template should be either empty or contain a single literal.+evalTemplate :: Monad m => Env -> [Inline] -> ExceptT Error.Error m [Inline]+evalTemplate env inlines = do+  t <- T.concat <$> traverse (evalInline env) inlines+  pure [Lit t]++evalInline :: Monad m => Env -> Inline -> ExceptT Error.Error m Text+evalInline env = \case+  Lit s -> pure s+  Place code -> do+    code' <- evalExpr env code+    case code' of+      SingleQuoteString s -> pure s+      Int x -> pure . T.pack $ show x+      -- Variable x -> context x -- Should not happen after evalExpr+      x -> error $ "evalInline: unhandled value: " <> show x++-- Extract both fragments and assignments.+-- TODO This should be merged with namedBlocks.+-- 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 _) = []++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++--------------------------------------------------------------------------------+simplify :: [Block] -> [Block]+simplify = concatMap simplify'++simplify' :: Block -> [Block]+simplify' = \case+  node@BlockDoctype -> [node]+  BlockElem name mdot attrs nodes -> [BlockElem name mdot attrs $ simplify nodes]+  node@(BlockText _ _) -> [node]+  BlockInclude _ _ mnodes -> maybe [] simplify mnodes+  BlockFragmentDef _ _ _ -> []+  BlockFragmentCall _ _ args -> simplify args+  BlockFor _ _ _ nodes -> simplify nodes+  node@(BlockComment _ _) -> [node]+  node@(BlockFilter _ _) -> [node]+  node@(BlockRawElem _ _) -> [node]+  BlockDefault _ nodes -> simplify nodes+  BlockImport _ mbody _ -> maybe [] simplify mbody+  BlockRun _ mbody -> maybe [] simplify mbody+  BlockReadJson _ _ _ -> []+  BlockAssignVar _ _ -> []+  BlockIf _ [] bs -> simplify bs+  BlockIf _ as _ -> simplify as+  BlockList nodes -> simplify nodes+  node@(BlockCode _) -> [node]
+ src/Slab/Execute.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE RecordWildCards #-}++module Slab.Execute+  ( executeFile+  , execute+  ) where++import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Except (ExceptT, runExceptT)+import Data.Text qualified as T+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)++--------------------------------------------------------------------------------++-- | Similar to `evaluateFile` but run external commands.+executeFile :: FilePath -> IO (Either Error.Error [Syntax.Block])+executeFile path =+  runExceptT $+    PreProcess.preprocessFileE path+      >>= Evaluate.evaluate Evaluate.defaultEnv ["toplevel"]+      >>= execute path++--------------------------------------------------------------------------------+execute+  :: FilePath+  -> [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+  node@Syntax.BlockDoctype -> pure node+  Syntax.BlockElem name mdot attrs nodes -> do+    nodes' <- execute ctx nodes+    pure $ Syntax.BlockElem name mdot attrs nodes'+  node@(Syntax.BlockText _ _) -> pure node+  Syntax.BlockInclude mname path mbody -> do+    mbody' <- traverse (execute ctx) mbody+    pure $ Syntax.BlockInclude mname path mbody'+  Syntax.BlockFragmentDef name params nodes -> do+    nodes' <- execute ctx nodes+    pure $ Syntax.BlockFragmentDef name params nodes'+  Syntax.BlockFragmentCall name values nodes -> do+    nodes' <- execute ctx nodes+    pure $ Syntax.BlockFragmentCall name values nodes'+  node@(Syntax.BlockFor _ _ _ _) -> pure node+  node@(Syntax.BlockComment _ _) -> pure node+  node@(Syntax.BlockFilter _ _) -> pure node+  node@(Syntax.BlockRawElem _ _) -> pure node+  Syntax.BlockDefault name nodes -> do+    nodes' <- execute ctx nodes+    pure $ Syntax.BlockDefault name nodes'+  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 <-+      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+  Syntax.BlockIf cond as bs -> do+    as' <- execute ctx as+    bs' <- execute ctx bs+    pure $ Syntax.BlockIf cond as' bs'+  Syntax.BlockList nodes -> do+    nodes' <- execute ctx nodes+    pure $ Syntax.BlockList nodes'+  node@(Syntax.BlockCode _) -> pure node
+ src/Slab/Generate/Haskell.hs view
@@ -0,0 +1,100 @@+module Slab.Generate.Haskell+  ( renderHs+  ) where++import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.IO qualified as T+import Prettyprinter+import Prettyprinter.Render.Text+import Slab.Error qualified as Error+import Slab.PreProcess qualified as PreProcess+import Slab.Syntax qualified as Syntax++--------------------------------------------------------------------------------+renderHs :: FilePath -> IO ()+renderHs path = do+  blocks <- PreProcess.preprocessFile path >>= Error.unwrap+  T.putStrLn $ renderModule blocks++renderModule :: [Syntax.Block] -> Text+renderModule = renderStrict . layoutPretty defaultLayoutOptions . prettyModule++renderBlocks :: [Syntax.Block] -> Text+renderBlocks = renderStrict . layoutPretty defaultLayoutOptions . prettyBlocks++--------------------------------------------------------------------------------+prettyModule :: [Syntax.Block] -> Doc ann+prettyModule blocks =+  vsep+    [ moduleHeader+    , indent 2 $ prettyBlocks blocks+    ]++moduleHeader :: Doc ann+moduleHeader =+  vsep+    [ "module Main where"+    , mempty+    , "import Data.Text (Text)"+    , "import Text.Blaze.Html5 (Html, (!))"+    , "import Text.Blaze.Html5 qualified as H"+    , "import Text.Blaze.Html5.Attributes qualified as A"+    , "import Text.Blaze.Html.Renderer.Pretty (renderHtml)"+    , mempty+    , "main :: IO ()"+    , "main = putStrLn . renderHtml $"+    ]++--------------------------------------------------------------------------------+prettyBlocks :: [Syntax.Block] -> Doc ann+prettyBlocks = vsep . map prettyBlock++prettyBlock :: Syntax.Block -> Doc ann+prettyBlock (Syntax.BlockElem name _ attrs children) = prettyBlockElem (name, attrs', children)+ where+  attrs' = Syntax.groupAttrs attrs++-- | Render an element, aligning the @!@ character:+--+-- @+--   elem ! a+--        ! b $ do+--     child0+--     child1+-- @+prettyBlockElem :: (Syntax.Elem, [Syntax.Attr], [Syntax.Block]) -> Doc ann+prettyBlockElem (t1, ts_, as) =+  case ts_ of+    [] ->+      let header = prettyT1 <+> dollar+       in vsep [header, footer]+    [t] ->+      let header = prettyT1 <+> "!" <+> prettyAttr t <+> dollar+       in vsep [header, footer]+    t : ts ->+      let header = prettyT1 <+> "!" <+> prettyAttr t+          body = indent lengthT1 $ vsep (map (("!" <+>) . prettyAttr) ts) <+> dollar+       in vsep [header, body, footer]+ where+  prettyT1 = prettyElem t1+  lengthT1 = succ . T.length . renderStrict $ layoutPretty defaultLayoutOptions prettyT1+  dollar = if length as > 1 then "$ do" else "$"+  footer = case as of+    [] -> indent 2 "mempty"+    _ -> vsep $ map (indent 2 . prettyBlock) as++prettyElem :: Syntax.Elem -> Doc ann+prettyElem = \case+  Syntax.Html -> "H.html"+  Syntax.Body -> "H.body"+  Syntax.Div -> "H.div"++prettyAttr :: Syntax.Attr -> Doc ann+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++prettyExpr :: Syntax.Expr -> Doc ann+prettyExpr _ = "TODO"
+ src/Slab/Parse.hs view
@@ -0,0 +1,722 @@+{-# LANGUAGE RecordWildCards #-}++module Slab.Parse+  ( parseFile+  , parseFileE+  , parse+  , parseExpr+  , parserTextInclude+  -- Inline parsing stuff++    -- * The @InterpolationContext@ type+  , InterpolationContext++    -- * Basic interface+  , parse'+  , parseInlines+  ) where++import Control.Monad (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.Maybe (isJust)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.IO qualified as T+import Data.Void (Void)+import Slab.Error qualified as Error+import Slab.Syntax+import Text.Megaparsec hiding (Label, label, parse, parseErrorPretty, unexpected)+import Text.Megaparsec qualified as M+import Text.Megaparsec.Char+import Text.Megaparsec.Char.Lexer qualified as L++--------------------------------------------------------------------------------+parseFile :: FilePath -> IO (Either Error.Error [Block])+parseFile = runExceptT . parseFileE++parseFileE :: FilePath -> ExceptT Error.Error IO [Block]+parseFileE path = do+  content <- liftIO $ T.readFile path+  withExceptT Error.ParseError . except $ parse path content++--------------------------------------------------------------------------------++parse :: FilePath -> Text -> Either (ParseErrorBundle Text Void) [Block]+parse fn = runParser (many parserNode <* eof) fn++-- | We expose the expression parser for development:+--+-- @+--     print $ Parse.parseExpr "1 + 2 * a"+-- @+parseExpr :: Text -> Either (ParseErrorBundle Text Void) Expr+parseExpr = runParser (sc *> parserExpr <* eof) ""++--------------------------------------------------------------------------------+type Parser = Parsec Void Text++parserNode :: Parser Block+parserNode = do+  node <-+    L.indentBlock scn $+      choice+        [ parserDoctype+        , try parserInclude+        , parserElement+        , parserPipe+        , parserExpr'+        , parserFragmentDef+        , parserComment+        , parserFilter+        , parserRawElement+        , parserDefault+        , parserImport+        , parserRun+        , parserLet+        , try parserEach+        , parserIf+        , parserFragmentCall+        ]+  case node of+    BlockIf cond as _ -> do+      mbs <- optional $ L.indentBlock scn parserElse+      pure $ BlockIf cond as $ maybe [] id mbs+    _ -> pure node++parserIf :: Parser (L.IndentOpt Parser Block Block)+parserIf = do+  _ <- lexeme $ string "if"+  cond <- parserExpr+  pure $ L.IndentMany Nothing (pure . (\as -> BlockIf cond as [])) parserNode++parserElse :: Parser (L.IndentOpt Parser [Block] Block)+parserElse = do+  _ <- lexeme $ string "else"+  pure $ L.IndentMany Nothing pure parserNode++parserElement :: Parser (L.IndentOpt Parser Block Block)+parserElement = do+  ref <- L.indentLevel+  header <- parserDiv+  case trailingSym $ header [] of+    HasDot -> do+      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']]+        _ -> pure $ L.IndentNone $ header [BlockText Dot template]+    HasEqual -> do+      mcontent <- optional parserExpr+      case mcontent of+        Just content -> pure $ L.IndentNone $ header [BlockCode content]+        Nothing -> do+          scn+          content <- parserExpr+          pure $ L.IndentNone $ header [BlockCode content]+    NoSym -> do+      template <- parseInlines+      case template of+        [] -> pure $ L.IndentMany Nothing (pure . header) parserNode+        _ -> pure $ L.IndentNone $ header [BlockText Normal template]++-- | Parse lines of text, indented more than `ref`.+-- E.g.:+--     a+--       b+--     c+-- will return ["a", "  b", "c"].+textBlock :: Pos -> Parser Text -> Parser [Text]+textBlock ref p = go+ where+  go = do+    n <- space'+    pos <- L.indentLevel+    done <- isJust <$> optional eof+    if done+      then return []+      else+        if pos <= ref+          then return []+          else do+            l <- p+            ls <- go+            let prefix = T.replicate (unPos pos - unPos ref) " "+                n' = replicate (n - 1) prefix+                l' = prefix <> l+            pure $ n' <> (l' : ls)++-- | Considering all the given lines as a block, strip the leading whitespace of+-- each line so that the left-most character of the block is in the first+-- column.+realign :: [Text] -> [Text]+realign xs = map (T.drop n) xs+ where+  n = minimum $ map (T.length . T.takeWhile (== ' ')) 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+-- to a single line, but here we want to be able to view such blocks as a+-- single node, and we make sur to add newlines between each when rendered.+parserPipe :: Parser (L.IndentOpt Parser Block Block)+parserPipe = do+  ref <- L.indentLevel+  template <- p+  templates <- go ref+  pure $ L.IndentNone $ BlockText Pipe $ intercalate [Lit "\n"] (template : templates)+ where+  go ref = do+    scn+    pos <- L.indentLevel+    done <- isJust <$> optional eof+    if done+      then return []+      else do+        cont <- isJust <$> (lookAhead $ optional $ string "|")+        if pos /= ref || not cont+          then return []+          else (:) <$> p <*> go ref+  p = do+    _ <- lexeme $ string "|"+    template <- parseInlines+    pure template++-- | A parser to convert the content of an @include@d to 'Syntax'. The+-- behavior w.r.t. to newlines should be the same as having each line+-- directly preceded by a @|@ in the including file.+parserTextInclude :: Text -> Block+parserTextInclude content =+  BlockText Include [Lit $ T.intercalate "\n" $ T.lines content]++parserExpr' :: Parser (L.IndentOpt Parser Block Block)+parserExpr' = do+  _ <- lexeme $ string "="+  content <- parserExpr+  pure $ L.IndentNone $ BlockCode content++parserExpr :: Parser Expr+parserExpr =+  parserExpression+    <|> (Object <$> parserObject)++parserVariable :: Parser Text+parserVariable = parserName++parserExpression :: Parser Expr+parserExpression = makeExprParser pTerm operatorTable+ where+  pTerm =+    lexeme (Int <$> parserNumber)+      <|> lexeme (SingleQuoteString <$> parserSingleQuoteString)+      <|> lexeme parserVariable'+      <|> parens parserExpression+  parens = between (char '(') (char ')')++-- 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)]+  ]++parserVariable' :: Parser Expr+parserVariable' = do+  name <- parserName+  mkey <- optional $ do+    _ <- string "["+    key <- parserSingleQuoteString+    _ <- string "]"+    pure key+  case mkey of+    Nothing -> pure $ Variable name+    Just key -> pure $ Lookup name (SingleQuoteString key)++--------------------------------------------------------------------------------+parserDoctype :: Parser (L.IndentOpt Parser Block Block)+parserDoctype = do+  _ <- lexeme (string "doctype")+  _ <- lexeme (string "html")+  pure $ L.IndentNone BlockDoctype++--------------------------------------------------------------------------------+-- E.g. div, div.a, .a+parserDiv :: Parser ([Block] -> Block)+parserDiv =+  parserElemWithAttrs <|> parserAttrs++-- 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"+  pure $ BlockElem name mdot attrs++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"+  )+    <?> "element name"++-- E.g. .a, ()+parserAttrs :: Parser ([Block] -> Block)+parserAttrs = do+  (attrs, mdot) <-+    lexeme+      ( do+          attrs <- some parserAttrs'+          mdot <- optional (string ".")+          pure (concat attrs, maybe NoSym (const HasDot) mdot)+      )+      <?> "attributes"+  pure $ BlockElem Div mdot attrs++parserAttrs' :: Parser [Attr]+parserAttrs' =+  -- `try` because we want to backtrack if there is a dot+  -- not followed by a class name, for mdot to succeed.+  ((: []) <$> parserId) <|> try ((: []) <$> parserClass) <|> parserAttrList++-- E.g. #a+parserId :: Parser Attr+parserId =+  Id+    . T.pack+    <$> (char '#' *> some (alphaNumChar <|> oneOf ("-_" :: String)))+    <?> "id"++-- E.g. .a+parserClass :: Parser Attr+parserClass =+  Class+    . T.pack+    <$> (char '.' *> some (alphaNumChar <|> oneOf ("-_" :: String)))+    <?> "class name"++-- E.g. (), (class='a')+parserAttrList :: Parser [Attr]+parserAttrList = (<?> "attribute") $ do+  _ <- string "("+  pairs <- many parserPair+  _ <- string ")"+  pure $ map (uncurry Attr) pairs++parserPair :: Parser (Text, Maybe 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)++parserValue :: Parser Expr+parserValue =+  SingleQuoteString <$> parserSingleQuoteString+    <|> SingleQuoteString <$> parserDoubleQuoteString+    <|> Int <$> parserNumber++parserSingleQuoteString :: Parser Text+parserSingleQuoteString = do+  _ <- string "'"+  s <- T.pack <$> (some (noneOf ("'\n" :: String))) <?> "string"+  _ <- string "'"+  pure s++parserDoubleQuoteString :: Parser Text+parserDoubleQuoteString = do+  _ <- string "\""+  s <- T.pack <$> (some (noneOf ("\"\n" :: String))) <?> "string"+  _ <- string "\""+  pure s++-- TODO Proper data type.+parserNumber :: Parser Int+parserNumber = L.decimal++parserText :: Parser Text+parserText = T.pack <$> lexeme (some (noneOf ['\n'])) <?> "text content"++parserIdentifier :: Parser Text+parserIdentifier = T.pack <$> lexeme (some (noneOf (" {}\n" :: String))) <?> "identifier"++--------------------------------------------------------------------------------+parserInclude :: Parser (L.IndentOpt Parser Block Block)+parserInclude = do+  mname <- lexeme $ do+    _ <- string "include"+    optional $ do+      _ <- string ":"+      parserIdentifier+  path <- parserPath+  pure $ L.IndentNone $ BlockInclude mname path Nothing++parserPath :: Parser FilePath+parserPath = lexeme (some (noneOf ['\n'])) <?> "path"++--------------------------------------------------------------------------------+parserFragmentDef :: Parser (L.IndentOpt Parser Block Block)+parserFragmentDef = do+  _ <- lexeme (string "fragment" <|> string "frag")+  name <- parserIdentifier+  params <- maybe [] id <$> optional parserParameters+  pure $ L.IndentMany Nothing (pure . BlockFragmentDef name params) parserNode++-- E.g. {}, {a, b}+parserParameters :: Parser [Text]+parserParameters = parserList' "{" "}" 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++-- E.g. {}, {1, 'a'}+parserArguments :: Parser [Expr]+parserArguments = parserList' "{" "}" parserExpr <?> "arguments"++--------------------------------------------------------------------------------+parserEach :: Parser (L.IndentOpt Parser Block Block)+parserEach = do+  _ <- lexeme (string "for")+  name <- lexeme parserName+  mindex <- optional $ do+    _ <- lexeme $ string ","+    lexeme parserName+  _ <- lexeme (string "in")+  collection <-+    (List <$> parserList) <|> (Object <$> parserObject) <|> (Variable <$> parserVariable)+  pure $ L.IndentMany Nothing (pure . BlockFor name mindex collection) parserNode++parserList :: Parser [Expr]+parserList = parserList' "[" "]" parserExpr++parserList' :: Text -> Text -> Parser a -> Parser [a]+parserList' before after p = do+  _ <- lexeme $ string before+  mx <- optional $ lexeme p+  xs <- case mx of+    Nothing -> pure []+    Just x -> do+      xs <- many $ do+        _ <- lexeme (string ",")+        lexeme p+      pure $ x : xs+  _ <- lexeme $ string after+  pure xs++parserObject :: Parser [(Expr, Expr)]+parserObject = do+  _ <- lexeme (string "{")+  mkv <- optional $ do+    key <- lexeme parserExpr+    _ <- lexeme (string ":")+    val <- lexeme parserExpr+    pure (key, val)+  kvs <- case mkv of+    Nothing -> pure []+    Just kv -> do+      kvs <- many $ do+        _ <- lexeme $ string ","+        key <- lexeme parserExpr+        _ <- lexeme (string ":")+        val <- lexeme parserExpr+        pure (key, val)+      pure $ kv : kvs+  _ <- lexeme (string "}")+  pure kvs++--------------------------------------------------------------------------------+parserComment :: Parser (L.IndentOpt Parser Block Block)+parserComment = do+  ref <- L.indentLevel+  b <-+    lexeme $+      choice+        [ string "---" *> pure PassthroughComment+        , string "--" *> pure NormalComment+        ]+  mcontent <- optional parserText+  case mcontent of+    Just content -> pure $ L.IndentNone $ BlockComment b content+    Nothing -> do+      scn+      items <- textBlock ref parserText+      let items' = realign items+      pure $ L.IndentNone $ BlockComment b $ T.intercalate "\n" items'++--------------------------------------------------------------------------------+parserFilter :: Parser (L.IndentOpt Parser Block Block)+parserFilter = do+  ref <- L.indentLevel+  name <-+    lexeme+      ( string ":"+          *> parserName+      )+      <?> "filter name"+  mcontent <- optional parserText+  case mcontent of+    Just content -> pure $ L.IndentNone $ BlockFilter name content+    Nothing -> do+      scn+      items <- textBlock ref parserText+      let items' = realign items+      pure $ L.IndentNone $ BlockFilter name $ T.intercalate "\n" items'++parserName :: Parser Text+parserName =+  T.pack+    <$> ( do+            a <- letterChar+            as <- many (alphaNumChar <|> oneOf ("-_" :: String))+            pure (a : as)+        )+    <?> "name"++--------------------------------------------------------------------------------+parserRawElement :: Parser (L.IndentOpt Parser Block Block)+parserRawElement = do+  header <- parserAngleBracket+  pure $ L.IndentMany Nothing (pure . header) parserNode++parserAngleBracket :: Parser ([Block] -> Block)+parserAngleBracket = do+  _ <- char '<'+  content <- parserText+  pure $ BlockRawElem $ "<" <> content++--------------------------------------------------------------------------------+parserDefault :: Parser (L.IndentOpt Parser Block Block)+parserDefault = do+  _ <- lexeme (string "default")+  name <- parserText+  pure $ L.IndentMany Nothing (pure . BlockDefault name) parserNode++--------------------------------------------------------------------------------+parserImport :: Parser (L.IndentOpt Parser Block Block)+parserImport = do+  _ <- lexeme (string "import")+  path <- parserPath+  pure $ L.IndentMany Nothing (pure . BlockImport path Nothing) parserNode++--------------------------------------------------------------------------------+parserRun :: Parser (L.IndentOpt Parser Block Block)+parserRun = do+  _ <- lexeme (string "run")+  cmd <- parserText+  pure $ L.IndentNone $ BlockRun cmd 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 <- lexeme parserValue+  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 :: 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++sc :: Parser ()+sc = L.space (void $ some (char ' ' <|> char '\t')) empty empty++lexeme :: Parser a -> Parser a+lexeme = L.lexeme sc++symbol :: Text -> Parser Text+symbol = L.symbol sc++--------------------------------------------------------------------------------++-- Text interpolation stuff++-- Text interpolation modeled on the @template@ library by Johan Tibell.+-- - This uses Megaparsec instead of an internal State monad parser.+-- - This uses @#@ instead of @$@.+-- - Only the safe parsers are provided.+-- - Only the applicative interface is provided.+-- - We don't support #name, but only #{name}, because # can appear+--   in character entities, URLs, ...+-- TODO Mention the BSD-3 license and Johan.++--------------------------------------------------------------------------------++-- | A mapping from placeholders in the template to values with an applicative+-- lookup function. For instance the lookup function can fail, returning+-- 'Nothing' or 'Left'.+type InterpolationContext f = Text -> f Text++--------------------------------------------------------------------------------+-- Basic interface++-- | Create a template from a template string. A malformed template+-- string will cause 'parse' to return a parse error.+parse' :: Text -> Either (M.ParseErrorBundle Text Void) [Inline]+parse' = M.parse (parseInlines <* M.eof) "-"++combineLits :: [Inline] -> [Inline]+combineLits [] = []+combineLits xs =+  let (lits, xs') = span isLit xs+   in case lits of+        [] -> gatherVars xs'+        [lit] -> lit : gatherVars xs'+        _ -> Lit (T.concat (map fromLit lits)) : gatherVars xs'+ where+  gatherVars [] = []+  gatherVars ys =+    let (vars, ys') = span isVar ys+     in vars <> combineLits ys'++  isLit (Lit _) = True+  isLit _ = False++  isVar = not . isLit++  fromLit (Lit v) = v+  fromLit _ = undefined++--------------------------------------------------------------------------------+-- Template parser++parseInlines :: Parser [Inline]+parseInlines = combineLits <$> M.many parseInline++parseInline :: Parser Inline+parseInline =+  M.choice+    [ parseLit+    , parsePlace+    , 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')+  pure $ Lit s++parsePlace :: Parser Inline+parsePlace = do+  _ <- string $ T.pack "#{"+  e <- parserExpr+  _ <- string $ T.pack "}"+  pure $ Place e++parseEscape :: Parser Inline+parseEscape = do+  _ <- string $ T.pack "##"+  pure $ Lit $ T.pack "#"++parseSharpLit :: Parser Inline+parseSharpLit = do+  _ <- string $ T.pack "#"+  s <- M.takeWhile1P Nothing (\c -> c /= '#' && c /= '\n')+  pure $ Lit $ "#" <> s
+ src/Slab/PreProcess.hs view
@@ -0,0 +1,119 @@+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE RecordWildCards #-}++module Slab.PreProcess+  ( Context (..)+  , preprocessFile+  , preprocessFileE+  ) where++import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE)+import Data.Aeson qualified as Aeson+import Data.ByteString.Lazy qualified as BL+import Data.Text qualified as T+import Data.Text.IO qualified as T+import Slab.Error qualified as Error+import Slab.Parse qualified as Parse+import Slab.Syntax+import System.Directory (doesFileExist)+import System.FilePath (takeDirectory, takeExtension, (</>))++--------------------------------------------------------------------------------+data Context = Context+  { ctxStartPath :: FilePath+  }++--------------------------------------------------------------------------------++-- | Similar to `parseFile` but pre-process the include statements.+preprocessFile :: FilePath -> IO (Either Error.Error [Block])+preprocessFile = runExceptT . preprocessFileE++preprocessFileE :: FilePath -> ExceptT Error.Error IO [Block]+preprocessFileE path = do+  nodes <- Parse.parseFileE path+  let ctx =+        Context+          { ctxStartPath = path+          }+  preprocess ctx nodes++--------------------------------------------------------------------------------++-- Process include statements (i.e. read the given path and parse its content+-- recursively).+preprocess :: Context -> [Block] -> ExceptT Error.Error IO [Block]+preprocess ctx nodes = mapM (preproc ctx) nodes++preproc :: Context -> Block -> ExceptT Error.Error IO Block+preproc ctx@Context {..} = \case+  node@BlockDoctype -> pure node+  BlockElem name mdot attrs nodes -> do+    nodes' <- preprocess ctx nodes+    pure $ BlockElem name mdot attrs nodes'+  node@(BlockText _ _) -> pure node+  BlockInclude mname path _ -> do+    let includedPath = takeDirectory ctxStartPath </> path+        slabExt = takeExtension includedPath == ".slab"+    exists <- liftIO $ doesFileExist includedPath+    if+        | exists && (not slabExt || mname == Just "escape-html") -> do+            -- Include the file content as-is.+            content <- liftIO $ T.readFile includedPath+            let node = Parse.parserTextInclude content+            pure $ BlockInclude mname path (Just [node])+        | exists -> do+            -- Parse and process the .slab file.+            nodes' <- preprocessFileE includedPath+            pure $ BlockInclude mname path (Just nodes')+        | otherwise ->+            throwE $ Error.PreProcessError $ "File " <> T.pack includedPath <> " doesn't exist"+  BlockFragmentDef name params nodes -> do+    nodes' <- preprocess ctx nodes+    pure $ BlockFragmentDef name params nodes'+  BlockFragmentCall name values nodes -> do+    nodes' <- preprocess ctx nodes+    pure $ BlockFragmentCall name values nodes'+  node@(BlockFor _ _ _ _) -> pure node+  node@(BlockComment _ _) -> pure node+  node@(BlockFilter _ _) -> pure node+  node@(BlockRawElem _ _) -> pure node+  BlockDefault name nodes -> do+    nodes' <- preprocess ctx nodes+    pure $ BlockDefault name nodes'+  BlockImport path _ args -> do+    -- An import is treated like an include used to define a fragment, then+    -- directly calling that fragment.+    let includedPath = takeDirectory ctxStartPath </> path+        slabExt = takeExtension includedPath == ".slab"+    exists <- liftIO $ doesFileExist includedPath+    if+        | exists && not slabExt ->+            throwE $ Error.PreProcessError $ "Extends requires a .slab file"+        | exists -> do+            -- Parse and process the .slab file.+            body <- preprocessFileE includedPath+            args' <- mapM (preproc ctx) args+            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+  BlockIf cond as bs -> do+    -- File inclusion is done right away, without checking the condition.+    as' <- preprocess ctx as+    bs' <- preprocess ctx bs+    pure $ BlockIf cond as' bs'+  BlockList nodes -> do+    nodes' <- preprocess ctx nodes+    pure $ BlockList nodes'+  node@(BlockCode _) -> pure node
+ src/Slab/Render.hs view
@@ -0,0 +1,196 @@+module Slab.Render+  ( prettyHtmls+  , renderHtmls+  , renderBlocks+  ) where++import Data.String (fromString)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Lazy qualified as TL+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.Html5 (Html, (!))+import Text.Blaze.Html5 qualified as H+import Text.Blaze.Html5.Attributes qualified as A+import Text.Blaze.Svg11 qualified as S++--------------------------------------------------------------------------------+prettyHtmls :: [Html] -> Text+prettyHtmls = T.pack . concat . map Pretty.renderHtml++renderHtmls :: [Html] -> TL.Text+renderHtmls = TL.concat . map renderHtml++--------------------------------------------------------------------------------+renderBlocks :: [Syntax.Block] -> [H.Html]+renderBlocks = map renderBlock++renderBlock :: Syntax.Block -> H.Html+renderBlock Syntax.BlockDoctype = H.docType+renderBlock (Syntax.BlockElem name mdot attrs children) =+  mAddAttrs $+    mAddId $+      mAddClass $+        renderElem name $+          mconcat $+            if mdot == Syntax.HasDot+              then [renderTexts children]+              else map renderBlock children+ 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 ?+  mAddClass :: H.Html -> H.Html+  mAddClass e =+    if classNames == []+      then e+      else e ! A.class_ (H.toValue classNames')+  classNames = Syntax.classNamesFromAttrs attrs+  classNames' :: Text+  classNames' = T.intercalate " " classNames++  mAddAttrs :: H.Html -> H.Html+  mAddAttrs =+    flip (foldl (\e (a, b) -> e ! H.customAttribute (fromString $ T.unpack a) (H.toValue b))) attrs'+  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.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.BlockFor _ _ _ nodes) = mapM_ renderBlock nodes+renderBlock (Syntax.BlockComment b content) =+  case b of+    Syntax.PassthroughComment -> H.textComment content+    Syntax.NormalComment -> mempty+renderBlock (Syntax.BlockFilter "escape-html" content) =+  H.text content+renderBlock (Syntax.BlockFilter name _) = error $ "Unknown filter name " <> T.unpack name+renderBlock (Syntax.BlockRawElem content children) = do+  H.preEscapedText content -- TODO Construct a proper tag ?+  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.BlockImport path Nothing _) = H.stringComment $ "extends " <> path+renderBlock (Syntax.BlockReadJson _ _ _) = mempty+renderBlock (Syntax.BlockAssignVar _ _) = mempty+renderBlock (Syntax.BlockIf _ as bs) = do+  -- The evaluation code transforms a BlockIf into a BlockList, so this should+  -- not be called.+  mapM_ renderBlock as+  mapM_ renderBlock bs+renderBlock (Syntax.BlockList nodes) =+  mapM_ renderBlock nodes+renderBlock (Syntax.BlockCode (Syntax.SingleQuoteString s))+  | s == T.empty = mempty+  | otherwise = H.text s -- Should be already escaped in the AST ?+renderBlock (Syntax.BlockCode (Syntax.Variable s)) =+  H.textComment $ "code variable " <> s+renderBlock (Syntax.BlockCode (Syntax.Int i)) =+  H.string $ show i+renderBlock (Syntax.BlockCode (Syntax.Object _)) =+  H.text "<Object>"+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++escapeTexts :: [Syntax.Block] -> H.Html+escapeTexts xs = H.text xs'+ where+  xs' = T.intercalate "\n" $ map extractText xs++extractText :: Syntax.Block -> Text+extractText = f+ where+  f Syntax.BlockDoctype = error "extractTexts called on a BlockDoctype"+  f (Syntax.BlockElem _ _ _ _) = error "extractTexts called on a BlockElem"+  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.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"+  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.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"++renderElem :: Syntax.Elem -> Html -> Html+renderElem = \case+  Syntax.Html -> H.html+  Syntax.Body -> H.body+  Syntax.Div -> H.div+  Syntax.Span -> H.span+  Syntax.Br -> const H.br+  Syntax.Hr -> const H.hr+  Syntax.H1 -> H.h1+  Syntax.H2 -> H.h2+  Syntax.H3 -> H.h3+  Syntax.H4 -> H.h4+  Syntax.H5 -> H.h5+  Syntax.H6 -> H.h6+  Syntax.Header -> H.header+  Syntax.Head -> H.head+  Syntax.Meta -> const H.meta+  Syntax.Main -> H.main+  Syntax.Link -> const H.link+  Syntax.A -> H.a+  Syntax.P -> H.p+  Syntax.Ul -> H.ul+  Syntax.Li -> H.li+  Syntax.Title -> H.title+  Syntax.Table -> H.table+  Syntax.Thead -> H.thead+  Syntax.Tbody -> H.tbody+  Syntax.Tr -> H.tr+  Syntax.Td -> H.td+  Syntax.Dl -> H.dl+  Syntax.Dt -> H.dt+  Syntax.Dd -> H.dd+  Syntax.Footer -> H.footer+  Syntax.Figure -> H.figure+  Syntax.Form -> H.form+  Syntax.Label -> H.label+  Syntax.Blockquote -> H.blockquote+  Syntax.Button -> H.button+  Syntax.Figcaption -> H.figcaption+  Syntax.Audio -> H.audio+  Syntax.Script -> H.script+  Syntax.Style -> H.style+  Syntax.Small -> H.small+  Syntax.Source -> const H.source+  Syntax.Pre -> H.pre+  Syntax.Code -> H.code+  Syntax.Img -> const H.img+  Syntax.IFrame -> H.iframe+  Syntax.Input -> const H.input+  Syntax.I -> H.i+  Syntax.Svg -> S.svg+  Syntax.Textarea -> H.textarea+  Syntax.Canvas -> H.canvas
+ src/Slab/Report.hs view
@@ -0,0 +1,45 @@+module Slab.Report+  ( run+  ) where++import Slab.Build qualified as Build+import Slab.Error qualified as Error+import Slab.Evaluate qualified as Evaluate+import Slab.Syntax qualified as Syntax++--------------------------------------------------------------------------------+run :: FilePath -> IO ()+run srcDir = do+  modules <- buildDir srcDir+  putStrLn $ "Read " <> show (length modules) <> " modules."+  let pages = filter isPage modules+  putStrLn $ show (length pages) <> " pages."+  mapM_ (putStrLn . modulePath) pages++data Module = Module+  { modulePath :: FilePath+  , moduleNodes :: [Syntax.Block]+  }+  deriving (Show)++isPage :: Module -> Bool+isPage Module {moduleNodes = (x : _)} = Syntax.isDoctype x+isPage _ = False++--------------------------------------------------------------------------------+-- Similar to Build.buildDir and buildFile, but don't render HTML to disk.++buildDir :: FilePath -> IO [Module]+buildDir srcDir = do+  templates <- Build.listTemplates srcDir+  mapM buildFile templates++buildFile :: FilePath -> IO Module+buildFile path = do+  putStrLn $ "Reading " <> path <> "..."+  nodes <- Evaluate.evaluateFile path >>= Error.unwrap+  pure+    Module+      { modulePath = path+      , moduleNodes = nodes+      }
+ src/Slab/Run.hs view
@@ -0,0 +1,108 @@+-- |+-- Module      : Slab.Run+-- Description : Implementation of Slab's CLI+--+-- @Slab.Run@ accepts commands defined in the "Slab.Command" module and+-- runs them.+module Slab.Run+  ( run+  ) where++import Control.Monad.Trans.Except (ExceptT, runExceptT)+import Data.Text.IO qualified as T+import Data.Text.Lazy.IO qualified as TL+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+import Slab.Parse qualified as Parse+import Slab.PreProcess qualified as PreProcess+import Slab.Render qualified as Render+import Slab.Report qualified as Report+import Slab.Serve qualified as Serve+import Slab.Syntax qualified as Syntax+import Slab.Watch qualified as Watch+import Text.Pretty.Simple (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.Report srcDir) = Report.run srcDir+run (Command.Generate path) = Generate.renderHs path+run (Command.CommandWithPath path pmode (Command.Render Command.RenderNormal)) = do+  nodes <- executeWithMode path pmode >>= 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+  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.Evaluate simpl)) = do+  nodes <- evaluateWithMode path pmode >>= Error.unwrap+  if simpl+    then TL.putStrLn $ pShowNoColor $ Evaluate.simplify nodes+    else TL.putStrLn $ pShowNoColor nodes+run (Command.CommandWithPath path pmode Command.Parse) = do+  nodes <- parseWithMode path pmode >>= Error.unwrap+  TL.putStrLn $ pShowNoColor nodes+run (Command.CommandWithPath path pmode Command.Classes) = do+  nodes <- parseWithMode path pmode >>= Error.unwrap+  mapM_ T.putStrLn $ Syntax.extractClasses nodes+run (Command.CommandWithPath path pmode (Command.Fragments mname)) = do+  nodes <- parseWithMode path pmode >>= Error.unwrap+  let ms = Syntax.extractFragments nodes+  case mname of+    Just name -> case Syntax.findFragment name ms of+      Just m -> TL.putStrLn $ pShowNoColor m+      Nothing -> putStrLn "No such fragment."+    Nothing -> TL.putStrLn $ pShowNoColor ms++--------------------------------------------------------------------------------+parseWithMode+  :: FilePath+  -> Command.ParseMode+  -> IO (Either Error.Error [Syntax.Block])+parseWithMode path pmode = runExceptT $ parseWithModeE path pmode++evaluateWithMode+  :: FilePath+  -> Command.ParseMode+  -> IO (Either Error.Error [Syntax.Block])+evaluateWithMode path pmode = runExceptT $ evaluateWithModeE path pmode++executeWithMode+  :: FilePath+  -> Command.ParseMode+  -> IO (Either Error.Error [Syntax.Block])+executeWithMode path pmode = runExceptT $ executeWithModeE path pmode++--------------------------------------------------------------------------------+parseWithModeE+  :: FilePath+  -> Command.ParseMode+  -> ExceptT Error.Error IO [Syntax.Block]+parseWithModeE path pmode =+  case pmode of+    Command.ParseShallow -> Parse.parseFileE path+    Command.ParseDeep -> PreProcess.preprocessFileE path++evaluateWithModeE+  :: FilePath+  -> Command.ParseMode+  -> ExceptT Error.Error IO [Syntax.Block]+evaluateWithModeE path pmode = do+  parsed <- parseWithModeE path pmode+  Evaluate.evaluate Evaluate.defaultEnv ["toplevel"] parsed++executeWithModeE+  :: FilePath+  -> Command.ParseMode+  -> ExceptT Error.Error IO [Syntax.Block]+executeWithModeE path pmode =+  evaluateWithModeE path pmode >>= Execute.execute path
+ src/Slab/Serve.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}++module Slab.Serve+  ( run+  ) where++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 Text.Blaze.Html5 (Html)+import WaiAppStatic.Storage.Filesystem+  ( defaultWebAppSettings+  )++------------------------------------------------------------------------------+run :: FilePath -> IO ()+run distDir =+  Warp.run 9000 $ serve distDir++-- | Turn our `serverT` implementation into a Wai application, suitable for+-- Warp.run.+serve :: FilePath -> Wai.Application+serve root =+  Servant.serveWithContext appProxy Server.EmptyContext $+    Server.hoistServerWithContext appProxy settingsProxy identity $+      serverT root++------------------------------------------------------------------------------+type ServerSettings = '[]++settingsProxy :: Proxy ServerSettings+settingsProxy = Proxy++------------------------------------------------------------------------------+type App =+  "hello" :> Get '[B.HTML] Html+    :<|> Servant.Raw -- Fallback handler for the static files, in particular the++appProxy :: Proxy App+appProxy = Proxy++------------------------------------------------------------------------------+serverT :: FilePath -> ServerT App Handler+serverT root =+  showHelloPage+    :<|> serveStatic root++------------------------------------------------------------------------------+showHelloPage :: Handler Html+showHelloPage = pure "Hello."++------------------------------------------------------------------------------+serveStatic :: FilePath -> Server.Tagged Handler Server.Application+serveStatic root = Servant.serveDirectoryWith settings+ where+  settings = defaultWebAppSettings root
+ src/Slab/Syntax.hs view
@@ -0,0 +1,348 @@+{-# LANGUAGE RecordWildCards #-}++module Slab.Syntax+  ( Block (..)+  , isDoctype+  , CommentType (..)+  , Elem (..)+  , TrailingSym (..)+  , Attr (..)+  , TextSyntax (..)+  , Expr (..)+  , Inline (..)+  , Env (..)+  , emptyEnv+  , trailingSym+  , freeVariables+  , thunk+  , extractClasses+  , extractFragments+  , findFragment+  , idNamesFromAttrs+  , classNamesFromAttrs+  , namesFromAttrs+  , groupAttrs+  ) where++import Data.Aeson qualified as Aeson+import Data.List (nub, sort)+import Data.Text (Text)+import Data.Text qualified as T++--------------------------------------------------------------------------------+data Block+  = -- | Only @doctype html@ for now.+    BlockDoctype+  | BlockElem Elem TrailingSym [Attr] [Block]+  | BlockText TextSyntax [Inline]+  | -- | @Nothing@ when the template is parsed, then @Just nodes@ after+    -- 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]+  | BlockFragmentCall Text [Expr] [Block]+  | BlockFor Text (Maybe Text) Expr [Block]+  | -- TODO Should we allow string interpolation here ?+    BlockComment CommentType Text+  | BlockFilter Text Text+  | BlockRawElem Text [Block]+  | -- | @default@ defines an optional formal parameter with a default content.+    -- Its content is used when the argument is not given.+    BlockDefault Text [Block]+  | -- | 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+  | BlockIf Expr [Block] [Block]+  | BlockList [Block]+  | BlockCode Expr+  deriving (Show, Eq)++isDoctype :: Block -> Bool+isDoctype BlockDoctype = True+isDoctype _ = False++trailingSym :: Block -> TrailingSym+trailingSym (BlockElem _ sym _ _) = sym+trailingSym _ = NoSym++-- | A "passthrough" comment will be included in the generated HTML.+data CommentType = NormalComment | PassthroughComment+  deriving (Show, Eq)++data Elem+  = Html+  | Body+  | Div+  | Span+  | Br+  | Hr+  | H1+  | H2+  | H3+  | H4+  | H5+  | H6+  | Header+  | Head+  | Meta+  | Main+  | Link+  | A+  | P+  | Ul+  | Li+  | Title+  | Table+  | Thead+  | Tbody+  | Tr+  | Td+  | Dl+  | Dt+  | Dd+  | Footer+  | Figure+  | Form+  | Label+  | Blockquote+  | Button+  | Figcaption+  | Audio+  | Script+  | Style+  | Small+  | Source+  | Pre+  | Code+  | Img+  | IFrame+  | Input+  | I+  | Svg+  | Textarea+  | Canvas+  deriving (Show, Eq)++data TrailingSym = HasDot | HasEqual | NoSym+  deriving (Show, Eq)++-- The Code must already be evaluated.+data Attr = Id Text | Class Text | Attr Text (Maybe Expr)+  deriving (Show, Eq)++-- Tracks the syntax used to enter the text.+data TextSyntax+  = -- | The text follows an element on the same line.+    Normal+  | -- | The text follows a pipe character. Multiple lines each introduced by a+    -- pipe symbol are grouped as a single 'BlockText' node.+    Pipe+  | -- | The text is part of a text block following a trailing dot.+    Dot+  | -- | The text is the content of an include statement without a .slab extension.+    Include+  | -- | The text is the output of command.+    RunOutput+  deriving (Show, Eq)++-- | Simple expression language.+data Expr+  = Variable Text+  | Int Int+  | SingleQuoteString Text+  | List [Expr]+  | Object [(Expr, Expr)]+  | -- The object[key] lookup. This is quite restrive as a start.+    Lookup Text Expr+  | Add Expr Expr+  | Sub Expr Expr+  | Times Expr Expr+  | Divide Expr Expr+  | -- 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+  deriving (Show, Eq)++-- | A representation of a 'Data.Text' template is a list of Inline, supporting+-- efficient rendering. Use 'parse' to create a template from a text containing+-- placeholders. 'Lit' is a literal Text value. 'Place' is a placeholder created+-- with @#{...}@.+data Inline = Lit {-# UNPACK #-} !Text | Place !Expr+  deriving (Eq, Show)++data Env = Env+  { envVariables :: [(Text, Expr)]+  }+  deriving (Eq, Show)++emptyEnv :: Env+emptyEnv = Env []++--------------------------------------------------------------------------------+freeVariables :: Expr -> [Text]+freeVariables =+  nub . \case+    Variable a -> [a]+    Int _ -> []+    SingleQuoteString _ -> []+    List as -> concatMap freeVariables as+    Object _ -> [] -- TODO I guess some of those can contain variables.+    Lookup a b -> a : freeVariables b+    Add a b -> freeVariables a <> freeVariables b+    Sub a b -> freeVariables a <> freeVariables b+    Times a b -> freeVariables a <> freeVariables b+    Divide a b -> freeVariables a <> freeVariables b+    Frag _ _ _ -> []+    Thunk _ _ -> []++-- Capture an environment, but limit its content to only the free variables of+-- the expression.+thunk :: Env -> Expr -> Expr+thunk Env {..} code = Thunk env code+ where+  env = Env $ filter ((`elem` frees) . fst) envVariables+  frees = freeVariables code++--------------------------------------------------------------------------------++extractClasses :: [Block] -> [Text]+extractClasses = nub . sort . concatMap f+ where+  f BlockDoctype = []+  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 (BlockFragmentCall _ _ children) = extractClasses children+  f (BlockFor _ _ _ children) = extractClasses children+  f (BlockComment _ _) = []+  f (BlockFilter _ _) = []+  -- TODO Would be nice to extract classes from verbatim HTML too.+  f (BlockRawElem _ _) = []+  f (BlockDefault _ children) = extractClasses children+  f (BlockImport _ children blocks) = maybe [] extractClasses children <> extractClasses blocks+  f (BlockRun _ _) = []+  f (BlockReadJson _ _ _) = []+  f (BlockAssignVar _ _) = []+  f (BlockIf _ as bs) = extractClasses as <> extractClasses bs+  f (BlockList children) = extractClasses children+  f (BlockCode _) = []++  g (Id _) = []+  g (Class c) = [c]+  g (Attr a b) = h a b+  h "class" (Just (SingleQuoteString c)) = [c]+  h "class" _ = error "The class is not a string"+  h _ _ = []++-- Return type used for `extractFragments`.+data BlockFragment+  = BlockFragmentDef' Text [Block]+  | BlockFragmentCall' Text+  deriving (Show, Eq)++extractFragments :: [Block] -> [BlockFragment]+extractFragments = concatMap f+ where+  f BlockDoctype = []+  f (BlockElem _ _ _ children) = extractFragments children+  f (BlockText _ _) = []+  f (BlockInclude _ _ children) = maybe [] extractFragments children+  f (BlockFragmentDef name _ children) = [BlockFragmentDef' name children]+  f (BlockFragmentCall name _ children) = [BlockFragmentCall' name] <> extractFragments children+  f (BlockFor _ _ _ children) = extractFragments children+  f (BlockComment _ _) = []+  f (BlockFilter _ _) = []+  f (BlockRawElem _ _) = []+  f (BlockDefault _ children) = extractFragments children+  f (BlockImport _ children args) = maybe [] extractFragments children <> extractFragments args+  f (BlockRun _ _) = []+  f (BlockReadJson _ _ _) = []+  f (BlockAssignVar _ _) = []+  f (BlockIf _ as bs) = extractFragments as <> extractFragments bs+  f (BlockList children) = extractFragments children+  f (BlockCode _) = []++findFragment :: Text -> [BlockFragment] -> Maybe [Block]+findFragment name ms = case filter f ms of+  [BlockFragmentDef' _ nodes] -> Just nodes+  _ -> Nothing+ where+  f (BlockFragmentDef' name' _) = name == name'+  f _ = False++--------------------------------------------------------------------------------+idNamesFromAttrs :: [Attr] -> [Text]+idNamesFromAttrs =+  concatMap+    ( \case+        Id i -> [i]+        Class _ -> []+        Attr a b -> f a b+    )+ where+  f "id" (Just (SingleQuoteString x)) = [x]+  f "id" (Just _) = error "The id is not a string"+  f _ _ = []++classNamesFromAttrs :: [Attr] -> [Text]+classNamesFromAttrs =+  concatMap+    ( \case+        Id _ -> []+        Class c -> [c]+        Attr a b -> f a b+    )+ where+  f "class" (Just (SingleQuoteString x)) = [x]+  f "class" (Just _) = error "The class is not a string"+  f _ _ = []++namesFromAttrs :: [Attr] -> [(Text, Text)]+namesFromAttrs =+  concatMap+    ( \case+        Id _ -> []+        Class _ -> []+        Attr a b -> f a b+    )+ 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)]++-- | Group multiple classes or IDs in a single class or ID, and transform the+-- other attributes in 'SingleQuoteString's.+groupAttrs :: [Attr] -> [Attr]+groupAttrs attrs = elemId <> elemClass <> elemAttrs+ where+  idNames = idNamesFromAttrs attrs+  idNames' :: Text+  idNames' = T.intercalate " " idNames+  elemId =+    if idNames == []+      then []+      else [Id idNames']++  classNames = classNamesFromAttrs attrs+  classNames' :: Text+  classNames' = T.intercalate " " classNames+  elemClass =+    if classNames == []+      then []+      else [Class classNames']++  attrs' = namesFromAttrs attrs+  elemAttrs = map (\(a, b) -> Attr a (Just $ SingleQuoteString b)) attrs'
+ src/Slab/Watch.hs view
@@ -0,0 +1,36 @@+module Slab.Watch+  ( run+  ) where++import Control.Concurrent (threadDelay)+import Control.Monad (forever)+import System.Directory (canonicalizePath)+import System.FSNotify+import System.FilePath (makeRelative, takeExtension, (</>))++--------------------------------------------------------------------------------+run :: FilePath -> (FilePath -> IO ()) -> IO ()+run srcDir update = do+  putStrLn "Watching..."+  withManager $ \mgr -> do+    -- Start a watching job in the background.+    -- TODO We should debounce multiple Modified events occurring in a short+    -- amount of time on the same file. Typically saving a file with Vim will+    -- trigger two Modified events on a .slab file.+    _ <-+      watchTree+        mgr+        srcDir+        ( \e -> do+            case e of+              Modified path _ _ | takeExtension path == ".slab" -> True+              _ -> False+        )+        ( \e -> do+            srcDir' <- canonicalizePath srcDir+            let path = srcDir </> makeRelative srcDir' (eventPath e)+            update path+        )++    -- Sleep forever (until interrupted).+    forever $ threadDelay 1000000
+ tests/Slab/GHCi.hs view
@@ -0,0 +1,40 @@+{-# OPTIONS_GHC -Wno-unused-imports #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-}++-- | This module is loaded only in the GHCi session. It exposes all the Slab+-- modules qualified (similarly to how they are imported throughout the Slab+-- code base).+module Slab.GHCi+  (+  ) where++import Data.Text qualified as T+import Slab.Build qualified as Build+import Slab.Command qualified as Command+import Slab.Evaluate qualified as Evaluate+import Slab.Execute qualified as Execute+import Slab.Generate.Haskell qualified as Generate+import Slab.Parse qualified as Parse+import Slab.Render qualified as Render+import Slab.Report qualified as Report+import Slab.Run qualified as Run+import Slab.Serve qualified as Serve+import Slab.Syntax qualified as Syntax+import Slab.Watch qualified as Watch+import System.Process (callCommand)++-- This import is present to set -interactive-print in ghci.conf.+import Text.Pretty.Simple qualified++--------------------------------------------------------------------------------+-- This is wired to :about.+about :: String -> IO String+about _ = do+  callCommand "clear"+  catFile "scripts/ghci.about.txt"+  pure ""++catFile :: FilePath -> IO ()+catFile filename = do+  content <- readFile filename+  putStrLn content
+ tests/Slab/Runner.hs view
@@ -0,0 +1,62 @@+-- | This module defines the main functions used in the Slab test suite.+module Slab.Runner+  ( runExamples+  ) where++import Data.List (sort)+import Data.Text (Text)+import Slab.Execute qualified as Execute+import Slab.Render qualified as Render+import System.FilePath+import System.FilePath.Glob qualified as Glob+import Test.Tasty+import Test.Tasty.Silver qualified as Silver++--------------------------------------------------------------------------------++-- | This function runs all the Golden tests of the Slab repository. The+-- example @.slab@ files are located in the @examples/@ directory. It is+-- exposed in the GHCi development environment.+runExamples :: IO ()+runExamples = do+  -- List all examples, comparing them to their corresponding golden files.+  goldens <- listExamples "examples/" >>= mapM mkGoldenTest+  -- Examples coming from+  -- https://github.com/pugjs/pug/tree/master/packages/pug/test/cases.+  cases <- listExamples "examples/cases/" >>= mapM mkGoldenTest+  -- Examples coming from the documentation.+  docs <- listExamples "examples/docs/" >>= mapM mkGoldenTest+  defaultMain $+    testGroup+      "Test suite"+      [ testGroup "Examples" goldens+      , testGroup "Cases" cases+      , testGroup "Documentation" docs+      ]++--------------------------------------------------------------------------------+listExamples :: FilePath -> IO [FilePath]+listExamples examplesDir = sort <$> Glob.globDir1 pat examplesDir+ where+  pat = Glob.compile "*.slab"++--------------------------------------------------------------------------------+mkGoldenTest :: FilePath -> IO TestTree+mkGoldenTest path = do+  -- `path` looks like @examples/a.slab@.+  -- `testName` looks like @a@.+  -- `goldenPath` looks like @examples/a.html@.+  let testName = takeBaseName path+      goldenPath = replaceExtension path ".html"+  pure $ Silver.goldenVsAction testName goldenPath action convert+ where+  action :: IO Text+  action = do+    evaluated <- Execute.executeFile path+    case evaluated of+      Left _ -> pure "TODO"+      Right nodes -> do+        let output = Render.prettyHtmls . Render.renderBlocks $ nodes+        pure output++  convert = id
+ tests/run-examples.hs view
@@ -0,0 +1,5 @@+import Slab.Runner (runExamples)++--------------------------------------------------------------------------------+main :: IO ()+main = runExamples