diff --git a/src/Language/Lambda.hs b/src/Language/Lambda.hs index 3ba7d4d51713d0219c817b0338f7f84469c14eca..0311263dd5cf45b50892d7b451694efb8b6f6231 100644 --- a/src/Language/Lambda.hs +++ b/src/Language/Lambda.hs @@ -25,8 +25,7 @@ type Globals = Map.Map String (LambdaExpr String) evalString :: Globals -> String -> Either ParseError (LambdaExpr String, Globals) -evalString globals str = flip (,) globals <$> eval' - where eval' = evalExpr uniques <$> parseExpr str +evalString globals str = evalExpr globals uniques <$> parseExpr str uniques :: [String] uniques = concatMap (\p -> map (:p) . reverse $ ['a'..'z']) suffix diff --git a/src/Language/Lambda/Eval.hs b/src/Language/Lambda/Eval.hs index e6532c3ec483107b7e87021ea1bc2c443839789f..8400022488ca6b5dfd8f1cc613a796a9f3f32871 100644 --- a/src/Language/Lambda/Eval.hs +++ b/src/Language/Lambda/Eval.hs @@ -3,18 +3,50 @@ module Language.Lambda.Eval where import Data.List import Data.Maybe +import qualified Data.Map as Map + import Language.Lambda.Expression -evalExpr :: Eq n => [n] -> LambdaExpr n -> LambdaExpr n -evalExpr uniqs (Abs name expr) = Abs name . evalExpr uniqs $ expr -evalExpr _ expr@(Var _) = expr -evalExpr uniqs (App e1 e2) = betaReduce uniqs (evalExpr uniqs e1) - (evalExpr uniqs e2) +-- | Evaluate an expression +evalExpr :: (Eq n, Ord n) + => Map.Map n (LambdaExpr n) -- ^ globals + -> [n] -- ^ unique supply + -> LambdaExpr n -- ^ the expression to evaluate + -> (LambdaExpr n, Map.Map n (LambdaExpr n)) +evalExpr globals uniqs (Let name expr) + = (Let name expr', Map.insert name expr' globals) + where expr' = evalExpr' uniqs (subGlobals globals expr) +evalExpr globals uniqs expr = (evalExpr' uniqs expr', globals) + where expr' = subGlobals globals expr -betaReduce :: Eq n => [n] -> LambdaExpr n -> LambdaExpr n -> LambdaExpr n -betaReduce uniqs (App e1 e1') e2 = App (betaReduce uniqs e1 e1') e2 +subGlobals :: (Eq n, Ord n) + => Map.Map n (LambdaExpr n) -- ^ globals + -> LambdaExpr n -- ^ the expression + -> LambdaExpr n +subGlobals g e@(Var x) = Map.findWithDefault e x g +subGlobals g (App e1 e2) = App (subGlobals g e1) (subGlobals g e2) +subGlobals g (Abs n expr) = Abs n (subGlobals g expr) +subGlobals _ expr = expr + +-- | Evaluate an expression; does not support `let` +evalExpr' :: Eq n + => [n] -- ^ unique supply + -> LambdaExpr n -- ^ the expression to evaluate + -> LambdaExpr n +evalExpr' _ expr@(Var _) = expr +evalExpr' uniqs (Abs name expr) = Abs name . evalExpr' uniqs $ expr +evalExpr' uniqs (Let name expr) = Let name . evalExpr' uniqs $ expr +evalExpr' uniqs (App e1 e2) = betaReduce uniqs (evalExpr' uniqs e1) + (evalExpr' uniqs e2) + +betaReduce :: Eq n + => [n] + -> LambdaExpr n + -> LambdaExpr n + -> LambdaExpr n betaReduce _ expr@(Var _) e2 = App expr e2 -betaReduce uniqs (Abs n e1) e2 = evalExpr uniqs . sub n e1' $ e2 +betaReduce uniqs (App e1 e1') e2 = App (betaReduce uniqs e1 e1') e2 +betaReduce uniqs (Abs n e1) e2 = evalExpr' uniqs . sub n e1' $ e2 where fvs = freeVarsOf e2 e1' = alphaConvert uniqs fvs e1 diff --git a/test/Language/Lambda/EvalSpec.hs b/test/Language/Lambda/EvalSpec.hs index bf7e41eea3609a34c6f55039cf911a2a90762b79..21afaf92690a8a77dfdeae1656cfa08f7f9452fb 100644 --- a/test/Language/Lambda/EvalSpec.hs +++ b/test/Language/Lambda/EvalSpec.hs @@ -1,5 +1,6 @@ module Language.Lambda.EvalSpec where +import Data.Map (empty, insert) import Test.Hspec import Language.Lambda @@ -9,7 +10,7 @@ import Language.Lambda.Expression spec :: Spec spec = do describe "evalExpr" $ do - let evalExpr' = evalExpr uniques + let evalExpr' = fst <$> evalExpr empty uniques it "beta reduces" $ do let expr = App (Abs "x" (Var "x")) (Var "z") @@ -28,6 +29,23 @@ spec = do (Abs "f" (Var "x")) evalExpr' expr `shouldBe` Abs "z" (Var "x") + it "reduces let bodies" $ do + let expr = Let "x" $ App (Abs "y" (Var "y")) (Var "z") + evalExpr' expr `shouldBe` Let "x" (Var "z") + + it "let expressions update state" $ do + let expr = Let "w" (Var "x") + (_, globals) = evalExpr empty uniques expr + + globals `shouldBe` insert "w" (Var "x") empty + + it "subs global variables" $ do + let globals = insert "w" (Var "x") empty + expr = Var "w" + + fst (evalExpr globals uniques expr) + `shouldBe` Var "x" + describe "betaReduce" $ do let betaReduce' = betaReduce []