diff --git a/seihou-core.cabal b/seihou-core.cabal --- a/seihou-core.cabal +++ b/seihou-core.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: seihou-core -version: 0.7.0.0 +version: 0.8.0.0 synopsis: Core library for Seihou project scaffolding description: Core library for Seihou, a composable project scaffolding system. diff --git a/src/Seihou/Core/Expr.hs b/src/Seihou/Core/Expr.hs --- a/src/Seihou/Core/Expr.hs +++ b/src/Seihou/Core/Expr.hs @@ -1,5 +1,6 @@ module Seihou.Core.Expr ( parseExpr, + renderExpr, evalExpr, exprRefs, ) @@ -35,6 +36,56 @@ Right (expr, rest) | T.null (T.strip rest) -> Right expr | otherwise -> Left ("unexpected trailing input: " <> rest) + +-- | Render an 'Expr' back to the surface syntax 'parseExpr' accepts. +-- +-- @parseExpr . renderExpr@ is the identity on every expression 'parseExpr' can +-- produce, which matters because the original condition text is not retained +-- anywhere: a @when@ clause is parsed out of Dhall and the string is discarded, +-- so any surface that wants to /show/ a condition has to rebuild it. +-- +-- Sub-expressions are parenthesized exactly where the grammar\'s precedence +-- (@||@ loosest, then @&&@, then @!@, then atoms) would otherwise reassociate +-- them. A 'VText' value is always quoted, both because it may contain a space +-- or a delimiter and because an unquoted @true@ would come back as a 'VBool'. +-- +-- One value has no surface syntax to render into: 'VList' cannot appear in an +-- expression 'parseExpr' produced, because the value grammar has no list +-- literal. It is rendered as a bracketed, comma-separated list for display, and +-- that one shape alone does not round-trip. +renderExpr :: Expr -> Text +renderExpr = go precLowest + where + go :: Int -> Expr -> Text + go prec (ExprOr left right) = + parenWhen (prec > precOr) (go precOr left <> " || " <> go precAnd right) + go prec (ExprAnd left right) = + parenWhen (prec > precAnd) (go precAnd left <> " && " <> go precNot right) + go prec (ExprNot inner) = + parenWhen (prec > precNot) ("!" <> go precAtom inner) + go _ (ExprIsSet (VarName name)) = "IsSet " <> name + go _ (ExprEq (VarName name) value) = "Eq " <> name <> " " <> renderVarValue value + go _ (ExprLit True) = "true" + go _ (ExprLit False) = "false" + + precLowest = 0 :: Int + precOr = 0 :: Int + precAnd = 1 :: Int + precNot = 2 :: Int + precAtom = 3 :: Int + + parenWhen True rendered = "(" <> rendered <> ")" + parenWhen False rendered = rendered + +-- | Render a 'VarValue' as an expression right-hand side. Text is always +-- quoted; see 'renderExpr' for why, and for the 'VList' caveat. +renderVarValue :: VarValue -> Text +renderVarValue (VText text) = "\"" <> text <> "\"" +renderVarValue (VBool True) = "true" +renderVarValue (VBool False) = "false" +renderVarValue (VInt n) = T.pack (show n) +renderVarValue (VList values) = + "[" <> T.intercalate ", " (renderVarValue <$> values) <> "]" -- | Evaluate an expression against a map of variable bindings. evalExpr :: Map VarName VarValue -> Expr -> Bool diff --git a/test/Seihou/Core/ExprSpec.hs b/test/Seihou/Core/ExprSpec.hs --- a/test/Seihou/Core/ExprSpec.hs +++ b/test/Seihou/Core/ExprSpec.hs @@ -1,7 +1,7 @@ module Seihou.Core.ExprSpec (tests) where import Data.Map.Strict qualified as Map -import Seihou.Core.Expr (evalExpr, exprRefs, parseExpr) +import Seihou.Core.Expr (evalExpr, exprRefs, parseExpr, renderExpr) import Seihou.Core.Types import Test.Hspec import Test.Tasty @@ -155,6 +155,42 @@ evalExpr vars expr `shouldBe` True evalExpr Map.empty expr `shouldBe` False + describe "renderExpr" $ do + it "renders each atom in the surface syntax" $ do + renderExpr (ExprLit True) `shouldBe` "true" + renderExpr (ExprLit False) `shouldBe` "false" + renderExpr (ExprIsSet "license") `shouldBe` "IsSet license" + renderExpr (ExprEq "license" (VText "MIT")) `shouldBe` "Eq license \"MIT\"" + renderExpr (ExprEq "enabled" (VBool True)) `shouldBe` "Eq enabled true" + renderExpr (ExprEq "count" (VInt 3)) `shouldBe` "Eq count 3" + + it "quotes text values so a bareword keyword is not reclassified" $ do + renderExpr (ExprEq "x" (VText "true")) `shouldBe` "Eq x \"true\"" + parseExpr (renderExpr (ExprEq "x" (VText "true"))) + `shouldBe` Right (ExprEq "x" (VText "true")) + + it "quotes text values containing a delimiter" $ do + let expr = ExprEq "x" (VText "a b) c") + parseExpr (renderExpr expr) `shouldBe` Right expr + + it "renders binary operators without needless parentheses" $ do + renderExpr (ExprAnd (ExprIsSet "a") (ExprIsSet "b")) + `shouldBe` "IsSet a && IsSet b" + renderExpr (ExprOr (ExprIsSet "a") (ExprIsSet "b")) + `shouldBe` "IsSet a || IsSet b" + renderExpr (ExprNot (ExprIsSet "a")) `shouldBe` "!IsSet a" + + it "parenthesizes only where precedence would reassociate" $ do + renderExpr (ExprAnd (ExprOr (ExprIsSet "a") (ExprIsSet "b")) (ExprIsSet "c")) + `shouldBe` "(IsSet a || IsSet b) && IsSet c" + renderExpr (ExprOr (ExprAnd (ExprIsSet "a") (ExprIsSet "b")) (ExprIsSet "c")) + `shouldBe` "IsSet a && IsSet b || IsSet c" + renderExpr (ExprNot (ExprAnd (ExprIsSet "a") (ExprIsSet "b"))) + `shouldBe` "!(IsSet a && IsSet b)" + + it "round-trips through parseExpr for every constructor and two nesting levels" $ do + mapM_ roundTrips roundTripCases + describe "exprRefs" $ do it "returns the compared literal for Eq with a bareword bool" $ do exprRefs (ExprEq "x" (VBool True)) `shouldBe` [("x", Just (VBool True))] @@ -175,3 +211,40 @@ it "returns nothing for a literal" $ do exprRefs (ExprLit True) `shouldBe` [] + +-- | @parseExpr . renderExpr@ must be the identity on every expression +-- 'parseExpr' can produce. +roundTrips :: Expr -> Expectation +roundTrips expr = parseExpr (renderExpr expr) `shouldBe` Right expr + +roundTripCases :: [Expr] +roundTripCases = + [ ExprLit True, + ExprLit False, + ExprIsSet "license", + ExprIsSet "project.name", + ExprEq "license" (VText "MIT"), + ExprEq "license" (VText "Apache 2.0"), + ExprEq "license" (VText ""), + ExprEq "enabled" (VBool True), + ExprEq "enabled" (VBool False), + ExprEq "count" (VInt 0), + ExprEq "count" (VInt (-3)), + ExprNot (ExprIsSet "a"), + ExprNot (ExprNot (ExprIsSet "a")), + ExprAnd (ExprIsSet "a") (ExprIsSet "b"), + ExprOr (ExprIsSet "a") (ExprIsSet "b"), + -- Two nesting levels, in both associations, for both operators. + ExprAnd (ExprAnd (ExprIsSet "a") (ExprIsSet "b")) (ExprIsSet "c"), + ExprAnd (ExprIsSet "a") (ExprAnd (ExprIsSet "b") (ExprIsSet "c")), + ExprOr (ExprOr (ExprIsSet "a") (ExprIsSet "b")) (ExprIsSet "c"), + ExprOr (ExprIsSet "a") (ExprOr (ExprIsSet "b") (ExprIsSet "c")), + ExprAnd (ExprOr (ExprIsSet "a") (ExprIsSet "b")) (ExprIsSet "c"), + ExprOr (ExprAnd (ExprIsSet "a") (ExprIsSet "b")) (ExprIsSet "c"), + ExprNot (ExprAnd (ExprIsSet "a") (ExprIsSet "b")), + ExprNot (ExprOr (ExprIsSet "a") (ExprIsSet "b")), + ExprAnd (ExprNot (ExprIsSet "a")) (ExprEq "b" (VText "x y")), + ExprOr + (ExprNot (ExprEq "a" (VBool True))) + (ExprAnd (ExprIsSet "b") (ExprEq "c" (VInt 7))) + ]