diff --git a/flake.lock b/flake.lock
index b331d354adada3b25724bf48916a76794baf7f28..cc53bf043bde669f8413013d67033e802ed29b7d 100644
--- a/flake.lock
+++ b/flake.lock
@@ -5,11 +5,11 @@
"systems": "systems"
},
"locked": {
- "lastModified": 1694529238,
- "narHash": "sha256-zsNZZGTGnMOf9YpHKJqMSsa0dXbfmxeoJ7xHlrt+xmY=",
+ "lastModified": 1705309234,
+ "narHash": "sha256-uNRRNRKmJyCRC/8y1RqBkqWBLM034y4qN7EprSdmgyA=",
"owner": "numtide",
"repo": "flake-utils",
- "rev": "ff7b65b44d01cf9ba6a71320833626af21126384",
+ "rev": "1ef2e671c3b0c19053962c07dbda38332dcebf26",
"type": "github"
},
"original": {
@@ -51,11 +51,11 @@
},
"nixpkgs": {
"locked": {
- "lastModified": 1699065553,
- "narHash": "sha256-j8UmH8fqXcOgL6WrlMcvV2m2XQ6OzU0IBucyuJ0vnyQ=",
+ "lastModified": 1707939175,
+ "narHash": "sha256-D1xan0lgxbmXDyzVqXTiSYHLmAMrMRdD+alKzEO/p3w=",
"owner": "nixos",
"repo": "nixpkgs",
- "rev": "8ab9c53eee434651ce170dee1d9727b974e9a6b6",
+ "rev": "f7e8132daca31b1e3859ac0fb49741754375ac3d",
"type": "github"
},
"original": {
diff --git a/flake.nix b/flake.nix
index c5ac7d39e9613c096a31a296ffea1d085ea1108b..de917a82405c04dc71f9f95232d3a94e5dde9219 100644
--- a/flake.nix
+++ b/flake.nix
@@ -27,6 +27,11 @@
(p.callCabal2nixWithOptions "language-c" inputs.language-c "" {}) {
doCheck = false;
};
+ # "hspec" = p.hspec_2_11_7;
+ # "hspec-discover" = p.hspec-discover_2_11_7;
+ # "hspec-core" = p.hspec-core_2_11_7;
+ # "hspec-api" = final.haskell.lib.overrideCabal (p.hspec-api) {doCheck = false;};
+ # "tasty-hspec" = p.tasty-hspec_1_2_0_4;
}
// load p "rtree"
// load p "rtree-c";
diff --git a/rtree/package.yaml b/rtree/package.yaml
index ec871b12445673f90b1a76e51eb26b831118aac6..c434bf09872d79db5a9c8f57c0205b057c8756ae 100644
--- a/rtree/package.yaml
+++ b/rtree/package.yaml
@@ -30,4 +30,8 @@ tests:
- hspec-discover
- hspec-expectations-pretty-diff
- hspec-hedgehog
- - hspec-golden
+ - hspec-core
+ - typed-process
+ - directory
+ - filepath
+ - bytestring
diff --git a/rtree/rtree.cabal b/rtree/rtree.cabal
index d567a57c36868c4c9e76f0f20943b61189028978..2b35f24639aaead895311655d5ec8b49d18528e1 100644
--- a/rtree/rtree.cabal
+++ b/rtree/rtree.cabal
@@ -35,23 +35,28 @@ test-suite rtree-test
other-modules:
Control.Monad.RTreeSpec
Spec
+ Test.Hspec.GitGolden
Paths_rtree
hs-source-dirs:
test/src
ghc-options: -Wall -fno-warn-incomplete-uni-patterns
build-depends:
base >=4.9 && <5
+ , bytestring
, containers
+ , directory
+ , filepath
, hedgehog
, hspec
+ , hspec-core
, hspec-discover
, hspec-expectations-pretty-diff
- , hspec-golden
, hspec-hedgehog
, indexed-traversable
, mtl
, rtree
, text
, transformers
+ , typed-process
, vector
default-language: Haskell2010
diff --git a/rtree/src/Control/Monad/RTree.hs b/rtree/src/Control/Monad/RTree.hs
index 5210cf1b53be985059c7e8b865678f0f3ed19544..f64aa26e207903cf5b554877c30632e025489d7e 100644
--- a/rtree/src/Control/Monad/RTree.hs
+++ b/rtree/src/Control/Monad/RTree.hs
@@ -39,7 +39,6 @@ import Control.Monad.State
import Data.Foldable
import Data.Foldable.WithIndex
import Data.Function ((&))
-import Data.Tree
-- | The simple RTree
data RTree i
@@ -82,11 +81,19 @@ iinputs = itoList
-- | For debugging purposes
drawRTree :: (i -> String) -> RTree i -> String
-drawRTree pp rt = drawTree (go rt)
+drawRTree pp = concat . go
where
go = \case
- Done i -> Node (pp i) []
- Split lhs rhs -> Node "<|" [go rhs, go lhs]
+ Done i -> map (\a -> " " <> a <> "\n") (lines $ pp i)
+ Split lhs rhs ->
+ let (rh : rhs') = go rhs
+ (lh : lhs') = go lhs
+ in fold
+ [ ["┳â”" <> rh]
+ , map ("┃ " <>) rhs'
+ , ["â”—â”" <> lh]
+ , map (" " <>) lhs'
+ ]
-- | Reduce the tree
reduce :: (MonadPlus m) => (i -> m Bool) -> RTree i -> m i
diff --git a/rtree/src/Control/Monad/Reduce.hs b/rtree/src/Control/Monad/Reduce.hs
index e498663159c6bff90bd53d53e220a0f6165e8328..f514a924e324a342ff4809d12ca8598b4ac96b95 100644
--- a/rtree/src/Control/Monad/Reduce.hs
+++ b/rtree/src/Control/Monad/Reduce.hs
@@ -126,7 +126,14 @@ liftMaybeT m = runMaybeT m >>= liftMaybe
-- | Returns either of the maybes or combines them if both have values.
onBoth :: (MonadPlus m) => m a -> m a -> (a -> a -> m a) -> m a
onBoth mlhs mrhs fn =
- join $ (fn <$> mlhs <*> mrhs) <|> fmap pure mrhs <|> fmap pure mlhs
+ optional mlhs >>= \case
+ Nothing -> mrhs
+ Just lhs ->
+ optional mrhs >>= \case
+ Nothing -> pure lhs
+ Just rhs -> fn lhs rhs
+
+-- <|> fmap pure mrhs) <|> fmap pure mlhs
{- | A reduction path, can be used as an index into reduction tree.
Is isomorphic to a list of choices.
diff --git a/rtree/test/expected/rexpr.txt/golden b/rtree/test/expected/rexpr.txt/golden
deleted file mode 100644
index af56d7a4d22b1f5ffd137f975f2850753cbcee7b..0000000000000000000000000000000000000000
--- a/rtree/test/expected/rexpr.txt/golden
+++ /dev/null
@@ -1,49 +0,0 @@
-<|
-|
-+- <|
-| |
-| +- <|
-| | |
-| | +- x := 0; 1 + x with context
-| | |
-| | `- x := 0; x with context
-| |
-| `- ⊥ with context
-|
-`- <|
- |
- +- <|
- | |
- | +- 1 + x with context x = 0,
- | |
- | `- <|
- | |
- | +- 1 + 0 with context x = 0,
- | |
- | `- <|
- | |
- | +- x with context x = 0,
- | |
- | `- <|
- | |
- | +- 0 with context x = 0,
- | |
- | `- <|
- | |
- | +- 1 with context x = 0,
- | |
- | `- ⊥ with context x = 0,
- |
- `- <|
- |
- +- x with context x = 0,
- |
- `- <|
- |
- +- 0 with context x = 0,
- |
- `- <|
- |
- +- 1 with context x = 0,
- |
- `- ⊥ with context x = 0,
diff --git a/rtree/test/expected/small-let-expr.txt b/rtree/test/expected/small-let-expr.txt
new file mode 100644
index 0000000000000000000000000000000000000000..979993e762c2e115bc61a7ba3a4d9c6ab250190c
--- /dev/null
+++ b/rtree/test/expected/small-let-expr.txt
@@ -0,0 +1,7 @@
+┳â”┳â”┳┠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.txt b/rtree/test/expected/small-opr-expr.txt
new file mode 100644
index 0000000000000000000000000000000000000000..d0c48ef77724aa58ed68201cb524c554a809189e
--- /dev/null
+++ b/rtree/test/expected/small-opr-expr.txt
@@ -0,0 +1,4 @@
+┳â”┳┠1 + 2 -|
+┃ ┗┠1 -|
+â”—â”┳┠2 -|
+ ┗┠⊥ -|
diff --git a/rtree/test/src/Control/Monad/RTreeSpec.hs b/rtree/test/src/Control/Monad/RTreeSpec.hs
index d3cab50f29a83381faa57d7af66b1671e24cf1ba..b0a2d18f6a23401f7cdfd0e6880c38234d32c4fd 100644
--- a/rtree/test/src/Control/Monad/RTreeSpec.hs
+++ b/rtree/test/src/Control/Monad/RTreeSpec.hs
@@ -15,23 +15,11 @@ import Data.Functor
import qualified Data.Map.Strict as Map
import Test.Hspec
import qualified Test.Hspec.Expectations.Pretty as Pretty
-import Test.Hspec.Golden
+import Test.Hspec.GitGolden
shouldBeString :: String -> String -> Pretty.Expectation
shouldBeString = Pretty.shouldBe
-golden :: FilePath -> String -> Golden String
-golden fp str =
- Golden
- { writeToFile = writeFile
- , readFromFile = readFile
- , goldenFile = "test/expected/" ++ fp ++ "/golden"
- , failFirstTime = False
- , encodePretty = id
- , actualFile = Just ("test/expected/" ++ fp ++ "/actual")
- , output = str
- }
-
rBool :: (MonadReduce m) => m Bool
rBool = split (pure False) (pure True)
@@ -49,6 +37,9 @@ 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 e = case e of
Cnt i -> do
@@ -57,18 +48,17 @@ rExpr e = case e of
v <- gets (Map.lookup k)
case v of
Nothing -> pure e
- Just x -> rExpr x <| pure e
+ Just x -> rExpr x
Opr e1 e2 -> onBoth (rExpr e1) (rExpr e2) \e1' e2' ->
pure $ Opr e1' e2'
- Let k e1 e2 ->
+ Let k e1 e2 -> do
+ e1' <- rExpr e1
split
do
- modify' (Map.insert k e1)
+ modify' (Map.insert k e1')
rExpr e2
do
- e1' <- rExpr e1
- e2' <- rExpr e2
- pure $ Let k e1' e2'
+ Let k e1' <$> rExpr e2
prettyExprS :: Int -> Expr -> String -> String
prettyExprS p = \case
@@ -87,6 +77,15 @@ 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
@@ -103,17 +102,16 @@ rtreeTSpec = describe "RTreeT" do
`shouldBe` (Just ex1, Map.empty)
it "should inputs expr" do
golden
- "rexpr.txt"
+ "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
- ( \(e, m) ->
- maybe "⊥" (flip (prettyExprS 0) "") e
- <> " with context "
- <> foldMap
- (\(k, v) -> showString k . showString " = " . prettyExprS 0 v . showString ", ")
- (Map.toList m)
- ""
- )
- (flattenT (unStateT mrExpr Map.empty))
+ prettyExprWithConfig
+ . flattenT
+ $ unStateT (runMaybeT $ rExpr ex2) Map.empty
)
equiv
diff --git a/rtree/test/src/Test/Hspec/GitGolden.hs b/rtree/test/src/Test/Hspec/GitGolden.hs
new file mode 100644
index 0000000000000000000000000000000000000000..b43846bc6475f67710303c5790946f6a83ae14a0
--- /dev/null
+++ b/rtree/test/src/Test/Hspec/GitGolden.hs
@@ -0,0 +1,29 @@
+{-# LANGUAGE OverloadedRecordDot #-}
+
+module Test.Hspec.GitGolden where
+
+import System.Directory
+import System.FilePath
+
+import qualified Data.Text.Lazy as Text
+import qualified Data.Text.Lazy.Encoding as Text
+import System.Process.Typed
+import Test.Hspec.Core.Spec
+
+data GitGolden = GitGolden
+ { filename :: FilePath
+ , content :: String
+ }
+
+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))
+
+golden :: FilePath -> String -> GitGolden
+golden fp str = GitGolden{filename = fp, content = str}