From ab5a157e74e620169b83aa994f7b577dd70bc891 Mon Sep 17 00:00:00 2001 From: Vo Minh Thu Date: Wed, 3 Jul 2024 13:44:09 +0200 Subject: [PATCH] Remove special BlockReadJson case. This is now handled as a normal variable declaration. This also means that a JSON path can appear anywhere in an expression, although it is not tested yet. --- src/Slab/Evaluate.hs | 18 ------------------ src/Slab/Execute.hs | 1 - src/Slab/Parse.hs | 18 ++---------------- src/Slab/PreProcess.hs | 34 +++++++++++++++++++++++++--------- src/Slab/Render.hs | 2 -- src/Slab/Report.hs | 1 - src/Slab/Syntax.hs | 7 ++----- 7 files changed, 29 insertions(+), 52 deletions(-) diff --git a/src/Slab/Evaluate.hs b/src/Slab/Evaluate.hs index bb04385..6853b2e 100644 --- a/src/Slab/Evaluate.hs +++ b/src/Slab/Evaluate.hs @@ -24,13 +24,9 @@ module Slab.Evaluate 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 @@ -185,7 +181,6 @@ eval env stack bl = case bl of body <- call env stack (T.pack path) [] args pure $ BlockImport path (Just body) args node@(BlockRun _ _) -> pure node - node@(BlockReadJson _ _ _) -> pure node node@(BlockAssignVars _) -> pure node BlockIf cond as bs -> do cond' <- evalExpr env cond @@ -398,23 +393,11 @@ extractVariable env = \case (BlockImport path (Just body) _) -> [(T.pack path, Frag [] env body)] (BlockImport _ _ _) -> [] (BlockRun _ _) -> [] - (BlockReadJson name _ (Just val)) -> [(name, jsonToExpr val)] - (BlockReadJson _ _ Nothing) -> [] (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 - -------------------------------------------------------------------------------- simplify :: [Block] -> [Block] simplify = concatMap simplify' @@ -434,7 +417,6 @@ simplify' = \case BlockDefault _ nodes -> simplify nodes BlockImport _ mbody _ -> maybe [] simplify mbody BlockRun _ mbody -> maybe [] simplify mbody - BlockReadJson _ _ _ -> [] BlockAssignVars _ -> [] BlockIf _ [] bs -> simplify bs BlockIf _ as _ -> simplify as diff --git a/src/Slab/Execute.hs b/src/Slab/Execute.hs index b9e8c7b..e705967 100644 --- a/src/Slab/Execute.hs +++ b/src/Slab/Execute.hs @@ -76,7 +76,6 @@ exec ctx = \case pure $ Syntax.BlockRun cmd $ Just [Syntax.BlockText Syntax.RunOutput [Syntax.Lit $ T.pack out]] - node@(Syntax.BlockReadJson _ _ _) -> pure node node@(Syntax.BlockAssignVars _) -> pure node Syntax.BlockIf cond as bs -> do as' <- execute ctx as diff --git a/src/Slab/Parse.hs b/src/Slab/Parse.hs index 5e5b4f8..1626a52 100644 --- a/src/Slab/Parse.hs +++ b/src/Slab/Parse.hs @@ -251,6 +251,7 @@ parserExprInd initialIndent = makeExprParser pApp (operatorTable' initialIndent) <|> 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 @@ -613,14 +614,7 @@ parserRun = do -------------------------------------------------------------------------------- parserLet :: Parser (L.IndentOpt Parser Block Block) -parserLet = - choice - [ try parserReadJson - , parserAssignVar - ] - -parserAssignVar :: Parser (L.IndentOpt Parser Block Block) -parserAssignVar = do +parserLet = do _ <- lexeme (string "let") scn blockIndent <- getSourcePos @@ -635,14 +629,6 @@ parserAssignVar = do pure (name, val) pure $ L.IndentNone $ BlockAssignVars pairs -parserReadJson :: Parser (L.IndentOpt Parser Block Block) -parserReadJson = do - _ <- lexeme (string "let") - name <- lexeme parserName - _ <- lexeme (string "=") - path <- parserPath - pure $ L.IndentNone $ BlockReadJson name path Nothing - -------------------------------------------------------------------------------- -- Similar to space, but counts newlines space' :: Parser Int diff --git a/src/Slab/PreProcess.hs b/src/Slab/PreProcess.hs index b8583a9..05db2b0 100644 --- a/src/Slab/PreProcess.hs +++ b/src/Slab/PreProcess.hs @@ -17,9 +17,12 @@ module Slab.PreProcess 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 @@ -106,15 +109,18 @@ preproc ctx@Context {..} = \case | 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@(BlockAssignVars _) -> 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 @@ preproc ctx@Context {..} = \case 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 diff --git a/src/Slab/Render.hs b/src/Slab/Render.hs index 344b7b6..877aeb8 100644 --- a/src/Slab/Render.hs +++ b/src/Slab/Render.hs @@ -101,7 +101,6 @@ 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.BlockAssignVars _) = mempty renderBlock (Syntax.BlockIf _ as bs) = do -- The evaluation code transforms a BlockIf into a BlockList, so this should @@ -148,7 +147,6 @@ extractText = f 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.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" diff --git a/src/Slab/Report.hs b/src/Slab/Report.hs index 7670ac7..8844909 100644 --- a/src/Slab/Report.hs +++ b/src/Slab/Report.hs @@ -108,7 +108,6 @@ extractHeadings = concatMap f f (Syntax.BlockDefault _ children) = extractHeadings children f (Syntax.BlockImport _ children args) = maybe [] extractHeadings children <> extractHeadings args f (Syntax.BlockRun _ _) = [] - f (Syntax.BlockReadJson _ _ _) = [] f (Syntax.BlockAssignVars _) = [] f (Syntax.BlockIf _ as bs) = extractHeadings as <> extractHeadings bs f (Syntax.BlockList children) = extractHeadings children diff --git a/src/Slab/Syntax.hs b/src/Slab/Syntax.hs index 88fded1..5cdcc14 100644 --- a/src/Slab/Syntax.hs +++ b/src/Slab/Syntax.hs @@ -36,7 +36,6 @@ module Slab.Syntax , groupAttrs ) where -import Data.Aeson qualified as Aeson import Data.List (nub, sort) import Data.Text (Text) import Data.Text qualified as T @@ -67,8 +66,6 @@ data Block -- 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. - BlockReadJson Text FilePath (Maybe Aeson.Value) | BlockAssignVars [(Text, Expr)] | BlockIf Expr [Block] [Block] | BlockList [Block] @@ -224,6 +221,8 @@ data Expr 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) @@ -297,7 +296,6 @@ extractClasses = nub . sort . concatMap f f (BlockDefault _ children) = extractClasses children f (BlockImport _ children blocks) = maybe [] extractClasses children <> extractClasses blocks f (BlockRun _ _) = [] - f (BlockReadJson _ _ _) = [] f (BlockAssignVars _) = [] f (BlockIf _ as bs) = extractClasses as <> extractClasses bs f (BlockList children) = extractClasses children @@ -333,7 +331,6 @@ extractFragments = concatMap f f (BlockDefault _ children) = extractFragments children f (BlockImport _ children args) = maybe [] extractFragments children <> extractFragments args f (BlockRun _ _) = [] - f (BlockReadJson _ _ _) = [] f (BlockAssignVars _) = [] f (BlockIf _ as bs) = extractFragments as <> extractFragments bs f (BlockList children) = extractFragments children