├── Setup.hs ├── test ├── Spec.hs ├── Examples │ └── parse │ │ └── decl │ │ ├── decl-00.lm │ │ ├── decl-02.lm │ │ └── decl-01.lm ├── DocTest.hs ├── Decl │ └── ParserSpec.hs └── Lambda │ ├── UntypedSpec.hs │ └── Untyped │ ├── EvalSpec.hs │ ├── FreeEvalSpec.hs │ ├── ParserSpec.hs │ └── FreeParserSpec.hs ├── README.md ├── .editorconfig ├── app └── Main.hs ├── std.lm ├── .gitignore ├── src ├── Lambda │ ├── Core.hs │ ├── Untyped │ │ ├── Types.hs │ │ ├── Parser │ │ │ └── Free.hs │ │ ├── Parser.hs │ │ ├── Eval.hs │ │ └── Eval │ │ │ └── Free.hs │ ├── SimplyTyped │ │ └── Fancy.hs │ └── Untyped.hs └── Decl │ └── Parser.hs ├── stack.yaml ├── LICENSE └── lambda.cabal /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /test/Examples/parse/decl/decl-00.lm: -------------------------------------------------------------------------------- 1 | def foo = \x . x; 2 | def bar = \y . y; 3 | -------------------------------------------------------------------------------- /test/Examples/parse/decl/decl-02.lm: -------------------------------------------------------------------------------- 1 | def foo = "hello world"; 2 | 3 | def bar = plus 1 2; 4 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # lambda 2 | 3 | I'm studying lambda calculus, type theory, and potential applications of Fancy Logics to programming languages. 4 | To further my understanding, I'm implementing the various lambda calculi in Haskell. 5 | -------------------------------------------------------------------------------- /test/DocTest.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import System.FilePath.Glob (glob) 4 | import Test.DocTest (doctest) 5 | 6 | main :: IO () 7 | main = do 8 | glob "src/**/*.hs" >>= doctest 9 | glob "app/**/*.hs" >>= doctest 10 | -------------------------------------------------------------------------------- /.editorconfig: -------------------------------------------------------------------------------- 1 | # http://editorconfig.org 2 | root = true 3 | 4 | [*] 5 | indent_style = space 6 | indent_size = 4 7 | end_of_line = lf 8 | charset = utf-8 9 | trim_trailing_whitespace = true 10 | insert_final_newline = true 11 | max_line_length = 80 12 | -------------------------------------------------------------------------------- /test/Examples/parse/decl/decl-01.lm: -------------------------------------------------------------------------------- 1 | def id = \x. x; 2 | 3 | def const = \x. \y. x; 4 | 5 | def flip = \f. \x. \y. f y x; 6 | 7 | def zero = \f. \y. y; 8 | 9 | def succ = \n. \f. \x. f (n f x); 10 | 11 | def one = succ zero; 12 | 13 | def plus = \m. \n. \f. \x. m f (n f x); 14 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Monad.State 4 | 5 | import Lambda.Untyped 6 | 7 | main :: IO () 8 | main = do 9 | mapM_ putStrLn 10 | [ "~~~" 11 | , "λ Lambda Repl λ" 12 | , "~~~" 13 | ] 14 | evalStateT (forever repl) mempty 15 | -------------------------------------------------------------------------------- /std.lm: -------------------------------------------------------------------------------- 1 | def id = \x. x; 2 | 3 | def const = \x. \y. x; 4 | 5 | def flip = \f. \x. \y. f y x; 6 | 7 | def zero = \f. \y. y; 8 | 9 | def succ = \n. \f. \x. f (n f x); 10 | 11 | def one = succ zero; 12 | 13 | def otherOne = \f. \x. f x; 14 | 15 | def plus = \m. \n. \f. \x. m f (n f x); 16 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | .stack-work/ 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | **/*.dump-hi 8 | *.chs.h 9 | *.dyn_o 10 | *.dyn_hi 11 | .virtualenv 12 | .hpc 13 | .hsenv 14 | .cabal-sandbox/ 15 | cabal.sandbox.config 16 | *.prof 17 | *.aux 18 | *.hp 19 | dist 20 | cabal-dev 21 | *.o 22 | *.hi 23 | *.chi 24 | *.chs.h 25 | *.dyn_o 26 | *.dyn_hi 27 | .virtualenv 28 | .hpc 29 | .hsenv 30 | .cabal-sandbox/ 31 | cabal.sandbox.config 32 | *.prof 33 | *.aux 34 | *.hp 35 | -------------------------------------------------------------------------------- /src/Lambda/Core.hs: -------------------------------------------------------------------------------- 1 | module Lambda.Core where 2 | 3 | -- | The data type LambdaF is parameterized over the type of variables and the 4 | -- type of 5 | data LambdaF v x 6 | = Var v 7 | | App x x 8 | | Abs v x 9 | deriving (Eq, Show) 10 | 11 | newtype Variable = Variable String 12 | deriving (Eq, Show) 13 | 14 | data Untyped 15 | 16 | newtype Fix f = Wrap { unwrap :: f (Fix f) } 17 | 18 | type Lambda = Fix (LambdaF Variable) 19 | 20 | var :: String -> Lambda 21 | var = Wrap . Var . Variable 22 | 23 | (#) :: Lambda -> Lambda -> Lambda 24 | l # r = Wrap (App l r) 25 | 26 | infixl 8 # 27 | 28 | (~>) :: String -> Lambda -> Lambda 29 | v ~> x = Wrap (Abs (Variable v) x) 30 | 31 | infixr 9 ~> 32 | -------------------------------------------------------------------------------- /test/Decl/ParserSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Decl.ParserSpec where 4 | 5 | import Control.Monad 6 | import System.Directory 7 | import Data.Monoid 8 | import Test.QuickCheck 9 | import Test.Hspec 10 | import Text.Megaparsec hiding (fromFile) 11 | import Data.Either 12 | import Text.Megaparsec.Text 13 | 14 | import Lambda.Untyped.Parser (Lambda(..), lambda) 15 | 16 | import Decl.Parser 17 | 18 | declaration' :: Parser (Decl Lambda) 19 | declaration' = declaration lambda 20 | 21 | 22 | spec :: Spec 23 | spec = do 24 | describe "declaration" $ do 25 | let p = parse declaration' "" 26 | it "parses a declaration" $ do 27 | p "def foo = x;" 28 | `shouldBe` 29 | Right (Def "foo" (Var "x")) 30 | describe "file examples" $ do 31 | let path = "test/Examples/parse/decl/decl-" 32 | path' i = path <> i <> ".lm" 33 | let p f = fromFile f lambda 34 | forM_ ["00", "01", "02"] $ \i -> do 35 | it "parses decl-00.lm" $ do 36 | p (path' i) >>= (`shouldSatisfy` isRight) 37 | -------------------------------------------------------------------------------- /test/Lambda/UntypedSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Lambda.UntypedSpec where 4 | 5 | import Control.Monad 6 | import Test.QuickCheck 7 | import Test.Hspec 8 | 9 | import Lambda.Untyped 10 | import Lambda.Untyped.Eval 11 | 12 | spec :: Spec 13 | spec = do 14 | describe "with standard library" $ do 15 | Right stdlib <- runIO . loadFromFile $ "std.lm" 16 | let eval' = fmap fullyReduce . flip evaluate stdlib 17 | e = eval' >=> eval' >=> eval' >=> eval' 18 | describe "arithmetic" $ do 19 | let zero = FreeVar "zero" 20 | plus = FreeVar "plus" 21 | one = FreeVar "one" 22 | succ = FreeVar "succ" 23 | otherOne = FreeVar "otherOne" 24 | it "succ zero == one" $ do 25 | e (App succ zero) `shouldBe` e one 26 | it "plus one zero == succ zero" $ do 27 | e (App (App plus one) zero) `shouldBe` e (App succ zero) 28 | it "plus one one == succ one" $ do 29 | pendingWith "the evaluation isn't strongly normalizing" 30 | e (App (App plus one) one) `shouldBe` e (App succ one) 31 | it "one == otherOne" $ do 32 | e one `shouldBe` e otherOne 33 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by stack init 2 | # For more information, see: http://docs.haskellstack.org/en/stable/yaml_configuration.html 3 | 4 | # Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) 5 | resolver: lts-7.1 6 | 7 | # Local packages, usually specified by relative directory name 8 | packages: 9 | - '.' 10 | # Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) 11 | extra-deps: [] 12 | 13 | # Override default flag values for local packages and extra-deps 14 | flags: {} 15 | 16 | # Extra package databases containing global packages 17 | extra-package-dbs: [] 18 | 19 | # Control whether we use the GHC we find on the path 20 | # system-ghc: true 21 | 22 | # Require a specific version of stack, using version ranges 23 | # require-stack-version: -any # Default 24 | # require-stack-version: >= 1.0.0 25 | 26 | # Override the architecture used by stack, especially useful on Windows 27 | # arch: i386 28 | # arch: x86_64 29 | 30 | # Extra directories used by stack for building 31 | # extra-include-dirs: [/path/to/dir] 32 | # extra-lib-dirs: [/path/to/dir] 33 | 34 | # Allow a newer minor version of GHC than the snapshot specifies 35 | # compiler-check: newer-minor 36 | -------------------------------------------------------------------------------- /src/Decl/Parser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Decl.Parser where 3 | 4 | import Data.Text (Text) 5 | import qualified Data.Text as T 6 | import qualified Data.Text.IO as T 7 | import Control.Monad 8 | import Text.Megaparsec 9 | import Text.Megaparsec.Text 10 | import qualified Text.Megaparsec.Lexer as L 11 | 12 | data Decl expr 13 | = Def Text expr 14 | deriving (Eq, Show) 15 | 16 | type ParseError' = ParseError Char Dec 17 | 18 | declaration :: Parser expr -> Parser (Decl expr) 19 | declaration pexpr = do 20 | defKw 21 | name <- T.pack <$> lexeme (some alphaNumChar) 22 | expr <- between (lexeme (char '=')) (lexeme (char ';')) pexpr 23 | return (Def name expr) 24 | 25 | declarations :: Parser expr -> Parser [Decl expr] 26 | declarations = many . lexeme . declaration 27 | 28 | fromFile :: FilePath -> Parser expr -> IO (Either (ParseError Char Dec) [Decl expr]) 29 | fromFile p e = do 30 | s <- T.readFile p 31 | return (parse (declarations e) p s) 32 | 33 | 34 | spaceConsumer :: Parser () 35 | spaceConsumer = 36 | L.space 37 | (void spaceChar) 38 | (L.skipLineComment "--") 39 | (L.skipBlockComment "(*" "*)") 40 | 41 | lexeme :: Parser a -> Parser a 42 | lexeme = L.lexeme spaceConsumer 43 | 44 | consume :: Parser a -> Parser () 45 | consume = void . lexeme 46 | 47 | defKw :: Parser () 48 | defKw = consume (string "def") 49 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (c) 2015 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /src/Lambda/Untyped/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE StandaloneDeriving #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | module Lambda.Untyped.Types where 5 | 6 | import Prelude hiding (abs) 7 | import Test.QuickCheck 8 | import Control.Monad.Free 9 | import Data.Monoid 10 | import Data.Text (Text) 11 | import qualified Data.Text as T 12 | 13 | -- | This representation of the lambda calculus has the base cases of the 14 | -- recursion taken out. This lays bare the structure of the branching. 15 | data LambdaF r 16 | = App r r 17 | | Abs Text r 18 | deriving (Eq, Show) 19 | 20 | var :: a -> Free f (Literal a) 21 | var = Pure . Var 22 | 23 | str :: Text -> Free f (Literal a) 24 | str = Pure . Str 25 | 26 | int :: Integer -> Free f (Literal a) 27 | int = Pure . Int 28 | 29 | app :: Free LambdaF a -> Free LambdaF a -> Free LambdaF a 30 | app l r = Free (App l r) 31 | 32 | abs :: Text -> Free LambdaF a -> Free LambdaF a 33 | abs x r = Free (Abs x r) 34 | 35 | -- | The type of literals is how we'll terminate the recursion. We leave the 36 | -- type of variables polymorphic. 37 | data Literal a 38 | = Var a 39 | | Str Text 40 | | Int Integer 41 | deriving (Eq, Show) 42 | 43 | instance Arbitrary Text where 44 | arbitrary = T.pack . take 6 <$> listOf1 (choose ('a', 'z')) 45 | 46 | instance Arbitrary a => Arbitrary (Literal a) where 47 | arbitrary = oneof [Var <$> arbitrary, Str <$> arbitrary, Int <$> arbitrary ] 48 | 49 | 50 | -- | The type of our parsing, then, is taking the free monad of the lambda 51 | -- calculus functor with the leaves of the tree denoted by the literal type. 52 | type Parsed a = Free LambdaF (Literal a) 53 | 54 | type Eval a = Free LambdaF (Either Int (Literal a)) 55 | 56 | instance Arbitrary a => Arbitrary (Free LambdaF a) where 57 | arbitrary = sized go 58 | where 59 | go i 60 | | i <= 0 = Pure <$> arbitrary 61 | | otherwise = 62 | oneof [ abs <$> randChars <*> go (i - 1) 63 | , app <$> go (i - 1) <*> go (i - 1) 64 | , Pure <$> arbitrary 65 | ] 66 | randChars = T.pack . take 6 <$> listOf1 (choose ('a', 'z')) 67 | 68 | shrink (Free (App a b)) = [a, b] <> (uncurry app <$> shrink (a, b)) 69 | shrink (Free (Abs _ l)) = l : shrink l 70 | shrink v@(Pure _) = [v] 71 | 72 | instance Functor LambdaF where 73 | fmap k (App f x) = App (k f) (k x) 74 | fmap k (Abs n e) = Abs n (k e) 75 | -------------------------------------------------------------------------------- /lambda.cabal: -------------------------------------------------------------------------------- 1 | name: lambda 2 | version: 0.1.0.0 3 | synopsis: Initial project template from stack 4 | description: Please see README.md 5 | homepage: http://github.com/githubuser/lambda#readme 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Author name here 9 | maintainer: example@example.com 10 | copyright: 2010 Author Here 11 | category: Web 12 | build-type: Simple 13 | -- extra-source-files: 14 | cabal-version: >=1.10 15 | 16 | library 17 | hs-source-dirs: 18 | src 19 | exposed-modules: 20 | Decl.Parser 21 | Lambda.Core 22 | Lambda.SimplyTyped.Fancy 23 | Lambda.Untyped 24 | Lambda.Untyped.Eval 25 | Lambda.Untyped.Eval.Free 26 | Lambda.Untyped.Types 27 | Lambda.Untyped.Parser 28 | Lambda.Untyped.Parser.Free 29 | build-depends: 30 | base >= 4.9 && < 5.1 31 | , containers 32 | , megaparsec 33 | , mtl 34 | , QuickCheck 35 | , text 36 | , transformers 37 | , free 38 | default-language: 39 | Haskell2010 40 | ghc-options: 41 | -Wall 42 | 43 | executable lambda-exe 44 | hs-source-dirs: app 45 | main-is: Main.hs 46 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 47 | build-depends: base 48 | , lambda 49 | , mtl 50 | default-language: Haskell2010 51 | 52 | test-suite lambda-test 53 | type: exitcode-stdio-1.0 54 | hs-source-dirs: test 55 | main-is: Spec.hs 56 | other-modules: 57 | Lambda.UntypedSpec 58 | , Lambda.Untyped.ParserSpec 59 | , Lambda.Untyped.EvalSpec 60 | , Lambda.Untyped.FreeEvalSpec 61 | , Lambda.Untyped.FreeParserSpec 62 | , Decl.ParserSpec 63 | build-depends: 64 | base 65 | , lambda 66 | , megaparsec 67 | , QuickCheck 68 | , hspec 69 | , directory 70 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 71 | default-language: Haskell2010 72 | 73 | test-suite doctest 74 | type: exitcode-stdio-1.0 75 | hs-source-dirs: test 76 | main-is: DocTest.hs 77 | build-depends: base 78 | , doctest 79 | , Glob 80 | , QuickCheck 81 | , hspec 82 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 83 | default-language: Haskell2010 84 | 85 | source-repository head 86 | type: git 87 | location: https://github.com/githubuser/lambda 88 | -------------------------------------------------------------------------------- /test/Lambda/Untyped/EvalSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Lambda.Untyped.EvalSpec where 4 | 5 | import Test.Hspec 6 | import Test.QuickCheck 7 | 8 | import qualified Lambda.Untyped.Parser as P 9 | import Lambda.Untyped.Eval as E 10 | 11 | spec :: Spec 12 | spec = do 13 | describe "convert" $ do 14 | it "can convert any lambda expression" $ do 15 | property $ \x -> 16 | convert x === convert x 17 | it "converts id correctly" $ do 18 | let e = P.Abs "x" (P.Var "x") 19 | convert e `shouldBe` Abs "x" (AbsVar 0) 20 | it "converts const correctly" $ do 21 | let e = P.Abs "x" (P.Abs "y" (P.Var "x")) 22 | convert e 23 | `shouldBe` 24 | Abs "x" (Abs "y" (AbsVar 1)) 25 | it "converts flip const correctly" $ do 26 | let e = P.Abs "x" (P.Abs "y" (P.Var "y")) 27 | convert e 28 | `shouldBe` 29 | Abs "x" (Abs "y" (AbsVar 0)) 30 | it "converts an app correctly" $ do 31 | let e = P.Abs "x" (P.App (P.Var "x") (P.Var "x")) 32 | convert e 33 | `shouldBe` 34 | Abs "x" (App (AbsVar 0) (AbsVar 0)) 35 | 36 | describe "revert" $ do 37 | it "converts and reverts as isomorphism" $ do 38 | property $ \x -> 39 | fmap P.pretty (revert (convert x)) === pure (P.pretty x) 40 | describe "nested abstractions" $ do 41 | let input = P.Abs "r" (P.Abs "m" (P.Var "m")) 42 | converted = Abs "r" (Abs "m" (AbsVar 0)) 43 | it "convert input = converted" $ do 44 | convert input `shouldBe` converted 45 | it "revert converted = pure input" $ do 46 | revert converted `shouldBe` pure input 47 | it "prints the right thing" $ do 48 | fmap P.pretty (revert (convert input)) 49 | `shouldBe` 50 | pure ("\\r . \\m . m") 51 | 52 | describe "beta reduction" $ do 53 | it "doesn't alter abstractions" $ do 54 | betaReduction (Abs "x" (FreeVar "y")) 55 | `shouldBe` 56 | Abs "x" (FreeVar "y") 57 | it "doesn't alter free variables" $ do 58 | betaReduction (FreeVar "x") 59 | `shouldBe` 60 | FreeVar "x" 61 | it "doesn't alter bound variables with empty context" $ do 62 | betaReduction (AbsVar 1) 63 | `shouldBe` 64 | AbsVar 1 65 | it "reduces applications to abstractions" $ do 66 | betaReduction (App (Abs "x" (AbsVar 0)) (FreeVar "y")) 67 | `shouldBe` 68 | FreeVar "y" 69 | it "handles nested applications" $ do 70 | betaReduction (App (Abs "x" (Abs "y" (AbsVar 1))) (FreeVar "z")) 71 | `shouldBe` 72 | Abs "y" (FreeVar "z") 73 | it "inserts free vars" $ do 74 | betaReduction (App (Abs "x" (AbsVar 0)) (FreeVar "x")) 75 | `shouldBe` 76 | FreeVar "x" 77 | -------------------------------------------------------------------------------- /src/Lambda/SimplyTyped/Fancy.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE StandaloneDeriving #-} 4 | {-# LANGUAGE KindSignatures #-} 5 | {-# LANGUAGE TypeOperators #-} 6 | {-# LANGUAGE DataKinds #-} 7 | 8 | module Lambda.SimplyTyped.Fancy where 9 | 10 | import Data.String 11 | 12 | -- | The simply typed lambda calculus begins with the untyped lambda calculus 13 | -- and adds types. Types have the following construction: 14 | -- 15 | -- 1. A type variable, or 16 | -- 2. An arrow type 17 | 18 | -- We represent these below. Rather than keeping a string or other identifier, 19 | -- we'll use the natural numbers to index types. This design decision is 20 | -- unfortunately caused by a limitation of Haskell's type system around what 21 | -- sorts of values can be lifted into the type level. 22 | data Type 23 | = TyVar Nat 24 | | TyArr Type Type 25 | deriving (Show, Eq) 26 | 27 | data Nat = Z | S Nat 28 | deriving (Show, Eq, Read) 29 | 30 | instance IsString Type where 31 | fromString = TyVar . read 32 | 33 | type a :-> b = 'TyArr a b 34 | 35 | type LUnit = TyVar Z 36 | type LBool = TyVar (S Z) 37 | 38 | -- | Variables now contain a phantom type which indicates whether they are Type 39 | -- variables or Term variables. 40 | newtype Variable t = Variable String 41 | deriving (Show, Eq) 42 | 43 | instance IsString (Variable t) where 44 | fromString = Variable 45 | 46 | -- | Since we're dealing with types now, we have to be more clever with our 47 | -- representation of terms. The Haskell data type 'Term' takes a lifted data of 48 | -- kind Type and yields a value of kind *. 49 | -- 50 | -- The constructor Var takes a Variable indexed on the type variable, and 51 | -- yields a Term indexed by the type given in the variable. 52 | -- 53 | -- Application takes a term that has a type of `a :-> b` as the first thing, 54 | -- a `Term a` as the second thing, and returns a `Term b` as the final value. 55 | -- 56 | -- Abstraction takes a Variable with type a, a Term of type b, and returns 57 | -- a Term of type `a -> b`. 58 | -- 59 | -- While somewhat complex, this allows us to use Haskell's compiler to ensure 60 | -- that we don't construct invalid terms. 61 | data Term :: Type -> * where 62 | Var :: Variable (Term a) -> Term a 63 | App :: Term (a :-> b) -> Term a -> Term b 64 | Abs :: Variable (Term a) -> Term b -> Term (a :-> b) 65 | 66 | deriving instance Show (Term n) 67 | 68 | instance IsString (Term a) where 69 | fromString = Var . Variable 70 | 71 | -- | The IsString instance makes referring to terms easy. We do need to annotate 72 | -- them with a type, or they'll be 'Term a' where 'a' is any type. We don't have 73 | -- type polymorphism yet, so we can't do that! 74 | x :: Term LUnit 75 | x = "x" 76 | 77 | y :: Term LBool 78 | y = Var (Variable "y") 79 | 80 | abs' :: Term (LUnit :-> LBool) 81 | abs' = Abs (Variable "x") (Var (Variable "y")) 82 | 83 | -- | 'app'' won't type check if we apply terms with incompatible values. 'App 84 | -- x abs'' causes a compile time type error. In this way, we've punted type 85 | -- checking to GHC itself! 86 | app' :: Term LBool 87 | app' = App abs' x 88 | 89 | -- As fun as all of this is, punting type checking to Haskell isn't the best way 90 | -- to actually learn about how the simply typed lambda calculus works. 91 | -------------------------------------------------------------------------------- /src/Lambda/Untyped.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Lambda.Untyped where 5 | 6 | import Data.Foldable 7 | import Lambda.Untyped.Parser as Parser 8 | import qualified Decl.Parser as D 9 | import Data.Monoid 10 | import System.IO 11 | import Text.Megaparsec 12 | -- import Data.Text (Text) 13 | -- import Data.Map (Map) 14 | import qualified Data.Map as Map 15 | import qualified Data.Text.IO as T 16 | import qualified Data.Text as T 17 | import Text.Megaparsec.Text 18 | import Control.Monad.State 19 | import Lambda.Untyped.Eval as Eval 20 | 21 | type Declaration = D.Decl Parser.Lambda 22 | type ParseError' = ParseError Char Dec 23 | 24 | declaration :: Parser Declaration 25 | declaration = D.declaration lambda 26 | 27 | declarations :: Parser [Declaration] 28 | declarations = many declaration 29 | 30 | parseFile :: FilePath -> IO (Either (ParseError Char Dec) [Declaration]) 31 | parseFile fp = parse declarations fp <$> T.readFile fp 32 | 33 | mkEvalEnv :: Foldable f => f Declaration -> EvalEnv 34 | mkEvalEnv = foldMap (\(D.Def x e) -> Map.singleton x (convert e)) 35 | 36 | evaluate :: Eval.Lambda -> EvalEnv -> Either Eval.EvalError Eval.Lambda 37 | evaluate = eval 38 | 39 | loadFromFile :: FilePath -> IO (Either (ParseError Char Dec) EvalEnv) 40 | loadFromFile file = do 41 | fmap (fmap mkEvalEnv . parse declarations file) (T.readFile file) 42 | 43 | repl :: StateT EvalEnv IO () 44 | repl = do 45 | response <- liftIO $ do 46 | T.putStr "λ> " 47 | hFlush stdout 48 | T.getLine 49 | handleCommand response $ do 50 | case parse (declaration <|> D.Def "it" <$> lambda) "repl" response of 51 | Right (D.Def x expr) -> do 52 | liftIO $ T.putStrLn (x <> " = " <> pretty expr) 53 | let converted = convert expr 54 | modify (Map.insert x converted) 55 | when ("it" == x) $ do 56 | mlambda <- evaluate converted <$> get 57 | 58 | liftIO . T.putStrLn $ case fullyReduce <$> mlambda of 59 | Right lambda -> 60 | case revert lambda of 61 | Right expr -> pretty expr 62 | Left err -> T.pack (show err) 63 | Left err -> T.pack $ show err 64 | Left err -> do 65 | liftIO $ T.putStrLn (T.pack (show err)) 66 | 67 | handleCommand :: (MonadIO m, MonadState EvalEnv m) 68 | => T.Text -> m () -> m () 69 | handleCommand input action = do 70 | if (T.head input == ':') then do 71 | let inputs = T.words input 72 | case head inputs of 73 | ":state" -> do 74 | liftIO . T.putStrLn . T.pack . show =<< get 75 | ":load" -> do 76 | let file = T.unpack . T.concat . drop 1 $ inputs 77 | defs <- liftIO $ loadFromFile file 78 | case defs of 79 | Left err -> 80 | liftIO . T.putStrLn . T.pack . show $ err 81 | Right env -> do 82 | modify (env <>) 83 | liftIO $ T.putStrLn ("Loaded " <> T.pack file) 84 | 85 | _ -> return () 86 | else action 87 | -------------------------------------------------------------------------------- /test/Lambda/Untyped/FreeEvalSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Lambda.Untyped.FreeEvalSpec where 4 | 5 | import Prelude hiding (abs) 6 | import Data.Maybe 7 | import Test.Hspec 8 | import Test.QuickCheck 9 | 10 | import Lambda.Untyped.Types 11 | import qualified Lambda.Untyped.Parser.Free as P 12 | import Lambda.Untyped.Eval.Free as E 13 | 14 | spec :: Spec 15 | spec = do 16 | describe "convert" $ do 17 | it "can convert any lambda expression" $ do 18 | property $ \x -> 19 | convert x === convert x 20 | it "converts id correctly" $ do 21 | let e = abs "x" (var "x") 22 | convert e `shouldBe` abs "x" (absVar 0) 23 | it "converts const correctly" $ do 24 | let e = abs "x" (abs "y" (var "x")) 25 | convert e 26 | `shouldBe` 27 | abs "x" (abs "y" (absVar 1)) 28 | it "converts flip const correctly" $ do 29 | let e = abs "x" (abs "y" (var "y")) 30 | convert e 31 | `shouldBe` 32 | abs "x" (abs "y" (absVar 0)) 33 | it "converts an app correctly" $ do 34 | let e = abs "x" (app (var "x") (var "x")) 35 | convert e 36 | `shouldBe` 37 | abs "x" (app (absVar 0) (absVar 0)) 38 | 39 | describe "revert" $ do 40 | it "converts and reverts as isomorphism" $ do 41 | property $ \x -> 42 | fmap P.pretty (revert (convert x)) === pure (P.pretty x) 43 | describe "nested abstractions" $ do 44 | let input = abs "r" (abs "m" (var "m")) 45 | converted = abs "r" (abs "m" (absVar 0)) 46 | it "convert input = converted" $ do 47 | convert input `shouldBe` converted 48 | it "revert converted = pure input" $ do 49 | revert converted `shouldBe` pure input 50 | it "prints the right thing" $ do 51 | fmap P.pretty (revert (convert input)) 52 | `shouldBe` 53 | pure ("\\r . \\m . m") 54 | 55 | describe "beta reduction" $ do 56 | it "doesn't alter abstractions" $ do 57 | betaReduction (abs "x" (freeVar "y")) 58 | `shouldBe` 59 | abs "x" (freeVar "y") 60 | it "doesn't alter free variables" $ do 61 | betaReduction (freeVar "x") 62 | `shouldBe` 63 | freeVar "x" 64 | it "doesn't alter bound variables with empty context" $ do 65 | betaReduction (absVar 1) 66 | `shouldBe` 67 | absVar 1 68 | it "reduces applications to abstractions" $ do 69 | betaReduction (app (abs "x" (absVar 0)) (freeVar "y")) 70 | `shouldBe` 71 | freeVar "y" 72 | it "handles nested applications" $ do 73 | betaReduction (app (abs "x" (abs "y" (absVar 1))) (freeVar "z")) 74 | `shouldBe` 75 | abs "y" (freeVar "z") 76 | it "inserts free vars" $ do 77 | betaReduction (app (abs "x" (absVar 0)) (freeVar "x")) 78 | `shouldBe` 79 | freeVar "x" 80 | 81 | describe "alphaEquiv" $ do 82 | it "is equality" $ do 83 | property $ \x y -> 84 | isJust (x `alphaEquiv` y) === (x == y) 85 | -------------------------------------------------------------------------------- /test/Lambda/Untyped/ParserSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Lambda.Untyped.ParserSpec where 4 | 5 | import Data.Either 6 | import Test.QuickCheck 7 | import Test.Hspec 8 | import Text.Megaparsec 9 | 10 | import Data.Maybe 11 | import Lambda.Untyped.Parser 12 | 13 | spec :: Spec 14 | spec = do 15 | describe "lit" $ do 16 | let p = parse literal "" 17 | it "can parse a string" $ do 18 | p "\"foobar\"" `shouldBe` pure (Str "foobar") 19 | it "can parse a number" $ do 20 | p "1234" `shouldBe` pure (Int 1234) 21 | it "can parse a negative number" $ do 22 | p "-123" `shouldBe` pure (Int (-123)) 23 | 24 | describe "var" $ do 25 | let p = parseMaybe variable 26 | it "accepts alphanumeric characters" $ do 27 | p "hello" `shouldBe` Just "hello" 28 | it "fails on symbols" $ do 29 | p "-asdf" `shouldBe` Nothing 30 | 31 | describe "abstraction" $ do 32 | let p = parseMaybe abstraction 33 | it "can parse an abstraction" $ do 34 | p "\\x. x" `shouldSatisfy` isJust 35 | 36 | describe "lambda" $ do 37 | let p = parse lambda "test" 38 | it "can parse a literal string" $ do 39 | p "\"foobar\"" `shouldBe` pure (Lit (Str "foobar")) 40 | it "can parse an integer literal" $ do 41 | p "1234" `shouldBe` pure (Lit (Int 1234)) 42 | it "can parse an application" $ do 43 | p "x y" `shouldBe` pure (App (Var "x") (Var "y")) 44 | it "can parse a bunch of application" $ do 45 | p "x y (x y)" `shouldSatisfy` isRight 46 | it "can parse a whole mess of stuff" $ do 47 | p "\\x . \\y . x (x y) (y x)" `shouldSatisfy` isRight 48 | it "can parse expressions beginning with parens" $ do 49 | p "(\\x . y)" `shouldSatisfy` isRight 50 | p "(\\x . y) a" `shouldSatisfy` isRight 51 | it "handles parens" $ do 52 | p "(x y) x" `shouldBe` pure (App (App (Var "x") (Var "y")) (Var "x")) 53 | describe "with literals" $ do 54 | it "handles application of literal" $ do 55 | p "f 100" `shouldBe` pure (App (Var "f") (Lit (Int 100))) 56 | it "handles abstraction on literal" $ do 57 | p "(\\x . x) 100" `shouldBe` 58 | pure (App (Abs "x" (Var "x")) (Lit (Int 100))) 59 | it "does weird things" $ do 60 | p "\"hello\" 100" `shouldBe` 61 | pure (App (Lit (Str "hello")) (Lit (Int 100))) 62 | it "preserves Galois connection" $ do 63 | let iso = parse lambda "test" . pretty 64 | property $ \x -> do 65 | iso x === pure x 66 | 67 | describe "pretty" $ do 68 | it "prints it nice" $ do 69 | let t = App (Abs "s" (Var "w")) (Var "j") 70 | pretty t `shouldBe` "(\\s . w) j" 71 | it "handles application streams" $ do 72 | let t = App (App (App (Var "x") (Var "y")) (Var "z")) (Var "w") 73 | pretty t `shouldBe` "x y z w" 74 | it "parenthesizes appropriately" $ do 75 | let t = App (Var "x") (App (Var "y") (Var "z")) 76 | pretty t `shouldBe` "x (y z)" 77 | 78 | describe "explicit" $ do 79 | let p = parse lambdaExplicit "test" 80 | it "parses variables" $ do 81 | p "a" `shouldBe` Right (Var "a") 82 | it "parses applications" $ do 83 | p "(a b)" `shouldBe` Right (App (Var "a") (Var "b")) 84 | it "parses abstractions" $ do 85 | p "(\\a . a)" `shouldBe` Right (Abs "a" (Var "a")) 86 | -------------------------------------------------------------------------------- /test/Lambda/Untyped/FreeParserSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Lambda.Untyped.FreeParserSpec where 4 | 5 | import Prelude hiding (abs) 6 | 7 | import Data.Either 8 | import Test.QuickCheck 9 | import Test.Hspec 10 | import Text.Megaparsec 11 | 12 | import Data.Maybe 13 | import Lambda.Untyped.Types 14 | import Lambda.Untyped.Parser.Free 15 | 16 | spec :: Spec 17 | spec = do 18 | describe "lit" $ do 19 | let p = parse literal "" 20 | it "can parse a string" $ do 21 | p "\"foobar\"" `shouldBe` pure (Str "foobar") 22 | it "can parse a number" $ do 23 | p "1234" `shouldBe` pure (Int 1234) 24 | it "can parse a negative number" $ do 25 | p "-123" `shouldBe` pure (Int (-123)) 26 | 27 | describe "var" $ do 28 | let p = parseMaybe variable 29 | it "accepts alphanumeric characters" $ do 30 | p "hello" `shouldBe` Just "hello" 31 | it "fails on symbols" $ do 32 | p "-asdf" `shouldBe` Nothing 33 | 34 | describe "abstraction" $ do 35 | let p = parseMaybe abstraction 36 | it "can parse an abstraction" $ do 37 | p "\\x. x" `shouldSatisfy` isJust 38 | 39 | describe "lambda" $ do 40 | let p = parse lambda "test" 41 | it "can parse a literal string" $ do 42 | p "\"foobar\"" `shouldBe` pure (str "foobar") 43 | it "can parse an integer literal" $ do 44 | p "1234" `shouldBe` pure (int 1234) 45 | it "can parse an application" $ do 46 | p "x y" `shouldBe` pure (app (var "x") (var "y")) 47 | it "can parse a bunch of application" $ do 48 | p "x y (x y)" `shouldSatisfy` isRight 49 | it "can parse a whole mess of stuff" $ do 50 | p "\\x . \\y . x (x y) (y x)" `shouldSatisfy` isRight 51 | it "can parse expressions beginning with parens" $ do 52 | p "(\\x . y)" `shouldSatisfy` isRight 53 | p "(\\x . y) a" `shouldSatisfy` isRight 54 | it "handles parens" $ do 55 | p "(x y) x" `shouldBe` pure (app (app (var "x") (var "y")) (var "x")) 56 | describe "with literals" $ do 57 | it "handles application of literal" $ do 58 | p "f 100" `shouldBe` pure (app (var "f") (int 100)) 59 | it "handles abstraction on literal" $ do 60 | p "(\\x . x) 100" `shouldBe` 61 | pure (app (abs "x" (var "x")) (int 100)) 62 | it "does weird things" $ do 63 | p "\"hello\" 100" `shouldBe` 64 | pure (app (str "hello") (int 100)) 65 | it "preserves Galois connection" $ do 66 | let iso = parse lambda "test" . pretty 67 | property $ \x -> do 68 | iso x === pure x 69 | 70 | describe "pretty" $ do 71 | it "prints it nice" $ do 72 | let t = app (abs "s" (var "w")) (var "j") 73 | pretty t `shouldBe` "(\\s . w) j" 74 | it "handles application streams" $ do 75 | let t = app (app (app (var "x") (var "y")) (var "z")) (var "w") 76 | pretty t `shouldBe` "x y z w" 77 | it "parenthesizes appropriately" $ do 78 | let t = app (var "x") (app (var "y") (var "z")) 79 | pretty t `shouldBe` "x (y z)" 80 | 81 | describe "explicit" $ do 82 | let p = parse lambdaExplicit "test" 83 | it "parses variables" $ do 84 | p "a" `shouldBe` Right (var "a") 85 | it "parses applications" $ do 86 | p "(a b)" `shouldBe` Right (app (var "a") (var "b")) 87 | it "parses abstractions" $ do 88 | p "(\\a . a)" `shouldBe` Right (abs "a" (var "a")) 89 | -------------------------------------------------------------------------------- /src/Lambda/Untyped/Parser/Free.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Lambda.Untyped.Parser.Free where 4 | 5 | import Control.Monad.Free 6 | import Data.Monoid 7 | import Control.Monad 8 | import Text.Megaparsec 9 | import Text.Megaparsec.Text 10 | import qualified Text.Megaparsec.Lexer as L 11 | import Data.Text (Text) 12 | import qualified Data.Text as T 13 | 14 | import Lambda.Untyped.Types as Types 15 | 16 | type Lambda = Parsed Text 17 | 18 | -- | Pretty-prints a lambda expression. 19 | -- 20 | -- >>> pretty (var "x") 21 | -- "x" 22 | -- >>> pretty (app (app (var "x") (var "y")) (var "z")) 23 | -- "x y z" 24 | -- >>> pretty (app (var "x") (app (var "y") (var "z"))) 25 | -- "x (y z)" 26 | -- >>> pretty (Types.abs "x" (var "x")) 27 | -- "\\x . x" 28 | -- >>> pretty (str "hello") 29 | -- "\"hello\"" 30 | -- >>> pretty (int 1000) 31 | -- "1000" 32 | -- >>> pretty (app (str "foo") (int 100)) 33 | -- "\"foo\" 100" 34 | pretty :: Lambda -> Text 35 | pretty (Pure v) = 36 | case v of 37 | Var a -> a 38 | Int a -> T.pack $ show a 39 | Str a -> "\"" <> a <> "\"" 40 | pretty (Free (Abs a l)) = "\\" <> a <> " . " <> pretty l 41 | pretty (Free (App l@(Pure (Var{})) r@(Pure (Var{})))) = pretty l <> " " <> pretty r 42 | pretty (Free (App l r)) = 43 | case l of 44 | Pure _ -> pretty l <> 45 | case r of 46 | Pure _ -> " " <> pretty r 47 | _ -> " (" <> pretty r <> ")" 48 | Free (Abs {}) -> "(" <> pretty l <> ") " <> 49 | case r of 50 | Pure (Var {}) -> pretty r 51 | _ -> "(" <> pretty r <> ")" 52 | Free (App {}) -> pretty l <> " " <> 53 | case r of 54 | Pure (Var {}) -> pretty r 55 | _ -> "(" <> pretty r <> ")" 56 | 57 | spaceConsumer :: Parser () 58 | spaceConsumer = 59 | L.space 60 | (void spaceChar) 61 | (L.skipLineComment "--") 62 | (L.skipBlockComment "(*" "*)") 63 | 64 | lexeme :: Parser a -> Parser a 65 | lexeme = L.lexeme spaceConsumer 66 | 67 | -- Parse a lambda expression. 68 | -- 69 | -- >>> let p = (\(Just x) -> x) . parseMaybe lambda 70 | -- >>> p "x" 71 | -- Var "x" 72 | -- >>> p "(x y)" 73 | -- App (Var "x") (Var "y") 74 | -- >>> p "\\ x . (x x)" 75 | -- Abs "x" (App (Var "x") (Var "x")) 76 | -- >>> p "x y z" 77 | -- App (App (Var "x") (Var "y")) (Var "z") 78 | lambda :: Parser Lambda 79 | lambda = choice 80 | [ manyApplication 81 | , parens lambda 82 | , abstraction 83 | , Pure <$> literal 84 | ] 85 | where 86 | manyApplication = 87 | foldl1 (\a c -> Free (App a c)) <$> some (choice [ 88 | abstraction 89 | , variable' 90 | , parens lambda 91 | , Pure <$> literal 92 | ]) 93 | 94 | -- | A parser for the fully explicit lambda calculus. 95 | lambdaExplicit :: Parser Lambda 96 | lambdaExplicit = choice 97 | [ variable' 98 | , Pure <$> literal 99 | , fmap Free . parens $ choice 100 | [ do 101 | slash 102 | v <- variable 103 | dot 104 | e <- lambdaExplicit 105 | return (Abs v e) 106 | , App <$> lambdaExplicit <*> lambdaExplicit 107 | ] 108 | ] 109 | 110 | parens :: Parser a -> Parser a 111 | parens = between oparen cparen 112 | 113 | literal :: Parser (Literal Text) 114 | literal = lexeme $ choice 115 | [ Int . read <$> choice 116 | [ (:) <$> char '-' <*> some digitChar 117 | , some digitChar 118 | ] 119 | , Str . T.pack <$> do 120 | _ <- char '"' 121 | L.charLiteral `manyTill` char '"' 122 | ] 123 | 124 | variable :: Parser Text 125 | variable = T.pack <$> lexeme ((:) <$> oneOf ['a'..'z'] <*> many alphaNumChar) 126 | 127 | variable' :: Parser Lambda 128 | variable' = fmap (Pure . Var) variable 129 | 130 | abstraction :: Parser Lambda 131 | abstraction = do 132 | slash 133 | v <- variable 134 | dot 135 | l <- lambda 136 | return (Free (Abs v l)) 137 | 138 | consume :: Parser a -> Parser () 139 | consume = void . lexeme 140 | 141 | slash :: Parser () 142 | slash = consume (char '\\') 143 | 144 | dot :: Parser () 145 | dot = consume (char '.') 146 | 147 | oparen :: Parser () 148 | oparen = consume (char '(') 149 | 150 | cparen :: Parser () 151 | cparen = consume (char ')') 152 | -------------------------------------------------------------------------------- /src/Lambda/Untyped/Parser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Lambda.Untyped.Parser where 4 | 5 | import Data.Monoid 6 | import Control.Monad 7 | import Text.Megaparsec 8 | import Test.QuickCheck 9 | import Test.QuickCheck.Gen () 10 | import Text.Megaparsec.Text 11 | import qualified Text.Megaparsec.Lexer as L 12 | import Data.Text (Text) 13 | import qualified Data.Text as T 14 | 15 | {- 16 | Lambda calculus abstract grammar: 17 | 18 | Lambda 19 | = Var 20 | | Abstraction 21 | | Application 22 | 23 | Abstraction 24 | = \ Var . Lambda 25 | 26 | Application 27 | = ( Lambda Lambda ) 28 | 29 | Var = alphanumeric 30 | -} 31 | 32 | data Lambda 33 | = Var Text 34 | | App Lambda Lambda 35 | | Abs Text Lambda 36 | | Lit Literal 37 | deriving (Eq, Show) 38 | 39 | data Literal 40 | = Str Text 41 | | Int Integer 42 | deriving (Eq, Show) 43 | 44 | instance Arbitrary Lambda where 45 | arbitrary = sized go 46 | where 47 | go :: Int -> Gen Lambda 48 | go i 49 | | i <= 0 = 50 | oneof [ Var <$> randChars 51 | , Lit . Str <$> randChars 52 | , Lit . Int <$> arbitrary 53 | ] 54 | | otherwise = 55 | oneof [ Abs <$> randChars <*> go (i - 1) 56 | , App <$> go (i - 1) <*> go (i - 1) 57 | , Var <$> randChars 58 | ] 59 | randChars = T.pack . take 6 <$> listOf1 (choose ('a', 'z')) 60 | 61 | shrink (App a b) = [a, b] <> (uncurry App <$> shrink (a, b)) 62 | shrink (Abs _ l) = l : shrink l 63 | shrink (Var a) = [Var a] 64 | shrink (Lit _) = [] 65 | 66 | -- | Pretty-prints a lambda expression. 67 | -- 68 | -- >>> pretty (Var "x") 69 | -- "x" 70 | -- >>> pretty (App (App (Var "x") (Var "y")) (Var "z")) 71 | -- "x y z" 72 | -- >>> pretty (App (Var "x") (App (Var "y") (Var "z"))) 73 | -- "x (y z)" 74 | -- >>> pretty (Abs "x" (Var "x")) 75 | -- "\\x . x" 76 | -- >>> pretty (Lit (Str "hello")) 77 | -- "\"hello\"" 78 | -- >>> pretty (Lit (Int 1000)) 79 | -- "1000" 80 | -- >>> pretty (App (Lit (Str "foo")) (Lit (Int 100))) 81 | -- "\"foo\" 100" 82 | pretty :: Lambda -> Text 83 | pretty (Var a) = a 84 | pretty (Abs a l) = "\\" <> a <> " . " <> pretty l 85 | pretty (App l@Var{} r@Var{}) = pretty l <> " " <> pretty r 86 | pretty (App l r) = 87 | case l of 88 | Var {} -> 89 | case r of 90 | Var {} -> pretty l <> " " <> pretty r 91 | _ -> pretty l <> " (" <> pretty r <> ")" 92 | Abs {} -> "(" <> pretty l <> ") " <> 93 | case r of 94 | Var {} -> pretty r 95 | _ -> "(" <> pretty r <> ")" 96 | App {} -> pretty l <> " " <> 97 | case r of 98 | Var {} -> pretty r 99 | Lit {} -> pretty r 100 | _ -> "(" <> pretty r <> ")" 101 | Lit {} -> pretty l <> " " <> 102 | case r of 103 | _ -> pretty r 104 | pretty (Lit (Str a)) = "\"" <> a <> "\"" 105 | pretty (Lit (Int i)) = T.pack . show $ i 106 | 107 | spaceConsumer :: Parser () 108 | spaceConsumer = 109 | L.space 110 | (void spaceChar) 111 | (L.skipLineComment "--") 112 | (L.skipBlockComment "(*" "*)") 113 | 114 | lexeme :: Parser a -> Parser a 115 | lexeme = L.lexeme spaceConsumer 116 | 117 | -- | Parse a lambda expression. 118 | -- 119 | -- >>> let p = (\(Just x) -> x) . parseMaybe lambda 120 | -- >>> p "x" 121 | -- Var "x" 122 | -- >>> p "(x y)" 123 | -- App (Var "x") (Var "y") 124 | -- >>> p "\\ x . (x x)" 125 | -- Abs "x" (App (Var "x") (Var "x")) 126 | -- >>> p "x y z" 127 | -- App (App (Var "x") (Var "y")) (Var "z") 128 | lambda :: Parser Lambda 129 | lambda = choice 130 | [ manyApplication 131 | , parens lambda 132 | , abstraction 133 | , Lit <$> literal 134 | ] 135 | where 136 | manyApplication = 137 | foldl1 App <$> some (choice [ 138 | abstraction 139 | , variable' 140 | , parens lambda 141 | , Lit <$> literal 142 | ]) 143 | 144 | -- | A parser for the fully explicit lambda calculus. 145 | lambdaExplicit :: Parser Lambda 146 | lambdaExplicit = choice 147 | [ variable' 148 | , Lit <$> literal 149 | , parens $ choice 150 | [ do 151 | slash 152 | v <- variable 153 | dot 154 | e <- lambdaExplicit 155 | return (Abs v e) 156 | , App <$> lambdaExplicit <*> lambdaExplicit 157 | ] 158 | ] 159 | 160 | -- | Pretty-print a lambda expression with explicit parentheses. 161 | prettyExplicit :: Lambda -> Text 162 | prettyExplicit (Var a) = a 163 | prettyExplicit (Abs v e) = 164 | "(\\" <> v <> " . " <> prettyExplicit e <> ")" 165 | prettyExplicit (App l r) = 166 | "(" <> prettyExplicit l <> " " <> prettyExplicit r <> ")" 167 | prettyExplicit (Lit r) = 168 | case r of 169 | Str x -> "\"" <> x <> "\"" 170 | Int i -> T.pack . show $ i 171 | 172 | parens :: Parser a -> Parser a 173 | parens = between oparen cparen 174 | 175 | literal :: Parser Literal 176 | literal = lexeme $ choice 177 | [ Int . read <$> choice 178 | [ (:) <$> char '-' <*> some digitChar 179 | , some digitChar 180 | ] 181 | , Str . T.pack <$> do 182 | char '"' 183 | L.charLiteral `manyTill` char '"' 184 | ] 185 | 186 | variable :: Parser Text 187 | variable = T.pack <$> lexeme ((:) <$> oneOf ['a'..'z'] <*> many alphaNumChar) 188 | 189 | variable' :: Parser Lambda 190 | variable' = fmap Var variable 191 | 192 | abstraction :: Parser Lambda 193 | abstraction = do 194 | slash 195 | v <- variable 196 | dot 197 | l <- lambda 198 | return (Abs v l) 199 | 200 | consume :: Parser a -> Parser () 201 | consume = void . lexeme 202 | 203 | slash :: Parser () 204 | slash = consume (char '\\') 205 | 206 | dot :: Parser () 207 | dot = consume (char '.') 208 | 209 | oparen :: Parser () 210 | oparen = consume (char '(') 211 | 212 | cparen :: Parser () 213 | cparen = consume (char ')') 214 | -------------------------------------------------------------------------------- /src/Lambda/Untyped/Eval.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Lambda.Untyped.Eval where 4 | 5 | import Data.Maybe 6 | import Data.Monoid 7 | import Data.Text (Text) 8 | import Control.Monad.Reader 9 | import Control.Monad.Except 10 | import Text.Show.Functions () 11 | import Control.Monad.Trans () 12 | -- import qualified Data.Text as T 13 | import qualified Data.List as L 14 | import Data.Map (Map) 15 | import qualified Data.Map as Map 16 | import Data.Set (Set) 17 | import qualified Data.Set as Set 18 | 19 | import qualified Lambda.Untyped.Parser as Parser 20 | 21 | data Lambda 22 | = FreeVar Text 23 | | AbsVar Int 24 | | App Lambda Lambda 25 | | Abs Text Lambda 26 | | Lit Parser.Literal 27 | deriving (Eq, Show) 28 | 29 | -- | Converts a parsed Lambda expression to an expression in de Bruijn notation. 30 | -- 31 | -- >>> :set -XOverloadedStrings 32 | -- >>> convert (Parser.Var "x") 33 | -- FreeVar "x" 34 | -- >>> convert (Parser.Abs "x" (Parser.Var "x")) 35 | -- Abs "x" (AbsVar 0) 36 | -- >>> convert (Parser.Abs "x" (Parser.App (Parser.Var "x") (Parser.Var "x"))) 37 | -- Abs "x" (App (AbsVar 0) (AbsVar 0)) 38 | convert :: Parser.Lambda -> Lambda 39 | convert = flip runReader (0, []) . convertWith 40 | 41 | type ConvertEnv = (Int, [Text]) 42 | 43 | -- | Given an environment consisting of the current binding depth and a list of 44 | -- bound variables, converts a parsed lambda expression into one using de Bruijn 45 | -- indexing. 46 | convertWith :: Parser.Lambda -> Reader ConvertEnv Lambda 47 | convertWith (Parser.Abs x lam) = do 48 | Abs x <$> local (\(d, xs) -> (d + 1, x:xs)) (convertWith lam) 49 | convertWith (Parser.App l r) = do 50 | App <$> convertWith l <*> convertWith r 51 | convertWith (Parser.Var x) = do 52 | env <- asks snd 53 | return $ maybe (FreeVar x) AbsVar (L.elemIndex x env) 54 | convertWith (Parser.Lit a) = return (Lit a) 55 | 56 | data ReversionError = VarNotFound Int 57 | deriving (Show, Eq) 58 | 59 | -- | Converts a de Bruijn indexed lambda into a textual lambda. This function 60 | -- assumes an empty context and a current binding depth of 0. If the expression 61 | -- is not well formed (eg, there are abstracted variables that don't correspond 62 | -- to anything in the context) then the function returns @Nothing@. 63 | -- 64 | -- >>> revert (App (Abs "x" (AbsVar 0)) (FreeVar "y")) 65 | -- Right (App (Abs "x" (Var "x")) (Var "y")) 66 | -- >>> revert (Abs "x" (Abs "y" (AbsVar 0))) 67 | -- Right (Abs "x" (Abs "y" (Var "y"))) 68 | revert :: Lambda -> Either ReversionError Parser.Lambda 69 | revert = flip runReader (0, mempty) . runExceptT . revertWith 70 | 71 | type RevertEnv = (Int, [Text]) 72 | 73 | -- | Converts a de Bruijn indexed lambda into a textual lambda. Provide the 74 | -- binding depth of the top most lambda and a context of bound variables to the 75 | -- reader function. 76 | revertWith :: Lambda -> ExceptT ReversionError (Reader RevertEnv) Parser.Lambda 77 | revertWith (FreeVar x) = return (Parser.Var x) 78 | revertWith (AbsVar hops) = do 79 | b <- asks snd 80 | let r = maybe (Left (VarNotFound hops)) Right (listToMaybe $ drop hops b) 81 | Parser.Var <$> ExceptT (return r) 82 | revertWith (Abs x e) = 83 | Parser.Abs x <$> local (\(d, b) -> (d + 1, x:b)) (revertWith e) 84 | revertWith (App l r) = 85 | Parser.App <$> revertWith l <*> revertWith r 86 | revertWith (Lit a) = return (Parser.Lit a) 87 | 88 | 89 | -- | Determines if two lambda expressions are alpha equivalent. Returns @Just 90 | -- lambda@ if the two are equivalent, and @Nothing@ if they're not. 91 | -- 92 | -- >>> alphaEquiv (Abs "x" (AbsVar 1)) (Abs "y" (AbsVar 1)) 93 | -- Just (Abs "x" (AbsVar 1)) 94 | -- >>> alphaEquiv (Abs "x" (AbsVar 1)) (Abs "y" (FreeVar "x")) 95 | -- Nothing 96 | alphaEquiv :: Lambda -> Lambda -> Maybe Lambda 97 | alphaEquiv (FreeVar x) (FreeVar y) 98 | | x == y = Just (FreeVar x) 99 | | otherwise = Nothing 100 | alphaEquiv (AbsVar d) (AbsVar d') 101 | | d == d' = Just (AbsVar d) 102 | | otherwise = Nothing 103 | alphaEquiv (App l r) (App l' r') = do 104 | App <$> alphaEquiv l l' <*> alphaEquiv r r' 105 | alphaEquiv (Abs x e) (Abs _ f) = do 106 | Abs x <$> alphaEquiv e f 107 | alphaEquiv _ _ = Nothing 108 | 109 | -- | Retrives the set of free variables in a given lambda expression. 110 | -- 111 | -- >>> freeVariables (Abs "x" (FreeVar "y")) 112 | -- fromList ["y"] 113 | -- >>> freeVariables (App (AbsVar 0) (AbsVar 1)) 114 | -- fromList [] 115 | freeVariables :: Lambda -> Set Text 116 | freeVariables (FreeVar x) = Set.singleton x 117 | freeVariables (AbsVar _) = mempty 118 | freeVariables (Abs _ e) = freeVariables e 119 | freeVariables (App l r) = freeVariables l <> freeVariables r 120 | freeVariables (Lit _) = mempty 121 | 122 | -- | Given a pairing between a free variable name and a lambda, substitute the 123 | -- lambda expression for each occurrence of the variable name. 124 | substitute :: (Text, Lambda) -> Lambda -> Lambda 125 | substitute s@(var, expr) v = 126 | case v of 127 | AbsVar _ -> v 128 | App l r -> App (substitute s l) (substitute s r) 129 | FreeVar n -> if n == var then expr else v 130 | Abs n e -> Abs n (substitute s e) 131 | Lit e -> Lit e 132 | 133 | -- | Recursively reduce a lambda expression. 134 | -- 135 | -- >>> betaReduction (App (Abs "x" (AbsVar 0)) (FreeVar "x")) 136 | -- FreeVar "x" 137 | betaReduction :: Lambda -> Lambda 138 | betaReduction = flip runReader (0, mempty) . betaReductionWith 139 | 140 | type ReduceEnv = (Int, Map Int Lambda) 141 | 142 | betaReductionWith :: Lambda -> Reader ReduceEnv Lambda 143 | betaReductionWith f@(FreeVar _) = return f 144 | betaReductionWith (AbsVar n) = do 145 | (currDepth, bindings) <- ask 146 | return (fromMaybe (AbsVar n) (Map.lookup (n - currDepth) bindings)) 147 | betaReductionWith (Abs n expr) = do 148 | Abs n <$> local (\(d, b) -> (d + 1, b)) (betaReductionWith expr) 149 | betaReductionWith (App (Abs _ x) r) = 150 | local (\(d, b) -> (d, Map.insert d r b)) (betaReductionWith x) 151 | betaReductionWith (App l r) = 152 | App <$> betaReductionWith l <*> betaReductionWith r 153 | betaReductionWith (Lit a) = return (Lit a) 154 | 155 | fullyReduce :: Lambda -> Lambda 156 | fullyReduce = go 1000 157 | where 158 | go :: Int -> Lambda -> Lambda 159 | go 0 l = l 160 | go n l = let b = betaReduction l 161 | in if b == l then l else go (n - 1) b 162 | 163 | type EvalEnv = Map Text Lambda 164 | 165 | data EvalError 166 | = VariableNotFound Text 167 | | TypeMismatch Text Lambda 168 | deriving (Eq, Show) 169 | 170 | eval :: Lambda -> EvalEnv -> Either EvalError Lambda 171 | eval l e = runReaderT (go l) e 172 | where 173 | go :: Lambda -> ReaderT EvalEnv (Either EvalError) Lambda 174 | go (App f x) = App <$> go f <*> go x 175 | go (FreeVar x) = do 176 | env <- ask 177 | case Map.lookup x env of 178 | Just a -> return a 179 | Nothing -> lift (Left (VariableNotFound x)) 180 | go r@(AbsVar _) = return r 181 | go (Abs _ n) = go n 182 | go (Lit a) = return (Lit a) 183 | 184 | 185 | -------------------------------------------------------------------------------- /src/Lambda/Untyped/Eval/Free.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE PatternSynonyms #-} 4 | 5 | module Lambda.Untyped.Eval.Free where 6 | 7 | import Prelude hiding (abs) 8 | import Control.Arrow ((***)) 9 | import Data.Maybe 10 | import Data.Monoid 11 | import Data.Text (Text) 12 | import Control.Monad.Free 13 | import Control.Monad.Reader 14 | import Control.Monad.Except 15 | import Text.Show.Functions () 16 | import Control.Monad.Trans () 17 | -- import qualified Data.Text as T 18 | import qualified Data.List as L 19 | import Data.Map (Map) 20 | import qualified Data.Map as Map 21 | import Data.Set (Set) 22 | import qualified Data.Set as Set 23 | 24 | import qualified Lambda.Untyped.Parser.Free as Parser 25 | 26 | import Lambda.Untyped.Types as Types 27 | 28 | type Lambda = Eval Text 29 | 30 | absVar :: a -> Free f (Either a b) 31 | absVar = Pure . Left 32 | 33 | freeVar :: a1 -> Free f (Either a (Literal a1)) 34 | freeVar = Pure . Right . Var 35 | 36 | int :: Integer -> Either a (Free f (Literal a1)) 37 | int = fmap Right Types.int 38 | 39 | str :: Text -> Either a (Free f (Literal a1)) 40 | str = fmap Right Types.str 41 | 42 | pattern (:~>) :: Text -> Free LambdaF a -> Free LambdaF a 43 | pattern x :~> m <- Free (Abs x m) 44 | pattern (:$:) :: Free LambdaF a -> Free LambdaF a -> Free LambdaF a 45 | pattern f :$: x <- Free (App f x) 46 | 47 | -- $setup 48 | -- >>> :set -XOverloadedStrings 49 | -- >>> 50 | 51 | 52 | -- | Converts a parsed Lambda expression to an expression in de Bruijn notation. 53 | -- 54 | -- >>> convert (var "x") 55 | -- Pure (Right (Var "x")) 56 | -- >>> convert (Types.abs "x" (var "x")) 57 | -- Free (Abs "x" (Pure (Left 0))) 58 | -- >>> convert (Types.abs "x" (app (var "x") (var "x"))) 59 | -- Free (Abs "x" (Free (App (Pure (Left 0)) (Pure (Left 0))))) 60 | convert :: Parser.Lambda -> Lambda 61 | convert = flip runReader (0, []) . convertWith 62 | 63 | type ConvertEnv = (Int, [Text]) 64 | 65 | -- | Given an environment consisting of the current binding depth and a list of 66 | -- bound variables, converts a parsed lambda expression into one using de Bruijn 67 | -- indexing. 68 | convertWith :: Parser.Lambda -> Reader ConvertEnv Lambda 69 | convertWith (x :~> lam) = 70 | abs x <$> local ((+1) *** (x:)) (convertWith lam) 71 | convertWith (l :$: r) = 72 | app <$> convertWith l <*> convertWith r 73 | convertWith (Pure (Var x)) = 74 | maybe (freeVar x) absVar . L.elemIndex x <$> asks snd 75 | convertWith (Pure a) = 76 | return (Pure (Right a)) 77 | 78 | data ReversionError = VarNotFound Int 79 | deriving (Show, Eq) 80 | 81 | -- | Converts a de Bruijn indexed lambda into a textual lambda. This function 82 | -- assumes an empty context and a current binding depth of 0. If the expression 83 | -- is not well formed (eg, there are abstracted variables that don't correspond 84 | -- to anything in the context) then the function returns @Nothing@. 85 | -- 86 | -- >>> revert (app (Types.abs "x" (absVar 0)) (freeVar "y")) 87 | -- Right (Free (App (Free (Abs "x" (Pure (Var "x")))) (Pure (Var "y")))) 88 | -- >>> revert (Types.abs "x" (Types.abs "y" (absVar 0))) 89 | -- Right (Free (Abs "x" (Free (Abs "y" (Pure (Var "y")))))) 90 | revert :: Lambda -> Either ReversionError Parser.Lambda 91 | revert = flip runReader (0, mempty) . runExceptT . revertWith 92 | 93 | type RevertEnv = (Int, [Text]) 94 | 95 | -- | Converts a de Bruijn indexed lambda into a textual lambda. Provide the 96 | -- binding depth of the top most lambda and a context of bound variables to the 97 | -- reader function. 98 | revertWith :: Lambda -> ExceptT ReversionError (Reader RevertEnv) Parser.Lambda 99 | revertWith (Free (Abs x e)) = 100 | abs x <$> local (\(d, b) -> (d + 1, x:b)) (revertWith e) 101 | revertWith (Free (App l r)) = 102 | app <$> revertWith l <*> revertWith r 103 | revertWith (Pure (Left hops)) = do 104 | b <- asks snd 105 | let r = maybe (Left (VarNotFound hops)) Right (listToMaybe $ drop hops b) 106 | var <$> ExceptT (return r) 107 | revertWith (Pure (Right a)) = return (Pure a) 108 | 109 | -- | Determines if two lambda expressions are alpha equivalent. Returns @Just 110 | -- lambda@ if the two are equivalent, and @Nothing@ if they're not. 111 | -- 112 | -- This is equivalent to @(==)@. 113 | -- 114 | -- >>> alphaEquiv (Types.abs "x" (absVar 1)) (Types.abs "y" (absVar 1)) 115 | -- Just (Free (Abs "x" (Pure (Left 1)))) 116 | -- >>> alphaEquiv (Types.abs "x" (absVar 1)) (Types.abs "y" (freeVar "x")) 117 | -- Nothing 118 | alphaEquiv :: Lambda -> Lambda -> Maybe Lambda 119 | alphaEquiv l@(Pure (Right (Var x))) (Pure (Right (Var y))) 120 | | x == y = Just l 121 | | otherwise = Nothing 122 | alphaEquiv l@(Pure (Left d)) (Pure (Left d')) 123 | | d == d' = Just l 124 | | otherwise = Nothing 125 | alphaEquiv (Free (App l r)) (Free (App l' r')) = do 126 | app <$> alphaEquiv l l' <*> alphaEquiv r r' 127 | alphaEquiv (Free (Abs x e)) (Free (Abs _ f)) = do 128 | abs x <$> alphaEquiv e f 129 | alphaEquiv _ _ = Nothing 130 | 131 | -- | Retrives the set of free variables in a given lambda expression. 132 | -- 133 | -- >>> freeVariables (Types.abs "x" (freeVar "y")) 134 | -- fromList ["y"] 135 | -- >>> freeVariables (app (absVar 0) (absVar 1)) 136 | -- fromList [] 137 | freeVariables :: Lambda -> Set Text 138 | freeVariables = iter f . fmap g 139 | where 140 | f = \case 141 | App f x -> f <> x 142 | Abs _ m -> m 143 | g = \case 144 | Right (Var x) -> Set.singleton x 145 | _ -> mempty 146 | 147 | -- | Given a pairing between a free variable name and a lambda, substitute the 148 | -- lambda expression for each occurrence of the variable name. 149 | -- 150 | -- >>> substitute ("x", freeVar "y") (freeVar "x") 151 | -- Pure (Right (Var "y")) 152 | -- >>> substitute ("x", freeVar "y") (freeVar "m") 153 | -- Pure (Right (Var "m")) 154 | substitute :: (Text, Lambda) -> Lambda -> Lambda 155 | substitute (v, e) expr = 156 | expr >>= \case 157 | Right (Var n) | n == v -> e 158 | a -> return a 159 | 160 | -- | Recursively reduce a lambda expression. 161 | -- 162 | -- >>> betaReduction (app (Types.abs "x" (absVar 0)) (freeVar "x")) 163 | -- Pure (Right (Var "x")) 164 | betaReduction :: Lambda -> Lambda 165 | betaReduction = flip runReader (0, mempty) . betaReductionWith 166 | 167 | type ReduceEnv = (Int, Map Int Lambda) 168 | 169 | betaReductionWith :: Lambda -> Reader ReduceEnv Lambda 170 | betaReductionWith f@(Pure (Right _)) = return f 171 | betaReductionWith (Pure (Left n)) = do 172 | (currDepth, bindings) <- ask 173 | return (fromMaybe (absVar n) (Map.lookup (n - currDepth) bindings)) 174 | betaReductionWith (Free (Abs n expr)) = do 175 | abs n <$> local (\(d, b) -> (d + 1, b)) (betaReductionWith expr) 176 | betaReductionWith (Free (App (Free (Abs _ x)) r)) = 177 | local (\(d, b) -> (d, Map.insert d r b)) (betaReductionWith x) 178 | betaReductionWith (Free (App l r)) = 179 | app <$> betaReductionWith l <*> betaReductionWith r 180 | 181 | fullyReduce :: Lambda -> Lambda 182 | fullyReduce = go 1000 183 | where 184 | go :: Int -> Lambda -> Lambda 185 | go 0 l = l 186 | go n l = let b = betaReduction l 187 | in if b == l then l else go (n - 1) b 188 | 189 | type EvalEnv = Map Text Lambda 190 | 191 | data EvalError 192 | = VariableNotFound Text 193 | | TypeMismatch Text Lambda 194 | deriving (Eq, Show) 195 | 196 | eval :: Lambda -> EvalEnv -> Either EvalError Lambda 197 | eval l e = runReaderT (go l) e 198 | where 199 | go :: Lambda -> ReaderT EvalEnv (Either EvalError) Lambda 200 | go (Free (App f x)) = app <$> go f <*> go x 201 | go (Free (Abs _ n)) = go n 202 | go (Pure (Right (Var x))) = do 203 | res <- asks (Map.lookup x) 204 | maybe (lift . Left . VariableNotFound $ x) return res 205 | go r@(Pure _) = return r 206 | 207 | 208 | --------------------------------------------------------------------------------