ghc-dup: 6875ffc60fc50ac18cc143d43a7860889e8a2b19
1: -- Copyright Sankell Software 2011
2:
3: module TinyLaunchbury (
4: Expr(Lambda, Apply, Var, Let, Prim, Ctor, Case),
5: reduce,
6: displayReduce) where
7:
8: import Data.List(foldl',intercalate,nub,(\\),delete)
9: import Control.Monad.State
10: import Control.Monad.Error
11: import Control.Monad.Identity
12: import Control.Arrow( second, (***) )
13: import Data.Monoid
14:
15:
16: type Name = String
17:
18: data Expr = Lambda Name Expr
19: | Apply Expr Name
20: | Var Name
21: | Let Bindings Expr
22: | Dup Name
23: | DeepDup Name
24: | Prim Name Expr Expr
25: | Ctor Int [Name]
26: | Case Expr Alts
27: | Int Int
28: | IfZero Expr Expr Expr
29: | Sub1 Name
30: deriving Eq
31:
32: type Binding = (Name,Expr)
33: type Bindings = [Binding]
34: type Alt = (Int, ([Name], Expr) )
35: type Alts = [Alt]
36:
37: -- |Gets the list of variable names from the bindings
38: binders :: Bindings -> [Name]
39: binders = map fst
40:
41: -- | Displays an Expression using a more common lambda calculus syntax
42: -- rather than just printing the syntax tree.
43: instance Show Expr where
44: show (Lambda x e) = "\\" ++ x ++ "." ++ show e
45: show (Apply e x) = show e ++ " " ++ x
46: show (Var x) = x
47: show (Let bindings e) = "let " ++ bindingStr ++ " in " ++ show e
48: where showBinding (x,e') = x ++ " = " ++ show e'
49: bindingStr = intercalate ", " (map showBinding bindings)
50: show (Dup x) = "dup " ++ x
51: show (DeepDup x) = "deepDup " ++ x
52: show (Prim fun e e') = show e ++ " " ++ fun ++ " " ++ show e'
53: show (Ctor ctor []) = show ctor
54: show (Ctor ctor args) = "<" ++ show ctor ++ " " ++ unwords args ++">"
55: show (Case e alts) = "case " ++ show e ++ " of " ++ caseStr
56: where dispCase (ctor, (args, e')) = show (Ctor ctor args)
57: ++ " -> " ++ show e'
58: caseStr = (intercalate ", " . map dispCase) alts
59: show (Int i) = show i
60: show (IfZero e1 e2 e3) = "if " ++ show e1 ++ "==0 then " ++ show e2 ++ " else " ++ show e3
61: show (Sub1 x) = x ++ " - 1"
62:
63: type Heap = [(Name, Expr)]
64:
65: -- | Remove some binding from the heap.
66: hRemoveBinding :: Name -> (Heap -> Heap)
67: hRemoveBinding x = filter $ (/= x) . fst
68:
69:
70: type StateErrorT s a m = ErrorT String (StateT s m) a
71: runStateErrorT = runStateT. runErrorT
72:
73: type StateError s a = StateErrorT s a Identity
74: runStateError m = runIdentity. runStateErrorT m
75:
76: data ReduceState = RS { rsHeap :: Heap
77: , rsFreshVars :: [Name]
78: , rsLogIndentation :: Int
79: , rsLog :: Log
80: }
81:
82: rsInitial :: ReduceState
83: rsInitial = RS { rsHeap = []
84: , rsFreshVars = freshVarNames
85: , rsLogIndentation = 0
86: , rsLog = []
87: }
88:
89: type ReduceM a = StateError ReduceState a
90: rmRun :: ReduceM a -> ReduceState-> (Either String a, ReduceState)
91: rmRun = runStateError
92:
93: -- hides the implementation detail of fail vs throw error; makes it easier to
94: -- swap out the underlying monad.
95: rmErr :: String -> ReduceM Expr
96: rmErr e = do appendToLog $ "Error: " ++ e
97: h <- fmap rsHeap get
98: appendToLog (show h)
99: throwError e
100:
101: -- |Like sub, but for a list of things to substite
102: -- usefull for implementing recursive lets (i.e. letrec)
103: subs :: [(Name,Name)] -> (Expr -> Expr)
104: subs = foldr (.) id . map (uncurry sub)
105:
106: -- |e[x/y] in Launchbury's notation
107: -- [x ↦ y]e in Pierce's notation in TaPL
108: -- recursively descend expression tree to substitute a free variable
109: sub :: Name -> Name -> (Expr -> Expr)
110: sub x y e =
111: let subExpr = sub x y
112: subName z | x == z = y
113: | otherwise = z
114: -- subAlt (ctor, (args, e'')) = (ctor, (map subName args, subExpr e''))
115: subAlt = second (map subName *** subExpr)
116: subBn = second (subExpr)
117: in case e of
118: Lambda z e'| z == x -> e -- only want to sub free variables;
119: -- x is no longer free
120: | otherwise -> Lambda z (subExpr e')
121: Apply e' z -> Apply (subExpr e') (subName z)
122: Var z -> Var (subName z)
123: Let bs e' | elem x (binders bs) -> e -- only want to sub free variables;
124: -- x is no longer free
125: | otherwise -> Let (map subBn bs) (subExpr e')
126: Prim fun e' e'' -> Prim fun (subExpr e') (subExpr e'')
127: -- substitute the variables in the ctor;
128: -- the ctor itself should be left alone
129: Ctor ctor args -> Ctor ctor (map subName args)
130: Case e' alts -> Case (subExpr e') (map subAlt alts)
131: Int n -> Int n
132: Sub1 z -> Sub1 (subName z)
133: IfZero e1 e2 e3 -> IfZero (subExpr e1) (subExpr e2) (subExpr e3)
134: DeepDup z -> DeepDup (subName z)
135: Dup z -> Dup (subName z)
136:
137: freeVarNames :: Expr -> [Name]
138: freeVarNames (Lambda z e') = delete z $ freeVarNames e'
139: freeVarNames (Apply e' z) = nub $ z : freeVarNames e'
140: freeVarNames (Var z) = [z]
141: freeVarNames (Let bs e) = (nub $ concatMap (freeVarNames . snd) bs ++ freeVarNames e) \\ map fst bs
142: freeVarNames (Dup x) = [x]
143: freeVarNames (DeepDup x) = [x]
144: freeVarNames (Prim fun e' e'') = nub $ freeVarNames e' ++ freeVarNames e''
145: freeVarNames (Ctor _ args) = nub args
146: freeVarNames (Case e alts) = nub $ freeVarNames e ++ concatMap freeVarNamesAlt alts
147: freeVarNames (Int n) = []
148: freeVarNames (Sub1 z) = [z]
149: freeVarNames (IfZero e1 e2 e3) = nub $ freeVarNames e1 ++ freeVarNames e2 ++ freeVarNames e3
150:
151: freeVarNamesAlt :: Alt -> [Name]
152: freeVarNamesAlt (ctr, (ns, e)) = freeVarNames e \\ ns
153:
154: -- helper function fro freshen; freshens an alternative in a case statement
155: freshenAlt :: Alt -> ReduceM Alt
156: freshenAlt (ctr, (ns,e)) = do e' <- freshen e
157: return (ctr, (ns, e'))
158:
159: -- |freshen takes an expression, and returns the same expression with every
160: -- bound variable substituted for a fresh variable.
161: freshen :: Expr -> ReduceM Expr
162: freshen l@(Lambda x e) = do y <- getFreshVar
163: e' <- (freshen . sub x y) e
164: return $ Lambda y e'
165: freshen (Apply e x) = do e' <- freshen e
166: return $ Apply e' x
167: freshen v@(Var _) = return v
168: freshen l@(Let bs e) = do let vs = map fst bs
169: es = map snd bs
170: vs' <- getFreshVars (length bs)
171: -- let is mutually recursive, so any binding
172: -- can refer to any other binding
173: let subFreshF = freshen . subs (zip vs vs')
174: es' <- mapM subFreshF es
175: e' <- subFreshF e
176: return $ Let (zip vs' es') e'
177: freshen (Prim fun e e') = liftM2 (Prim fun) (freshen e) (freshen e')
178: -- if the constructor's args needed to be freshened
179: -- they already were
180: freshen c@(Ctor ctor args) = return c
181: freshen (Case e alts) = liftM2 Case (freshen e) (mapM freshenAlt alts)
182: freshen c@(Int _) = return c
183: freshen c@(Sub1 _) = return c
184: freshen c@(IfZero e1 e2 e3)= do e1' <- freshen e1
185: e2' <- freshen e2
186: e3' <- freshen e3
187: return $ IfZero e1' e2' e3'
188: freshen c@(DeepDup _) = return c
189: freshen c@(Dup _) = return c
190:
191: type ErrorOr a = Either String a
192: type Log = String
193:
194: appendToLog :: String -> ReduceM ()
195: appendToLog msg = modify $ \s -> s {rsLog = rsLog s ++ "\n"
196: ++ (replicate (rsLogIndentation s) '|'
197: ++ msg)}
198: -- | returns whatever x is bound to in the heap, or calls rmErr if it isn't in
199: -- the heap
200: heapLookup :: Name -> ReduceM Expr
201: heapLookup x = do me <- fmap (lookup x . rsHeap) get
202: -- return the error if me is nothing; return me otherwise
203: maybe (rmErr $ "Illigal free variable: " ++ x
204: ++ " isn't in the heap.") return me
205:
206: heapModify :: (Heap -> Heap) -> ReduceM ()
207: heapModify f = modify $ \s -> s { rsHeap = f (rsHeap s) }
208:
209: -- | Removes a binding from the heap.
210: heapRemove :: Name -> ReduceM ()
211: heapRemove x = heapModify (hRemoveBinding x)
212:
213: -- | Adds a binding to the heap
214: heapAdd :: Name -> Expr -> ReduceM ()
215: heapAdd x e = heapModify ((x,e):)
216:
217: getFreshVar :: ReduceM Name
218: getFreshVar = do (v:vs) <- fmap rsFreshVars get
219: modify (\s -> s {rsFreshVars = vs})
220: return v
221:
222: getFreshVars :: Int -> ReduceM [Name]
223: getFreshVars = sequence . flip replicate getFreshVar
224:
225: withLogIndent :: ReduceM b -> ReduceM b
226: withLogIndent funarg = do s@(RS _ _ i _) <- get
227: put $ s {rsLogIndentation = i+1}
228: result <- funarg
229: s' <- get
230: put $ s' {rsLogIndentation = i}
231: return result
232:
233: realReduce :: Expr -> ReduceM ()
234: realReduce e = do e' <- reduceM e
235: appendToLog $ "Ans: " ++ show e'
236: appendToLog $ "Final heap: "
237: h <- fmap rsHeap get
238: appendToLog (show h)
239:
240:
241: evalAndGetLog :: ReduceM a -> String
242: evalAndGetLog = rsLog . snd . flip rmRun rsInitial
243:
244: evalAndGetExpr :: Expr -> Either String Expr
245: evalAndGetExpr = fst . flip rmRun rsInitial . reduceM
246:
247: -- |Reduces an expression, and returns a string containing the log appended with
248: -- the result
249: reduce :: Expr -> String
250: reduce = evalAndGetLog . realReduce
251:
252: -- | Prints the result of reduce to stdout. The main reason for this function
253: -- is that the log contains newline Chars, and newlines don't format correctly
254: -- in ghci.
255: displayReduce :: Expr -> IO ()
256: displayReduce = putStrLn . reduce
257:
258:
259: freshVarNames :: [Name]
260: freshVarNames = ["$" ++ show x | x <- [1..]]
261:
262: showHeap h = "{" ++ heapStr ++ "}"
263: where showElem (x, e) = x ++ " -> " ++ show e
264: heapStr = intercalate ", " $ map showElem h
265:
266:
267:
268: -- |Performs long-step reduction of an expression, logging the steps taken along the way.
269: reduceM :: Expr -> ReduceM Expr
270: reduceM e = let logCase msg = do s <- get
271: appendToLog $ msg ++ show e
272: ++ " : " ++ showHeap (rsHeap s)
273: in case e of
274: Lambda e' x -> logCase "Returning lambda: " >> return (Lambda e' x)
275: Apply e' x -> do logCase "Reducing apply: "
276: Lambda y' e'' <- withLogIndent $ reduceM e'
277: withLogIndent $ reduceM (sub y' x e'')
278: Var x -> do logCase "Reducing variable: "
279: e' <- heapLookup x
280: heapRemove x
281: z <- withLogIndent $ reduceM e'
282: appendToLog $ "Rebinding var " ++ x ++ " to " ++ show z
283: heapAdd x z
284: freshen z
285: Let bs e' -> do logCase "Reducing let: "
286: mapM_ (uncurry heapAdd) bs
287: withLogIndent $ reduceM e'
288: Dup x -> do logCase "Reducing dup: "
289: z <- heapLookup x
290: x' <- getFreshVar
291: heapAdd x' z
292: withLogIndent $ reduceM (Var x')
293: DeepDup x -> do logCase "Reducing deepDup: "
294: z <- heapLookup x
295: case z of
296: DeepDup y -> withLogIndent $ reduceM (DeepDup y)
297: _ -> do
298: x' <- getFreshVar
299: let fv = freeVarNames z
300: fv' <- getFreshVars (length fv)
301: thunks <- forM (zip fv fv') $ \(v,v') -> do
302: e'<- heapLookup v
303: heapAdd v' $ DeepDup v
304: let z' = subs (zip fv fv') z
305: heapAdd x' z'
306: withLogIndent $ reduceM (Var x')
307: Prim fun e1 e2 -> do logCase "Reducing primitive: "
308: n1 <- withLogIndent $ reduceM e1
309: n2 <- withLogIndent $ reduceM e2
310: result <- executePrimitive fun n1 n2
311: appendToLog $ "Primitive evaluated to "
312: ++ show result
313: return result
314: Ctor ctor args -> do logCase "Returning constructor: "
315: return $ Ctor ctor args
316: Case e' alts ->
317: do logCase "Reducing case statement: "
318: e''@(Ctor ctor args) <- withLogIndent $ reduceM e'
319: case lookup ctor alts of
320: Just (altNs, altE) -> withLogIndent $ reduceM $ subs (zip altNs args) altE
321: Nothing -> rmErr $ "non-exhaustive patterns in case " ++ show e
322: ++ "; no match for constructor " ++ show e''
323:
324: Int n -> do logCase "Returning Integer: "
325: return $ Int n
326:
327: Sub1 x -> do logCase "Reducing Sub1: "
328: Int n <- withLogIndent $ reduceM (Var x)
329: return $ Int (n-1)
330:
331: IfZero e1 e2 e3 ->
332: do logCase "Reducing IfZero: "
333: Int n <- withLogIndent $ reduceM e1
334: if (n == 0)
335: then withLogIndent $ reduceM e2
336: else withLogIndent $ reduceM e3
337:
338:
339: executePrimitive :: Name -> Expr -> Expr -> ReduceM Expr
340: executePrimitive f (Ctor n1 []) (Ctor n2 []) =
341: let fReal = lookup f [("+",(+))
342: ,("-",(-))
343: ,("/",(div))
344: ,("*",(*))]
345: in case fReal of
346: Just fun -> return $ Ctor (fun n1 n2) []
347: Nothing -> rmErr $ "primitive " ++ f
348: ++ " doesn't exist for nullary constructors"
349: executePrimitive f e e' = rmErr $ "e = " ++ show e ++ " e' = " ++ show e'
350:
351: -- Some example expressions, plus some functions to make constructing
352: -- expressions easier
353: mkNum x = Ctor x []
354:
355: addExpr = Prim "+"
356: multExpr = Prim "*"
357:
358: add x y = addExpr (mkNum x) (mkNum y)
359: addVar x y = addExpr (Var x) (mkNum y)
360: addVars x y = addExpr (Var x) (Var y)
361: multVars x y = multExpr (Var x) (Var y)
362: applyVars x y = Apply (Var x) y
363:
364: simpleExpr = Let [("u", add 3 2),
365: ("v", addVar "u" 1)]
366: $ addVars "v" "v"
367:
368: -- Recursive, but refers to x before x is put back on the heap.
369: -- will very quickly fail.
370: errorExpr = Let [("x", Var "x")] (Var "x")
371:
372: fastExpr = Let [("u", add 2 3),
373: ("f", Let [("v", addVar "u" 1)]
374: (Lambda "x" (addVars "v" "x"))),
375: ("a", mkNum 2),
376: ("b", mkNum 3)]
377: $ addExpr (applyVars "f" "a") (applyVars "f" "b")
378:
379:
380:
381: slowExpr = Let [("u", add 2 3),
382: ("f", (Lambda "x"
383: (Let [("v", addVar "u" 1)]
384: (addVars "v" "x")))),
385: ("a", mkNum 2),
386: ("b", mkNum 3)]
387: $ addExpr (applyVars "f" "a") (applyVars "f" "b")
388:
389: slowExprHaskell = let u = 3+5
390: f = let v = u+1 in \x -> v + x
391: in f 2 + f 3
392:
393: -- f reduces to \x.f x and is replaced onto the heap before
394: -- we apply x to it.
395: infinteLoopExpr = Let [("f", Lambda "x" (applyVars "f" "x")),
396: ("a", mkNum 2)]
397: $ applyVars "f" "a"
398:
399:
400:
401: nestedExpr = let applyAdd var expr = Apply (Apply expr "add") var
402: in Let [("add", Lambda "x" $ Lambda "y" (addVars "x" "y"))
403: ,("a", mkNum 1)
404: ,("addA", applyVars "add" "a")
405: ,("b", mkNum 2)
406: ,("addB", applyVars "add" "b")
407: ,("applyAToB", applyVars "addA" "addB")
408: ,("c", mkNum 3)
409: ,("addC", applyVars "add" "c")
410: ,("applyCToAB", applyVars "applyAToB" "addC")
411: ,("d", mkNum 4)
412: ]
413: $ applyVars "applyCToAB" "d"
414:
415: enumTest = Let
416: [("enum", Lambda "n" $ IfZero (Var "n")
417: (Ctor 0 [])
418: (Let [
419: ("n-1", Sub1 "n"),
420: ("tail", Apply (Var "enum") "n-1")
421: ] $ Ctor 1 ["n", "tail"] )),
422: ("0", Int 0),
423: ("5", Int 5),
424: ("walk", Lambda "n'" $ Lambda "e" $ Case (Var "e") [
425: (0, ([], Var "n'")),
426: (1, (["h","t"], Let [("n'-1", Sub1 "n'")] $
427: Apply (Apply (Var "walk") "n'-1") "t"))]),
428: ("list", Apply (Var "enum") "5")
429: ] $ Apply (Apply (Var "walk") "0") "list"
430:
431: enumTest2 = Let
432: [("enum", Lambda "n" $ IfZero (Var "n")
433: (Ctor 0 [])
434: (Let [
435: ("n-1", Sub1 "n"),
436: ("tail", Apply (Var "enum") "n-1")
437: ] $ Ctor 1 ["n", "tail"] )),
438: ("0", Int 0),
439: ("5", Int 5),
440: ("walk", Lambda "n'" $ Lambda "e" $ Case (DeepDup "e") [
441: (0, ([], Var "n'")),
442: (1, (["h","t"], Let [("n'-1", Sub1 "n'")] $
443: Apply (Apply (Var "walk") "n'-1") "t"))]),
444: ("list", Apply (Var "enum") "5"),
445: ("list'", DeepDup "list"),
446: ("list''", DeepDup "list'")
447: ] $ Apply (Apply (Var "walk") "0") "list"
Generated by git2html.