Add more examples

rtree/test/expected/double-let-expr

+┳━┳━┳━┳━┳━┳━ 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
+┃   ┃     ┗━ ⊥
+┃   ┗━ ⊥
+┗━ ⊥

rtree/test/expected/small-let-expr

+┳━┳━┳━┳━ x := 1; 2 + x
+┃ ┃ ┃ ┗━ x := 1; 2
+┃ ┃ ┗━┳━ x := 1; x
+┃ ┃   ┗━ ⊥
+┃ ┗━┳━┳━┳━ 2 + 1
+┃   ┃ ┃ ┗━ 3
+┃   ┃ ┗━ 2
+┃   ┗━┳━ 1
+┃     ┗━ ⊥
+┗━ ⊥

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

+┳━┳━┳━ 1 + 2
+┃ ┃ ┗━ 3
+┃ ┗━ 1
+┗━┳━ 2
+  ┗━ ⊥

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

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

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)

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}