TinyLaunchbury (empty) → 1.0
raw patch · 4 files changed
+379/−0 lines, 4 filesdep +basedep +mtlsetup-changed
Dependencies added: base, mtl
Files
- LICENSE +25/−0
- Setup.hs +3/−0
- TinyLaunchbury.cabal +16/−0
- TinyLaunchbury.hs +335/−0
+ LICENSE view
@@ -0,0 +1,25 @@+Copyright (c) 2011, Sankel Software +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of the Sankel Software nor the + names of its contributors may be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL SANKEL SOFTWARE BE LIABLE FOR ANY +DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple + +main = defaultMain
+ TinyLaunchbury.cabal view
@@ -0,0 +1,16 @@+Name: TinyLaunchbury +Version: 1.0 +License: BSD3 +License-File: LICENSE +Author: Elliot Stern, David Sankell +Maintainer: Elliot Stern <eliyahu.ben.miney@gmail.com> +Synopsis: Simple implementation of call-by-need using Launchbury's semantics +Category: Compilers/Interpreters +Description: A simple implementation of Launchbury's operational semantics for lazy languages. +Build-Type: Simple +Cabal-Version: >= 1.2 + +Library + Build-Depends: base >= 4 && < 5, + mtl >= 1 && < 3.0 + Exposed-Modules: TinyLaunchbury
+ TinyLaunchbury.hs view
@@ -0,0 +1,335 @@+-- Copyright Sankell Software 2011 + +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] + +-- |Gets the list of variable names from the bindings +binders :: Bindings -> [Name] +binders = map fst + +-- | Displays an Expression using a more common lambda calculus syntax +-- rather than just printing the syntax tree. +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)] + +-- | Remove some binding from the heap. +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 + +-- hides the implementation detail of fail vs throw error; makes it easier to +-- swap out the underlying monad. +rmErr :: String -> ReduceM Expr +rmErr e = do appendToLog $ "Error: " ++ e + h <- fmap rsHeap get + appendToLog (show h) + throwError e + +-- |Like sub, but for a list of things to substite +-- usefull for implementing recursive lets (i.e. letrec) +subs :: [(Name,Name)] -> (Expr -> Expr) +subs = foldr (.) id . map (uncurry sub) + +-- |e[x/y] in Launchbury's notation +-- [x ↦ y]e in Pierce's notation in TaPL +-- recursively descend expression tree to substitute a free variable +sub :: Name -> Name -> (Expr -> Expr) +sub x y e = + let subExpr = sub x y + subName z | x == z = y + | otherwise = z + -- subAlt (ctor, (args, e'')) = (ctor, (map subName args, subExpr e'')) + subAlt = second (map subName *** subExpr) + in case e of + Lambda z e'| z == x -> e -- only want to sub free variables; + -- x is no longer free + | 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 -- only want to sub free variables; + -- x is no longer free + | otherwise -> Let bs (subExpr e') + Prim fun e' e'' -> Prim fun (subExpr e') (subExpr e'') + -- substitute the variables in the ctor; + -- the ctor itself should be left alone + Ctor ctor args -> Ctor ctor (map subName args) + Case e' alts -> Case (subExpr e') (map subAlt alts) + +-- helper function fro freshen; freshens an alternative in a case statement +freshenAlt :: Alt -> ReduceM Alt +freshenAlt (ctr, (ns,e)) = do e' <- freshen e + return (ctr, (ns, e')) + +-- |freshen takes an expression, and returns the same expression with every +-- bound variable substituted for a fresh variable. +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 is mutually recursive, so any binding + -- can refer to any other binding + 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') + -- if the constructor's args needed to be freshened + -- they already were +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)} +-- | returns whatever x is bound to in the heap, or calls rmErr if it isn't in +-- the heap +heapLookup :: Name -> ReduceM Expr +heapLookup x = do me <- fmap (lookup x . rsHeap) get + -- return the error if me is nothing; return me otherwise + 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) } + +-- | Removes a binding from the heap. +heapRemove :: Name -> ReduceM () +heapRemove x = heapModify (hRemoveBinding x) + +-- | Adds a binding to the heap +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 + +-- |Reduces an expression, and returns a string containing the log appended with +-- the result +reduce :: Expr -> String +reduce = evalAndGetLog . realReduce + +-- | Prints the result of reduce to stdout. The main reason for this function +-- is that the log contains newline Chars, and newlines don't format correctly +-- in ghci. +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 + + + +-- |Performs long-step reduction of an expression, logging the steps taken along the way. +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' + +-- Some example expressions, plus some functions to make constructing +-- expressions easier +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" + +-- Recursive, but refers to x before x is put back on the heap. +-- will very quickly fail. +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 + +-- f reduces to \x.f x and is replaced onto the heap before +-- we apply x to it. +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"