Add overloading example

rtree/src/Control/Monad/Reduce.hs

@@ -40,6 +40,7 @@ module Control.Monad.Reduce (
 
 import Control.Applicative
 import Control.Monad
+import Control.Monad.State
 import Control.Monad.Trans.Maybe
 import Data.Bool
 import qualified Data.List.NonEmpty as NE
@@ -133,7 +134,9 @@ onBoth mlhs mrhs fn =
         Nothing -> pure lhs
         Just rhs -> fn lhs rhs
 
--- <|> fmap pure mrhs) <|> fmap pure mlhs
+instance (MonadReduce m) => MonadReduce (StateT s m) where
+  check = StateT (\s -> split (pure (False, s)) (pure (True, s)))
+  {-# INLINE check #-}
 
 {- | A reduction path, can be used as an index into reduction tree.
 Is isomorphic to a list of choices.

rtree/test/expected/double-overloading-let-expr

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

rtree/test/src/Control/Monad/RTreeSpec.hs

@@ -28,10 +28,10 @@ rList :: (MonadReduce m) => [a] -> m [a]
 rList = collect (given $>)
 
 data Expr
-  = Var String
-  | Cnt Int
-  | Opr Expr Expr
-  | Let String Expr Expr
+  = Var !String
+  | Cnt !Int
+  | Opr !Expr !Expr
+  | Let !String !Expr !Expr
   deriving (Show, Eq)
 
 rExpr
@@ -49,7 +49,7 @@ rExpr e = case e of
   Opr e1 e2 -> onBoth (rExpr e1) (rExpr e2) \e1' e2' ->
     case (e1', e2') of
       (Cnt a, Cnt b) -> pure (Cnt (a + b)) <| pure (Opr e1' e2')
-      _ -> pure $ Opr e1' e2'
+      _ow -> pure $ Opr e1' e2'
   Let k e1 e2 -> do
     e1' <- rExpr e1
     split
@@ -68,18 +68,18 @@ prettyExprS :: Int -> Expr -> String -> String
 prettyExprS d = \case
   Var x -> showString x
   Opr l r ->
-    showParen (d > addPrec)
-      $ prettyExprS (addPrec + 1) l
-      . showString " + "
-      . prettyExprS (addPrec + 1) r
+    showParen (d > addPrec) $
+      prettyExprS (addPrec + 1) l
+        . showString " + "
+        . prettyExprS (addPrec + 1) r
   Cnt i -> shows i
   Let x e1 e2 ->
-    showParen (d > letPrec)
-      $ showString x
-      . showString " := "
-      . prettyExprS (letPrec + 1) e1
-      . showString "; "
-      . prettyExprS letPrec e2
+    showParen (d > letPrec) $
+      showString x
+        . showString " := "
+        . prettyExprS (letPrec + 1) e1
+        . showString "; "
+        . prettyExprS letPrec e2
  where
   addPrec = 2
   letPrec = 1
@@ -88,20 +88,6 @@ prettyExprWithConfig :: (Maybe Expr, Map.Map String (Either String Expr)) -> Str
 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
@@ -120,21 +106,24 @@ rtreeTSpec = describe "RTreeT" do
     let handle str e = describe str do
           let me = runMaybeT $ rExpr e
           it "should extract" do
-            evalState (extractT me) Map.empty
-              `shouldBe` Just e
+            extract (runStateT me Map.empty)
+              `shouldBe` (Just e, Map.empty)
           it "should draw the same" do
             golden
               ("test/expected/" <> str)
-              (drawRTree prettyExprWithConfig (flattenT (unStateT me Map.empty)))
+              (drawRTree prettyExprWithConfig (runStateT me Map.empty))
+
+    handle "small-opr-expr" $
+      Opr (Cnt 1) (Cnt 2)
 
-    handle "small-opr-expr"
-      $ Opr (Cnt 1) (Cnt 2)
+    handle "small-let-expr" $
+      Let "x" (Cnt 1) (Opr (Cnt 2) (Var "x"))
 
-    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")))
 
-    handle "double-let-expr"
-      $ Let "x" (Cnt 1) (Let "y" (Cnt 2) (Opr (Var "x") (Var "y")))
+    handle "double-overloading-let-expr" $
+      Let "x" (Cnt 1) (Let "x" (Cnt 2) (Opr (Var "x") (Var "x")))
 
 equiv
   :: (Show b, MonadReduce x, MonadReduce y, Eq b)

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

@@ -12,8 +12,8 @@ import System.Process.Typed
 import Test.Hspec.Core.Spec
 
 data GitGolden = GitGolden
-  { filename :: FilePath
-  , content :: String
+  { filename :: !FilePath
+  , content :: !String
   }
 
 instance Example GitGolden where
@@ -29,8 +29,20 @@ instance Example GitGolden where
 
     case ec of
       ExitFailure _ -> do
-        pure $ Result "" (Pending location (Just $ "file " <> show e.filename <> " not in index"))
-      _ -> do
+        pure $
+          Result
+            ""
+            ( Failure
+                location
+                ( Reason $
+                    "file "
+                      <> show e.filename
+                      <> " not in index"
+                      <> "\n"
+                      <> e.content
+                )
+            )
+      ExitSuccess -> do
         (_, diff) <- readProcessStdout (proc "git" ["diff", e.filename])
 
         pure $ case (ec, Text.unpack (Text.decodeUtf8 diff)) of