Include git-golden

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": {

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";

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

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

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

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.

rtree/test/expected/rexpr.txt/golden

-<|
-|
-+- <|
-|  |
-|  +- <|
-|  |  |
-|  |  +- 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, 

rtree/test/expected/small-let-expr.txt

+┳━┳━┳━ x := 0; 1 + x     -| 
+┃ ┃ ┗━ x := 0; x     -| 
+┃ ┗━┳━┳━ 1 + 0     -| x = 0, 
+┃   ┃ ┗━ 1     -| x = 0, 
+┃   ┗━┳━ 0     -| x = 0, 
+┃     ┗━ ⊥     -| x = 0, 
+┗━ ⊥     -| 

rtree/test/expected/small-opr-expr.txt

+┳━┳━ 1 + 2     -| 
+┃ ┗━ 1     -| 
+┗━┳━ 2     -| 
+  ┗━ ⊥     -| 

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

rtree/test/src/Test/Hspec/GitGolden.hs

+{-# 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}