Skip to content
Snippets Groups Projects
Commit 1b00c98f authored by chrg's avatar chrg
Browse files

Add overloading example

parent eacab4ca
No related branches found
No related tags found
No related merge requests found
......@@ -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.
......
┳━┳━┳━┳━┳━┳━ 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
┃ ┃ ┗━ ⊥
┃ ┗━ ⊥
┗━ ⊥
......@@ -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,14 +68,14 @@ prettyExprS :: Int -> Expr -> String -> String
prettyExprS d = \case
Var x -> showString x
Opr l r ->
showParen (d > addPrec)
$ prettyExprS (addPrec + 1) l
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
showParen (d > letPrec) $
showString x
. showString " := "
. prettyExprS (letPrec + 1) e1
. showString "; "
......@@ -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)
......
......@@ -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
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment