From eacab4cab1bd91ee9d62402df6df44a5c8cd064a Mon Sep 17 00:00:00 2001
From: Christian Gram Kalhauge <chrg@dtu.dk>
Date: Thu, 15 Feb 2024 22:22:40 +0100
Subject: [PATCH] Add more examples
---
rtree/test/expected/double-let-expr | 20 ++++
rtree/test/expected/small-let-expr | 10 ++
rtree/test/expected/small-let-expr.txt | 7 --
rtree/test/expected/small-opr-expr | 5 +
rtree/test/expected/small-opr-expr.txt | 4 -
rtree/test/src/Control/Monad/RTreeSpec.hs | 120 +++++++++++++---------
rtree/test/src/Test/Hspec/GitGolden.hs | 28 ++++-
7 files changed, 130 insertions(+), 64 deletions(-)
create mode 100644 rtree/test/expected/double-let-expr
create mode 100644 rtree/test/expected/small-let-expr
delete mode 100644 rtree/test/expected/small-let-expr.txt
create mode 100644 rtree/test/expected/small-opr-expr
delete mode 100644 rtree/test/expected/small-opr-expr.txt
diff --git a/rtree/test/expected/double-let-expr b/rtree/test/expected/double-let-expr
new file mode 100644
index 0000000..5ac1a22
--- /dev/null
+++ b/rtree/test/expected/double-let-expr
@@ -0,0 +1,20 @@
+┳â”┳â”┳â”┳â”┳â”┳┠x := 1; y := 2; x + y
+┃ ┃ ┃ ┃ ┃ ┗┠x := 1; y := 2; x
+┃ ┃ ┃ ┃ â”—â”┳┠x := 1; y := 2; y
+┃ ┃ ┃ ┃ ┗┠⊥
+┃ ┃ ┃ â”—â”┳â”┳┠x := 1; x + 2
+┃ ┃ ┃ ┃ ┗┠x := 1; x
+┃ ┃ ┃ â”—â”┳┠x := 1; 2
+┃ ┃ ┃ ┗┠⊥
+┃ ┃ ┗┠⊥
+┃ â”—â”┳â”┳â”┳â”┳┠y := 2; 1 + y
+┃ ┃ ┃ ┃ ┗┠y := 2; 1
+┃ ┃ ┃ â”—â”┳┠y := 2; y
+┃ ┃ ┃ ┗┠⊥
+┃ ┃ â”—â”┳â”┳â”┳┠1 + 2
+┃ ┃ ┃ ┃ ┗┠3
+┃ ┃ ┃ ┗┠1
+┃ ┃ â”—â”┳┠2
+┃ ┃ ┗┠⊥
+┃ ┗┠⊥
+┗┠⊥
diff --git a/rtree/test/expected/small-let-expr b/rtree/test/expected/small-let-expr
new file mode 100644
index 0000000..e7c2cde
--- /dev/null
+++ b/rtree/test/expected/small-let-expr
@@ -0,0 +1,10 @@
+┳â”┳â”┳â”┳┠x := 1; 2 + x
+┃ ┃ ┃ ┗┠x := 1; 2
+┃ ┃ â”—â”┳┠x := 1; x
+┃ ┃ ┗┠⊥
+┃ â”—â”┳â”┳â”┳┠2 + 1
+┃ ┃ ┃ ┗┠3
+┃ ┃ ┗┠2
+┃ â”—â”┳┠1
+┃ ┗┠⊥
+┗┠⊥
diff --git a/rtree/test/expected/small-let-expr.txt b/rtree/test/expected/small-let-expr.txt
deleted file mode 100644
index 979993e..0000000
--- a/rtree/test/expected/small-let-expr.txt
+++ /dev/null
@@ -1,7 +0,0 @@
-┳â”┳â”┳┠x := 0; 1 + x -|
-┃ ┃ ┗┠x := 0; x -|
-┃ â”—â”┳â”┳┠1 + 0 -| x = 0,
-┃ ┃ ┗┠1 -| x = 0,
-┃ â”—â”┳┠0 -| x = 0,
-┃ ┗┠⊥ -| x = 0,
-┗┠⊥ -|
diff --git a/rtree/test/expected/small-opr-expr b/rtree/test/expected/small-opr-expr
new file mode 100644
index 0000000..b6a7514
--- /dev/null
+++ b/rtree/test/expected/small-opr-expr
@@ -0,0 +1,5 @@
+┳â”┳â”┳┠1 + 2
+┃ ┃ ┗┠3
+┃ ┗┠1
+â”—â”┳┠2
+ ┗┠⊥
diff --git a/rtree/test/expected/small-opr-expr.txt b/rtree/test/expected/small-opr-expr.txt
deleted file mode 100644
index d0c48ef..0000000
--- a/rtree/test/expected/small-opr-expr.txt
+++ /dev/null
@@ -1,4 +0,0 @@
-┳â”┳┠1 + 2 -|
-┃ ┗┠1 -|
-â”—â”┳┠2 -|
- ┗┠⊥ -|
diff --git a/rtree/test/src/Control/Monad/RTreeSpec.hs b/rtree/test/src/Control/Monad/RTreeSpec.hs
index b0a2d18..ec6c4bb 100644
--- a/rtree/test/src/Control/Monad/RTreeSpec.hs
+++ b/rtree/test/src/Control/Monad/RTreeSpec.hs
@@ -6,6 +6,7 @@
module Control.Monad.RTreeSpec where
+import Control.Applicative
import Control.Monad.Identity (Identity (runIdentity))
import Control.Monad.RTree
import Control.Monad.State
@@ -33,59 +34,79 @@ data Expr
| Let String Expr Expr
deriving (Show, Eq)
-ex1 :: Expr
-ex1 =
- Let "x" (Cnt 0) (Opr (Cnt 1) (Var "x"))
-
-ex2 :: Expr
-ex2 = Opr (Cnt 1) (Cnt 2)
-
-rExpr :: (MonadReducePlus m, MonadState (Map.Map String Expr) m) => Expr -> m Expr
+rExpr
+ :: (MonadReducePlus m, MonadState (Map.Map String (Either String Expr)) m)
+ => Expr
+ -> m Expr
rExpr e = case e of
Cnt i -> do
given $> Cnt i
Var k -> do
- v <- gets (Map.lookup k)
+ v <- liftMaybe =<< gets (Map.lookup k)
case v of
- Nothing -> pure e
- Just x -> rExpr x
+ Left k' -> given $> Var k'
+ Right x -> rExpr x
Opr e1 e2 -> onBoth (rExpr e1) (rExpr e2) \e1' e2' ->
- pure $ Opr e1' e2'
+ case (e1', e2') of
+ (Cnt a, Cnt b) -> pure (Cnt (a + b)) <| pure (Opr e1' e2')
+ _ -> pure $ Opr e1' e2'
Let k e1 e2 -> do
e1' <- rExpr e1
split
- do
- modify' (Map.insert k e1')
- rExpr e2
- do
- Let k e1' <$> rExpr e2
+ (modifyIn (Map.insert k (Right e1')) $ rExpr e2)
+ (Let k e1' <$> modifyIn (Map.insert k (Left k)) (rExpr e2))
+
+modifyIn :: (Alternative m, MonadState s m) => (s -> s) -> m b -> m b
+modifyIn fn mx = do
+ s <- get
+ put (fn s)
+ x <- optional mx
+ put s
+ liftMaybe x
prettyExprS :: Int -> Expr -> String -> String
-prettyExprS p = \case
+prettyExprS d = \case
Var x -> showString x
- Opr l r -> prettyExprS p l . showString " + " . prettyExprS p r
- Cnt i -> showsPrec p i
+ Opr l r ->
+ showParen (d > addPrec)
+ $ prettyExprS (addPrec + 1) l
+ . showString " + "
+ . prettyExprS (addPrec + 1) r
+ Cnt i -> shows i
Let x e1 e2 ->
- showString x
+ showParen (d > letPrec)
+ $ showString x
. showString " := "
- . prettyExprS p e1
+ . prettyExprS (letPrec + 1) e1
. showString "; "
- . prettyExprS p e2
+ . prettyExprS letPrec e2
+ where
+ addPrec = 2
+ letPrec = 1
+
+prettyExprWithConfig :: (Maybe Expr, Map.Map String (Either String Expr)) -> String
+prettyExprWithConfig (e, _) =
+ maybe "⊥" (flip (prettyExprS 0) "") e
+
+-- <> "\n("
+-- <> L.intercalate
+-- ", "
+-- ( map
+-- ( \(k, v) ->
+-- showString k
+-- . showString " = "
+-- . either showString (prettyExprS 0) v
+-- $ ""
+-- )
+-- (Map.toList m)
+-- )
+-- <> ")"
spec :: Spec
spec = do
rtreeSpec
rtreeTSpec
-prettyExprWithConfig :: (Maybe Expr, Map.Map String Expr) -> String
-prettyExprWithConfig (e, m) =
- maybe "⊥" (flip (prettyExprS 0) "") e
- <> " -| "
- <> foldMap
- (\(k, v) -> showString k . showString " = " . prettyExprS 0 v . showString ", ")
- (Map.toList m)
- ""
-
rtreeTSpec :: Spec
rtreeTSpec = describe "RTreeT" do
describe "equivalence" do
@@ -96,23 +117,24 @@ rtreeTSpec = describe "RTreeT" do
equiv (rList [1, 2, 3 :: Int]) inputs (toList :: RTreeT Identity [Int] -> [[Int]])
describe "rExpr" do
- let mrExpr = runMaybeT $ rExpr ex1
- it "should extract expr" do
- runState (extractT mrExpr) Map.empty
- `shouldBe` (Just ex1, Map.empty)
- it "should inputs expr" do
- golden
- "test/expected/small-let-expr.txt"
- (drawRTree prettyExprWithConfig (flattenT (unStateT mrExpr Map.empty)))
-
- it "should handle small opr expr" do
- golden
- "test/expected/small-opr-expr.txt"
- ( drawRTree
- prettyExprWithConfig
- . flattenT
- $ unStateT (runMaybeT $ rExpr ex2) Map.empty
- )
+ let handle str e = describe str do
+ let me = runMaybeT $ rExpr e
+ it "should extract" do
+ evalState (extractT me) Map.empty
+ `shouldBe` Just e
+ it "should draw the same" do
+ golden
+ ("test/expected/" <> str)
+ (drawRTree prettyExprWithConfig (flattenT (unStateT me Map.empty)))
+
+ handle "small-opr-expr"
+ $ Opr (Cnt 1) (Cnt 2)
+
+ handle "small-let-expr"
+ $ Let "x" (Cnt 1) (Opr (Cnt 2) (Var "x"))
+
+ handle "double-let-expr"
+ $ Let "x" (Cnt 1) (Let "y" (Cnt 2) (Opr (Var "x") (Var "y")))
equiv
:: (Show b, MonadReduce x, MonadReduce y, Eq b)
diff --git a/rtree/test/src/Test/Hspec/GitGolden.hs b/rtree/test/src/Test/Hspec/GitGolden.hs
index b43846b..055cc1f 100644
--- a/rtree/test/src/Test/Hspec/GitGolden.hs
+++ b/rtree/test/src/Test/Hspec/GitGolden.hs
@@ -5,6 +5,7 @@ module Test.Hspec.GitGolden where
import System.Directory
import System.FilePath
+import Data.Function
import qualified Data.Text.Lazy as Text
import qualified Data.Text.Lazy.Encoding as Text
import System.Process.Typed
@@ -19,11 +20,30 @@ instance Example GitGolden where
evaluateExample e _p _a _c = do
createDirectoryIfMissing True (takeDirectory e.filename)
writeFile e.filename e.content
- (ec, diff) <- readProcessStdout (proc "git" ["diff", e.filename])
- pure $ case (ec, Text.unpack (Text.decodeUtf8 diff)) of
- (ExitSuccess, "") -> Result "" Success
- (_, df) -> Result "failed" (Failure Nothing (Reason df))
+ ec <-
+ proc "git" ["ls-files", "--error-unmatch", e.filename]
+ & setStdout nullStream
+ & setStderr nullStream
+ & runProcess
+
+ case ec of
+ ExitFailure _ -> do
+ pure $ Result "" (Pending location (Just $ "file " <> show e.filename <> " not in index"))
+ _ -> do
+ (_, diff) <- readProcessStdout (proc "git" ["diff", e.filename])
+
+ pure $ case (ec, Text.unpack (Text.decodeUtf8 diff)) of
+ (ExitSuccess, "") -> Result "" Success
+ (_, df) ->
+ Result
+ "failed"
+ ( Failure
+ location
+ ( Reason
+ (unlines . drop 4 . lines $ df)
+ )
+ )
golden :: FilePath -> String -> GitGolden
golden fp str = GitGolden{filename = fp, content = str}
--
GitLab