module TinyLaunchbury (
Expr(Lambda, Apply, Var, Let, Prim, Ctor, Case),
reduce,
displayReduce) where
import Data.List(foldl',intercalate)
import Control.Monad.State
import Control.Monad.Error
import Control.Monad.Identity
import Control.Arrow( second, (***) )
import Data.Monoid
type Name = String
data Expr = Lambda Name Expr
| Apply Expr Name
| Var Name
| Let Bindings Expr
| Prim Name Expr Expr
| Ctor Int [Name]
| Case Expr Alts
deriving Eq
type Binding = (Name,Expr)
type Bindings = [Binding]
type Alt = (Int, ([Name], Expr) )
type Alts = [Alt]
binders :: Bindings -> [Name]
binders = map fst
instance Show Expr where
show (Lambda x e) = "\\" ++ x ++ "." ++ show e
show (Apply e x) = show e ++ " " ++ x
show (Var x) = x
show (Let bindings e) = "let " ++ bindingStr ++ " in " ++ show e
where showBinding (x,e') = x ++ " = " ++ show e'
bindingStr = intercalate ", " (map showBinding bindings)
show (Prim fun e e') = show e ++ " " ++ fun ++ " " ++ show e'
show (Ctor ctor []) = show ctor
show (Ctor ctor args) = "<" ++ show ctor ++ " " ++ unwords args ++">"
show (Case e alts) = "case " ++ show e ++ " of " ++ caseStr
where dispCase (ctor, (args, e')) = show (Ctor ctor args)
++ " -> " ++ show e'
caseStr = (intercalate ", " . map dispCase) alts
type Heap = [(Name, Expr)]
hRemoveBinding :: Name -> (Heap -> Heap)
hRemoveBinding x = filter $ (/= x) . fst
type StateErrorT s a m = ErrorT String (StateT s m) a
runStateErrorT = runStateT. runErrorT
type StateError s a = StateErrorT s a Identity
runStateError m = runIdentity. runStateErrorT m
data ReduceState = RS { rsHeap :: Heap
, rsFreshVars :: [Name]
, rsLogIndentation :: Int
, rsLog :: Log
}
rsInitial :: ReduceState
rsInitial = RS { rsHeap = []
, rsFreshVars = freshVarNames
, rsLogIndentation = 0
, rsLog = []
}
type ReduceM a = StateError ReduceState a
rmRun :: ReduceM a -> ReduceState-> (Either String a, ReduceState)
rmRun = runStateError
rmErr :: String -> ReduceM Expr
rmErr e = do appendToLog $ "Error: " ++ e
h <- fmap rsHeap get
appendToLog (show h)
throwError e
subs :: [(Name,Name)] -> (Expr -> Expr)
subs = foldr (.) id . map (uncurry sub)
sub :: Name -> Name -> (Expr -> Expr)
sub x y e =
let subExpr = sub x y
subName z | x == z = y
| otherwise = z
subAlt = second (map subName *** subExpr)
in case e of
Lambda z e'| z == x -> e
| otherwise -> Lambda z (subExpr e')
Apply e' z -> Apply (subExpr e') (subName z)
Var z -> Var (subName z)
Let bs e' | elem x (binders bs) -> e
| otherwise -> Let bs (subExpr e')
Prim fun e' e'' -> Prim fun (subExpr e') (subExpr e'')
Ctor ctor args -> Ctor ctor (map subName args)
Case e' alts -> Case (subExpr e') (map subAlt alts)
freshenAlt :: Alt -> ReduceM Alt
freshenAlt (ctr, (ns,e)) = do e' <- freshen e
return (ctr, (ns, e'))
freshen :: Expr -> ReduceM Expr
freshen l@(Lambda x e) = do y <- getFreshVar
e' <- (freshen . sub x y) e
return $ Lambda y e'
freshen (Apply e x) = do e' <- freshen e
return $ Apply e' x
freshen v@(Var _) = return v
freshen l@(Let bs e) = do let vs = map fst bs
es = map snd bs
vs' <- getFreshVars (length bs)
let subFreshF = freshen . subs (zip vs vs')
es' <- mapM subFreshF es
e' <- subFreshF e
return $ Let (zip vs' es') e'
freshen (Prim fun e e') = liftM2 (Prim fun) (freshen e) (freshen e')
freshen c@(Ctor ctor args) = return c
freshen (Case e alts) = liftM2 Case (freshen e) (mapM freshenAlt alts)
type ErrorOr a = Either String a
type Log = String
appendToLog :: String -> ReduceM ()
appendToLog msg = modify $ \s -> s {rsLog = rsLog s ++ "\n"
++ (replicate (rsLogIndentation s) '|'
++ msg)}
heapLookup :: Name -> ReduceM Expr
heapLookup x = do me <- fmap (lookup x . rsHeap) get
maybe (rmErr $ "Illigal free variable: " ++ x
++ " isn't in the heap.") return me
heapModify :: (Heap -> Heap) -> ReduceM ()
heapModify f = modify $ \s -> s { rsHeap = f (rsHeap s) }
heapRemove :: Name -> ReduceM ()
heapRemove x = heapModify (hRemoveBinding x)
heapAdd :: Name -> Expr -> ReduceM ()
heapAdd x e = heapModify ((x,e):)
getFreshVar :: ReduceM Name
getFreshVar = do (v:vs) <- fmap rsFreshVars get
modify (\s -> s {rsFreshVars = vs})
return v
getFreshVars :: Int -> ReduceM [Name]
getFreshVars = sequence . flip replicate getFreshVar
withLogIndent :: ReduceM b -> ReduceM b
withLogIndent funarg = do s@(RS _ _ i _) <- get
put $ s {rsLogIndentation = i+1}
result <- funarg
s' <- get
put $ s' {rsLogIndentation = i}
return result
realReduce :: Expr -> ReduceM ()
realReduce e = do e' <- reduceM e
appendToLog $ "Ans: " ++ show e'
evalAndGetLog :: ReduceM a -> String
evalAndGetLog = rsLog . snd . flip rmRun rsInitial
evalAndGetExpr :: Expr -> Either String Expr
evalAndGetExpr = fst . flip rmRun rsInitial . reduceM
reduce :: Expr -> String
reduce = evalAndGetLog . realReduce
displayReduce :: Expr -> IO ()
displayReduce = putStrLn . reduce
freshVarNames :: [Name]
freshVarNames = ["$" ++ show x | x <- [1..]]
showHeap h = "{" ++ heapStr ++ "}"
where showElem (x, e) = x ++ " -> " ++ show e
heapStr = intercalate ", " $ map showElem h
reduceM :: Expr -> ReduceM Expr
reduceM e = let logCase msg = do s <- get
appendToLog $ msg ++ show e
++ " : " ++ showHeap (rsHeap s)
in case e of
Lambda e' x -> logCase "Returning lambda: " >> return (Lambda e' x)
Apply e' x -> do logCase "Reducing apply: "
Lambda y' e'' <- withLogIndent $ reduceM e'
withLogIndent $ reduceM (sub y' x e'')
Var x -> do logCase "Reducing variable: "
e' <- heapLookup x
heapRemove x
z <- withLogIndent $ reduceM e'
appendToLog $ "Rebinding var " ++ x ++ " to " ++ show z
heapAdd x z
freshen z
Let bs e' -> do logCase "Reducing let: "
mapM_ (uncurry heapAdd) bs
withLogIndent $ reduceM e'
Prim fun e1 e2 -> do logCase "Reducing primitive: "
n1 <- withLogIndent $ reduceM e1
n2 <- withLogIndent $ reduceM e2
result <- executePrimitive fun n1 n2
appendToLog $ "Primitive evaluated to "
++ show result
return result
Ctor ctor args -> do logCase "Returning constructor: "
return $ Ctor ctor args
Case e' alts ->
do logCase "Reducing case statement: "
e''@(Ctor ctor args) <- withLogIndent $ reduceM e'
case lookup ctor alts of
Just (altNs, altE) -> withLogIndent $ reduceM $ subs (zip altNs args) altE
Nothing -> rmErr $ "non-exhaustive patterns in case " ++ show e
++ "; no match for constructor " ++ show e''
executePrimitive :: Name -> Expr -> Expr -> ReduceM Expr
executePrimitive f (Ctor n1 []) (Ctor n2 []) =
let fReal = lookup f [("+",(+))
,("-",())
,("/",(div))
,("*",(*))]
in case fReal of
Just fun -> return $ Ctor (fun n1 n2) []
Nothing -> rmErr $ "primitive " ++ f
++ " doesn't exist for nullary constructors"
executePrimitive f e e' = rmErr $ "e = " ++ show e ++ " e' = " ++ show e'
mkNum x = Ctor x []
addExpr = Prim "+"
multExpr = Prim "*"
add x y = addExpr (mkNum x) (mkNum y)
addVar x y = addExpr (Var x) (mkNum y)
addVars x y = addExpr (Var x) (Var y)
multVars x y = multExpr (Var x) (Var y)
applyVars x y = Apply (Var x) y
simpleExpr = Let [("u", add 3 2),
("v", addVar "u" 1)]
$ addVars "v" "v"
errorExpr = Let [("x", Var "x")] (Var "x")
fastExpr = Let [("u", add 2 3),
("f", Let [("v", addVar "u" 1)]
(Lambda "x" (addVars "v" "x"))),
("a", mkNum 2),
("b", mkNum 3)]
$ addExpr (applyVars "f" "a") (applyVars "f" "b")
slowExpr = Let [("u", add 2 3),
("f", (Lambda "x"
(Let [("v", addVar "u" 1)]
(addVars "v" "x")))),
("a", mkNum 2),
("b", mkNum 3)]
$ addExpr (applyVars "f" "a") (applyVars "f" "b")
slowExprHaskell = let u = 3+5
f = let v = u+1 in \x -> v + x
in f 2 + f 3
infinteLoopExpr = Let [("f", Lambda "x" (applyVars "f" "x")),
("a", mkNum 2)]
$ applyVars "f" "a"
nestedExpr = let applyAdd var expr = Apply (Apply expr "add") var
in Let [("add", Lambda "x" $ Lambda "y" (addVars "x" "y"))
,("a", mkNum 1)
,("addA", applyVars "add" "a")
,("b", mkNum 2)
,("addB", applyVars "add" "b")
,("applyAToB", applyVars "addA" "addB")
,("c", mkNum 3)
,("addC", applyVars "add" "c")
,("applyCToAB", applyVars "applyAToB" "addC")
,("d", mkNum 4)
]
$ applyVars "applyCToAB" "d"