├── .gitignore ├── .travis.yml ├── LICENSE ├── README.md ├── Setup.hs ├── app ├── CliOptions.hs ├── Main.hs ├── Repl.hs └── Repl │ ├── Shared.hs │ ├── SystemF.hs │ └── Untyped.hs ├── doc ├── lambda-calculus.md └── system-f.md ├── lambda-calculator.cabal ├── package.yaml ├── scripts └── HLint.hs ├── shell.nix ├── src └── Language │ ├── Lambda.hs │ └── Lambda │ ├── Shared │ ├── Errors.hs │ └── UniqueSupply.hs │ ├── SystemF.hs │ ├── SystemF │ ├── Eval.hs │ ├── Expression.hs │ ├── Parser.hs │ ├── State.hs │ └── TypeCheck.hs │ ├── Untyped.hs │ └── Untyped │ ├── Eval.hs │ ├── Expression.hs │ ├── Parser.hs │ └── State.hs ├── stack.yaml ├── stack.yaml.lock └── test ├── Language └── Lambda │ ├── SystemF │ ├── EvalSpec.hs │ ├── Examples │ │ ├── BoolSpec.hs │ │ └── NatSpec.hs │ ├── ExpressionSpec.hs │ ├── HspecUtils.hs │ ├── ParserSpec.hs │ └── TypeCheckSpec.hs │ ├── SystemFSpec.hs │ ├── Untyped │ ├── EvalSpec.hs │ ├── Examples │ │ ├── BoolSpec.hs │ │ ├── NatSpec.hs │ │ └── PairSpec.hs │ ├── ExpressionSpec.hs │ ├── HspecUtils.hs │ └── ParserSpec.hs │ └── UntypedSpec.hs └── Spec.hs /.gitignore: -------------------------------------------------------------------------------- 1 | *.el 2 | .history 3 | .stack-work 4 | dist -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: haskell 2 | cache: 3 | directories: 4 | - $HOME/.stack 5 | before_install: 6 | # Download and unpack the stack executable 7 | - mkdir -p ~/.local/bin 8 | - export PATH=$HOME/.local/bin:$PATH 9 | - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 10 | install: 11 | # setup stack env 12 | - stack --no-terminal setup 13 | script: 14 | - stack --no-terminal test 15 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2016 Sean D Gillespie 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy of 6 | this software and associated documentation files (the "Software"), to deal in 7 | the Software without restriction, including without limitation the rights to 8 | use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies 9 | of the Software, and to permit persons to whom the Software is furnished to do 10 | so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS 17 | FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR 18 | COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER 19 | IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 20 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Lambda Calculator 2 | > Lambda Calculus and System F interpreter. 3 | 4 | A simple implementation of the Untyped Lambda Calculus and System F. It is written in 5 | Haskell and is implemented to be as easy as possible to follow, at the possible expense of 6 | performance. 7 | 8 | This project is intended to be an educational resource for learning and 9 | implementing functional programming languages. 10 | 11 | ## Installation 12 | 13 | Lambda Calculator is on [Hackage](https://hackage.haskell.org/package/lambda-calculator-3.1.1.0): 14 | 15 | cabal install lambda-calculator 16 | 17 | 18 | ## Running 19 | Once the program is installed, you simply run it: 20 | 21 | lambda-calculator # Or, 22 | lambda-calculator --system-f 23 | 24 | This will open a repl (read-eval-print loop) prompt 25 | 26 | Lambda Calculator (3.1.1.0) 27 | Type :h for help 28 | 29 | For information on valid syntax, type `:h` or `:help`. 30 | 31 | You can start typing lambda calculus expressions and the program will evaluate them 32 | and print the result. Here are a few examples: 33 | 34 | Lambda Calculator (3.1.1.0) 35 | Type :h for help 36 | λ > \x. x 37 | λx. x 38 | λ > (\x. x) n 39 | n 40 | λ > (\n f x. f (n f x)) (\f x. f (f x)) 41 | λf x. f (f (f x)) 42 | λ > :q 43 | 44 | Here are some examples for the System F interpreter (`--system-f`): 45 | 46 | Lambda Calculator (3.1.1.0) 47 | Type :h for help 48 | 49 | Λ > \x:T. x 50 | λ x:T. x : T -> T 51 | Λ > (\x:T. x) y:T 52 | y:T : T 53 | Λ > (\n:((T->T)->T->T) f:(T->T) x:T. f (n f x)) (\f:(T->T) x:T. x) 54 | λ f:(T->T) x:T. f x : (T -> T) -> T -> T 55 | Λ > :q 56 | 57 | You can exit by typing the command :q. 58 | 59 | ## Building 60 | In order to build, you will need 61 | 62 | * GHC >= 8 63 | * stack 64 | 65 | Build: 66 | 67 | stack build 68 | 69 | Then install: 70 | 71 | stack install 72 | 73 | ## Running Tests 74 | In order to run the testsuite, run 75 | 76 | stack test 77 | 78 | ## Implementation 79 | Complete implementation specifications can be found here: 80 | 81 | * [doc/lambda-calculus.md](doc/lambda-calculus.md) 82 | * [doc/system-f.md](doc/system-f.md) 83 | 84 | ## Author 85 | **Sean Gillespie** [sean@mistersg.net](mailto:sean@mistersg.net) 86 | 87 | # License 88 | This project is licensed under the MIT License. See [LICENSE](LICENSE) 89 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /app/CliOptions.hs: -------------------------------------------------------------------------------- 1 | module CliOptions 2 | ( CliOptions(..), 3 | Language(..), 4 | parseCliOptions 5 | ) where 6 | 7 | import RIO 8 | 9 | import Options.Applicative hiding (command, ParseError()) 10 | 11 | data CliOptions = CliOptions { 12 | language :: Language, 13 | version :: Bool 14 | } 15 | 16 | -- | Supported Languages: 17 | -- 18 | -- * Untyped Lambda Calculus 19 | -- * System F 20 | data Language 21 | = Untyped 22 | | SystemF 23 | 24 | parseCliOptions :: IO CliOptions 25 | parseCliOptions = execParser opts 26 | where opts = info 27 | (helper <*> cliParser) 28 | (briefDesc <> progDesc "A Lambda Calculus Interpreter") 29 | 30 | cliParser :: Parser CliOptions 31 | cliParser = CliOptions 32 | <$> language 33 | <*> switch version 34 | where language = flag' SystemF systemF <|> flag Untyped Untyped untyped 35 | 36 | version = long "version" 37 | <> short 'v' 38 | <> help "Print the version" 39 | 40 | systemF = long "system-f" 41 | <> short 'f' 42 | <> help "Use the System F interpreter" 43 | 44 | untyped = long "untyped" 45 | <> short 'l' 46 | <> help "Use the Untyped Lambda Calculus interpreter" 47 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import CliOptions (CliOptions(..), parseCliOptions) 4 | import Repl (runRepl) 5 | import qualified Paths_lambda_calculator as P 6 | 7 | import Data.Version 8 | import RIO 9 | 10 | main :: IO () 11 | main = runSimpleApp $ do 12 | CliOptions{..} <- liftIO parseCliOptions 13 | 14 | if version 15 | then 16 | logInfo $ "Lambda Calculator (" <> version' <> ")" 17 | else 18 | liftIO $ runRepl language 19 | 20 | -- | Get the current version 21 | version' :: Utf8Builder 22 | version' = fromString $ showVersion P.version 23 | -------------------------------------------------------------------------------- /app/Repl.hs: -------------------------------------------------------------------------------- 1 | module Repl (runRepl) where 2 | 3 | import CliOptions (Language(..)) 4 | import Repl.SystemF (runSystemFRepl) 5 | import Repl.Untyped (runUntypedRepl) 6 | 7 | import RIO 8 | 9 | runRepl :: Language -> IO () 10 | runRepl SystemF = runSystemFRepl 11 | runRepl Untyped = runUntypedRepl 12 | -------------------------------------------------------------------------------- /app/Repl/Shared.hs: -------------------------------------------------------------------------------- 1 | module Repl.Shared where 2 | 3 | import Paths_lambda_calculator (version) 4 | 5 | import Data.Text.IO (putStrLn) 6 | import Data.Version (showVersion) 7 | import RIO 8 | import System.Console.Repline 9 | 10 | mkReplOpts 11 | :: (MonadIO m, MonadThrow m) 12 | => (MultiLine -> HaskelineT m String) 13 | -> Command (HaskelineT m) 14 | -> Text 15 | -> ReplOpts m 16 | mkReplOpts banner command helpMsg = ReplOpts 17 | { banner = banner, 18 | command = command, 19 | options = commands helpMsg, 20 | prefix = Just ':', 21 | multilineCommand = Nothing, 22 | tabComplete = Custom completer, 23 | initialiser = initializer, 24 | finaliser = return Exit 25 | } 26 | 27 | prompt :: Applicative ap => Text -> HaskelineT ap Text 28 | prompt prefix = pure $ prefix <> " > " 29 | 30 | commands :: (MonadIO m, MonadThrow m) => Text -> [(String, String -> HaskelineT m ())] 31 | commands helpMsg 32 | = [ ("h", help'), 33 | ("help", help'), 34 | ("q", quit'), 35 | ("quit", quit') 36 | ] 37 | where help' = const (helpCommand helpMsg) 38 | quit' = const abort 39 | 40 | completer :: Monad m => CompletionFunc m 41 | completer (left, _) = pure (left, []) -- No tab completion 42 | 43 | initializer :: MonadIO io => HaskelineT io () 44 | initializer = liftIO $ putStrLn greeting 45 | where greeting = "Lambda Calculator (" 46 | <> version' 47 | <> ")\nType :h for help\n" 48 | 49 | helpCommand :: MonadIO io => Text -> HaskelineT io () 50 | helpCommand message = liftIO $ putStrLn message 51 | 52 | version' :: Text 53 | version' = fromString $ showVersion version 54 | -------------------------------------------------------------------------------- /app/Repl/SystemF.hs: -------------------------------------------------------------------------------- 1 | module Repl.SystemF (runSystemFRepl) where 2 | 3 | import Language.Lambda.Shared.Errors (LambdaException()) 4 | import Language.Lambda.Shared.UniqueSupply (defaultUniques) 5 | import Language.Lambda.SystemF 6 | import Repl.Shared 7 | 8 | import Data.Text (singleton) 9 | import Data.Text.IO (putStrLn) 10 | import RIO 11 | import RIO.State 12 | import RIO.Text (pack, unpack) 13 | import System.Console.Repline 14 | import Control.Monad.Except (ExceptT(..), runExceptT) 15 | 16 | type EvalT name m 17 | = StateT (TypecheckState name) 18 | (ExceptT LambdaException m) 19 | 20 | type Repl a = HaskelineT (EvalT Text IO) a 21 | 22 | runSystemFRepl :: IO () 23 | runSystemFRepl 24 | = void . runExceptT . evalStateT (evalReplOpts replOpts) $ initialState 25 | where replOpts = mkReplOpts banner' (evalSystemF . pack) helpMsg 26 | initialState = mkTypecheckState defaultUniques defaultTyUniques 27 | 28 | banner' :: MultiLine -> Repl String 29 | banner' _ = unpack <$> prompt (singleton upperLambda) 30 | 31 | evalSystemF :: Text -> Repl () 32 | evalSystemF input = do 33 | state' <- get 34 | 35 | let res = runTypecheck (evalText input) state' 36 | case res of 37 | Left err -> liftIO . putStrLn . textDisplay $ err 38 | Right (res', newState) -> do 39 | put newState 40 | liftIO . putStrLn . prettyPrint $ res' 41 | 42 | helpMsg :: Text 43 | helpMsg = " Commands available: \n" 44 | <> " Evaluate \n" 45 | <> " :help, :h Show this help\n" 46 | <> " :quit, :q Quit\n\n" 47 | 48 | <> " Expressions can take the form:\n" 49 | <> " x variable\n" 50 | <> " x:T type annotated variable\n" 51 | <> " \\x:T. t abstraction\n" 52 | <> " f x function application\n" 53 | <> " \\X. t type abstraction\n" 54 | <> " x [T] type application\n" 55 | <> " let x = t global binding\n\n" 56 | 57 | <> " Types can take the form:\n" 58 | <> " T type variable\n" 59 | <> " T -> T type of functions\n" 60 | <> " forall X. T universal type\n\n" 61 | 62 | <> " Examples of valid expressions:\n" 63 | <> " x\n" 64 | <> " \\x:T. x\n" 65 | <> " (\\x:T. x) y:T\n" 66 | <> " \\X. \\x:X. x\n" 67 | <> " \\x:(forall T. T). x\n" 68 | <> " (\\n:((T->T)->T->T) f:(T->T) x:T. f (n f x)) (\\f:(T->T) x:T. x)\n" 69 | -------------------------------------------------------------------------------- /app/Repl/Untyped.hs: -------------------------------------------------------------------------------- 1 | module Repl.Untyped (runUntypedRepl) where 2 | 3 | import Language.Lambda.Shared.Errors (LambdaException()) 4 | import Language.Lambda.Shared.UniqueSupply (defaultUniques) 5 | import Language.Lambda.Untyped 6 | import Repl.Shared 7 | 8 | import Data.Text (singleton) 9 | import Data.Text.IO (putStrLn) 10 | import RIO 11 | import RIO.State 12 | import RIO.Text (pack, unpack) 13 | import System.Console.Repline 14 | import Control.Monad.Except 15 | 16 | type EvalT name m 17 | = StateT (EvalState name) 18 | (ExceptT LambdaException m) 19 | 20 | type Repl a = HaskelineT (EvalT Text IO) a 21 | 22 | runUntypedRepl :: IO () 23 | runUntypedRepl 24 | = void . runExceptT . evalStateT (evalReplOpts replOpts) $ initialState 25 | where replOpts = mkReplOpts banner' (evalLambda . pack) helpMsg 26 | initialState = mkEvalState defaultUniques 27 | 28 | banner' :: MultiLine -> Repl String 29 | banner' _ = unpack <$> prompt (singleton lambda) 30 | 31 | evalLambda :: Text -> Repl () 32 | evalLambda input = do 33 | state' <- get 34 | 35 | let res = runEval (evalText input) state' 36 | case res of 37 | Left err -> liftIO . putStrLn . textDisplay $ err 38 | Right (res', newState) -> do 39 | put newState 40 | liftIO . putStrLn . prettyPrint $ res' 41 | 42 | helpMsg :: Text 43 | helpMsg = " Commands available: \n" 44 | <> " Evaluate \n" 45 | <> " :help, :h Show this help\n" 46 | <> " :quit, :q Quit\n\n" 47 | 48 | <> " Expressions can take the form:\n" 49 | <> " x variable\n" 50 | <> " \\x. t abstraction\n" 51 | <> " f x function application\n" 52 | <> " let x = t global binding\n\n" 53 | 54 | <> " Examples of valid expressions:\n" 55 | <> " x\n" 56 | <> " \\x. x\n" 57 | <> " (\\x. x) n\n" 58 | <> " (\\n f x. f (n f x)) (\\f x. f (f x))\n" 59 | -------------------------------------------------------------------------------- /doc/lambda-calculus.md: -------------------------------------------------------------------------------- 1 | # Implementation Details: Untyped Lambda Calculus 2 | 3 | The primary goal of Lambda Calculator is to be as close to pure Lambda Calculus as 4 | possible, while providing enough extensions to be useful. In this document, we will 5 | describe how the interpreter works and highlight differences from pure Lambda Calculus. 6 | 7 | ## Syntax 8 | 9 | We support the usual synax forms: variable, abstraction, and application. Additionally, 10 | let expressions may be used to bind an expression to a name. Subsequently, all references 11 | to that name will be substituted with the bound expression. 12 | 13 | All of the syntax forms are summarized in the table below: 14 | 15 | |form |name | 16 | |-----------|-----------| 17 | |`x` |variable | 18 | |`\x. t` |abstraction| 19 | |`f x` |application| 20 | |`let x = t`|let | 21 | 22 | Here are some examples of valid expressions: 23 | 24 | \x. x 25 | (\x. x) n 26 | (\n f x. f (n f x)) (\f x. f (f x)) 27 | let id = (\x. x) 28 | 29 | A let expression can only occur at the top-level. Here are some examples of invalid 30 | expressions: 31 | 32 | let x = let y = z 33 | \x. let z = w 34 | 35 | ## Evaluation 36 | 37 | In pure Lambda Calculus, abstractions are the only valid values. However, in Lambda 38 | Calculator, any expression can be a value, as long as it is as reduced to normal 39 | form. This means that free variables are allowed, and we reduce expressions as far as 40 | we can. 41 | 42 | Each evaluation rule has the general form: 43 | 44 | t → t' ⇒ u → u' 45 | 46 | which means if `t` evaluates to `t'`, then `u` evaluates to `u'` 47 | 48 | We will start with function application, which can be described by the two rules 49 | 50 | t → t', u → u' ⇒ t u → t' u' (E-App) 51 | (\x. t) w → [x ↦ w] t (E-AppAbs) 52 | 53 | The first rule, _E-App_ means that we attempt to reduce each operand before applying an 54 | abstraction. The second rule, _E-AppAbs_ represents beta reduction. It says that an 55 | abstraction `\x. t` applied to a term `w` is evaluated by substituting the abstraction's 56 | argument `x` with `w` in the abstraction's body `t`. 57 | 58 | While applying _E-AppAbs_, we also perform Alpha conversion to prevent shadowing free 59 | variables in the first term by abstractions in the second. When we see the following form: 60 | 61 | (\w. x) (\y. z) 62 | 63 | We rewrite `(\w. x)` to an another abstraction who's argument does not appear free in 64 | `(\y. z)`. 65 | 66 | Next, we have Eta conversion 67 | 68 | \x. f x → f (E-Eta) 69 | 70 | Which converts any abstraction to it's point-free representation. 71 | 72 | Finally, we have let expression evaluation 73 | 74 | t → u ⇒ let x = t → u (E-Let) 75 | x = y ∈ Γ ⇒ x → y (E-Global) 76 | 77 | Unlike in pure Lambda Calculus we have a globals context, we call Γ. This contains 78 | pairs names to expressions. The rule _E-Let_ allow the user to bind a global variable. We 79 | first attempt to reduce its body to normal form, and then we add the pair `x = u` to 80 | Γ. 81 | 82 | We use the next rule, _E-Global_, to replace free variables if they are bound in Γ. 83 | 84 | All of the evaluation rules are summarized in the table below: 85 | 86 | |rule |name | 87 | |------------------------------|-----------| 88 | |`t → t', u → u' ⇒ t u → t' u'`|E-App | 89 | |`(\x. t) w → [x ↦ w] t` |E-AppAbs | 90 | |`\x. f x → f` |E-Eta | 91 | |`t → u ⇒ let x = t → u` |E-Let | 92 | |`x = y ∈ Γ ⇒ x → y` |E-Global | 93 | -------------------------------------------------------------------------------- /doc/system-f.md: -------------------------------------------------------------------------------- 1 | # Implementation Details: System F 2 | 3 | The primary goal of Lambda Calculator is to be as close to pure System F as possible, 4 | while providing enough extensions to be useful. In this document, we will describe how the 5 | interpreter works and highlight differences from pure System F. 6 | 7 | ## Syntax 8 | 9 | We support the usual syntax forms: variable, application, abstraction, type application, 10 | and type abstraction. 11 | 12 | As in the Untyped interpreter, let expressions may be used to bind 13 | an expression to a name. Subsequently, all references to that name will be substituted 14 | with the bound expression. 15 | 16 | Because we allow free variables and free types, we also allow a variable annotated with a 17 | type. All syntax forms are summarized in the table below: 18 | 19 | |form |name | 20 | |-----------|-----------------------| 21 | |`x` |variable | 22 | |`x:T` |type annotated variable| 23 | |`f x` |application | 24 | |`\x:T. t` |abstraction | 25 | |`x [T]` |type application | 26 | |`\X. t` |type abstraction | 27 | |`let x = t`|let | 28 | 29 | We support pure System F types with no changes, summarized below: 30 | 31 | |form |name | 32 | |-------------|--------------------| 33 | |`T` |type variable | 34 | |`T->T` |type of functions | 35 | |`forall X. T`|universal type | 36 | 37 | ## Typechecking 38 | 39 | We begin with a typing context Γ, which is a mapping to free variables to their 40 | types. Items in Γ may also be type variables, which do not have associated types. 41 | We will use the following notation for &Gaimma;: 42 | 43 | |notation|name | 44 | |--------|---------------------| 45 | |`Γ,x:T` |term variable binding| 46 | |`Γ,X` |type variable binding| 47 | 48 | Most typing rules has the general from: 49 | 50 | Γ ⊢ t:T ⇒ u : U 51 | 52 | Which means if, in the typing context Γ, `t` has type `T`, then `u` has type `U`. 53 | 54 | We start with the type of variables: 55 | 56 | x:T Γ ⇒ x : T (T-Var) 57 | x ∉ Γ ⇒ x : Z (T-Var2) 58 | 59 | The first two rules, _T-Var_ means that a variable's type is looked up from the 60 | context. Because we allow free variables, if the variable is not in the context, we 61 | generate a unique type variable. We assume all free type variables are concrete types (and 62 | not universal types). 63 | 64 | Next, we have type annotated variables: 65 | 66 | x:T ∈ Γ ⇒ (x:T) : T (T-VarAnn) 67 | x ∉ Γ ⇒ (x:T) : T (T-VarAnn2) 68 | 69 | Which allows the user to specify the type of a variable. The variable is again looked up 70 | in the context. If it does not match, it is a type error. If the variable is not in the 71 | context, it has the specified type. 72 | 73 | Next, we have the type of abstractions: 74 | 75 | Γ,x:T ⊢ t:U ⇒ (\x:T. t) : T -> U (T-Abs) 76 | 77 | We first add the parameter `x:T` to the context, then calculate the type of its body 78 | `t`. The resulting type is a function type mapping `T` to `U`. 79 | 80 | Application is unchanged from pure System F: 81 | 82 | Γ ⊢ f:(T -> U), x:T ⇒ f x : U (T-App) 83 | 84 | Next, we have type abstraction: 85 | 86 | Γ,X ⊢ t:T ⇒ \X. t : forall X. T (T-TyAbs) 87 | 88 | We add the type abstraction parameter `X` to Γ, then calculate the type of its body. 89 | 90 | Type application is unchanged from pure System F: 91 | 92 | Γ ⊢ t:(forall X. T) ⇒ t [V] : [X ↦ V] T (T-TyApp) 93 | 94 | Given the rules above, if we have an abstraction, say `\x:(forall T. U). x`, then its type 95 | would be `(forall T. U) -> (forall T. U)`. It would be more correct for it to be `forall T. U -> U`, 96 | so we introduce variants of `T-Var` to account for this. 97 | 98 | x:(forall T. U), T ∈ Γ ⇒ x : U (T-VarPoly) 99 | x:(forall T. U), T ∈ Γ ⇒ (x:U) : U (T-VarAnnPoly) 100 | Γ,T ⊢ t:V ⇒ (\x:(forall T. U). t) : forall T. U -> V (T-AbsPoly) 101 | Γ ⊢ f:(forall T. U -> V), x:(forall T. U -> V) ⇒ (f x) : forall T. V (T-App) 102 | 103 | All of the typing rules are summarized below: 104 | 105 | x:T Γ ⇒ x : T (T-Var) 106 | x ∉ Γ ⇒ x : Z (T-Var2) 107 | x:T ∈ Γ ⇒ (x:T) : T (T-VarAnn) 108 | x ∉ Γ ⇒ (x:T) : T (T-VarAnn2) 109 | Γ,x:T ⊢ t:U ⇒ (\x:T. t) : T -> U (T-Abs) 110 | Γ ⊢ f:(T -> U), x:T ⇒ f x : U (T-App) 111 | Γ,X ⊢ t:T ⇒ \X. t : forall X. T (T-TyAbs) 112 | Γ ⊢ t:(forall X. T) ⇒ t [V] : [X ↦ V] T 113 | (T-TyApp) 114 | x:(forall T. U), T ∈ Γ ⇒ x : U (T-VarPoly) 115 | x:(forall T. U), T ∈ Γ ⇒ (x:U) : U 116 | (T-VarAnnPoly) 117 | Γ,T ⊢ t:V ⇒ (\x:(forall T. U). t) : forall T. U -> V 118 | (T-AbsPoly) 119 | Γ ⊢ f:(forall T. U -> V), x:(forall T. U -> V) ⇒ (f x) : forall T. V 120 | (T-AppPoly) 121 | ## Evaluation 122 | 123 | In pure System F, only abstractions and type abstractins are valid values. Because we 124 | allow free variables, as in the untyped interpreter, we allow any expression as a value. 125 | Also in pure System F, free type variables are not allowed, but we allow them as well. 126 | 127 | Each evaluation rule has the general form: 128 | 129 | t → t' ⇒ u → u' 130 | 131 | which means if `t` evaluates to `t'`, then `u` evaluates to `u'` 132 | 133 | We will start with function application, which can be described by the two rules 134 | 135 | t → t', u → u' ⇒ t u → t' u' (E-App) 136 | (\x. t) w → [x ↦ w] t (E-AppAbs) 137 | 138 | The first rule, _E-App_ means that we attempt to reduce each operand before applying an 139 | abstraction. The second rule, _E-AppAbs_ represents beta reduction. It says that an 140 | abstraction `\x. t` applied to a term `w` is evaluated by substituting the abstraction's 141 | argument `x` with `w` in the abstraction's body `t`. 142 | 143 | While applying _E-AppAbs_, we also perform Alpha conversion to prevent shadowing free 144 | variables in the first term by abstractions in the second. When we see the following form: 145 | 146 | (\w:T. x) (\y:U. z) 147 | 148 | We rewrite `(\w:T. x)` to an another abstraction who's argument does not appear free in 149 | `(\y:U. z)`. 150 | 151 | Next, we have Eta conversion 152 | 153 | \x::T. f x → f (E-Eta) 154 | 155 | Which converts any abstraction to it's point-free representation. 156 | 157 | The following type application rules are unchanged from pure System F: 158 | 159 | t → t', ⇒ t [T] → t' [T] (E-TApp) 160 | (\X. t) [T] → [X ↦ T] t (E-TAppTAbs) 161 | 162 | We add polymorphic variants: 163 | 164 | x:(forall X. T) [U] (E-TAppVarPoly) 165 | (\x:(forall X. T). t) [U] → \x:([X ↦ U] T). t 166 | (E-TAppAbsPoly) 167 | 168 | Finally, we have let expression evaluation 169 | 170 | t → u ⇒ let x = t → u (E-Let) 171 | x = y ∈ Γ ⇒ x → y (E-Global) 172 | 173 | Unlike in pure System F we have a globals context, we call Γ. This contains pairs 174 | names to expressions. The rule _E-Let_ allows the user to bind a global variable. We first 175 | attempt to reduce its body to normal form, and then we add the pair `x = u` to Γ. 176 | 177 | We use the next rule, _E-Global_, to replace free variables if they are bound in Γ. 178 | 179 | All of the evaluation rules are summarized below: 180 | 181 | t → t', u → u' ⇒ t u → t' u' (E-App) 182 | (\x. t) w → [x ↦ w] t (E-AppAbs) 183 | \x::T. f x → f (E-Eta) 184 | t → t', ⇒ t [T] → t' [T] (E-TApp) 185 | (\X. t) [T] → [X ↦ T] t (E-TAppTAbs) 186 | x:(forall X. T) [U] (E-TAppVarPoly) 187 | (\x:(forall X. T). t) [U] → \x:([X ↦ U] T). t 188 | (E-TAppAbsPoly) 189 | t → u ⇒ let x = t → u (E-Let) 190 | x = y ∈ Γ ⇒ x → y (E-Global) 191 | -------------------------------------------------------------------------------- /lambda-calculator.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.35.0. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | -- 7 | -- hash: 3256f86f253ee771f5e7374ff11bcb34286722368054e4e233095c13c9abe64b 8 | 9 | name: lambda-calculator 10 | version: 3.1.0.0 11 | synopsis: A lambda calculus interpreter 12 | description: A simple implementation of the Untyped Lambda Calculus 13 | category: LambdaCalculus,Language,Teaching 14 | homepage: https://github.com/sgillespie/lambda-calculator#readme 15 | bug-reports: https://github.com/sgillespie/lambda-calculator/issues 16 | author: Sean D Gillespie 17 | maintainer: sean@mistersg.net 18 | copyright: 2016-2023 Sean Gillespie 19 | license: MIT 20 | license-file: LICENSE 21 | build-type: Simple 22 | 23 | source-repository head 24 | type: git 25 | location: https://github.com/sgillespie/lambda-calculator 26 | 27 | library 28 | exposed-modules: 29 | Language.Lambda.Shared.Errors 30 | Language.Lambda.Shared.UniqueSupply 31 | Language.Lambda.Untyped 32 | Language.Lambda.Untyped.Expression 33 | Language.Lambda.Untyped.Eval 34 | Language.Lambda.Untyped.Parser 35 | Language.Lambda.Untyped.State 36 | Language.Lambda.SystemF 37 | Language.Lambda.SystemF.Eval 38 | Language.Lambda.SystemF.Expression 39 | Language.Lambda.SystemF.Parser 40 | Language.Lambda.SystemF.State 41 | Language.Lambda.SystemF.TypeCheck 42 | other-modules: 43 | Language.Lambda 44 | Paths_lambda_calculator 45 | hs-source-dirs: 46 | src 47 | default-extensions: 48 | BangPatterns 49 | ConstraintKinds 50 | DataKinds 51 | DefaultSignatures 52 | DeriveDataTypeable 53 | DeriveFoldable 54 | DeriveFunctor 55 | DeriveGeneric 56 | DeriveTraversable 57 | DoAndIfThenElse 58 | EmptyDataDecls 59 | ExistentialQuantification 60 | FlexibleContexts 61 | FlexibleInstances 62 | FunctionalDependencies 63 | GADTs 64 | GeneralizedNewtypeDeriving 65 | InstanceSigs 66 | KindSignatures 67 | LambdaCase 68 | MultiParamTypeClasses 69 | MultiWayIf 70 | NamedFieldPuns 71 | NoImplicitPrelude 72 | OverloadedStrings 73 | PartialTypeSignatures 74 | PatternGuards 75 | PolyKinds 76 | RankNTypes 77 | RecordWildCards 78 | ScopedTypeVariables 79 | StandaloneDeriving 80 | TupleSections 81 | TypeFamilies 82 | TypeSynonymInstances 83 | ViewPatterns 84 | ghc-options: -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints 85 | build-depends: 86 | base >=4.9 && <5 87 | , containers 88 | , microlens 89 | , mtl 90 | , parsec 91 | , prettyprinter 92 | , rio 93 | default-language: Haskell2010 94 | 95 | executable lambda-calculator 96 | main-is: Main.hs 97 | other-modules: 98 | CliOptions 99 | Repl 100 | Repl.Shared 101 | Repl.SystemF 102 | Repl.Untyped 103 | Paths_lambda_calculator 104 | hs-source-dirs: 105 | app 106 | default-extensions: 107 | BangPatterns 108 | ConstraintKinds 109 | DataKinds 110 | DefaultSignatures 111 | DeriveDataTypeable 112 | DeriveFoldable 113 | DeriveFunctor 114 | DeriveGeneric 115 | DeriveTraversable 116 | DoAndIfThenElse 117 | EmptyDataDecls 118 | ExistentialQuantification 119 | FlexibleContexts 120 | FlexibleInstances 121 | FunctionalDependencies 122 | GADTs 123 | GeneralizedNewtypeDeriving 124 | InstanceSigs 125 | KindSignatures 126 | LambdaCase 127 | MultiParamTypeClasses 128 | MultiWayIf 129 | NamedFieldPuns 130 | NoImplicitPrelude 131 | OverloadedStrings 132 | PartialTypeSignatures 133 | PatternGuards 134 | PolyKinds 135 | RankNTypes 136 | RecordWildCards 137 | ScopedTypeVariables 138 | StandaloneDeriving 139 | TupleSections 140 | TypeFamilies 141 | TypeSynonymInstances 142 | ViewPatterns 143 | ghc-options: -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N 144 | build-depends: 145 | base >=4.9 && <5 146 | , bytestring 147 | , containers 148 | , lambda-calculator 149 | , microlens 150 | , mtl 151 | , optparse-applicative 152 | , prettyprinter 153 | , repline 154 | , rio 155 | , text 156 | default-language: Haskell2010 157 | 158 | test-suite lambda-calculus-lint 159 | type: exitcode-stdio-1.0 160 | main-is: HLint.hs 161 | hs-source-dirs: 162 | scripts 163 | default-extensions: 164 | BangPatterns 165 | ConstraintKinds 166 | DataKinds 167 | DefaultSignatures 168 | DeriveDataTypeable 169 | DeriveFoldable 170 | DeriveFunctor 171 | DeriveGeneric 172 | DeriveTraversable 173 | DoAndIfThenElse 174 | EmptyDataDecls 175 | ExistentialQuantification 176 | FlexibleContexts 177 | FlexibleInstances 178 | FunctionalDependencies 179 | GADTs 180 | GeneralizedNewtypeDeriving 181 | InstanceSigs 182 | KindSignatures 183 | LambdaCase 184 | MultiParamTypeClasses 185 | MultiWayIf 186 | NamedFieldPuns 187 | NoImplicitPrelude 188 | OverloadedStrings 189 | PartialTypeSignatures 190 | PatternGuards 191 | PolyKinds 192 | RankNTypes 193 | RecordWildCards 194 | ScopedTypeVariables 195 | StandaloneDeriving 196 | TupleSections 197 | TypeFamilies 198 | TypeSynonymInstances 199 | ViewPatterns 200 | ghc-options: -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N 201 | build-depends: 202 | base >=4.9 && <5 203 | , hlint 204 | , microlens 205 | , mtl 206 | , prettyprinter 207 | , rio 208 | default-language: Haskell2010 209 | 210 | test-suite lambda-calculus-test 211 | type: exitcode-stdio-1.0 212 | main-is: Spec.hs 213 | other-modules: 214 | Language.Lambda.SystemF.EvalSpec 215 | Language.Lambda.SystemF.Examples.BoolSpec 216 | Language.Lambda.SystemF.Examples.NatSpec 217 | Language.Lambda.SystemF.ExpressionSpec 218 | Language.Lambda.SystemF.HspecUtils 219 | Language.Lambda.SystemF.ParserSpec 220 | Language.Lambda.SystemF.TypeCheckSpec 221 | Language.Lambda.SystemFSpec 222 | Language.Lambda.Untyped.EvalSpec 223 | Language.Lambda.Untyped.Examples.BoolSpec 224 | Language.Lambda.Untyped.Examples.NatSpec 225 | Language.Lambda.Untyped.Examples.PairSpec 226 | Language.Lambda.Untyped.ExpressionSpec 227 | Language.Lambda.Untyped.HspecUtils 228 | Language.Lambda.Untyped.ParserSpec 229 | Language.Lambda.UntypedSpec 230 | Paths_lambda_calculator 231 | hs-source-dirs: 232 | test 233 | default-extensions: 234 | BangPatterns 235 | ConstraintKinds 236 | DataKinds 237 | DefaultSignatures 238 | DeriveDataTypeable 239 | DeriveFoldable 240 | DeriveFunctor 241 | DeriveGeneric 242 | DeriveTraversable 243 | DoAndIfThenElse 244 | EmptyDataDecls 245 | ExistentialQuantification 246 | FlexibleContexts 247 | FlexibleInstances 248 | FunctionalDependencies 249 | GADTs 250 | GeneralizedNewtypeDeriving 251 | InstanceSigs 252 | KindSignatures 253 | LambdaCase 254 | MultiParamTypeClasses 255 | MultiWayIf 256 | NamedFieldPuns 257 | NoImplicitPrelude 258 | OverloadedStrings 259 | PartialTypeSignatures 260 | PatternGuards 261 | PolyKinds 262 | RankNTypes 263 | RecordWildCards 264 | ScopedTypeVariables 265 | StandaloneDeriving 266 | TupleSections 267 | TypeFamilies 268 | TypeSynonymInstances 269 | ViewPatterns 270 | ghc-options: -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N 271 | build-depends: 272 | HUnit 273 | , base >=4.9 && <5 274 | , containers 275 | , hspec 276 | , lambda-calculator 277 | , microlens 278 | , mtl 279 | , prettyprinter 280 | , rio 281 | default-language: Haskell2010 282 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: lambda-calculator 2 | version: '3.1.1.0' 3 | synopsis: A lambda calculus interpreter 4 | description: A simple implementation of the Untyped Lambda Calculus 5 | category: LambdaCalculus,Language,Teaching 6 | author: Sean D Gillespie 7 | maintainer: sean@mistersg.net 8 | copyright: 2016-2023 Sean Gillespie 9 | license: MIT 10 | github: sgillespie/lambda-calculator 11 | 12 | dependencies: 13 | - base >= 4.9 && < 5 14 | - microlens 15 | - mtl 16 | - prettyprinter 17 | - rio 18 | 19 | ghc-options: 20 | - -Wcompat 21 | - -Widentities 22 | - -Wincomplete-record-updates 23 | - -Wincomplete-uni-patterns 24 | - -Wpartial-fields 25 | - -Wredundant-constraints 26 | 27 | default-extensions: 28 | - BangPatterns 29 | - ConstraintKinds 30 | - DataKinds 31 | - DefaultSignatures 32 | - DeriveDataTypeable 33 | - DeriveFoldable 34 | - DeriveFunctor 35 | - DeriveGeneric 36 | - DeriveTraversable 37 | - DoAndIfThenElse 38 | - EmptyDataDecls 39 | - ExistentialQuantification 40 | - FlexibleContexts 41 | - FlexibleInstances 42 | - FunctionalDependencies 43 | - GADTs 44 | - GeneralizedNewtypeDeriving 45 | - InstanceSigs 46 | - KindSignatures 47 | - LambdaCase 48 | - MultiParamTypeClasses 49 | - MultiWayIf 50 | - NamedFieldPuns 51 | - NoImplicitPrelude 52 | - OverloadedStrings 53 | - PartialTypeSignatures 54 | - PatternGuards 55 | - PolyKinds 56 | - RankNTypes 57 | - RecordWildCards 58 | - ScopedTypeVariables 59 | - StandaloneDeriving 60 | - TupleSections 61 | - TypeFamilies 62 | - TypeSynonymInstances 63 | - ViewPatterns 64 | 65 | library: 66 | source-dirs: src 67 | exposed-modules: 68 | - Language.Lambda.Shared.Errors 69 | - Language.Lambda.Shared.UniqueSupply 70 | - Language.Lambda.Untyped 71 | - Language.Lambda.Untyped.Expression 72 | - Language.Lambda.Untyped.Eval 73 | - Language.Lambda.Untyped.Parser 74 | - Language.Lambda.Untyped.State 75 | - Language.Lambda.SystemF 76 | - Language.Lambda.SystemF.Eval 77 | - Language.Lambda.SystemF.Expression 78 | - Language.Lambda.SystemF.Parser 79 | - Language.Lambda.SystemF.State 80 | - Language.Lambda.SystemF.TypeCheck 81 | dependencies: 82 | - containers 83 | - parsec 84 | 85 | executables: 86 | lambda-calculator: 87 | main: Main.hs 88 | source-dirs: app 89 | dependencies: 90 | - bytestring 91 | - containers 92 | - lambda-calculator 93 | - optparse-applicative 94 | - repline 95 | - text 96 | ghc-options: 97 | - -threaded 98 | - -rtsopts 99 | - -with-rtsopts=-N 100 | 101 | tests: 102 | lambda-calculus-test: 103 | main: Spec.hs 104 | source-dirs: test 105 | ghc-options: 106 | - -threaded 107 | - -rtsopts 108 | - -with-rtsopts=-N 109 | dependencies: 110 | - HUnit 111 | - containers 112 | - hspec 113 | - lambda-calculator 114 | 115 | lambda-calculus-lint: 116 | main: HLint.hs 117 | source-dirs: scripts 118 | other-modules: [] 119 | ghc-options: 120 | - -threaded 121 | - -rtsopts 122 | - -with-rtsopts=-N 123 | dependencies: 124 | - hlint 125 | -------------------------------------------------------------------------------- /scripts/HLint.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Language.Haskell.HLint (hlint) 4 | import RIO 5 | 6 | arguments :: [String] 7 | arguments = [ 8 | "app", 9 | "src", 10 | "test" 11 | ] 12 | 13 | main :: IO () 14 | main = hlint arguments >>= main' 15 | where main' [] = exitSuccess 16 | main' _ = exitFailure 17 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | { 2 | ghc 3 | }: 4 | 5 | let 6 | rev = "249c76eb6787420b2178a3ba4cc64c4d9c4a5997"; # pin 7 | sha256 = "sha256:1lq2py428bfs6vv7qikzgh7hqyxw17c65dnfi35m46kjnidrrcbh"; 8 | pkgsArchive = fetchTarball { 9 | url = "https://github.com/NixOS/nixpkgs/archive/${rev}.tar.gz"; 10 | sha256 = sha256; 11 | }; 12 | 13 | nixpkgs = import pkgsArchive {}; 14 | inherit (nixpkgs) haskell; 15 | in 16 | 17 | haskell.lib.buildStackProject { 18 | inherit ghc; 19 | name = "myEnv"; 20 | buildInputs = [nixpkgs.zlib]; 21 | } 22 | -------------------------------------------------------------------------------- /src/Language/Lambda.hs: -------------------------------------------------------------------------------- 1 | module Language.Lambda 2 | ( module Language.Lambda.Shared.Errors 3 | ) where 4 | 5 | import Language.Lambda.Shared.Errors 6 | -------------------------------------------------------------------------------- /src/Language/Lambda/Shared/Errors.hs: -------------------------------------------------------------------------------- 1 | module Language.Lambda.Shared.Errors 2 | ( LambdaException(..), 3 | isLambdaException, 4 | isLetError, 5 | isParseError, 6 | isImpossibleError, 7 | isTyMismatchError, 8 | ) where 9 | 10 | import RIO 11 | 12 | data LambdaException 13 | -- | An expression that cannot be parsed 14 | -- Examples: 15 | -- 16 | -- \x y 17 | -- = y 18 | = ParseError Text 19 | 20 | -- | A let binding nested in another expression 21 | -- Examples: 22 | -- 23 | -- \x. let y = z 24 | -- x (let y = z) 25 | | InvalidLet Text -- ^ A let binding nested in another expression 26 | 27 | -- | The expected type does not match the actual type 28 | -- Examples: 29 | -- 30 | -- (\x: X. x) (y:Y) 31 | -- (\x: T. x) [U] 32 | | TyMismatchError Text 33 | 34 | -- | A catch-all error that indicates a bug in this project 35 | | ImpossibleError 36 | deriving (Eq, Typeable) 37 | 38 | instance Exception LambdaException 39 | 40 | instance Display LambdaException where 41 | textDisplay (ParseError txt) = "Parse error " <> txt 42 | textDisplay (InvalidLet txt) = "Illegal nested let: " <> txt 43 | textDisplay (TyMismatchError txt) = "Type error: " <> txt 44 | textDisplay ImpossibleError = "An impossible error occurred! Please file a bug." 45 | 46 | instance Show LambdaException where 47 | show = show . textDisplay 48 | 49 | -- | Returns true if the passed in value is a LamdbaExpression. Can be used, for example, 50 | -- as a `shouldThrow` matcher 51 | isLambdaException :: LambdaException -> Bool 52 | isLambdaException _ = True 53 | 54 | isLetError :: LambdaException -> Bool 55 | isLetError (InvalidLet _) = True 56 | isLetError _ = False 57 | 58 | isParseError :: LambdaException -> Bool 59 | isParseError (ParseError _) = True 60 | isParseError _ = False 61 | 62 | isImpossibleError :: LambdaException -> Bool 63 | isImpossibleError ImpossibleError = True 64 | isImpossibleError _ = False 65 | 66 | isTyMismatchError :: LambdaException -> Bool 67 | isTyMismatchError (TyMismatchError _) = True 68 | isTyMismatchError _ = False 69 | -------------------------------------------------------------------------------- /src/Language/Lambda/Shared/UniqueSupply.hs: -------------------------------------------------------------------------------- 1 | module Language.Lambda.Shared.UniqueSupply where 2 | 3 | import Language.Lambda.Shared.Errors (LambdaException(..)) 4 | 5 | import Control.Monad.Except (MonadError(..), throwError) 6 | import RIO 7 | import RIO.List (find) 8 | import RIO.Text (pack, toUpper) 9 | 10 | type Unique = Text 11 | 12 | defaultUniques :: [Unique] 13 | defaultUniques = map pack strings 14 | where strings = concatMap (\p -> map (:p) . reverse $ ['a'..'z']) suffix 15 | suffix = "" : map show [(0::Int)..] 16 | 17 | defaultTyUniques :: [Unique] 18 | defaultTyUniques = map toUpper defaultUniques 19 | 20 | next 21 | :: (Ord name, MonadError LambdaException m) 22 | => [name] -- ^ Unique supply 23 | -> [name] -- ^ Free Variables 24 | -> m name 25 | next freeVars uniques' = case find (`notElem` freeVars) uniques' of 26 | Just unique -> pure unique 27 | Nothing -> throwError ImpossibleError 28 | -------------------------------------------------------------------------------- /src/Language/Lambda/SystemF.hs: -------------------------------------------------------------------------------- 1 | module Language.Lambda.SystemF ( 2 | evalText, 3 | typecheckText, 4 | runEvalText, 5 | runTypecheckText, 6 | execEvalText, 7 | execTypecheckText, 8 | unsafeExecEvalText, 9 | unsafeExecTypecheckText, 10 | defaultUniques, 11 | defaultTyUniques, 12 | mkState, 13 | 14 | module Language.Lambda.SystemF.Expression, 15 | module Language.Lambda.SystemF.Parser, 16 | module Language.Lambda.SystemF.State 17 | ) where 18 | 19 | import Language.Lambda.Shared.Errors 20 | import Language.Lambda.Shared.UniqueSupply (defaultUniques, defaultTyUniques) 21 | import Language.Lambda.SystemF.Eval (evalExpr) 22 | import Language.Lambda.SystemF.Expression 23 | import Language.Lambda.SystemF.Parser 24 | import Language.Lambda.SystemF.State 25 | import Language.Lambda.SystemF.TypeCheck 26 | 27 | import Control.Monad.Except 28 | import RIO 29 | import qualified RIO.Text as Text 30 | import qualified RIO.Map as Map 31 | 32 | evalText 33 | :: Text 34 | -> Typecheck Text (TypedExpr Text) 35 | evalText = either throwParseError processExpr . parseExpr 36 | where throwParseError = throwError . ParseError . Text.pack . show 37 | 38 | typecheckText 39 | :: Text 40 | -> Typecheck Text (Ty Text) 41 | typecheckText = either throwParseError typecheck . parseExpr 42 | where throwParseError = throwError . ParseError . Text.pack . show 43 | 44 | runEvalText 45 | :: Text 46 | -> Globals Text 47 | -> Either LambdaException (TypedExpr Text, TypecheckState Text) 48 | runEvalText input globals' = runTypecheck (evalText input) (mkState globals') 49 | 50 | runTypecheckText 51 | :: Text 52 | -> Globals Text 53 | -> Either LambdaException (Ty Text, TypecheckState Text) 54 | runTypecheckText input globals' 55 | = runTypecheck (typecheckText input) (mkState globals') 56 | 57 | execEvalText 58 | :: Text 59 | -> Globals Text 60 | -> Either LambdaException (TypedExpr Text) 61 | execEvalText input globals' 62 | = execTypecheck (evalText input) (mkState globals') 63 | 64 | execTypecheckText 65 | :: Text 66 | -> Globals Text 67 | -> Either LambdaException (Ty Text) 68 | execTypecheckText input globals' 69 | = execTypecheck (typecheckText input) (mkState globals') 70 | 71 | unsafeExecEvalText 72 | :: Text 73 | -> Globals Text 74 | -> TypedExpr Text 75 | unsafeExecEvalText input globals' 76 | = unsafeExecTypecheck (evalText input) (mkState globals') 77 | 78 | unsafeExecTypecheckText 79 | :: Text 80 | -> Globals Text 81 | -> Ty Text 82 | unsafeExecTypecheckText input globals' 83 | = unsafeExecTypecheck (typecheckText input) (mkState globals') 84 | 85 | mkState :: Globals Text -> TypecheckState Text 86 | mkState globals' = TypecheckState globals' defaultUniques defaultTyUniques 87 | 88 | processExpr :: SystemFExpr Text -> Typecheck Text (TypedExpr Text) 89 | processExpr (Let n expr) = tcAndEval expr >>= addBinding n 90 | processExpr expr = tcAndEval expr 91 | 92 | tcAndEval :: SystemFExpr Text -> Typecheck Text (TypedExpr Text) 93 | tcAndEval expr = do 94 | ty <- typecheck expr 95 | reduced <- evalExpr expr 96 | 97 | pure $ TypedExpr reduced ty 98 | 99 | addBinding :: Text -> TypedExpr Text -> Typecheck Text (TypedExpr Text) 100 | addBinding name expr = modifyGlobals (Map.insert name expr) >> pure expr 101 | -------------------------------------------------------------------------------- /src/Language/Lambda/SystemF/Eval.hs: -------------------------------------------------------------------------------- 1 | module Language.Lambda.SystemF.Eval 2 | ( evalExpr, 3 | subGlobals, 4 | betaReduce, 5 | alphaConvert, 6 | etaConvert, 7 | freeVarsOf 8 | ) where 9 | 10 | import Language.Lambda.Shared.Errors 11 | import Language.Lambda.Shared.UniqueSupply (next) 12 | import Language.Lambda.SystemF.Expression 13 | import Language.Lambda.SystemF.State 14 | 15 | import Control.Monad.Except (throwError) 16 | import Prettyprinter 17 | import RIO 18 | import qualified RIO.Map as Map 19 | 20 | -- | Evaluates an expression 21 | evalExpr 22 | :: (Pretty name, Ord name) 23 | => SystemFExpr name 24 | -> Typecheck name (SystemFExpr name) 25 | evalExpr = evalTopLevel 26 | 27 | -- | Evaluates a top-level expression 28 | evalTopLevel 29 | :: (Pretty name, Ord name) 30 | => SystemFExpr name 31 | -> Typecheck name (SystemFExpr name) 32 | evalTopLevel (Let n expr) = Let n <$> (subGlobals expr >>= evalInner) 33 | evalTopLevel expr = subGlobals expr >>= evalInner 34 | 35 | -- | Evaluates a non top-level expression. Does NOT support Lets 36 | evalInner 37 | :: (Pretty name, Ord name) 38 | => SystemFExpr name 39 | -> Typecheck name (SystemFExpr name) 40 | evalInner (Abs n ty expr) = Abs n ty <$> evalInner expr 41 | evalInner (App e1 e2) = evalApp e1 e2 42 | evalInner (TyAbs n expr) = TyAbs n <$> evalInner expr 43 | evalInner (TyApp expr ty) = evalTyApp expr ty 44 | evalInner (Let n expr) = throwError . InvalidLet . prettyPrint $ Let n expr 45 | evalInner expr = pure expr 46 | 47 | subGlobals :: Ord name => SystemFExpr name -> Typecheck name (SystemFExpr name) 48 | subGlobals expr = getGlobals >>= subGlobals' 49 | where subGlobals' globals' = case expr of 50 | Var x -> pure . maybe expr (view _expr) $ globals' Map.!? x 51 | VarAnn x _ -> pure . maybe expr (view _expr) $ globals' Map.!? x 52 | App e1 e2 -> App <$> subGlobals e1 <*> subGlobals e2 53 | Abs name ty expr' 54 | | Map.member name globals' -> pure expr 55 | | otherwise -> Abs name ty <$> subGlobals expr' 56 | _ -> pure expr 57 | 58 | evalApp 59 | :: (Pretty name, Ord name) 60 | => SystemFExpr name 61 | -> SystemFExpr name 62 | -> Typecheck name (SystemFExpr name) 63 | evalApp e1 e2 = do 64 | e1' <- evalInner e1 65 | e2' <- evalInner e2 66 | 67 | betaReduce e1' e2' 68 | 69 | evalTyApp 70 | :: (Pretty name, Ord name) 71 | => SystemFExpr name 72 | -> Ty name 73 | -> Typecheck name (SystemFExpr name) 74 | evalTyApp expr ty = case expr of 75 | TyAbs name inner -> evalInner $ substituteTyInExpr ty name inner 76 | Abs name (TyForAll tyName ty') inner -> 77 | Abs name (substituteTy ty tyName ty') <$> evalInner inner 78 | VarAnn name (TyForAll tyName ty') -> pure $ VarAnn name (substituteTy ty tyName ty') 79 | _ -> TyApp <$> evalInner expr <*> pure ty 80 | 81 | betaReduce 82 | :: (Ord name, Pretty name) 83 | => SystemFExpr name 84 | -> SystemFExpr name 85 | -> Typecheck name (SystemFExpr name) 86 | betaReduce e1 e2 = case e1 of 87 | App e1' e2' -> App <$> betaReduce e1' e2' <*> pure e2 88 | Abs n _ e1' -> do 89 | converted <- alphaConvert (freeVarsOf e2) e1' 90 | evalInner $ substitute converted n e2 91 | Let _ _ -> throwError ImpossibleError 92 | _ -> pure $ App e1 e2 93 | 94 | alphaConvert 95 | :: (Ord name, Pretty name) 96 | => [name] 97 | -> SystemFExpr name 98 | -> Typecheck name (SystemFExpr name) 99 | alphaConvert freeVars (Abs name ty body) = do 100 | uniques <- getVarUniques 101 | nextName <- next freeVars uniques 102 | alphaConvertAbs name ty body freeVars nextName 103 | alphaConvert _ expr = pure expr 104 | 105 | etaConvert :: Ord name => SystemFExpr name -> SystemFExpr name 106 | etaConvert (Abs name ty body) = case body of 107 | App e1 (Var name') 108 | | name == name' -> etaConvert e1 109 | | otherwise -> Abs name ty (App (etaConvert e1) (Var name')) 110 | body'@Abs{} 111 | | body' == eta' -> Abs name ty body' 112 | | otherwise -> etaConvert $ Abs name ty eta' 113 | where eta' = etaConvert body' 114 | _ -> Abs name ty $ etaConvert body 115 | etaConvert (App e1 e2) = App (etaConvert e1) (etaConvert e2) 116 | etaConvert expr = expr 117 | 118 | substitute 119 | :: Eq name 120 | => SystemFExpr name 121 | -> name 122 | -> SystemFExpr name 123 | -> SystemFExpr name 124 | substitute expr forName inExpr 125 | = case expr of 126 | (Var n) 127 | | n == forName -> inExpr 128 | | otherwise -> expr 129 | (VarAnn n _) 130 | | n == forName -> inExpr 131 | | otherwise -> expr 132 | (Abs n ty body) 133 | | n == forName -> expr 134 | | otherwise -> Abs n ty $ substitute body forName inExpr 135 | (App e1 e2) -> App (sub e1) (sub e2) 136 | (TyAbs n body) -> TyAbs n $ substitute body forName inExpr 137 | (TyApp body ty) -> TyApp (substitute body forName inExpr) ty 138 | _ -> inExpr 139 | where sub expr' = substitute expr' forName inExpr 140 | 141 | substituteTyInExpr 142 | :: Eq name 143 | => Ty name 144 | -> name 145 | -> SystemFExpr name 146 | -> SystemFExpr name 147 | substituteTyInExpr ty forName inExpr 148 | = case inExpr of 149 | VarAnn name ty' -> VarAnn name (substituteTy ty forName ty') 150 | App e1 e2 -> App (sub e1) (sub e2) 151 | Abs name ty' expr -> Abs name (substituteTy ty forName ty') (sub expr) 152 | TyAbs name expr -> TyAbs name (sub expr) 153 | TyApp expr ty' -> TyApp (sub expr) (substituteTy ty forName ty') 154 | _ -> inExpr 155 | where sub = substituteTyInExpr ty forName 156 | 157 | freeVarsOf 158 | :: (Ord name, Pretty name) 159 | => SystemFExpr name 160 | -> [name] 161 | freeVarsOf (Abs n _ expr) = filter (/=n) . freeVarsOf $ expr 162 | freeVarsOf (App e1 e2) = freeVarsOf e1 ++ freeVarsOf e2 163 | freeVarsOf (Var n) = [n] 164 | freeVarsOf (VarAnn n _) = [n] 165 | freeVarsOf (Let _ expr) = freeVarsOf expr 166 | freeVarsOf (TyAbs _ expr) = freeVarsOf expr 167 | freeVarsOf (TyApp expr _) = freeVarsOf expr 168 | 169 | alphaConvertAbs 170 | :: (Ord name, Pretty name) 171 | => name 172 | -> Ty name 173 | -> SystemFExpr name 174 | -> [name] 175 | -> name 176 | -> Typecheck name (SystemFExpr name) 177 | alphaConvertAbs name ty body freeVars nextName 178 | | name `elem` freeVars = pure $ Abs nextName ty (substitute body name (Var nextName)) 179 | | otherwise = Abs name ty <$> alphaConvert freeVars body 180 | -------------------------------------------------------------------------------- /src/Language/Lambda/SystemF/Expression.hs: -------------------------------------------------------------------------------- 1 | module Language.Lambda.SystemF.Expression 2 | ( SystemFExpr(..), 3 | TypedExpr(..), 4 | Ty(..), 5 | _expr, 6 | _ty, 7 | prettyPrint, 8 | substituteTy, 9 | upperLambda 10 | ) where 11 | 12 | import Data.Monoid 13 | import Prettyprinter 14 | import Prettyprinter.Render.Text (renderStrict) 15 | import RIO 16 | 17 | data SystemFExpr name 18 | -- | A global binding: `let x = y` 19 | = Let name (SystemFExpr name) 20 | -- | Variable: `x` 21 | | Var name 22 | -- | Variable annotated with type: `x:T` 23 | | VarAnn name (Ty name) 24 | -- | Function application: `x y` 25 | | App (SystemFExpr name) (SystemFExpr name) 26 | -- | Lambda abstraction: `\x: X. x` 27 | | Abs name (Ty name) (SystemFExpr name) 28 | -- | Type Abstraction: `\X. body` 29 | | TyAbs name (SystemFExpr name) 30 | -- | Type Application: `x [X]` 31 | | TyApp (SystemFExpr name) (Ty name) 32 | deriving (Eq, Show) 33 | 34 | data TypedExpr name = TypedExpr 35 | { teExpr :: SystemFExpr name, 36 | teTy :: Ty name 37 | } deriving (Eq, Show) 38 | 39 | data Ty name 40 | = TyVar name -- ^ Type variable (T) 41 | | TyArrow (Ty name) (Ty name) -- ^ Type arrow (T -> U) 42 | | TyForAll name (Ty name) -- ^ Universal type (forall T. X) 43 | deriving (Show) 44 | 45 | instance (Pretty name) => Pretty (SystemFExpr name) where 46 | pretty (Var name) = pretty name 47 | pretty (VarAnn name ty) = prettyVarAnn name ty 48 | pretty (App e1 e2) = prettyApp e1 e2 49 | pretty (Abs name ty body) = prettyAbs name ty body 50 | pretty (Let name expr) = prettyLet name expr 51 | pretty (TyAbs ty body) = prettyTyAbs ty body 52 | pretty (TyApp expr ty) = prettyTyApp expr ty 53 | 54 | instance Pretty name => Pretty (TypedExpr name) where 55 | pretty expr = pretty (expr ^. _expr) <+> colon <+> pretty (expr ^. _ty) 56 | 57 | instance Pretty name => Pretty (Ty name) where 58 | pretty = prettyTy False 59 | 60 | instance Eq name => Eq (Ty name) where 61 | (==) = isTyEquivalent 62 | 63 | _expr :: Lens' (TypedExpr name) (SystemFExpr name) 64 | _expr = lens teExpr (\res expr -> res { teExpr = expr }) 65 | 66 | _ty :: Lens' (TypedExpr name) (Ty name) 67 | _ty = lens teTy (\res ty -> res { teTy = ty }) 68 | 69 | prettyPrint :: Pretty pretty => pretty -> Text 70 | prettyPrint expr = renderStrict docStream 71 | where docStream = layoutPretty defaultLayoutOptions (pretty expr) 72 | 73 | substituteTy 74 | :: Eq name 75 | => Ty name 76 | -> name 77 | -> Ty name 78 | -> Ty name 79 | substituteTy ty forName inTy 80 | = case inTy of 81 | TyVar n 82 | | n == forName -> ty 83 | | otherwise -> inTy 84 | TyArrow t1 t2 -> TyArrow (sub t1) (sub t2) 85 | TyForAll n ty' 86 | | n == forName -> inTy 87 | | otherwise -> TyForAll n (sub ty') 88 | where sub = substituteTy ty forName 89 | 90 | upperLambda :: Char 91 | upperLambda = 'Λ' 92 | 93 | prettyVarAnn :: Pretty name => name -> Ty name -> Doc a 94 | prettyVarAnn var ty = pretty var <> colon <> prettyTy' ty 95 | where prettyTy' (TyVar _) = prettyTy True ty 96 | prettyTy' _ = parens $ prettyTy True ty 97 | 98 | prettyApp 99 | :: Pretty name 100 | => SystemFExpr name 101 | -> SystemFExpr name 102 | -> Doc a 103 | prettyApp e1@Abs{} e2@Abs{} = parens (pretty e1) <+> parens (pretty e2) 104 | prettyApp e1@Abs{} e2 = parens (pretty e1) <+> pretty e2 105 | prettyApp e1 e2@Abs{} = pretty e1 <+> parens (pretty e2) 106 | prettyApp e1 e2@App{} = pretty e1 <+> parens (pretty e2) 107 | prettyApp e1 e2 = pretty e1 <+> pretty e2 108 | 109 | prettyAbs 110 | :: Pretty name 111 | => name 112 | -> Ty name 113 | -> SystemFExpr name 114 | -> Doc ann 115 | prettyAbs name ty body 116 | = lambda 117 | <+> hsep (map (uncurry prettyArg) names) 118 | <> dot 119 | <+> pretty body' 120 | where (names, body') = uncurryAbs name ty body 121 | 122 | prettyLet :: Pretty name => name -> SystemFExpr name -> Doc ann 123 | prettyLet name expr = "let" <+> pretty name <+> equals <+> pretty expr 124 | 125 | prettyTyAbs :: (Pretty name) => name -> SystemFExpr name -> Doc ann 126 | prettyTyAbs name body = upperLambda' <+> hsep (map pretty names) <> dot 127 | <+> pretty body' 128 | where (names, body') = uncurryTyAbs name body 129 | prettyTyApp :: (Pretty name) => SystemFExpr name -> Ty name -> Doc ann 130 | prettyTyApp expr ty = pretty expr <+> brackets (pretty ty) 131 | 132 | prettyTy :: Pretty name => Bool -> Ty name -> Doc ann 133 | prettyTy _ (TyVar name) = pretty name 134 | prettyTy compact (TyArrow t1 t2) = prettyTyArrow compact t1 t2 135 | prettyTy compact (TyForAll name ty) = prettyTyForAll compact name ty 136 | 137 | isTyEquivalent :: Eq name => Ty name -> Ty name -> Bool 138 | isTyEquivalent t1 t2 139 | | t1 `isTySame` t2 = True 140 | | otherwise = case (t1, t2) of 141 | (TyForAll n1 t1', TyForAll n2 t2') -> (n1, t1') `areForAllsEquivalent` (n2, t2') 142 | _ -> False 143 | 144 | prettyTyArrow :: Pretty name => Bool -> Ty name -> Ty name -> Doc ann 145 | prettyTyArrow compact (TyArrow t1 t2) t3 146 | = prettyTyArrow' compact compositeTy $ prettyTy compact t3 147 | where compositeTy = parens $ prettyTyArrow compact t1 t2 148 | 149 | prettyTyArrow compact t1 t2 150 | = prettyTyArrow' compact (prettyTy compact t1) (prettyTy compact t2) 151 | 152 | prettyTyForAll :: Pretty name => Bool -> name -> Ty name -> Doc ann 153 | prettyTyForAll compact name ty 154 | = "forall" 155 | <+> pretty name <> dot 156 | <+> prettyTy compact ty 157 | 158 | lambda :: Doc ann 159 | lambda = pretty 'λ' 160 | 161 | prettyArg :: (Pretty name, Pretty ty) => name -> Ty ty -> Doc ann 162 | prettyArg name (TyArrow t1 t2) 163 | = pretty name <> colon <> parens (prettyTyArrow True t1 t2) 164 | prettyArg name ty = pretty name <> colon <> pretty ty 165 | 166 | upperLambda' :: Doc ann 167 | upperLambda' = pretty upperLambda 168 | 169 | isTySame :: Eq name => Ty name -> Ty name -> Bool 170 | isTySame (TyVar n1) (TyVar n2) = n1 == n2 171 | isTySame (TyArrow t1 t2) (TyArrow t1' t2') = t1 == t1' && t2 == t2' 172 | isTySame (TyForAll n1 t1) (TyForAll n2 t2) = n1 == n2 && t1 == t2 173 | isTySame _ _ = False 174 | 175 | areForAllsEquivalent :: Eq name => (name, Ty name) -> (name, Ty name) -> Bool 176 | areForAllsEquivalent (n1, t1) (n2, t2) = t1 == substituteTy (TyVar n1) n2 t2 177 | 178 | prettyTyArrow' :: Bool -> Doc ann -> Doc ann -> Doc ann 179 | prettyTyArrow' compact doc1 doc2 = doc1 `add'` "->" `add'` doc2 180 | where add' 181 | | compact = (<>) 182 | | otherwise = (<+>) 183 | 184 | uncurryAbs :: n -> Ty n -> SystemFExpr n -> ([(n, Ty n)], SystemFExpr n) 185 | uncurryAbs name ty = uncurry' [(name, ty)] 186 | where uncurry' ns (Abs n' t' body') = uncurry' ((n', t'):ns) body' 187 | uncurry' ns body' = (reverse ns, body') 188 | 189 | uncurryTyAbs :: n -> SystemFExpr n -> ([n], SystemFExpr n) 190 | uncurryTyAbs ty = uncurry' [ty] 191 | where uncurry' ts (TyAbs t' body') = uncurry' (t':ts) body' 192 | uncurry' ts body' = (reverse ts, body') 193 | -------------------------------------------------------------------------------- /src/Language/Lambda/SystemF/Parser.hs: -------------------------------------------------------------------------------- 1 | module Language.Lambda.SystemF.Parser ( 2 | parseExpr, 3 | parseType 4 | ) where 5 | 6 | import Control.Monad 7 | import Data.Functor 8 | import RIO hiding ((<|>), abs, many, try) 9 | import qualified RIO.Text as Text 10 | 11 | import Text.Parsec 12 | import Text.Parsec.Text 13 | 14 | import Language.Lambda.SystemF.Expression 15 | 16 | parseExpr :: Text -> Either ParseError (SystemFExpr Text) 17 | parseExpr = parse (whitespace *> topLevelExpr <* eof) "" 18 | 19 | parseType :: Text -> Either ParseError (Ty Text) 20 | parseType = parse (whitespace *> ty <* eof) "" 21 | 22 | -- Lets can only be at the top level 23 | topLevelExpr :: Parser (SystemFExpr Text) 24 | topLevelExpr = let' <|> expr 25 | 26 | -- Parse expressions 27 | expr :: Parser (SystemFExpr Text) 28 | expr = try tyapp <|> try app <|> term 29 | 30 | app :: Parser (SystemFExpr Text) 31 | app = chainl1 term (return App) 32 | 33 | tyapp :: Parser (SystemFExpr Text) 34 | tyapp = TyApp 35 | <$> term 36 | <*> ty' 37 | where ty' = symbol '[' *> ty <* symbol ']' 38 | 39 | term :: Parser (SystemFExpr Text) 40 | term = try abs <|> tyabs <|> var <|> parens expr 41 | 42 | let' :: Parser (SystemFExpr Text) 43 | let' = Let <$> ident <*> expr 44 | where ident = symbol' "let" *> exprId <* symbol '=' 45 | 46 | var :: Parser (SystemFExpr Text) 47 | var = try varann <|> var' 48 | where var' = Var <$> exprId 49 | varann = VarAnn <$> (exprId <* symbol ':') <*> ty 50 | 51 | abs :: Parser (SystemFExpr Text) 52 | abs = curry' 53 | <$> (symbol '\\' *> many1 args <* symbol '.') 54 | <*> expr 55 | where args = (,) <$> (exprId <* symbol ':') <*> ty 56 | curry' = flip . foldr . uncurry $ Abs 57 | 58 | tyabs :: Parser (SystemFExpr Text) 59 | tyabs = curry' <$> args <*> expr 60 | where args = symbol '\\' *> many1 typeId <* symbol '.' 61 | curry' = flip (foldr TyAbs) 62 | 63 | -- Parse type expressions 64 | ty :: Parser (Ty Text) 65 | ty = try forall <|> try arrow 66 | 67 | forall :: Parser (Ty Text) 68 | forall = curry' <$> args <*> ty 69 | where args = symbol' "forall" *> many1 typeId <* symbol '.' 70 | curry' = flip $ foldr TyForAll 71 | 72 | arrow :: Parser (Ty Text) 73 | arrow = chainr1 tyterm (symbol' "->" $> TyArrow) 74 | 75 | tyterm :: Parser (Ty Text) 76 | tyterm = tyvar <|> parens ty 77 | 78 | tyvar :: Parser (Ty Text) 79 | tyvar = TyVar <$> typeId 80 | 81 | parens :: Parser a -> Parser a 82 | parens p = symbol '(' *> p <* symbol ')' 83 | 84 | identifier :: Parser Char -> Parser Text 85 | identifier firstChar = lexeme $ Text.cons <$> first' <*> (Text.pack <$> many rest) 86 | where first' = firstChar <|> char '_' 87 | rest = first' <|> digit 88 | 89 | typeId, exprId :: Parser Text 90 | typeId = identifier upper 91 | exprId = identifier lower 92 | 93 | whitespace :: Parser () 94 | whitespace = void . many . oneOf $ " \t" 95 | 96 | symbol :: Char -> Parser () 97 | symbol = void . lexeme . char 98 | 99 | symbol' :: Text -> Parser () 100 | symbol' = void . lexeme . string . Text.unpack 101 | 102 | lexeme :: Parser a -> Parser a 103 | lexeme p = p <* whitespace 104 | -------------------------------------------------------------------------------- /src/Language/Lambda/SystemF/State.hs: -------------------------------------------------------------------------------- 1 | module Language.Lambda.SystemF.State 2 | ( TypecheckState(..), 3 | Typecheck(), 4 | Context(), 5 | Binding(..), 6 | Globals(), 7 | runTypecheck, 8 | execTypecheck, 9 | unsafeRunTypecheck, 10 | unsafeExecTypecheck, 11 | mkTypecheckState, 12 | _context, 13 | _globals, 14 | _varUniques, 15 | _tyUniques, 16 | getContext, 17 | getGlobals, 18 | getVarUniques, 19 | getTyUniques, 20 | modifyGlobals, 21 | modifyVarUniques, 22 | modifyTyUniques, 23 | setGlobals, 24 | setVarUniques, 25 | setTyUniques 26 | ) where 27 | 28 | import Language.Lambda.Shared.Errors (LambdaException(..)) 29 | import Language.Lambda.SystemF.Expression 30 | 31 | import Control.Monad.Except (Except(), runExcept) 32 | import RIO 33 | import RIO.State 34 | import qualified RIO.Map as Map 35 | 36 | data TypecheckState name = TypecheckState 37 | { tsGlobals :: Globals name, 38 | tsVarUniques :: [name], -- ^ A unique supply of term-level variables 39 | tsTyUniques :: [name] -- ^ A unique supply of type-level variables 40 | } deriving (Eq, Show) 41 | 42 | type Typecheck name 43 | = StateT (TypecheckState name) 44 | (Except LambdaException) 45 | 46 | type Globals name = Map name (TypedExpr name) 47 | 48 | type Context name = Map name (Binding name) 49 | 50 | data Binding name 51 | = BindTerm (Ty name) 52 | | BindTy 53 | deriving (Eq, Show) 54 | 55 | runTypecheck 56 | :: Typecheck name result 57 | -> TypecheckState name 58 | -> Either LambdaException (result, TypecheckState name) 59 | runTypecheck computation = runExcept . runStateT computation 60 | 61 | execTypecheck 62 | :: Typecheck name result 63 | -> TypecheckState name 64 | -> Either LambdaException result 65 | execTypecheck computation = runExcept . evalStateT computation 66 | 67 | unsafeRunTypecheck 68 | :: Typecheck name result 69 | -> TypecheckState name 70 | -> (result, TypecheckState name) 71 | unsafeRunTypecheck computation state' = either impureThrow id tcResult 72 | where tcResult = runTypecheck computation state' 73 | 74 | unsafeExecTypecheck :: Typecheck name result -> TypecheckState name -> result 75 | unsafeExecTypecheck computation state' = either impureThrow id tcResult 76 | where tcResult = execTypecheck computation state' 77 | 78 | mkTypecheckState :: [name] -> [name] -> TypecheckState name 79 | mkTypecheckState = TypecheckState Map.empty 80 | 81 | _context :: SimpleGetter (TypecheckState name) (Context name) 82 | _context = to (getContext' . tsGlobals) 83 | where getContext' :: Globals name -> Context name 84 | getContext' = Map.map (\expr -> BindTerm (expr ^. _ty)) 85 | 86 | _globals :: Lens' (TypecheckState name) (Globals name) 87 | _globals f state' = (\globals' -> state' { tsGlobals = globals' }) 88 | <$> f (tsGlobals state') 89 | 90 | _varUniques :: Lens' (TypecheckState name) [name] 91 | _varUniques f state' = (\uniques' -> state' { tsVarUniques = uniques' }) 92 | <$> f (tsVarUniques state') 93 | 94 | _tyUniques :: Lens' (TypecheckState name) [name] 95 | _tyUniques f state' = (\uniques' -> state' { tsTyUniques = uniques' }) 96 | <$> f (tsTyUniques state') 97 | 98 | getVarUniques :: Typecheck name [name] 99 | getVarUniques = gets (^. _varUniques) 100 | 101 | getTyUniques :: Typecheck name [name] 102 | getTyUniques = gets (^. _tyUniques) 103 | 104 | getContext :: Typecheck name (Context name) 105 | getContext = gets (^. _context) 106 | 107 | getGlobals :: Typecheck name (Globals name) 108 | getGlobals = gets (^. _globals) 109 | 110 | modifyGlobals :: (Globals name -> Globals name) -> Typecheck name () 111 | modifyGlobals f = modify $ _globals %~ f 112 | 113 | modifyVarUniques :: ([name] -> [name]) -> Typecheck name () 114 | modifyVarUniques f = modify $ _varUniques %~ f 115 | 116 | modifyTyUniques :: ([name] -> [name]) -> Typecheck name () 117 | modifyTyUniques f = modify $ _tyUniques %~ f 118 | 119 | setVarUniques :: [name] -> Typecheck name () 120 | setVarUniques uniques' = modify $ _varUniques .~ uniques' 121 | 122 | setTyUniques :: [name] -> Typecheck name () 123 | setTyUniques uniques' = modify $ _tyUniques .~ uniques' 124 | 125 | setGlobals :: Globals name -> Typecheck name () 126 | setGlobals globals' = modify $ _globals .~ globals' 127 | -------------------------------------------------------------------------------- /src/Language/Lambda/SystemF/TypeCheck.hs: -------------------------------------------------------------------------------- 1 | module Language.Lambda.SystemF.TypeCheck where 2 | 3 | import Language.Lambda.Shared.Errors (LambdaException(..)) 4 | import Language.Lambda.SystemF.Expression 5 | import Language.Lambda.SystemF.State 6 | 7 | import Control.Monad.Except (MonadError(..)) 8 | import Prettyprinter 9 | import RIO 10 | import qualified RIO.Map as Map 11 | 12 | type UniqueSupply n = [n] 13 | type Context' n t = Map n t 14 | 15 | typecheck 16 | :: (Ord name, Pretty name) 17 | => SystemFExpr name 18 | -> Typecheck name (Ty name) 19 | typecheck expr = do 20 | ctx <- getContext 21 | typecheckTopLevel ctx expr 22 | 23 | typecheckTopLevel 24 | :: (Ord name, Pretty name) 25 | => Context name 26 | -> SystemFExpr name 27 | -> Typecheck name (Ty name) 28 | typecheckTopLevel ctx (Let n expr) = typecheckLet ctx n expr 29 | typecheckTopLevel ctx expr = typecheckExpr ctx expr 30 | 31 | typecheckLet 32 | :: (Pretty name, Ord name) 33 | => Context name 34 | -> name 35 | -> SystemFExpr name 36 | -> Typecheck name (Ty name) 37 | typecheckLet ctx _ = typecheckExpr ctx 38 | 39 | typecheckExpr 40 | :: (Ord name, Pretty name) 41 | => Context name 42 | -> SystemFExpr name 43 | -> Typecheck name (Ty name) 44 | typecheckExpr ctx (Var v) = typecheckVar ctx v 45 | typecheckExpr ctx (VarAnn v ty) = typecheckVarAnn ctx v ty 46 | typecheckExpr ctx (Abs n t body) = typecheckAbs ctx n t body 47 | typecheckExpr ctx (App e1 e2) = typecheckApp ctx e1 e2 48 | typecheckExpr ctx (TyAbs t body) = typecheckTyAbs ctx t body 49 | typecheckExpr ctx (TyApp e ty) = typecheckTyApp ctx e ty 50 | typecheckExpr _ (Let _ _) = throwError ImpossibleError 51 | 52 | typecheckVar :: Ord name => Context name -> name -> Typecheck name (Ty name) 53 | typecheckVar ctx = defaultToUnique . typecheckVar' ctx 54 | where defaultToUnique = maybe (TyVar <$> tyUnique) pure 55 | 56 | typecheckVarAnn 57 | :: (Ord name, Pretty name) 58 | => Context name 59 | -> name 60 | -> Ty name 61 | -> Typecheck name (Ty name) 62 | typecheckVarAnn ctx var ty = maybe (pure ty) checkContextType maybeTy 63 | where checkContextType ty' 64 | | ty' == ty = pure ty 65 | | otherwise = throwError $ tyMismatchError ty' ty 66 | maybeTy = typecheckVar' ctx var 67 | 68 | typecheckAbs 69 | :: (Ord name, Pretty name) 70 | => Context name 71 | -> name 72 | -> Ty name 73 | -> SystemFExpr name 74 | -> Typecheck name (Ty name) 75 | typecheckAbs ctx name ty body = typecheckAbs' ty' (Map.insert name (BindTerm ty') ctx) 76 | where typecheckAbs' (TyForAll tyName tyBody) ctx' = do 77 | inner <- typecheckExpr (Map.insert tyName BindTy ctx') body 78 | pure $ TyForAll tyName (TyArrow tyBody inner) 79 | typecheckAbs' t ctx' = TyArrow t <$> typecheckExpr ctx' body 80 | 81 | ty' = liftForAlls ty 82 | 83 | typecheckApp 84 | :: (Ord name, Pretty name) 85 | => Context name 86 | -> SystemFExpr name 87 | -> SystemFExpr name 88 | -> Typecheck name (Ty name) 89 | typecheckApp ctx e1 e2 = do 90 | -- Typecheck expressions 91 | t1 <- typecheckExpr ctx e1 92 | t2 <- typecheckExpr ctx e2 93 | 94 | (t1AppInput, t1AppOutput) <- case t1 of 95 | (TyArrow appInput appOutput) -> pure (appInput, appOutput) 96 | (TyForAll n1 (TyArrow appInput _)) 97 | -> pure (TyForAll n1 appInput, t2) 98 | _ -> throwError $ TyMismatchError "Not Arrow" 99 | 100 | -- Verify the output of e1 matches the type of e2 101 | if t1AppInput `isTyEquivalent` t2 102 | then return t1AppOutput 103 | else throwError $ tyMismatchError (TyArrow t2 t1AppOutput) (TyArrow t1 t1AppOutput) 104 | 105 | typecheckTyAbs 106 | :: (Ord name, Pretty name) 107 | => Context name 108 | -> name 109 | -> SystemFExpr name 110 | -> Typecheck name (Ty name) 111 | typecheckTyAbs ctx ty body = TyForAll ty <$> typecheckExpr ctx' body 112 | where ctx' = Map.insert ty BindTy ctx 113 | 114 | typecheckTyApp 115 | :: (Ord name, Pretty name) 116 | => Context name 117 | -> SystemFExpr name 118 | -> Ty name 119 | -> Typecheck name (Ty name) 120 | typecheckTyApp ctx expr ty = do 121 | -- Clear in-scope type variables 122 | let ctx' = Map.filter isTyBind ctx 123 | 124 | typecheckExpr ctx' expr >>= \case 125 | TyForAll tyName tyBody -> pure $ substituteTy ty tyName tyBody 126 | _ -> do 127 | err <- tyAppMismatchError ctx expr ty 128 | throwError err 129 | 130 | where 131 | isTyBind BindTy = False 132 | isTyBind _ = True 133 | 134 | typecheckVar' :: Ord name => Context name -> name -> Maybe (Ty name) 135 | typecheckVar' ctx var = Map.lookup var ctx >>= \case 136 | BindTerm ty@(TyForAll tyName tyBody) 137 | | Map.member tyName ctx -> Just tyBody 138 | | otherwise -> Just ty 139 | BindTerm ty -> Just ty 140 | BindTy -> Nothing 141 | 142 | liftForAlls :: Ty name -> Ty name 143 | liftForAlls ty = foldr TyForAll res tyNames 144 | where (tyNames, res) = liftForAlls' ty 145 | 146 | liftForAlls' :: Ty name -> ([name], Ty name) 147 | liftForAlls' (TyVar name) = ([], TyVar name) 148 | liftForAlls' (TyForAll name body) = (name:names, body') 149 | where (names, body') = liftForAlls' body 150 | liftForAlls' (TyArrow t1 t2) = (n1 ++ n2, TyArrow t1' t2') 151 | where (n1, t1') = liftForAlls' t1 152 | (n2, t2') = liftForAlls' t2 153 | 154 | isTyEquivalent :: Ord name => Ty name -> Ty name -> Bool 155 | isTyEquivalent t1 t2 156 | | t1 == t2 = True 157 | | otherwise = case (t1, t2) of 158 | (TyForAll n1 t1', TyForAll n2 t2') -> (n1, t1') `areForAllsEquivalent` (n2, t2') 159 | _ -> False 160 | 161 | areForAllsEquivalent :: Ord name => (name, Ty name) -> (name, Ty name) -> Bool 162 | areForAllsEquivalent (n1, t1) (n2, t2) = t1 == substituteTy (TyVar n1) n2 t2 163 | 164 | tyUnique :: Typecheck name name 165 | tyUnique = getTyUniques >>= tyUnique' 166 | where tyUnique' (u:us) = setTyUniques us $> u 167 | tyUnique' _ = throwError ImpossibleError 168 | 169 | tyMismatchError 170 | :: Pretty ty => ty -> ty -> LambdaException 171 | tyMismatchError expected actual 172 | = TyMismatchError 173 | $ "Couldn't match expected type " 174 | <> prettyPrint expected 175 | <> " with actual type " 176 | <> prettyPrint actual 177 | 178 | tyAppMismatchError 179 | :: (Ord name, Pretty name) 180 | => Context name 181 | -> SystemFExpr name 182 | -> Ty name 183 | -> Typecheck name LambdaException 184 | tyAppMismatchError ctx expr appTy = tyAppMismatchError' <$> typecheckExpr ctx expr 185 | where tyAppMismatchError' actual = TyMismatchError 186 | $ "Cannot apply type " 187 | <> prettyPrint appTy 188 | <> " to non-polymorphic type " 189 | <> prettyPrint actual 190 | -------------------------------------------------------------------------------- /src/Language/Lambda/Untyped.hs: -------------------------------------------------------------------------------- 1 | module Language.Lambda.Untyped ( 2 | evalText, 3 | runEvalText, 4 | execEvalText, 5 | unsafeExecEvalText, 6 | defaultUniques, 7 | 8 | module Language.Lambda.Untyped.Expression, 9 | module Language.Lambda.Untyped.Eval, 10 | module Language.Lambda.Untyped.Parser, 11 | module Language.Lambda.Untyped.State 12 | ) where 13 | 14 | import Control.Monad.Except 15 | import Data.Either 16 | import RIO 17 | import qualified RIO.Text as Text 18 | 19 | import Language.Lambda.Shared.Errors 20 | import Language.Lambda.Shared.UniqueSupply (defaultUniques) 21 | import Language.Lambda.Untyped.Eval 22 | import Language.Lambda.Untyped.Expression 23 | import Language.Lambda.Untyped.Parser 24 | import Language.Lambda.Untyped.State 25 | 26 | evalText :: Text -> Eval Text (LambdaExpr Text) 27 | evalText = either throwParseError evalExpr . parseExpr 28 | where throwParseError = throwError . ParseError . Text.pack . show 29 | 30 | runEvalText 31 | :: Text 32 | -> Globals Text 33 | -> Either LambdaException (LambdaExpr Text, EvalState Text) 34 | runEvalText input globals' = runEval (evalText input) (mkState globals') 35 | 36 | execEvalText 37 | :: Text 38 | -> Globals Text 39 | -> Either LambdaException (LambdaExpr Text) 40 | execEvalText input globals' = execEval (evalText input) (mkState globals') 41 | 42 | unsafeExecEvalText 43 | :: Text 44 | -> Globals Text 45 | -> LambdaExpr Text 46 | unsafeExecEvalText input globals' 47 | = unsafeExecEval (evalText input) (mkState globals') 48 | 49 | mkState :: Globals Text -> EvalState Text 50 | mkState = flip EvalState defaultUniques 51 | -------------------------------------------------------------------------------- /src/Language/Lambda/Untyped/Eval.hs: -------------------------------------------------------------------------------- 1 | module Language.Lambda.Untyped.Eval 2 | ( EvalState(..), 3 | evalExpr, 4 | subGlobals, 5 | betaReduce, 6 | alphaConvert, 7 | etaConvert, 8 | freeVarsOf 9 | ) where 10 | 11 | import Control.Monad.Except 12 | import Prettyprinter 13 | import RIO 14 | import RIO.List (find) 15 | import qualified RIO.Map as Map 16 | 17 | import Language.Lambda.Shared.Errors 18 | import Language.Lambda.Untyped.Expression 19 | import Language.Lambda.Untyped.State 20 | 21 | -- | Evaluate an expression 22 | evalExpr :: (Pretty name, Ord name) => LambdaExpr name -> Eval name (LambdaExpr name) 23 | evalExpr (Let name expr) = do 24 | globals' <- getGlobals 25 | result <- evalExpr' $ subGlobals globals' expr 26 | 27 | setGlobals $ Map.insert name result globals' 28 | 29 | return $ Let name result 30 | 31 | evalExpr expr = do 32 | globals' <- getGlobals 33 | evalExpr' $ subGlobals globals' expr 34 | 35 | -- | Evaluate an expression; does not support `let` 36 | evalExpr' :: (Eq name, Pretty name) => LambdaExpr name -> Eval name (LambdaExpr name) 37 | evalExpr' expr@(Var _) = return expr 38 | evalExpr' (Abs name expr) = Abs name <$> evalExpr' expr 39 | evalExpr' (App e1 e2) = do 40 | e1' <- evalExpr' e1 41 | e2' <- evalExpr' e2 42 | betaReduce e1' e2' 43 | evalExpr' expr@(Let _ _) = throwError . InvalidLet . prettyPrint $ expr 44 | 45 | -- | Look up free vars that have global bindings and substitute them 46 | subGlobals 47 | :: Ord name 48 | => Map name (LambdaExpr name) 49 | -> LambdaExpr name 50 | -> LambdaExpr name 51 | subGlobals globals' expr@(Var x) = Map.findWithDefault expr x globals' 52 | subGlobals globals' (App e1 e2) = App (subGlobals globals' e1) (subGlobals globals' e2) 53 | subGlobals globals' (Abs name expr) = Abs name expr' 54 | where expr' 55 | | Map.member name globals' = expr 56 | | otherwise = subGlobals globals' expr 57 | subGlobals _ expr = expr 58 | 59 | -- | Function application 60 | betaReduce 61 | :: (Eq name, Pretty name) 62 | => LambdaExpr name 63 | -> LambdaExpr name 64 | -> Eval name (LambdaExpr name) 65 | betaReduce expr@(Var _) e2 = return $ App expr e2 66 | betaReduce (App e1 e1') e2 = do 67 | reduced <- betaReduce e1 e1' 68 | return $ App reduced e2 69 | betaReduce (Abs n e1) e2 = do 70 | e1' <- alphaConvert (freeVarsOf e2) e1 71 | evalExpr' $ substitute e1' n e2 72 | betaReduce _ _ = throwError ImpossibleError 73 | 74 | -- | Rename abstraction parameters to avoid name captures 75 | alphaConvert :: Eq name => [name] -> LambdaExpr name -> Eval name (LambdaExpr name) 76 | alphaConvert freeVars (Abs name body) = do 77 | uniques' <- getUniques 78 | let nextVar = fromMaybe name $ find (`notElem` freeVars) uniques' 79 | 80 | if name `elem` freeVars 81 | then return $ Abs nextVar (substitute body name (Var nextVar)) 82 | else Abs name <$> alphaConvert freeVars body 83 | 84 | alphaConvert _ expr = return expr 85 | 86 | -- | Eliminite superfluous abstractions 87 | etaConvert :: Eq n => LambdaExpr n -> LambdaExpr n 88 | etaConvert (Abs n (App e1 (Var n'))) 89 | | n == n' = etaConvert e1 90 | | otherwise = Abs n (App (etaConvert e1) (Var n')) 91 | etaConvert (Abs n e@(Abs _ _)) 92 | -- If `etaConvert e == e` then etaConverting it will create an infinite loop 93 | | e == e' = Abs n e' 94 | | otherwise = etaConvert (Abs n e') 95 | where e' = etaConvert e 96 | etaConvert (Abs n expr) = Abs n (etaConvert expr) 97 | etaConvert (App e1 e2) = App (etaConvert e1) (etaConvert e2) 98 | etaConvert expr = expr 99 | 100 | -- | Substitute an expression for a variable name in another expression 101 | substitute :: Eq name => LambdaExpr name -> name -> LambdaExpr name -> LambdaExpr name 102 | substitute subExpr@(Var name) subName inExpr 103 | | name == subName = inExpr 104 | | otherwise = subExpr 105 | 106 | substitute subExpr@(Abs name expr) subName inExpr 107 | | name == subName = subExpr 108 | | otherwise = Abs name (substitute expr subName inExpr) 109 | 110 | substitute (App e1 e2) subName inExpr 111 | = App (sub e1) (sub e2) 112 | where sub expr = substitute expr subName inExpr 113 | 114 | substitute _ _ expr = expr 115 | 116 | -- | Find the free variables in an expression 117 | freeVarsOf :: Eq n => LambdaExpr n -> [n] 118 | freeVarsOf (Abs n expr) = filter (/=n) . freeVarsOf $ expr 119 | freeVarsOf (App e1 e2) = freeVarsOf e1 ++ freeVarsOf e2 120 | freeVarsOf (Var n) = [n] 121 | freeVarsOf _ = [] 122 | -------------------------------------------------------------------------------- /src/Language/Lambda/Untyped/Expression.hs: -------------------------------------------------------------------------------- 1 | module Language.Lambda.Untyped.Expression 2 | ( LambdaExpr(..), 3 | lambda, 4 | prettyPrint 5 | ) where 6 | 7 | import RIO 8 | import Prettyprinter 9 | import Prettyprinter.Render.Text (renderStrict) 10 | 11 | data LambdaExpr name 12 | = Var name -- ^ Variables 13 | | App (LambdaExpr name) (LambdaExpr name) -- ^ Application 14 | | Abs name (LambdaExpr name) -- ^ Abstractions 15 | | Let name (LambdaExpr name) -- ^ Let bindings 16 | deriving (Eq, Show) 17 | 18 | instance Pretty name => Pretty (LambdaExpr name) where 19 | pretty (Var name) = pretty name 20 | pretty (Abs name body) = prettyAbs name body 21 | pretty (App e1 e2) = prettyApp e1 e2 22 | pretty (Let name body) = prettyLet name body 23 | 24 | prettyPrint :: Pretty name => LambdaExpr name -> Text 25 | prettyPrint expr = renderStrict docStream 26 | where docStream = layoutPretty defaultLayoutOptions (pretty expr) 27 | 28 | lambda :: Char 29 | lambda = 'λ' 30 | 31 | prettyAbs :: Pretty name => name -> LambdaExpr name -> Doc a 32 | prettyAbs name body 33 | = lambda' <> hsep (map pretty names) <> dot 34 | <+> pretty body' 35 | where (names, body') = uncurryAbs name body 36 | 37 | prettyApp :: Pretty name => LambdaExpr name -> LambdaExpr name -> Doc a 38 | prettyApp e1@(Abs _ _) e2@(Abs _ _) = parens (pretty e1) <+> parens (pretty e2) 39 | prettyApp e1@(Abs _ _) e2 = parens (pretty e1) <+> pretty e2 40 | prettyApp e1 e2@(Abs _ _) = pretty e1 <+> parens (pretty e2) 41 | prettyApp e1 e2@(App _ _) = pretty e1 <+> parens (pretty e2) 42 | prettyApp e1 e2 = pretty e1 <+> pretty e2 43 | 44 | prettyLet :: Pretty name => name -> LambdaExpr name -> Doc a 45 | prettyLet name body 46 | = pretty ("let"::Text) 47 | <+> pretty name 48 | <+> "=" 49 | <+> pretty body 50 | 51 | lambda' :: Doc ann 52 | lambda' = pretty lambda 53 | 54 | uncurryAbs :: n -> LambdaExpr n -> ([n], LambdaExpr n) 55 | uncurryAbs n = uncurry' [n] 56 | where uncurry' ns (Abs n' body') = uncurry' (n':ns) body' 57 | uncurry' ns body' = (reverse ns, body') 58 | -------------------------------------------------------------------------------- /src/Language/Lambda/Untyped/Parser.hs: -------------------------------------------------------------------------------- 1 | module Language.Lambda.Untyped.Parser 2 | ( parseExpr, 3 | module Text.Parsec 4 | ) where 5 | 6 | import Control.Monad 7 | import RIO hiding ((<|>), abs, curry, many, try) 8 | import qualified RIO.Text as Text 9 | 10 | import Text.Parsec 11 | import Text.Parsec.Text 12 | 13 | import Language.Lambda.Untyped.Expression 14 | 15 | parseExpr :: Text -> Either ParseError (LambdaExpr Text) 16 | parseExpr = parse (whitespace *> expr <* eof) "" 17 | 18 | expr :: Parser (LambdaExpr Text) 19 | expr = try app <|> term 20 | 21 | term :: Parser (LambdaExpr Text) 22 | term = let' <|> abs <|> var <|> parens 23 | 24 | var :: Parser (LambdaExpr Text) 25 | var = Var <$> identifier 26 | 27 | abs :: Parser (LambdaExpr Text) 28 | abs = curry <$> idents <*> expr 29 | where idents = symbol '\\' *> many1 identifier <* symbol '.' 30 | curry = flip (foldr Abs) 31 | 32 | app :: Parser (LambdaExpr Text) 33 | app = chainl1 term (return App) 34 | 35 | let' :: Parser (LambdaExpr Text) 36 | let' = Let <$> ident <*> expr 37 | where ident = keyword "let" *> identifier <* symbol '=' 38 | 39 | parens :: Parser (LambdaExpr Text) 40 | parens = symbol '(' *> expr <* symbol ')' 41 | 42 | lexeme :: Parser a -> Parser a 43 | lexeme p = p <* whitespace 44 | 45 | whitespace :: Parser () 46 | whitespace = void . many . oneOf $ " \t" 47 | 48 | identifier :: Parser Text 49 | identifier = lexeme $ Text.cons <$> first' <*> (Text.pack <$> many rest) 50 | where first' = letter <|> char '_' 51 | rest = first' <|> digit 52 | 53 | symbol :: Char -> Parser () 54 | symbol = void . lexeme . char 55 | 56 | keyword :: Text -> Parser () 57 | keyword = void . lexeme . string . Text.unpack 58 | -------------------------------------------------------------------------------- /src/Language/Lambda/Untyped/State.hs: -------------------------------------------------------------------------------- 1 | module Language.Lambda.Untyped.State 2 | ( EvalState(..), 3 | Eval(), 4 | Globals(), 5 | runEval, 6 | execEval, 7 | unsafeExecEval, 8 | unsafeRunEval, 9 | globals, 10 | uniques, 11 | mkEvalState, 12 | getGlobals, 13 | getUniques, 14 | setGlobals, 15 | setUniques 16 | ) where 17 | 18 | import Language.Lambda.Shared.Errors 19 | import Language.Lambda.Untyped.Expression 20 | 21 | import Control.Monad.Except 22 | import RIO 23 | import RIO.State 24 | import qualified RIO.Map as Map 25 | 26 | -- | The evaluation state 27 | data EvalState name = EvalState 28 | { esGlobals :: Globals name, 29 | esUniques :: [name] -- ^ Unused unique names 30 | } 31 | 32 | -- | A stateful computation 33 | type Eval name 34 | = StateT (EvalState name) 35 | (Except LambdaException) 36 | 37 | -- | A mapping of global variables to expressions 38 | type Globals name = Map name (LambdaExpr name) 39 | 40 | -- | Run an evalualation 41 | runEval :: Eval name result -> EvalState name -> Either LambdaException (result, EvalState name) 42 | runEval computation = runExcept . runStateT computation 43 | 44 | -- | Run an evalualation, throwing away the final state 45 | execEval :: Eval name result -> EvalState name -> Either LambdaException result 46 | execEval computation = runExcept . evalStateT computation 47 | 48 | -- | Run an evaluation. If the result is an error, throws it 49 | unsafeRunEval :: Eval name result -> EvalState name -> (result, EvalState name) 50 | unsafeRunEval computation state' 51 | = case runEval computation state' of 52 | Left err -> error $ show err 53 | Right res -> res 54 | 55 | -- | Run an evaluation, throwing away the final state. If the result is an error, throws it 56 | unsafeExecEval:: Eval name result -> EvalState name -> result 57 | unsafeExecEval computation state' 58 | = case execEval computation state' of 59 | Left err -> impureThrow err 60 | Right res -> res 61 | 62 | -- | Create an EvalState 63 | mkEvalState :: [name] -> EvalState name 64 | mkEvalState = EvalState Map.empty 65 | 66 | globals :: Lens' (EvalState name) (Globals name) 67 | globals f state' 68 | = (\globals' -> state' { esGlobals = globals' }) 69 | <$> f (esGlobals state') 70 | 71 | uniques :: Lens' (EvalState name) [name] 72 | uniques f state' 73 | = (\uniques' -> state' { esUniques = uniques' }) 74 | <$> f (esUniques state') 75 | 76 | -- | Access globals from the state monad 77 | getGlobals :: Eval name (Globals name) 78 | getGlobals = gets (^. globals) 79 | 80 | -- | Access unique supply from state monad 81 | getUniques :: Eval name [name] 82 | getUniques = gets (^. uniques) 83 | 84 | setGlobals :: Globals name -> Eval name () 85 | setGlobals globals' = modify (& globals .~ globals') 86 | 87 | setUniques :: [name] -> Eval name () 88 | setUniques uniques' = modify (& uniques .~ uniques') 89 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-18.18 2 | 3 | packages: 4 | - '.' 5 | 6 | extra-deps: 7 | - Shellac-0.9.9 8 | - Shellac-haskeline-0.2.1 9 | 10 | nix: 11 | shell-file: shell.nix 12 | -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: 7 | - completed: 8 | pantry-tree: 9 | sha256: 3c976e2387a598452163f65a14b2cce9f2ffe0e5cc15e15ada173d34cbcdc465 10 | size: 918 11 | hackage: Shellac-0.9.9@sha256:3ffcc6aa147ae304774ddde0cd56e92f8d913f12d2e4a7d7fc0e66b7019007db,1984 12 | original: 13 | hackage: Shellac-0.9.9 14 | - completed: 15 | pantry-tree: 16 | sha256: 4f98a09ec110da209e58f809b7015448426430014fbd1d15366809a94b3533b9 17 | size: 244 18 | hackage: Shellac-haskeline-0.2.1@sha256:c0fe9917222253f24738fe1feda8150625a4b5034bb21757ae8eba8d92760a10,1052 19 | original: 20 | hackage: Shellac-haskeline-0.2.1 21 | snapshots: 22 | - completed: 23 | sha256: 63539429076b7ebbab6daa7656cfb079393bf644971156dc349d7c0453694ac2 24 | size: 586296 25 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/18.yaml 26 | original: lts-18.18 27 | -------------------------------------------------------------------------------- /test/Language/Lambda/SystemF/EvalSpec.hs: -------------------------------------------------------------------------------- 1 | module Language.Lambda.SystemF.EvalSpec (spec) where 2 | 3 | import RIO 4 | import RIO.Map (fromList) 5 | import Test.Hspec 6 | 7 | import Language.Lambda.Shared.Errors 8 | import Language.Lambda.Shared.UniqueSupply (defaultUniques, defaultTyUniques) 9 | import Language.Lambda.SystemF.Expression 10 | import Language.Lambda.SystemF.Eval 11 | import Language.Lambda.SystemF.HspecUtils 12 | import Language.Lambda.SystemF.State 13 | 14 | spec :: Spec 15 | spec = do 16 | let evalExpr' expr = execTypecheck (evalExpr expr) $ 17 | mkTypecheckState defaultUniques defaultTyUniques 18 | 19 | describe "evalExpr" $ do 20 | it "Does not reduce normal form" $ do 21 | "x" `shouldEvalTo` "x" 22 | 23 | it "beta reduces" $ do 24 | "(\\x:T. x) y:T" `shouldEvalTo` "y:T" 25 | "(\\f:(T->T) x:T. f x) (g:T->T) (y:T)" `shouldEvalTo` "g:(T->T) y:T" 26 | "\\x:T. (\\y:T. y) x" `shouldEvalTo` "\\x:T. x" 27 | "(\\f:(T->T) x:T. f x) (\\f:T. x:T)" `shouldEvalTo` "\\z:T. x:T" 28 | 29 | it "reduces let bodies" $ do 30 | "let x = (\\y:Y. y) z:Y" `shouldEvalTo` "let x = z:Y" 31 | 32 | it "nested let expressions fail" $ do 33 | eval "let x = let y = z" `shouldFailWith` isLambdaException 34 | 35 | it "reduces type abstractions to A normal form" $ do 36 | "\\T. (\\y:T. y) x:T" `shouldEvalTo` "\\T. x:T" 37 | 38 | it "reduces type applications" $ do 39 | "(\\T. x:T) [X]" `shouldEvalTo` "x:X" 40 | "(\\x:(forall T. T). x) [X]" `shouldEvalTo` "\\x:X. x" 41 | "x:(forall T. T) [X]" `shouldEvalTo` "x:X" 42 | "(\\x:(forall T. T). x) (\\X. y:X)" `shouldEvalTo` "\\X. y:X" 43 | 44 | describe "subGlobals" $ do 45 | let subGlobals' :: SystemFExpr Text -> SystemFExpr Text 46 | subGlobals' expr = unsafeExecTypecheck (subGlobals expr) state 47 | state = TypecheckState globals' defaultUniques defaultTyUniques 48 | globals' = fromList [("w", TypedExpr (Var "x") (TyVar "X"))] 49 | 50 | it "subs simple variables" $ do 51 | subGlobals' (Var "w") `shouldBe` Var "x" 52 | subGlobals' (VarAnn "w" (TyVar "X")) `shouldBe` Var "x" 53 | 54 | it "does not sub shadowed bindings" $ do 55 | let expr = Abs "w" (TyVar "W") $ Var "w" 56 | subGlobals' expr `shouldBe` expr 57 | 58 | xit "does not capture globals" $ do 59 | let expr = Abs "x" (TyVar "X") $ Var "w" 60 | subGlobals' expr `shouldBe` Abs "a" (TyVar "X") (Var "x") 61 | 62 | describe "betaReduce" $ do 63 | let betaReduce' :: SystemFExpr Text -> SystemFExpr Text -> SystemFExpr Text 64 | betaReduce' e1 e2 = unsafeExecTypecheck (betaReduce e1 e2) $ 65 | mkTypecheckState defaultUniques defaultTyUniques 66 | 67 | it "reduces simple applications" $ do 68 | let e1 = Abs "x" (TyVar "T") (Var "x") 69 | e2 = Var "y" 70 | 71 | betaReduce' e1 e2 `shouldBe` e2 72 | 73 | it "reduces nested abstractions" $ do 74 | let e1 = Abs "x" (TyVar "T") (Abs "y" (TyVar "U") (Var "x")) 75 | e2 = Var "z" 76 | betaReduce' e1 e2 `shouldBe` Abs "y" (TyVar "U") (Var "z") 77 | 78 | it "reduces inner applications" $ do 79 | let e1 = Abs "f" (TyArrow (TyVar "T") (TyVar "T")) $ 80 | App (Var "f") (VarAnn "x" (TyVar "T")) 81 | e2 = Var "g" 82 | betaReduce' e1 e2 `shouldBe` App (Var "g") (VarAnn "x" (TyVar "T")) 83 | 84 | it "does not reduce unreducible expressions" $ do 85 | let e2 = Var "y" 86 | 87 | betaReduce' (Var "x") e2 88 | `shouldBe` App (Var "x") (Var "y") 89 | betaReduce' (VarAnn "x" (TyVar "T")) e2 90 | `shouldBe` App (VarAnn "x" (TyVar "T")) (Var "y") 91 | betaReduce' (TyAbs "X" (Var "x")) e2 92 | `shouldBe` App (TyAbs "X" (Var "x")) e2 93 | betaReduce' (TyApp (Var "x") (TyVar "X")) e2 94 | `shouldBe` App (TyApp (Var "x") (TyVar "X")) e2 95 | 96 | it "does not reduce irreducible chained applications" $ do 97 | let e1 = App (Var "x") (Var "y") 98 | e2 = Var "z" 99 | betaReduce' e1 e2 `shouldBe` App (App (Var "x") (Var "y")) (Var "z") 100 | 101 | it "does not sub shadowed bindings" $ do 102 | let e1 = Abs "x" (TyVar "T") (Abs "x" (TyVar "U") (Var "x")) 103 | e2 = Var "z" 104 | betaReduce' e1 e2 `shouldBe` Abs "x" (TyVar "U") (Var "x") 105 | 106 | it "fails to reduce Let" $ do 107 | let e1 = Let "x" (Var "x") 108 | e2 = Var "z" 109 | evaluate (betaReduce' e1 e2) `shouldThrow` isImpossibleError 110 | 111 | it "avoids capture" $ do 112 | let beta :: SystemFExpr Text -> SystemFExpr Text -> SystemFExpr Text 113 | beta e1 e2 = unsafeExecTypecheck (betaReduce e1 e2) $ 114 | mkTypecheckState ["z"] defaultTyUniques 115 | 116 | let e1 = Abs "f" (TyArrow (TyVar "T") (TyVar "U")) $ 117 | Abs "x" (TyVar "U") $ 118 | App (Var "f") (Var "x") 119 | e2 = Abs "f" (TyVar "T") $ Var "x" 120 | beta e1 e2 `shouldBe` Abs "z" (TyVar "U") (Var "x") 121 | 122 | describe "evalTyApp" $ do 123 | it "reduces simple type applications" $ do 124 | let expr = TyApp 125 | (TyAbs "T" (VarAnn "x" (TyVar "T"))) 126 | (TyVar "X") 127 | 128 | evalExpr' expr `shouldBeRight` VarAnn "x" (TyVar "X") 129 | 130 | it "reduces type applications with abstractions" $ do 131 | let expr = TyApp 132 | (TyAbs "T" (Abs "x" (TyVar "T") (Var "x"))) 133 | (TyVar "X") 134 | 135 | evalExpr' expr `shouldBeRight` Abs "x" (TyVar "X") (Var "x") 136 | 137 | it "does not reduce irreducible expressions" $ do 138 | let tyApp inner = TyApp (TyAbs "T" inner) (TyVar "X") 139 | 140 | evalExpr' (tyApp (Var "x")) `shouldBeRight` Var "x" 141 | evalExpr' (tyApp (VarAnn "x" (TyVar "Z"))) `shouldBeRight` VarAnn "x" (TyVar "Z") 142 | evalExpr' (tyApp (Abs "x" (TyVar "Z") (Var "x"))) 143 | `shouldBeRight` Abs "x" (TyVar "Z") (Var "x") 144 | 145 | it "fails on let" $ do 146 | let expr = TyApp (Let "x" (VarAnn "y" (TyVar "T"))) (TyVar "X") 147 | evalExpr' expr `shouldSatisfy` either isLetError (const False) 148 | 149 | it "reduces nested expressions" $ do 150 | let tyApp inner = TyApp (TyAbs "T" inner) (TyVar "X") 151 | 152 | let e1 = App (Var "f") (VarAnn "x" (TyVar "T")) 153 | evalExpr' (tyApp e1) `shouldBeRight` App (Var "f") (VarAnn "x" $ TyVar "X") 154 | 155 | let e2 = Abs "x" (TyVar "U") (VarAnn "t" $ TyVar "T") 156 | evalExpr' (tyApp e2) `shouldBeRight` Abs "x" (TyVar "U") (VarAnn "t" $ TyVar "X") 157 | 158 | let e3 = TyAbs "U" $ VarAnn "x" (TyVar "T") 159 | evalExpr' (tyApp e3) `shouldBeRight` TyAbs "U" (VarAnn "x" $ TyVar "X") 160 | 161 | let e4 = TyApp (VarAnn "x" (TyVar "T")) (TyVar "U") 162 | evalExpr' (tyApp e4) `shouldBeRight` TyApp (VarAnn "x" $ TyVar "X") (TyVar "U") 163 | 164 | let e5 = TyApp 165 | (TyAbs "U" $ VarAnn "x" (TyVar "U")) 166 | (TyVar "T") 167 | evalExpr' (tyApp e5) `shouldBeRight` VarAnn "x" (TyVar "X") 168 | 169 | it "reduces in nested types" $ do 170 | let tyApp inner = TyApp (TyAbs "T" inner) (TyVar "X") 171 | 172 | let e1 = VarAnn "f" $ TyArrow (TyVar "T") (TyVar "U") 173 | evalExpr' (tyApp e1) `shouldBeRight` VarAnn "f" (TyArrow (TyVar "X") (TyVar "U")) 174 | 175 | let e2 = VarAnn "f" $ TyForAll "T" (TyVar "T") 176 | evalExpr' (tyApp e2) `shouldBeRight` e2 177 | 178 | let e3 = VarAnn "f" $ TyForAll "U" (TyVar "T") 179 | evalExpr' (tyApp e3) `shouldBeRight` VarAnn "f" (TyForAll "U" (TyVar "X")) 180 | 181 | 182 | describe "alphaConvert" $ do 183 | let alphaConvert' :: [Text] -> [Text] -> SystemFExpr Text -> SystemFExpr Text 184 | alphaConvert' uniques' fvs expr = unsafeExecTypecheck (alphaConvert fvs expr) $ 185 | mkTypecheckState uniques' defaultTyUniques 186 | 187 | it "alpha converts simple expressions" $ do 188 | let freeVars = ["x"] :: [Text] 189 | expr = Abs "x" (TyVar "T") (Var "x") 190 | uniques' = ["y"] 191 | alphaConvert' uniques' freeVars expr `shouldBe` Abs "y" (TyVar "T") (Var "y") 192 | 193 | it "avoids captures" $ do 194 | let freeVars = ["x"] 195 | expr = Abs "x" (TyVar "T") (Var "x") 196 | uniques' = ["x", "y"] 197 | alphaConvert' uniques' freeVars expr `shouldBe` Abs "y" (TyVar "T") (Var "y") 198 | 199 | describe "etaConvert" $ do 200 | it "eta converts simple expressions" $ do 201 | let expr :: SystemFExpr Text 202 | expr = Abs "x" (TyVar "T") $ App (Var "f") (Var "x") 203 | etaConvert expr `shouldBe` Var "f" 204 | 205 | it "eta converts nested applications" $ do 206 | let expr1 :: SystemFExpr Text 207 | expr1 = Abs "y" (TyVar "T") $ App (App (Var "f") (Var "x")) (Var "y") 208 | etaConvert expr1 `shouldBe` App (Var "f") (Var "x") 209 | 210 | let expr2 :: SystemFExpr Text 211 | expr2 = Abs "x" (TyArrow (TyVar "T") (TyVar "T")) $ 212 | Abs "y" (TyVar "T") $ 213 | App (App (Var "f") (Var "x")) (Var "y") 214 | etaConvert expr2 `shouldBe` Var "f" 215 | 216 | let expr3 :: SystemFExpr Text 217 | expr3 = Abs "x" (TyVar "T") $ 218 | Abs "y" (TyArrow (TyVar "T") (TyVar "T")) $ 219 | App (Var "y") (Var "x") 220 | etaConvert expr3 `shouldBe` expr3 221 | 222 | let expr4 :: SystemFExpr Text 223 | expr4 = Abs "f" (TyVar "T") $ 224 | Abs "x" (TyVar "T") (Var "x") 225 | etaConvert expr4 `shouldBe` expr4 226 | 227 | it "ignores non-eta convertable expressions" $ do 228 | let expr :: SystemFExpr Text 229 | expr = Abs "x" (TyVar "T") $ Var "x" 230 | etaConvert expr `shouldBe` expr 231 | 232 | describe "freeVarsOf" $ do 233 | let freeVarsOf' :: SystemFExpr Text -> [Text] 234 | freeVarsOf' = freeVarsOf 235 | 236 | it "Returns simple vars" $ do 237 | freeVarsOf' (Var "x") `shouldBe` ["x"] 238 | freeVarsOf' (VarAnn "x" (TyVar "T")) `shouldBe` ["x"] 239 | 240 | it "Does not return bound vars" $ 241 | freeVarsOf' (Abs "x" (TyVar "T") (Var "x")) `shouldBe` [] 242 | 243 | it "Returns nested simple vars" $ 244 | freeVarsOf' (Abs "x" (TyVar "T") (Var "y")) `shouldBe` ["y"] 245 | 246 | it "Returns applied simple vars" $ 247 | freeVarsOf' (App (Var "x") (Var "y")) `shouldBe` ["x", "y"] 248 | -------------------------------------------------------------------------------- /test/Language/Lambda/SystemF/Examples/BoolSpec.hs: -------------------------------------------------------------------------------- 1 | module Language.Lambda.SystemF.Examples.BoolSpec where 2 | 3 | import RIO 4 | import Test.Hspec 5 | 6 | import Language.Lambda.SystemF.HspecUtils 7 | 8 | spec :: Spec 9 | spec = describe "Bool" $ do 10 | -- Bool is the definition of Booleans. We represent bools 11 | -- using Church Encodings: 12 | -- 13 | -- true: \T. \t:T f:T. t 14 | -- false: \T. \t:T f:T. f 15 | -- false: \T. \t:T f:T. f 16 | describe "not" $ do 17 | -- not takes a Bool and returns its opposite value 18 | -- 19 | -- not(true) = false 20 | -- not(false) = true 21 | -- 22 | -- not is defined by 23 | -- not = \x. x (\t f. f) (\t f. t) 24 | it "not true = false" $ 25 | "(\\x:(forall T. T -> T -> T). \\X. \\t:X f:X. (x [X]) f t) (\\U. \\t:U f:U. t)" 26 | `shouldEvalTo` "\\X. \\t:X f:X. f" 27 | 28 | it "not false = true" $ 29 | "(\\x:(forall T. T-> T -> T). \\X. \\t:X f:X. (x [X]) f t) (\\U. \\t:U f:U. f)" 30 | `shouldEvalTo` "\\X. \\t:X f:X. t" 31 | -------------------------------------------------------------------------------- /test/Language/Lambda/SystemF/Examples/NatSpec.hs: -------------------------------------------------------------------------------- 1 | module Language.Lambda.SystemF.Examples.NatSpec where 2 | 3 | import RIO 4 | import Test.Hspec 5 | 6 | import Language.Lambda.SystemF (evalText) 7 | import Language.Lambda.SystemF.HspecUtils 8 | 9 | spec :: Spec 10 | spec = describe "Nat" $ do 11 | -- Nat is the definition of natural numbers. More precisely, Nat 12 | -- is the set of nonnegative integers. We represent nats using 13 | -- Church Encodings: 14 | -- 15 | -- 0: \f:(T->T) x:T. x 16 | -- 1: \f:(T->T) x:T. f x 17 | -- 2: \f:(T->T) x:T. f (f x) 18 | -- ...and so on 19 | 20 | describe "successor" $ do 21 | -- successor is a function that adds 1 22 | -- succ(0) = 1 23 | -- succ(1) = 2 24 | -- ... and so forth 25 | -- 26 | -- successor is defined by 27 | -- succ = \n:((T->T)->T->T) f:(T->T) x:T. f (n f x) 28 | it "succ 0 = 1" $ do 29 | "(\\n:((T->T)->T->T) f:(T->T) x:T. f (n f x)) (\\f:(T->T) x:T. x)" 30 | `shouldEvalTo` "\\f:(T->T) x:T. f x" 31 | 32 | it "succ 1 = 2" $ 33 | "(\\n:((T->T)->T->T) f:(T->T) x:T. f (n f x)) (\\f:(T->T) x:T. f x)" 34 | `shouldEvalTo` "\\f:(T->T) x:T. f (f x)" 35 | 36 | describe "add" $ do 37 | -- add(m, n) = m + n 38 | -- 39 | -- It is defined by applying successor m times on n: 40 | -- add = \m:((T->T)->T->T) n:((T->T)->T->T) f:(T->T) x:T. m f (n f x) 41 | it "add 0 2 = 2" $ 42 | "(\\m:((T->T)->T->T) n:((T->T)->T->T) f:(T->T) x:T. m f (n f x)) (\\f:(T->T) x:T. x) (\\f:(T->T) x:T. f (f x))" 43 | `shouldEvalTo` "\\f:(T->T) x:T. f (f x)" 44 | 45 | it "add 3 2 = 5" $ 46 | "(\\m:((T->T)->T->T) n:((T->T)->T->T) f:(T->T) x:T. m f (n f x)) (\\f:(T->T) x:T. f (f (f x))) (\\f:(T->T) x:T. f (f x))" 47 | `shouldEvalTo` "\\f:(T->T) x:T. f (f (f (f (f x))))" 48 | 49 | it "add 0 n = n" $ 50 | "(\\m:((T->T)->T->T) n:((T->T)->T->T) f:(T->T) x:T. m f (n f x)) (\\f:(T->T) x:T. x) n:((T->T)->T->T)" 51 | `shouldEvalTo` "\\f:(T->T) x:T. n:((T->T)->T->T) f x" 52 | 53 | describe "multiply" $ do 54 | -- multiply(m, n) = m * n 55 | -- 56 | -- multiply is defined by applying add m times 57 | -- multiply = \m n f x. m (n f x) x) 58 | -- 59 | -- Using eta conversion, we can omit the parameter x 60 | -- multiply = \m n f. m (n f) 61 | it "multiply 0 2 = 0" $ 62 | "(\\m:((T->T)->T->T) n:((T->T)->T->T) f:(T->T). m (n f)) (\\f:(T->T) x:T. x) (\\f:(T->T) x:T. f (f x))" 63 | `shouldEvalTo` "\\f:(T->T) x:T. x" 64 | 65 | it "multiply 2 3 = 6" $ 66 | "(\\m:((T->T)->T->T) n:((T->T)->T->T) f:(T->T). m (n f)) (\\f:(T->T) x:T. f (f x)) (\\f:(T->T) x:T. f (f (f x)))" 67 | `shouldEvalTo` "\\f:(T->T) x:T. f (f (f (f (f (f x)))))" 68 | 69 | it "multiply 0 n = 0" $ 70 | "(\\m:((T->T)->T->T) n:((T->T)->T->T) f:(T->T). m (n f)) (\\f:(T->T) x:T. x) n:((T->T)->T->T)" 71 | `shouldEvalTo` "\\f:(T->T) x:T. x" 72 | 73 | it "multiply 1 n = n" $ 74 | "(\\m:((T->T)->T->T) n:((T->T)->T->T) f:(T->T). m (n f)) (\\f:(T->T) x:T. f x) n:((T->T)->T->T)" 75 | `shouldEvalTo` "\\f:(T->T) x:T. n:((T->T)->T->T) f x" 76 | -------------------------------------------------------------------------------- /test/Language/Lambda/SystemF/ExpressionSpec.hs: -------------------------------------------------------------------------------- 1 | module Language.Lambda.SystemF.ExpressionSpec where 2 | 3 | import RIO 4 | import Test.Hspec 5 | 6 | import Language.Lambda.SystemF.Expression 7 | 8 | spec :: Spec 9 | spec = do 10 | describe "prettyPrint" $ do 11 | let prettyPrint' :: SystemFExpr Text -> Text 12 | prettyPrint' = prettyPrint 13 | 14 | prettyPrintTy :: Ty Text -> Text 15 | prettyPrintTy = prettyPrint 16 | 17 | it "prints simple variables" $ 18 | prettyPrint' (Var "x") `shouldBe` "x" 19 | 20 | it "prints annotated variables" $ 21 | prettyPrint' (VarAnn "x" (TyVar "T")) `shouldBe` "x:T" 22 | 23 | it "prints simple applications" $ 24 | prettyPrint' (App (Var "a") (Var "b")) `shouldBe` "a b" 25 | 26 | it "prints simple abstractions" $ 27 | prettyPrint' (Abs "x" (TyVar "T") (Var "x")) `shouldBe` "λ x:T. x" 28 | 29 | it "prints simple type abstractions" $ 30 | prettyPrint' (TyAbs "X" (Var "x")) `shouldBe` "Λ X. x" 31 | 32 | it "prints simple type applications" $ 33 | prettyPrint' (TyApp (Var "t") (TyVar "T")) `shouldBe` "t [T]" 34 | 35 | it "prints simple let expressions" $ 36 | prettyPrint' (Let "x" (Var "y")) `shouldBe` "let x = y" 37 | 38 | it "prints annotated variables with composite types" $ 39 | prettyPrint' (VarAnn "x" (TyArrow (TyVar "T") (TyVar "V"))) `shouldBe` "x:(T->V)" 40 | 41 | it "prints nested abstractions" $ 42 | prettyPrint' (Abs "f" (TyVar "F") (Abs "x" (TyVar "X") (Var "x"))) 43 | `shouldBe` "λ f:F x:X. x" 44 | 45 | it "prints abstractions with composite types" $ do 46 | prettyPrint' (Abs "f" (TyArrow (TyVar "X") (TyVar "Y")) (Var "f")) 47 | `shouldBe ` "λ f:(X->Y). f" 48 | 49 | prettyPrint' (Abs "f" (TyArrow (TyVar "X") (TyArrow (TyVar "Y") (TyVar "Z"))) (Var "f")) 50 | `shouldBe ` "λ f:(X->Y->Z). f" 51 | 52 | it "prints nested type abstractions" $ 53 | prettyPrint' (TyAbs "A" (TyAbs "B" (Var "x"))) 54 | `shouldBe` "Λ A B. x" 55 | 56 | it "prints nested applications" $ 57 | prettyPrint' (App (App (Var "f") (Var "x")) (Var "y")) 58 | `shouldBe` "f x y" 59 | 60 | it "prints parenthesized applications" $ do 61 | prettyPrint' (App (Var "w") (App (Var "x") (Var "y"))) 62 | `shouldBe` "w (x y)" 63 | 64 | prettyPrint' (App (Abs "t" (TyVar "T") (Var "t")) (Var "x")) 65 | `shouldBe` "(λ t:T. t) x" 66 | 67 | prettyPrint' (App (Abs "f" (TyVar "F") (Var "f")) (Abs "g" (TyVar "G") (Var "g"))) 68 | `shouldBe` "(λ f:F. f) (λ g:G. g)" 69 | 70 | it "prints simple types" $ 71 | prettyPrintTy (TyVar "X") `shouldBe` "X" 72 | 73 | it "print simple arrow types" $ 74 | prettyPrintTy (TyArrow (TyVar "A") (TyVar "B")) `shouldBe` "A -> B" 75 | 76 | it "prints simple forall types" $ 77 | prettyPrintTy (TyForAll "X" (TyVar "X")) `shouldBe` "forall X. X" 78 | 79 | it "prints chained arrow types" $ 80 | prettyPrintTy (TyArrow (TyVar "X") (TyArrow (TyVar "Y") (TyVar "Z"))) 81 | `shouldBe` "X -> Y -> Z" 82 | 83 | it "prints nested arrow types" $ 84 | prettyPrintTy (TyArrow (TyArrow (TyVar "T") (TyVar "U")) (TyVar "V")) 85 | `shouldBe` "(T -> U) -> V" 86 | 87 | it "prints complex forall types" $ 88 | prettyPrintTy (TyForAll "A" (TyArrow (TyVar "A") (TyVar "A"))) 89 | `shouldBe` "forall A. A -> A" 90 | 91 | it "prints nested forall types" $ 92 | prettyPrintTy (TyForAll "W" 93 | (TyForAll "X" 94 | (TyArrow (TyVar "W") (TyArrow (TyVar "X") (TyVar "Y"))))) 95 | `shouldBe` "forall W. forall X. W -> X -> Y" 96 | 97 | describe "(==)" $ do 98 | let tyvar = "X" :: Text 99 | 100 | it "same types return true" $ do 101 | TyVar tyvar `shouldBe` TyVar tyvar 102 | TyArrow (TyVar tyvar) (TyVar tyvar) `shouldBe` TyArrow (TyVar tyvar) (TyVar tyvar) 103 | TyForAll tyvar (TyVar tyvar) `shouldBe` TyForAll tyvar (TyVar tyvar) 104 | 105 | it "equivalent foralls return true" $ 106 | TyForAll tyvar (TyVar tyvar) `shouldBe` TyForAll "Y" (TyVar "Y") 107 | 108 | it "unequal types return false" $ do 109 | TyVar tyvar `shouldNotBe` TyVar "Y" 110 | TyArrow (TyVar tyvar) (TyVar tyvar) `shouldNotBe` TyArrow (TyVar "Y") (TyVar "Y") 111 | TyForAll tyvar (TyVar tyvar) `shouldNotBe` TyForAll tyvar (TyVar "Y") 112 | TyVar tyvar `shouldNotBe` TyForAll tyvar (TyVar tyvar) 113 | 114 | describe "substituteTy" $ do 115 | let sub :: Ty Text -> Text -> Ty Text -> Ty Text 116 | sub = substituteTy 117 | 118 | it "substititues simple types" $ do 119 | sub (TyVar "X") "Y" (TyVar "Y") `shouldBe` TyVar "X" 120 | sub (TyVar "X") "Y" (TyVar "Z") `shouldBe` TyVar "Z" 121 | sub (TyArrow (TyVar "Z") (TyVar "X")) "Y" (TyVar "Y") 122 | `shouldBe` TyArrow (TyVar "Z") (TyVar "X") 123 | sub (TyForAll "X" (TyVar "Z")) "Y" (TyVar "Y") 124 | `shouldBe` TyForAll "X" (TyVar "Z") 125 | sub (TyVar "X") "Y" (TyForAll "Z" (TyVar "Y")) 126 | `shouldBe` TyForAll "Z" (TyVar "X") 127 | 128 | it "does not capture foralls" $ do 129 | sub (TyVar "X") "Y" (TyForAll "Y" (TyVar "Y")) 130 | `shouldBe` TyForAll "Y" (TyVar "Y") 131 | -------------------------------------------------------------------------------- /test/Language/Lambda/SystemF/HspecUtils.hs: -------------------------------------------------------------------------------- 1 | module Language.Lambda.SystemF.HspecUtils where 2 | 3 | import Language.Lambda.Shared.Errors 4 | import Language.Lambda.SystemF 5 | 6 | import RIO 7 | import Test.Hspec 8 | import qualified RIO.Map as Map 9 | 10 | shouldEvalTo :: Text -> Text -> Expectation 11 | shouldEvalTo input expected = eval input `shouldBe` eval expected 12 | 13 | shouldTypecheckTo :: Text -> Text -> Expectation 14 | shouldTypecheckTo = shouldTypecheckToWithGlobals [] 15 | 16 | shouldTypecheckToWithGlobals :: [(Text, TypedExpr Text)] -> Text -> Text -> Expectation 17 | shouldTypecheckToWithGlobals globals expr ty = typecheck' globals expr `shouldHaveType` ty 18 | 19 | shouldBeRight 20 | :: (Show l, Show r, Eq l, Eq r) 21 | => Either l r 22 | -> r 23 | -> Expectation 24 | shouldBeRight res = (res `shouldBe`) . Right 25 | 26 | shouldBeLeft 27 | :: (Show l, Show r, Eq l, Eq r) 28 | => Either l r 29 | -> l 30 | -> Expectation 31 | shouldBeLeft res = (res `shouldBe`) . Left 32 | 33 | shouldHaveType 34 | :: Either LambdaException (Ty Text) 35 | -> Text 36 | -> Expectation 37 | shouldHaveType res tyRepr = case parseType tyRepr of 38 | Left err -> expectationFailure $ 39 | "Could not parse type " <> show tyRepr <> ": " <> show err 40 | Right ty -> res `shouldBe` Right ty 41 | 42 | shouldFailWith 43 | :: Show a 44 | => Either LambdaException a 45 | -> Selector LambdaException 46 | -> Expectation 47 | shouldFailWith res selector = case res of 48 | Left err -> err `shouldSatisfy` selector 49 | Right res' -> expectationFailure $ 50 | "did not get expected failure: " <> show res' 51 | 52 | eval :: Text -> Either LambdaException (TypedExpr Text) 53 | eval input = execTypecheck (evalText input) initialState 54 | where initialState = mkTypecheckState defaultUniques defaultTyUniques 55 | 56 | typecheck' :: [(Text, TypedExpr Text)] -> Text -> Either LambdaException (Ty Text) 57 | typecheck' globals input = execTypecheck (typecheckText input) initialState 58 | where initialState = TypecheckState (Map.fromList globals) defaultUniques defaultTyUniques 59 | 60 | runTypecheck' 61 | :: [(Text, TypedExpr Text)] 62 | -> Text 63 | -> Either LambdaException (Ty Text, TypecheckState Text) 64 | runTypecheck' globals input = runTypecheck (typecheckText input) initialState 65 | where initialState = TypecheckState (Map.fromList globals) defaultUniques defaultTyUniques 66 | -------------------------------------------------------------------------------- /test/Language/Lambda/SystemF/ParserSpec.hs: -------------------------------------------------------------------------------- 1 | module Language.Lambda.SystemF.ParserSpec (spec) where 2 | 3 | import Data.Either 4 | 5 | import RIO 6 | import Test.Hspec 7 | 8 | import Language.Lambda.SystemF.Expression 9 | import Language.Lambda.SystemF.HspecUtils 10 | import Language.Lambda.SystemF.Parser 11 | 12 | spec :: Spec 13 | spec = do 14 | describe "parseExpr" $ do 15 | it "parses simple variables" $ 16 | parseExpr "x" `shouldBe` Right (Var "x") 17 | 18 | it "parses annotated variables" $ 19 | parseExpr "x:T" `shouldBe` Right (VarAnn "x" (TyVar "T")) 20 | 21 | it "parses parenthesized variables" $ 22 | parseExpr "(x)" `shouldBe` Right (Var "x") 23 | 24 | it "parses simple abstractions" $ 25 | parseExpr "\\x:T. x" `shouldBe` Right (Abs "x" (TyVar "T") (Var "x")) 26 | 27 | it "parses simple type abstractions" $ 28 | parseExpr "\\X. x" `shouldBe` Right (TyAbs "X" (Var "x")) 29 | 30 | it "parses simple type applications" $ 31 | parseExpr "x [T]" `shouldBe` Right (TyApp (Var "x") (TyVar "T")) 32 | 33 | it "parses simple lets" $ do 34 | parseExpr "let x = t" `shouldBeRight` Let "x" (Var "t") 35 | parseExpr "let f = \\x: T. x" `shouldBeRight` 36 | Let "f" (Abs "x" (TyVar "T") (Var "x")) 37 | 38 | it "parses nested abstractions" $ 39 | parseExpr "\\a:A b:B. b" 40 | `shouldBe` Right (Abs "a" (TyVar "A") (Abs "b" (TyVar "B") (Var "b"))) 41 | 42 | it "parses abstractions with arrow types" $ 43 | parseExpr "\\f:(T->U). f" 44 | `shouldBe` Right (Abs "f" (TyArrow (TyVar "T") (TyVar "U")) (Var "f")) 45 | 46 | it "parses simple applications" $ 47 | parseExpr "f x" `shouldBe` Right (App (Var "f") (Var "x")) 48 | 49 | it "parses chained applications" $ 50 | parseExpr "a b c" `shouldBe` Right (App (App (Var "a") (Var "b")) (Var "c")) 51 | 52 | it "parses complex expressions" $ do 53 | let exprs = [ 54 | "\\f:(A->B) x:B. f x", 55 | "(\\p:(X->Y->Z) x:X y:Y. y) (\\p:(A->B->C) x:B y:C. x)", 56 | "f (\\x:T. x)", 57 | "(\\ x:X . f x) g y", 58 | "(\\f:(X->Y) . (\\ x:X y:Y. f x y) f x y) w x y", 59 | "(\\x:T. x) [U]" 60 | ] 61 | 62 | mapM_ (flip shouldSatisfy isRight . parseExpr) exprs 63 | 64 | it "does not parse trailing errors" $ 65 | parseExpr "x +" `shouldSatisfy` isLeft 66 | 67 | it "does not parse misplaced lets" $ 68 | parseExpr "\\x: T. let y = x" `shouldSatisfy` isLeft 69 | 70 | it "ignores whitespace" $ do 71 | let exprs = [ 72 | " x ", 73 | " \\ x : X. x ", 74 | " ( x ) " 75 | ] 76 | 77 | mapM_ (flip shouldSatisfy isRight . parseExpr) exprs 78 | 79 | describe "parseType" $ do 80 | it "parses simple variables" $ 81 | parseType "X" `shouldBe` Right (TyVar "X") 82 | 83 | it "parses parenthesized variables" $ 84 | parseType "(T)" `shouldBe` Right (TyVar "T") 85 | 86 | it "parses simple arrow types" $ 87 | parseType "A -> B" `shouldBe` Right (TyArrow (TyVar "A") (TyVar "B")) 88 | 89 | it "parses parenthesized arrow types" $ 90 | parseType "((X)->(Y))" `shouldBe` Right (TyArrow (TyVar "X") (TyVar "Y")) 91 | 92 | it "parses nested arrow types" $ do 93 | parseType "T -> U -> V" 94 | `shouldBe` Right (TyArrow (TyVar "T") (TyArrow (TyVar "U") (TyVar "V"))) 95 | 96 | parseType "(W -> V) -> U" 97 | `shouldBe` Right (TyArrow (TyArrow (TyVar "W") (TyVar "V")) (TyVar "U")) 98 | 99 | it "parses forall types" $ do 100 | parseType "forall T. T" `shouldBeRight` TyForAll "T" (TyVar "T") 101 | parseType "forall T U. T->U" 102 | `shouldBeRight` TyForAll "T" (TyForAll "U" (TyArrow (TyVar "T") (TyVar "U"))) 103 | -------------------------------------------------------------------------------- /test/Language/Lambda/SystemF/TypeCheckSpec.hs: -------------------------------------------------------------------------------- 1 | module Language.Lambda.SystemF.TypeCheckSpec (spec) where 2 | 3 | import Language.Lambda.Shared.Errors 4 | import Language.Lambda.SystemF.Expression 5 | import Language.Lambda.SystemF.State 6 | import Language.Lambda.SystemF.HspecUtils 7 | 8 | import Control.Monad.Except 9 | import Data.Map 10 | import Lens.Micro 11 | import RIO 12 | import Test.Hspec 13 | 14 | spec :: Spec 15 | spec = describe "typecheck" $ do 16 | let someGlobal = ("x", TypedExpr (Var "y") (TyVar "X")) 17 | 18 | it "typechecks simple variables" $ do 19 | typecheck' [someGlobal] "x" `shouldHaveType` "X" 20 | typecheck' [] "x" `shouldHaveType` "Z" 21 | 22 | it "typechecks annotated variables" $ do 23 | typecheck' [someGlobal] "x:X" `shouldHaveType` "X" 24 | typecheck' [someGlobal] "x:X" `shouldHaveType` "X" 25 | 26 | typecheck' [someGlobal] "x:Y" `shouldFailWith` isTyMismatchError 27 | 28 | it "typechecks abstractions" $ 29 | typecheck' [] "\\x:A. x" `shouldHaveType` "A -> A" 30 | 31 | it "typechecks applications" $ do 32 | let globals' 33 | = [ ("f", TypedExpr (Var "f") $ TyArrow (TyVar "T") (TyVar "U")), 34 | ("a", TypedExpr (Var "a") $ TyVar "T"), 35 | ("b", TypedExpr (Var "b") (TyVar "B")) 36 | ] 37 | 38 | typecheck' globals' "f a" `shouldHaveType` "U" 39 | typecheck' [] "(\\t: T. t) x:T" `shouldHaveType` "T" 40 | 41 | -- Polymorphic application 42 | typecheck' [] "\\x:(forall T. T). x" 43 | `shouldHaveType` "forall T. T -> T" 44 | typecheck' [] "\\x:(forall T. T->U). x" 45 | `shouldHaveType` "forall T. (T -> U) -> (T -> U)" 46 | typecheck' [] "\\x:(U->(forall T. T)). x" 47 | `shouldHaveType` "forall T. (U -> T) -> (U -> T)" 48 | typecheck' [] "\\x:(forall T. T). x:T" 49 | `shouldHaveType` "forall T. T -> T" 50 | typecheck' [] "(\\z:(forall X. X). z) (\\X. a:X)" 51 | `shouldHaveType` "forall X. X" 52 | typecheck' [] "(\\x:(forall T. T). x) (\\X. y:X)" 53 | `shouldHaveType` "forall X. X" 54 | 55 | typecheck' globals' "a b" `shouldFailWith` isTyMismatchError 56 | typecheck' globals' "f b" `shouldFailWith` isTyMismatchError 57 | 58 | it "typechecks let expressions" $ do 59 | typecheck' [] "let x = y" `shouldHaveType` "Z" 60 | typecheck' [] "\\x:T. let y = z" `shouldFailWith` isLambdaException 61 | 62 | it "typechecks type abstractions" $ do 63 | typecheck' [] "\\X. (\\x:X. x)" `shouldHaveType` "forall X. X->X" 64 | typecheck' [] "\\X. x" `shouldHaveType` "forall X. Z" 65 | 66 | it "typechecks type applications" $ do 67 | let globals' 68 | = [ ("y", TypedExpr (Var "y") (TyVar "Y")), 69 | ("x", TypedExpr (Var "x") $ TyVar "A")] 70 | 71 | typecheck' globals' "((\\X.\\x:X.x) [Y]) y" `shouldHaveType` "Y" 72 | typecheck' globals' "(\\X. x) [T]" `shouldHaveType` "A" 73 | typecheck' globals' "(\\X. z: X) [T]" `shouldHaveType` "T" 74 | typecheck' globals' "(\\X. (\\x:X. x)) [Y]" `shouldHaveType` "Y -> Y" 75 | typecheck' globals' "(z:forall X. X) [Y]" `shouldHaveType` "Y" 76 | typecheck' globals' "\\x:(forall X. X). x [Y]" `shouldHaveType` "forall X. X -> Y" 77 | 78 | 79 | typecheck' [] "x:T [U]" `shouldFailWith` isTyMismatchError 80 | typecheck' globals' "x [U]" `shouldFailWith` isTyMismatchError 81 | 82 | it "doesn't modify context" $ do 83 | let exprs 84 | = [ "\\x:A. x", 85 | "\\X. x" ] 86 | 87 | forM_ exprs $ \expr -> do 88 | let ctx = do 89 | (_, state) <- runTypecheck' [] expr 90 | pure $ state ^. _context 91 | 92 | ctx `shouldBeRight` empty 93 | -------------------------------------------------------------------------------- /test/Language/Lambda/SystemFSpec.hs: -------------------------------------------------------------------------------- 1 | module Language.Lambda.SystemFSpec where 2 | 3 | import Language.Lambda.Shared.Errors (LambdaException(..), isLambdaException) 4 | import Language.Lambda.SystemF 5 | import Language.Lambda.SystemF.HspecUtils 6 | 7 | import Lens.Micro 8 | import RIO 9 | import RIO.Map (empty, fromList) 10 | import Test.Hspec 11 | 12 | spec :: Spec 13 | spec = do 14 | describe "evalText" $ do 15 | let eval' :: Text -> Either LambdaException (SystemFExpr Text) 16 | eval' = over _Right (^. _expr) . eval 17 | 18 | it "evaluates simple text" $ do 19 | eval' "x" `shouldBeRight` Var "x" 20 | eval' "\\x:T. x" `shouldBeRight` Abs "x" (TyVar "T") (Var "x") 21 | eval' "\\X. x" `shouldBeRight` TyAbs "X" (Var "x") 22 | 23 | it "reduces simple applications" $ 24 | eval' "(\\x:T. x) y:T" `shouldBeRight` VarAnn "y" (TyVar "T") 25 | 26 | it "reduces applications with nested redexes" $ 27 | eval' "(\\f:T->T x:T. f x) (\\y:T. y)" 28 | `shouldBeRight` Abs "x" (TyVar "T") (Var "x") 29 | 30 | it "lets update state" $ do 31 | let act = evalText "let x = a: A" >> evalText "x" 32 | 33 | unsafeExecTypecheck act (mkTypecheckState [] []) 34 | `shouldBe` TypedExpr (VarAnn "a" (TyVar "A")) (TyVar "A") 35 | 36 | describe "runEvalText" $ do 37 | let runEvalText' input = extract $ runEvalText input empty 38 | extract = _Right %~ (^. _expr) . fst 39 | 40 | it "evaluates simple text" $ do 41 | runEvalText' "x" `shouldBeRight` Var "x" 42 | runEvalText' "\\x:T. x" `shouldBeRight` Abs "x" (TyVar "T") (Var "x") 43 | runEvalText' "\\X. x" `shouldBeRight` TyAbs "X" (Var "x") 44 | 45 | describe "execEvalText" $ do 46 | let execEvalText' input = extract $ execEvalText input empty 47 | extract = over _Right (^. _expr) 48 | 49 | it "evaluates simple text" $ do 50 | execEvalText' "x" `shouldBeRight` Var "x" 51 | execEvalText' "\\x:T. x" `shouldBeRight` Abs "x" (TyVar "T") (Var "x") 52 | execEvalText' "\\X. x" `shouldBeRight` TyAbs "X" (Var "x") 53 | 54 | describe "unsafeExecEvalText" $ do 55 | let unsafeExecEvalText' input = extract $ unsafeExecEvalText input empty 56 | extract = (^. _expr) 57 | 58 | it "evaluates simple text" $ do 59 | unsafeExecEvalText' "x" `shouldBe` Var "x" 60 | unsafeExecEvalText' "\\x:T. x" `shouldBe` Abs "x" (TyVar "T") (Var "x") 61 | unsafeExecEvalText' "\\X. x" `shouldBe` TyAbs "X" (Var "x") 62 | 63 | it "throws errors" $ do 64 | evaluate (unsafeExecEvalText' "\\x. x") `shouldThrow` isLambdaException 65 | 66 | describe "typecheckText" $ do 67 | let tc :: Text -> Either LambdaException (Ty Text) 68 | tc input = execTypecheck (typecheckText input) initialState 69 | 70 | initialState = mkTypecheckState defaultUniques defaultTyUniques 71 | 72 | it "typechecks simple text" $ do 73 | tc "x" `shouldHaveType` "Z" 74 | tc "\\x:T. x" `shouldHaveType` "T -> T" 75 | tc "\\X. x" `shouldHaveType` "forall X. Z" 76 | tc "(\\x:T. x) y:T" `shouldHaveType` "T" 77 | tc "(\\f:(T->T) x:T. f x) (\\y:T. y)" `shouldHaveType` "T -> T" 78 | 79 | describe "runTypecheckText" $ do 80 | let tc :: Text -> Either LambdaException (Ty Text) 81 | tc input = fst <$> runTypecheckText input globals' 82 | 83 | globals' = fromList [("x", TypedExpr (Var "x") (TyVar "A"))] 84 | 85 | it "typechecks simple text" $ do 86 | tc "x" `shouldHaveType` "A" 87 | tc "\\x:T. x" `shouldHaveType` "T -> T" 88 | tc "\\X. x" `shouldHaveType` "forall X. A" 89 | tc "(\\x:T. x) y:T" `shouldHaveType` "T" 90 | tc "(\\f:(T->T) x:T. f x) (\\y:T. y)" `shouldHaveType` "T -> T" 91 | 92 | describe "execTypecheckText" $ do 93 | let tc :: Text -> Either LambdaException (Ty Text) 94 | tc input = execTypecheckText input globals' 95 | 96 | globals' = fromList [("x", TypedExpr (Var "x") (TyVar "A"))] 97 | 98 | it "typechecks simple text" $ do 99 | tc "x" `shouldHaveType` "A" 100 | tc "\\x:T. x" `shouldHaveType` "T -> T" 101 | tc "\\X. x" `shouldHaveType` "forall X. A" 102 | tc "(\\x:T. x) y:T" `shouldHaveType` "T" 103 | tc "(\\f:(T->T) x:T. f x) (\\y:T. y)" `shouldHaveType` "T -> T" 104 | 105 | describe "unsafeExecTypecheckText" $ do 106 | let tc :: Text -> Ty Text 107 | tc input = unsafeExecTypecheckText input globals' 108 | 109 | globals' = fromList [("x", TypedExpr (Var "x") (TyVar "A"))] 110 | 111 | it "typechecks simple text" $ do 112 | Right (tc "x") `shouldHaveType` "A" 113 | Right (tc "\\x:T. x") `shouldHaveType` "T -> T" 114 | Right (tc "\\X. x") `shouldHaveType` "forall X. A" 115 | Right (tc "(\\x:T. x) y:T") `shouldHaveType` "T" 116 | Right (tc "(\\f:(T->T) x:T. f x) (\\y:T. y)") `shouldHaveType` "T -> T" 117 | -------------------------------------------------------------------------------- /test/Language/Lambda/Untyped/EvalSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-} 2 | module Language.Lambda.Untyped.EvalSpec where 3 | 4 | import Data.Map (fromList) 5 | import RIO 6 | import Test.Hspec 7 | 8 | import Language.Lambda.Shared.Errors 9 | import Language.Lambda.Untyped 10 | 11 | spec :: Spec 12 | spec = do 13 | describe "evalExpr" $ do 14 | let evalExpr' expr = execEval (evalExpr expr) (mkEvalState defaultUniques) 15 | 16 | it "beta reduces" $ do 17 | let expr = App (Abs "x" (Var "x")) (Var "z") 18 | evalExpr' expr `shouldBe` Right (Var "z") 19 | 20 | it "reduces multiple applications" $ do 21 | let expr = App (App (Abs "f" (Abs "x" (App (Var "f") (Var "x")))) (Var "g")) (Var "y") 22 | evalExpr' expr `shouldBe` Right (App (Var "g") (Var "y")) 23 | 24 | it "reduces inner redexes" $ do 25 | let expr = Abs "x" (App (Abs "y" (Var "y")) (Var "x")) 26 | evalExpr' expr `shouldBe` Right (Abs "x" (Var "x")) 27 | 28 | it "reduces with name captures" $ do 29 | let expr = App (Abs "f" (Abs "x" (App (Var "f") (Var "x")))) 30 | (Abs "f" (Var "x")) 31 | evalExpr' expr `shouldBe` Right (Abs "z" (Var "x")) 32 | 33 | it "reduces let bodies" $ do 34 | let expr = Let "x" $ App (Abs "y" (Var "y")) (Var "z") 35 | evalExpr' expr `shouldBe` Right (Let "x" (Var "z")) 36 | 37 | it "let expressions update state" $ do 38 | let res = flip unsafeExecEval (mkEvalState defaultUniques) $ do 39 | _ <- evalExpr $ Let "w" (Var "x") 40 | evalExpr $ Var "w" 41 | 42 | res `shouldBe` Var "x" 43 | 44 | it "nested let expressions fail" $ do 45 | let res = flip unsafeExecEval (mkEvalState defaultUniques) $ do 46 | evalExpr $ Let "x" (Let "y" (Var "z")) 47 | evaluate res `shouldThrow` isLetError 48 | 49 | describe "subGlobals" $ do 50 | let globals' :: Map String (LambdaExpr String) 51 | globals' = fromList [("w", Var "x")] 52 | subGlobals' = subGlobals globals' 53 | 54 | it "subs simple variables" $ 55 | subGlobals' (Var "w") `shouldBe` Var "x" 56 | 57 | it "does not sub shadowed bindings" $ do 58 | let expr = Abs "w" (Var "w") 59 | subGlobals' expr `shouldBe` expr 60 | 61 | xit "does not capture globals" $ do 62 | let expr = Abs "x" (Var "w") 63 | subGlobals' expr `shouldBe` Abs "a" (Var "x") 64 | 65 | describe "betaReduce" $ do 66 | let betaReduce' :: LambdaExpr Text -> LambdaExpr Text -> LambdaExpr Text 67 | betaReduce' e1 e2 = unsafeExecEval (betaReduce e1 e2) (mkEvalState []) 68 | 69 | it "reduces simple applications" $ do 70 | let e1 = Abs "x" (Var "x") 71 | e2 = Var "y" 72 | betaReduce' e1 e2 `shouldBe` Var "y" 73 | 74 | it "reduces nested abstractions" $ do 75 | let e1 = Abs "x" (Abs "y" (Var "x")) 76 | e2 = Var "z" 77 | betaReduce' e1 e2 `shouldBe` Abs "y" (Var "z") 78 | 79 | it "reduces inner applications" $ do 80 | let e1 = Abs "f" (App (Var "f") (Var "x")) 81 | e2 = Var "g" 82 | betaReduce' e1 e2 `shouldBe` App (Var "g") (Var "x") 83 | 84 | it "does not reduce unreducible expression" $ do 85 | let e1 = Var "x" 86 | e2 = Var "y" 87 | betaReduce' e1 e2 `shouldBe` App (Var "x") (Var "y") 88 | 89 | it "does not reduce irreducible chained applications" $ do 90 | let e1 = App (Var "x") (Var "y") 91 | e2 = Var "z" 92 | betaReduce' e1 e2 `shouldBe` App (App (Var "x") (Var "y")) (Var "z") 93 | 94 | it "does not sub shadowed bindings" $ do 95 | let e1 = Abs "x" (Abs "x" (Var "x")) 96 | e2 = Var "z" 97 | betaReduce' e1 e2 `shouldBe` Abs "x" (Var "x") 98 | 99 | it "avoids captures" $ do 100 | let beta :: LambdaExpr Text -> LambdaExpr Text -> LambdaExpr Text 101 | beta e1 e2 = unsafeExecEval (betaReduce e1 e2) (mkEvalState ["z"]) 102 | 103 | let e1 = Abs "f" $ Abs "x" $ App (Var "f") (Var "x") 104 | e2 = Abs "f" $ Var "x" 105 | beta e1 e2 `shouldBe` Abs "z" (Var "x") 106 | 107 | describe "alphaConvert" $ do 108 | let alphaConvert' :: [Text] -> [Text] -> LambdaExpr Text -> LambdaExpr Text 109 | alphaConvert' uniques' fvs expr 110 | = unsafeExecEval (alphaConvert fvs expr) (mkEvalState uniques') 111 | 112 | it "alpha converts simple expressions" $ do 113 | let freeVars = ["x"] :: [Text] 114 | expr = Abs "x" (Var "x") 115 | uniques' = ["y"] 116 | alphaConvert' uniques' freeVars expr `shouldBe` Abs "y" (Var "y") 117 | 118 | it "avoids captures" $ do 119 | let freeVars = ["x"] 120 | expr = Abs "x" (Var "x") 121 | uniques' = ["x", "y"] 122 | alphaConvert' uniques' freeVars expr `shouldBe` Abs "y" (Var "y") 123 | 124 | describe "etaConvert" $ do 125 | it "eta converts simple expressions" $ do 126 | let expr :: LambdaExpr Text 127 | expr = Abs "x" $ App (Var "f") (Var "x") :: LambdaExpr Text 128 | etaConvert expr `shouldBe` Var "f" 129 | 130 | it "eta converts nested applications" $ do 131 | let expr :: LambdaExpr Text 132 | expr = Abs "y" $ App (App (Var "f") (Var "x")) (Var "y") 133 | etaConvert expr `shouldBe` App (Var "f") (Var "x") 134 | 135 | let expr' :: LambdaExpr Text 136 | expr' = Abs "x" $ Abs "y" (App (App (Var "f") (Var "x")) (Var "y")) 137 | etaConvert expr' `shouldBe` Var "f" 138 | 139 | let expr'' :: LambdaExpr Text 140 | expr'' = Abs "x" (Abs "y" (App (Var "y") (Var "x"))) 141 | etaConvert expr'' `shouldBe` expr'' 142 | 143 | let expr''' :: LambdaExpr Text 144 | expr''' = Abs "f" (Abs "x" (Var "x")) 145 | etaConvert expr''' `shouldBe` expr''' 146 | 147 | it "ignores non-eta convertable expressions" $ do 148 | let expr :: LambdaExpr Text 149 | expr = Abs "x" $ Var "x" 150 | etaConvert expr `shouldBe` expr 151 | 152 | describe "freeVarsOf" $ do 153 | let freeVarsOf' :: LambdaExpr Text -> [Text] 154 | freeVarsOf' = freeVarsOf 155 | 156 | it "Returns simple vars" $ 157 | freeVarsOf' (Var "x") `shouldBe` ["x"] 158 | 159 | it "Does not return bound vars" $ 160 | freeVarsOf' (Abs "x" (Var "x")) `shouldBe` [] 161 | 162 | it "Returns nested simple vars" $ 163 | freeVarsOf' (Abs "x" (Var "y")) `shouldBe` ["y"] 164 | 165 | it "Returns applied simple vars" $ 166 | freeVarsOf' (App (Var "x") (Var "y")) `shouldBe` ["x", "y"] 167 | -------------------------------------------------------------------------------- /test/Language/Lambda/Untyped/Examples/BoolSpec.hs: -------------------------------------------------------------------------------- 1 | module Language.Lambda.Untyped.Examples.BoolSpec where 2 | 3 | import RIO 4 | import Test.Hspec 5 | 6 | import Language.Lambda.Untyped.HspecUtils 7 | 8 | spec :: Spec 9 | spec = describe "Bool" $ do 10 | -- Bool is the definition of Booleans. We represent bools 11 | -- using Church Encodings: 12 | -- 13 | -- true: \t f. t 14 | -- false: \t f. f 15 | describe "and" $ do 16 | -- The function and takes two Bools and returns true 17 | -- iff both arguments are true 18 | -- 19 | -- and(true, true) = true 20 | -- and(false, true) = false 21 | -- and(true, false) = false 22 | -- and(false, false) = false 23 | -- 24 | -- and is defined by 25 | -- and = \x y. x y x 26 | it "true and true = true" $ 27 | "(\\x y. x y x) (\\t f. t) (\\t f. t)" `shouldEvalTo` "\\t f. t" 28 | 29 | it "true and false = false" $ 30 | "(\\x y. x y x) (\\t f. t) (\\t f. f)" `shouldEvalTo` "\\t f. f" 31 | 32 | it "false and true = false" $ 33 | "(\\x y. x y x) (\\t f. f) (\\t f. t)" `shouldEvalTo` "\\t f. f" 34 | 35 | it "false and false = false" $ 36 | "(\\x y. x y x) (\\t f. f) (\\t f. f)" `shouldEvalTo` "\\t f. f" 37 | 38 | it "false and p = false" $ 39 | "(\\x y. x y x) (\\t f. f) p" `shouldEvalTo` "\\t f. f" 40 | 41 | it "true and p = false" $ 42 | "(\\x y. x y x) (\\t f. t) p" `shouldEvalTo` "p" 43 | 44 | describe "or" $ do 45 | -- or takes two Bools and returns true iff either argument is true 46 | -- 47 | -- or(true, true) = true 48 | -- or(true, false) = true 49 | -- or(false, true) = true 50 | -- or(false, false) = false 51 | -- 52 | -- or is defined by 53 | -- or = \x y. x x y 54 | it "true or true = true" $ 55 | "(\\x y. x x y) (\\t f. t) (\\t f. t)" `shouldEvalTo` "\\t f. t" 56 | 57 | it "true or false = true" $ 58 | "(\\x y. x x y) (\\t f. t) (\\t f. f)" `shouldEvalTo` "\\t f. t" 59 | 60 | it "false or true = true" $ 61 | "(\\x y. x x y) (\\t f. f) (\\t f. t)" `shouldEvalTo` "\\t f. t" 62 | 63 | it "false or false = false" $ 64 | "(\\x y. x x y) (\\t f. f) (\\t f. f)" `shouldEvalTo` "\\t f. f" 65 | 66 | it "true or p = true" $ 67 | "(\\x y. x x y) (\\t f. t) p" `shouldEvalTo` "\\t f. t" 68 | 69 | it "false or p = p" $ 70 | "(\\x y. x x y) (\\t f. f) p" `shouldEvalTo` "p" 71 | 72 | 73 | describe "not" $ do 74 | -- not takes a Bool and returns its opposite value 75 | -- 76 | -- not(true) = false 77 | -- not(false) = true 78 | -- 79 | -- not is defined by 80 | -- not = \x. x (\t f. f) (\t f. t) 81 | it "not true = false" $ 82 | "(\\x. x (\\t f. f) (\\t f. t)) \\t f. t" `shouldEvalTo` "\\t f. f" 83 | 84 | it "not false = true" $ 85 | "(\\x. x (\\t f. f) (\\t f. t)) \\t f. f" `shouldEvalTo` "\\t f. t" 86 | 87 | describe "if" $ do 88 | -- if takes a Bool and two values. If returns the first value 89 | -- if the Bool is true, and the second otherwise. In other words, 90 | -- if p x y = if p then x else y 91 | -- 92 | -- if(true, x, y) = x 93 | -- if(false, x, y) = y 94 | -- 95 | -- if is defined by 96 | -- if = \p x y. p x y 97 | it "if true 0 1 = 0" $ 98 | "(\\p x y. p x y) (\\t f. t) (\\f x. x) (\\f x. f x)" 99 | `shouldEvalTo` "\\f x. x" 100 | 101 | it "if false 0 1 = 1" $ 102 | "(\\p x y. p x y) (\\t f. f) (\\f x. x) (\\f x. f x)" 103 | `shouldEvalTo` "\\f x. f x" 104 | 105 | it "it true p q = p" $ 106 | "(\\p x y. p x y) (\\t f. t) p q" `shouldEvalTo` "p" 107 | 108 | it "it false p q = q" $ 109 | "(\\p x y. p x y) (\\t f. f) p q" `shouldEvalTo` "q" 110 | -------------------------------------------------------------------------------- /test/Language/Lambda/Untyped/Examples/NatSpec.hs: -------------------------------------------------------------------------------- 1 | module Language.Lambda.Untyped.Examples.NatSpec where 2 | 3 | import RIO 4 | import Test.Hspec 5 | 6 | import Language.Lambda.Untyped.HspecUtils 7 | 8 | spec :: Spec 9 | spec = describe "Nat" $ do 10 | -- Nat is the definition of natural numbers. More precisely, Nat 11 | -- is the set of nonnegative integers. We represent nats using 12 | -- Church Encodings: 13 | -- 14 | -- 0: \f x. x 15 | -- 1: \f x. f x 16 | -- 2: \f x. f (f x) 17 | -- ...and so on 18 | 19 | describe "successor" $ do 20 | -- successor is a function that adds 1 21 | -- succ(0) = 1 22 | -- succ(1) = 2 23 | -- ... and so forth 24 | -- 25 | -- successor is defined by 26 | -- succ = \n f x. f (n f x) 27 | it "succ 0 = 1" $ 28 | "(\\n f x. f (n f x)) (\\f x. x)" `shouldEvalTo` "\\f x. f x" 29 | 30 | it "succ 1 = 2" $ 31 | "(\\n f x. f (n f x)) (\\f x. f x)" `shouldEvalTo` "\\f x. f (f x)" 32 | 33 | describe "add" $ do 34 | -- add(m, n) = m + n 35 | -- 36 | -- It is defined by applying successor m times on n: 37 | -- add = \m n f x. m f (n f x) 38 | it "add 0 2 = 2" $ 39 | "(\\m n f x. m f (n f x)) (\\f x. x) (\\f x. f (f x))" 40 | `shouldEvalTo` "\\f x. f (f x)" 41 | 42 | it "add 3 2 = 5" $ 43 | "(\\m n f x. m f (n f x)) (\\f x. f (f (f x))) (\\f x. f (f x))" 44 | `shouldEvalTo` "\\f x. f (f (f (f (f x))))" 45 | 46 | -- Here, we use `\f x. n f x` instead of `n`. This is because 47 | -- I haven't implemented eta conversion 48 | it "add 0 n = n" $ 49 | "(\\m n f x. m f (n f x)) (\\f x. x) n" 50 | `shouldEvalTo` "\\f x. n f x" 51 | 52 | describe "multiply" $ do 53 | -- multiply(m, n) = m * n 54 | -- 55 | -- multiply is defined by applying add m times 56 | -- multiply = \m n f x. m (n f x) x) 57 | -- 58 | -- Using eta conversion, we can omit the parameter x 59 | -- multiply = \m n f. m (n f) 60 | it "multiply 0 2 = 0" $ 61 | "(\\m n f. m (n f)) (\\f x. x) (\\f x. f (f x))" 62 | `shouldEvalTo` "\\f x. x" 63 | 64 | it "multiply 2 3 = 6" $ 65 | "(\\m n f. m (n f)) (\\f x. f (f x)) (\\f x. f (f (f x)))" 66 | `shouldEvalTo` "\\f x. f (f (f (f (f (f x)))))" 67 | 68 | it "multiply 0 n = 0" $ 69 | "(\\m n f. m (n f)) (\\f x. x) n" 70 | `shouldEvalTo` "\\f x. x" 71 | 72 | it "multiply 1 n = n" $ 73 | "(\\m n f. m (n f)) (\\f x. f x) n" 74 | `shouldEvalTo` "\\f x. n f x" 75 | 76 | describe "power" $ do 77 | -- The function power raises m to the power of n. 78 | -- power(m, n) = m^n 79 | -- 80 | -- power is defined by applying multiply n times 81 | -- power = \m n f x. (n m) f x 82 | -- 83 | -- Using eta conversion again, we can omit the parameter f 84 | -- power = \m n = n m 85 | 86 | -- NOTE: Here we use the first form to get more predictable 87 | -- variable names. Otherwise, alpha conversion will choose a random 88 | -- unique variable. 89 | it "power 0 1 = 0" $ 90 | "(\\m n f x. (n m) f x) (\\f x. x) (\\f x. f x)" 91 | `shouldEvalTo` "\\f x. x" 92 | 93 | it "power 2 3 = 8" $ 94 | "(\\m n f x. (n m) f x) (\\f x. f (f x)) (\\f x. f (f (f x)))" 95 | `shouldEvalTo` "\\f x. f (f (f (f (f (f (f (f x)))))))" 96 | 97 | it "power n 0 = 1" $ 98 | "(\\m n f x. (n m) f x) n (\\f x. x)" 99 | `shouldEvalTo` "\\f x. f x" 100 | 101 | it "power n 1 = n" $ 102 | "(\\m n f x. (n m) f x) n (\\f x. f x)" 103 | `shouldEvalTo` "\\f x. n f x" 104 | -------------------------------------------------------------------------------- /test/Language/Lambda/Untyped/Examples/PairSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-} 2 | module Language.Lambda.Untyped.Examples.PairSpec where 3 | 4 | import Language.Lambda.Untyped.HspecUtils 5 | 6 | import RIO 7 | import Test.Hspec 8 | 9 | spec :: Spec 10 | spec = describe "Pair" $ do 11 | -- Pair is the definition of tuples with two items. Pairs, 12 | -- again are represented using Church Encodings: 13 | -- 14 | -- pair = \x y f. f x y 15 | describe "first" $ do 16 | -- The function first returns the first item in a pair 17 | -- first(x, y) = x 18 | -- 19 | -- first is defined by 20 | -- first = \p. p (\t f. t) 21 | it "first 0 1 = 0" $ 22 | "(\\p. p (\\t f. t)) ((\\x y f. f x y) (\\f x. x) (\\f x. f x))" 23 | `shouldEvalTo` "\\f x. x" 24 | 25 | it "first x y = x" $ 26 | "(\\p. p (\\t f. t)) ((\\x y f. f x y) x y)" `shouldEvalTo` "x" 27 | 28 | describe "second" $ do 29 | -- The function second returns the second item in a pair 30 | -- second(x, y) = y 31 | -- 32 | -- second is defined by 33 | -- second = \p. p (\t f. f) 34 | it "second 0 1 = 1" $ 35 | "(\\p. p (\\t f. f)) ((\\x y f. f x y) (\\f x. x) (\\f x. f x))" 36 | `shouldEvalTo` "\\f x. f x" 37 | 38 | it "second x y = y" $ do 39 | "(\\p. p (\\t f. f)) ((\\x y f. f x y) x y)" `shouldEvalTo` "y" 40 | "(\\p. p (\\x y z. x)) ((\\x y z f. f x y z) x y z)" `shouldEvalTo` "x" 41 | -------------------------------------------------------------------------------- /test/Language/Lambda/Untyped/ExpressionSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-} 2 | module Language.Lambda.Untyped.ExpressionSpec where 3 | 4 | import Language.Lambda.Untyped.Expression 5 | 6 | import RIO 7 | import Test.Hspec 8 | 9 | spec :: Spec 10 | spec = describe "prettyPrint" $ do 11 | let prettyPrint' :: LambdaExpr Text -> Text 12 | prettyPrint' = prettyPrint 13 | 14 | it "prints simple variables" $ 15 | prettyPrint' (Var "x") `shouldBe` "x" 16 | 17 | it "prints simple abstractions" $ 18 | prettyPrint' (Abs "x" (Var "x")) `shouldBe` "λx. x" 19 | 20 | it "prints simple applications" $ 21 | prettyPrint' (App (Var "a") (Var "b")) 22 | `shouldBe` "a b" 23 | 24 | it "prints simple let expressions" $ 25 | prettyPrint' (Let "x" (Var "y")) `shouldBe` "let x = y" 26 | 27 | it "prints nested abstractions" $ 28 | prettyPrint' (Abs "f" (Abs "x" (Abs "y" (Var "x")))) 29 | `shouldBe` "λf x y. x" 30 | 31 | it "prints nested applications" $ 32 | prettyPrint' (App (App (Var "f") (Var "x")) (Var "y")) 33 | `shouldBe` "f x y" 34 | 35 | it "prints parenthesized applications" $ do 36 | prettyPrint' (App (Var "f") (App (Var "x") (Var "y"))) 37 | `shouldBe` "f (x y)" 38 | 39 | prettyPrint' (App (Abs "x" (Var "x")) (Var "y")) 40 | `shouldBe` "(λx. x) y" 41 | 42 | prettyPrint' (App (Var "x") (Abs "f" (Var "f"))) 43 | `shouldBe` "x (λf. f)" 44 | 45 | prettyPrint' (App (Abs "f" (Var "f")) (Abs "g" (Var "g"))) 46 | `shouldBe` "(λf. f) (λg. g)" 47 | 48 | it "prints complex let expressions" $ 49 | prettyPrint' (Let "x" (Abs "a" (Abs "b" (App (Var "a") (Var "b"))))) 50 | `shouldBe` "let x = λa b. a b" 51 | -------------------------------------------------------------------------------- /test/Language/Lambda/Untyped/HspecUtils.hs: -------------------------------------------------------------------------------- 1 | module Language.Lambda.Untyped.HspecUtils where 2 | 3 | import RIO 4 | import Test.Hspec 5 | 6 | import Language.Lambda.Shared.Errors 7 | import Language.Lambda.Untyped 8 | 9 | shouldEvalTo :: Text -> Text -> Expectation 10 | shouldEvalTo s1 = shouldBe (eval s1) . eval 11 | 12 | eval :: Text -> Either LambdaException (LambdaExpr Text) 13 | eval input = execEval (evalText input) (mkEvalState defaultUniques) 14 | -------------------------------------------------------------------------------- /test/Language/Lambda/Untyped/ParserSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-} 2 | module Language.Lambda.Untyped.ParserSpec (spec) where 3 | 4 | import Language.Lambda.Untyped.Expression 5 | import Language.Lambda.Untyped.Parser 6 | 7 | import Data.Either 8 | import Test.Hspec 9 | import RIO 10 | 11 | spec :: Spec 12 | spec = describe "parseExpr" $ do 13 | it "parses simple variables" $ 14 | parseExpr "x" `shouldBe` Right (Var "x") 15 | 16 | it "parses parenthesized variables" $ 17 | parseExpr "(x)" `shouldBe` Right (Var "x") 18 | 19 | it "parses simple abstractions" $ 20 | parseExpr "\\x. x" `shouldBe` Right (Abs "x" (Var "x")) 21 | 22 | it "parses nested abstractions" $ 23 | parseExpr "\\f a. a" `shouldBe` Right (Abs "f" (Abs "a" (Var "a"))) 24 | 25 | it "parses simple applications" $ 26 | parseExpr "f x" `shouldBe` Right (App (Var "f") (Var "x")) 27 | 28 | it "parses chained applications" $ 29 | parseExpr "f x y" `shouldBe` Right (App (App (Var "f") (Var "x")) (Var "y")) 30 | 31 | it "parses simple let expressions" $ 32 | parseExpr "let x = z" `shouldBe` Right (Let "x" (Var "z")) 33 | 34 | it "parses complex expressions" $ do 35 | let exprs = [ 36 | "\\f x. f x", 37 | "(\\p x y. y) (\\p x y. x)", 38 | "f (\\x. x)", 39 | "(\\x . f x) g y", 40 | "(\\f . (\\ x y. f x y) f x y) w x y", 41 | "let x = \\f x. f x" 42 | ] 43 | 44 | mapM_ (flip shouldSatisfy isRight . parseExpr) exprs 45 | 46 | it "does not parse trailing errors" $ 47 | parseExpr "x +" `shouldSatisfy` isLeft 48 | 49 | it "ignores whitespace" $ do 50 | let exprs = [ 51 | " x ", 52 | " \\ x . x ", 53 | " ( x ) " 54 | ] 55 | 56 | mapM_ (flip shouldSatisfy isRight . parseExpr) exprs 57 | -------------------------------------------------------------------------------- /test/Language/Lambda/UntypedSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-} 2 | module Language.Lambda.UntypedSpec where 3 | 4 | import RIO 5 | import qualified RIO.Map as Map 6 | import qualified RIO.Text as Text 7 | import Test.Hspec 8 | 9 | import Language.Lambda.Untyped 10 | import Language.Lambda.Untyped.HspecUtils 11 | 12 | spec :: Spec 13 | spec = do 14 | describe "evalText" $ do 15 | it "evaluates simple text" $ do 16 | eval "x" `shouldBe` Right (Var "x") 17 | eval "\\x. x" `shouldBe` Right (Abs "x" (Var "x")) 18 | eval "f y" `shouldBe` Right (App (Var "f") (Var "y")) 19 | 20 | it "reduces simple applications" $ 21 | eval "(\\x .x) y" `shouldBe` Right (Var "y") 22 | 23 | it "reduces applications with nested redexes" $ 24 | eval "(\\f x. f x) (\\y. y)" `shouldBe` Right (Abs "x" (Var "x")) 25 | 26 | describe "runEvalText" $ do 27 | let runEvalText' input = fst <$> runEvalText input Map.empty 28 | 29 | it "evaluates simple strings" $ do 30 | runEvalText' "x" `shouldBe` Right (Var "x") 31 | runEvalText' "\\x. x" `shouldBe` Right (Abs "x" (Var "x")) 32 | runEvalText' "f y" `shouldBe` Right (App (Var "f") (Var "y")) 33 | 34 | it "reduces simple applications" $ 35 | runEvalText' "(\\x .x) y" `shouldBe` Right (Var "y") 36 | 37 | it "reduces applications with nested redexes" $ 38 | runEvalText' "(\\f x. f x) (\\y. y)" `shouldBe` Right (Abs "x" (Var "x")) 39 | 40 | describe "execEvalText" $ do 41 | let execEvalText' input = execEvalText input Map.empty 42 | 43 | it "evaluates simple texts" $ do 44 | execEvalText' "x" `shouldBe` Right (Var "x") 45 | execEvalText' "\\x. x" `shouldBe` Right (Abs "x" (Var "x")) 46 | execEvalText' "f y" `shouldBe` Right (App (Var "f") (Var "y")) 47 | 48 | it "reduces simple applications" $ 49 | execEvalText' "(\\x .x) y" `shouldBe` Right (Var "y") 50 | 51 | it "reduces applications with nested redexes" $ 52 | execEvalText' "(\\f x. f x) (\\y. y)" `shouldBe` Right (Abs "x" (Var "x")) 53 | 54 | describe "unsafeExecEvalText" $ do 55 | let unsafeExecEvalText' input = unsafeExecEvalText input Map.empty 56 | 57 | it "evaluates simple texts" $ do 58 | unsafeExecEvalText' "x" `shouldBe` Var "x" 59 | unsafeExecEvalText' "\\x. x" `shouldBe` Abs "x" (Var "x") 60 | unsafeExecEvalText' "f y" `shouldBe` App (Var "f") (Var "y") 61 | 62 | it "reduces simple applications" $ 63 | unsafeExecEvalText' "(\\x .x) y" `shouldBe` Var "y" 64 | 65 | it "reduces applications with nested redexes" $ 66 | unsafeExecEvalText' "(\\f x. f x) (\\y. y)" `shouldBe` Abs "x" (Var "x") 67 | 68 | describe "defaultUniques" $ do 69 | let alphabet = reverse ['a'..'z'] 70 | len = length alphabet 71 | 72 | it "starts with plain alphabet" $ 73 | take len defaultUniques `shouldBe` map (`Text.cons` Text.empty) alphabet 74 | 75 | it "adds index afterwards" $ 76 | take len (drop len defaultUniques) 77 | `shouldBe` map (`Text.cons` Text.singleton '0') alphabet 78 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | --------------------------------------------------------------------------------