diff --git a/rtree/src/Control/Monad/Reduce.hs b/rtree/src/Control/Monad/Reduce.hs
index f514a924e324a342ff4809d12ca8598b4ac96b95..dd401199d88afba3858f077edf02316c01d33274 100644
--- a/rtree/src/Control/Monad/Reduce.hs
+++ b/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.
diff --git a/rtree/test/expected/double-overloading-let-expr b/rtree/test/expected/double-overloading-let-expr
new file mode 100644
index 0000000000000000000000000000000000000000..99dab4ef18c48a34ee840bc576eb54c019117d95
--- /dev/null
+++ b/rtree/test/expected/double-overloading-let-expr
@@ -0,0 +1,21 @@
+┳â”┳â”┳â”┳â”┳â”┳┠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
+┃ ┃ ┗┠⊥
+┃ ┗┠⊥
+┗┠⊥
diff --git a/rtree/test/src/Control/Monad/RTreeSpec.hs b/rtree/test/src/Control/Monad/RTreeSpec.hs
index ec6c4bbe006ef0a6609726be4e599b6abb263994..79a8d12605bb0bebdaafeba12394dbc6b785bc7f 100644
--- a/rtree/test/src/Control/Monad/RTreeSpec.hs
+++ b/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)
diff --git a/rtree/test/src/Test/Hspec/GitGolden.hs b/rtree/test/src/Test/Hspec/GitGolden.hs
index 055cc1ff4861e13269262fafd5ba593a1757c22e..5652c2878e4501f173f953cd1cb03737c14fcced 100644
--- a/rtree/test/src/Test/Hspec/GitGolden.hs
+++ 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