├── .gitignore ├── .travis.yml ├── CHANGES.md ├── Exercise1.md ├── Exercise2.md ├── Exercise3.md ├── LICENSE ├── README.md ├── Setup.hs ├── cabal.project.local ├── exercises ├── Ex1.hs └── Ex2.hs ├── glambda.cabal ├── main └── Main.hs ├── pres ├── G.hs ├── README.md ├── STy.hs ├── deBruijn.tex ├── notes.txt ├── slides.key └── slides.pdf ├── src └── Language │ └── Glambda │ ├── Check.hs │ ├── Eval.hs │ ├── Exp.hs │ ├── Globals.hs │ ├── Lex.hs │ ├── Monad.hs │ ├── Parse.hs │ ├── Pretty.hs │ ├── Repl.hs │ ├── Shift.hs │ ├── Statement.hs │ ├── Token.hs │ ├── Type.hs │ ├── Unchecked.hs │ └── Util.hs └── tests ├── Tests ├── Check.hs ├── Lex.hs ├── Main.hs ├── Parse.hs └── Util.hs ├── prime.glam └── revapp.glam /.gitignore: -------------------------------------------------------------------------------- 1 | ### Haskell 2 | dist 3 | dist-* 4 | cabal-dev 5 | *.o 6 | *.hi 7 | *.chi 8 | *.chs.h 9 | *.dyn_o 10 | *.dyn_hi 11 | *.prof 12 | *.aux 13 | *.hp 14 | *.eventlog 15 | .virtualenv 16 | .hsenv 17 | .hpc 18 | .cabal-sandbox/ 19 | cabal.sandbox.config 20 | cabal.config 21 | cabal.project.local 22 | .ghc.environment.* 23 | .HTF/ 24 | # Stack 25 | .stack-work/ 26 | 27 | ### IDE/support 28 | # Vim 29 | [._]*.s[a-v][a-z] 30 | [._]*.sw[a-p] 31 | [._]s[a-v][a-z] 32 | [._]sw[a-p] 33 | *~ 34 | tags 35 | 36 | # IntellijIDEA 37 | .idea/ 38 | .ideaHaskellLib/ 39 | *.iml 40 | 41 | # Atom 42 | .haskell-ghc-mod.json 43 | 44 | # VS 45 | .vscode/ 46 | 47 | # Emacs 48 | *# 49 | .dir-locals.el 50 | TAGS 51 | 52 | # other 53 | .DS_Store 54 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # NB: don't set `language: haskell` here 2 | 3 | # The following enables several GHC versions to be tested; often it's enough to test only against the last release in a major GHC version. Feel free to omit lines listings versions you don't need/want testing for. 4 | env: 5 | - CABALVER=1.18 GHCVER=7.6.3 6 | - CABALVER=1.18 GHCVER=7.8.3 7 | - CABALVER=1.18 GHCVER=7.8.4 8 | - CABALVER=1.22 GHCVER=7.10.1 9 | - CABALVER=1.22 GHCVER=7.10.2 10 | - CABALVER=1.22 GHCVER=7.10.3 11 | - CABALVER=1.24 GHCVER=8.0.1 12 | - CABALVER=1.24 GHCVER=8.2.1 13 | - CABALVER=1.24 GHCVER=8.4.4 14 | - CABALVER=1.24 GHCVER=8.6.4 15 | - CABALVER=head GHCVER=head 16 | 17 | matrix: 18 | allow_failures: 19 | - env: CABALVER=head GHCVER=head 20 | 21 | # Note: the distinction between `before_install` and `install` is not important. 22 | before_install: 23 | - travis_retry sudo add-apt-repository -y ppa:hvr/ghc 24 | - travis_retry sudo apt-get update 25 | - travis_retry sudo apt-get install cabal-install-$CABALVER ghc-$GHCVER # see note about happy/alex 26 | - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH 27 | 28 | install: 29 | - cabal --version 30 | - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" 31 | - travis_retry cabal update 32 | - cabal install --only-dependencies --enable-tests --enable-benchmarks 33 | 34 | # Here starts the actual work to be performed for the package under test; any command which exits with a non-zero exit code causes the build to fail. 35 | script: 36 | - if [ -f configure.ac ]; then autoreconf -i; fi 37 | - cabal configure --enable-tests --enable-benchmarks -v2 --ghc-options="-Werror" # -v2 provides useful information for debugging 38 | - cabal build --ghc-options="-Werror" # this builds all libraries and executables (including tests/benchmarks) 39 | - cabal test 40 | - cabal check 41 | - cabal sdist # tests that a source-distribution can be generated 42 | 43 | # Check that the resulting source distribution can be built & installed. 44 | # If there are no other `.tar.gz` files in `dist`, this can be even simpler: 45 | # `cabal install --force-reinstalls dist/*-*.tar.gz` 46 | - SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz && 47 | (cd dist && cabal install --force-reinstalls "$SRC_TGZ") 48 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | Release notes for glambda 2 | ========================= 3 | 4 | 1.0.2 5 | ----- 6 | 7 | Update package dependencies to drop dependency on `either`. 8 | 9 | 1.0.1 10 | ----- 11 | 12 | Update package dependencies to drop dependency on `errors`. 13 | 14 | 1.0 15 | --- 16 | 17 | Initial release. 18 | -------------------------------------------------------------------------------- /Exercise1.md: -------------------------------------------------------------------------------- 1 | Exercise 1: Extend `zero` 2 | ========================= 3 | 4 | The first exercise is to extend the `zero` function we have just seen. 5 | 6 | In the `glambda` repo, look in the `exercises` directory and open up 7 | `Ex1.hs`. The code we've been discussing should appear. 8 | 9 | Add constructors for 10 | * `[]` (the list type) 11 | * `Wrap` (defined in the file) 12 | * `()` (the unit type), and 13 | * `(->)` 14 | 15 | Add clauses of `zero` for these as well. 16 | 17 | The solution is available in `Ex1.hs` in the `solutions` branch. 18 | -------------------------------------------------------------------------------- /Exercise2.md: -------------------------------------------------------------------------------- 1 | Exercise 2: `get` 2 | ================= 3 | 4 | The second exercise is to write the `get` function, retrieving an element 5 | from a heterogeneous list. 6 | 7 | In the `glambda` repo, look in the `exercises` directory and open up 8 | `Ex2.hs`. The code we've been discussing should appear. 9 | 10 | Write a function `get :: HList tys -> Elem tys ty -> ty`. A correct 11 | definition of this function will tickle GHC's bug #3927 (fixed for GHC 8), 12 | when you get a spurious warning about incomplete patterns. 13 | 14 | If you have extra time left over at the end, start playing with glambda. 15 | In the top level of the `glambda` repo, say 16 | 17 | > cabal configure 18 | > cabal build 19 | > ./dist/build/glam/glam 20 | 21 | A brief manual for the Glamorous Glambda interpreter is toward the bottom 22 | of the [README](README.md) for this repo. You'll find some test `.glam` 23 | files in the `tests` directory. Load them with `:load tests/revapp.glam` 24 | for instance. (No quotes around filenames, please.) 25 | 26 | The solution is available in `Ex2.hs` in the `solutions` branch. 27 | -------------------------------------------------------------------------------- /Exercise3.md: -------------------------------------------------------------------------------- 1 | Exercise 3: `eval`, `apply`, and `cond` 2 | ======================================= 3 | 4 | The last exercise is to write the `eval`, `apply`, and `cond` functions. 5 | 6 | To ensure the proper setup for this task, go into the `glambda` repo you've 7 | cloned and say 8 | 9 | > git checkout ex3 10 | 11 | This will put you on the `ex3` branch, which has everything in just the right 12 | state for this exercise. 13 | 14 | Just to make sure everything is still humming along nicely at this point, 15 | go ahead and do a 16 | 17 | > cabal configure 18 | > cabal build 19 | 20 | (You won't need to enable testing for these exercises.) 21 | 22 | The final program should build without any problems. Of course, it doesn't 23 | have an evaluator! But you should still be able to do things, as long as 24 | those things don't require using the big-step evaluator function application. 25 | (Both the big-step and small-step evaluators use the same -- now missing -- 26 | code for function application.) To test, you can run `glam`: 27 | 28 | > ./dist/build/glam/glam 29 | ... 30 | λ> :step \x:Int.x 31 | λ#. #0 : Int -> Int 32 | λ#. #0 : Int -> Int 33 | λ> :quit 34 | 35 | Note how these instructions use `:step` to avoid using the big-step evaluator. 36 | 37 | Write your evaluator in `src/Language/Glambda/Eval.hs`. You will see `apply`, 38 | `cond`, and `eval` functions stubbed out in that file. Fill them in. 39 | 40 | Useful tips: 41 | * To start an interactive session with the glambda package loaded, use 42 | `cabal repl` in the `glambda` directory. If that somehow isn't the 43 | setup you want, `cabal exec XXX` runs command `XXX` with your sandbox 44 | available. (For example, you can say `cabal exec ghci` for a sandbox-aware 45 | GHCi session or `cabal exec bash` to make a prompt where every call to 46 | GHC or its utilities uses your sandboxed set of packages.) 47 | 48 | * You will need to work closely with the `Exp` type, defined in 49 | `src/Language/Glambda/Exp.hs`. You will also need the `Val` type, 50 | also defined in `Exp.hs`. If it's more convenient, you can also 51 | use the Haddock docs at https://hackage.haskell.org/package/glambda 52 | 53 | * You may want to look at `step`, the small-step stepper for inspiration. 54 | 55 | * You will also need to use substitution. Use 56 | 57 | subst :: Exp ctx s -> Exp (s ': ctx) t -> Exp ctx t 58 | 59 | to substitute the first expression in for the 0'th variable of the second. 60 | This function is defined in the `Language.Glambda.Shift` module. 61 | 62 | * You will *not* need to edit any file other than `Eval.hs`. 63 | 64 | The solution is available in `Eval.hs` in the `master` branch. 65 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015, Richard Eisenberg 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | 7 | 1. Redistributions of source code must retain the above copyright notice, this 8 | list of conditions and the following disclaimer. 9 | 10 | 2. Redistributions in binary form must reproduce the above copyright notice, 11 | this list of conditions and the following disclaimer in the documentation 12 | and/or other materials provided with the distribution. 13 | 14 | 3. Neither the name of the author nor the names of its contributors may be 15 | used to endorse or promote products derived from this software without 16 | specific prior written permission. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 19 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 20 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 21 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 22 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 24 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 25 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 26 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 27 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 28 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | A Practical Introduction to Haskell GADTs 2 | ========================================= 3 | 4 | This repo and these notes are for a talk given at [LambdaConf][1] in 5 | Boulder, CO, USA, on 22 May, 2015. 6 | 7 | See below for more information about `glambda` itself. 8 | 9 | Setup 10 | ----- 11 | 12 | **Do this first!** 13 | 14 | We will be working from my [glambda][2] project to learn about Generalized 15 | Algebraic Datatypes (GADTs). The `glambda` package has a non-trivial set 16 | of dependencies. While I'm introducing myself and GADTs, generally, it would 17 | be wise to download and compile all of the dependencies onto your laptop. 18 | Then, when we get to hands-on exercises, you'll be all ready to go. 19 | 20 | Here's what to do 21 | 22 | > git clone git://github.com/goldfirere/glambda.git 23 | > cd glambda 24 | > cabal sandbox init 25 | > cabal install --only-dependencies --enable-tests -j<# of CPUs you have> 26 | 27 | This should make your computer spin for a little while. In the meantime, 28 | enjoy the talk! (If you have trouble with `cabal sandbox`, possibly because 29 | of an old `cabal`, try the sequence of commands above without that step.) 30 | 31 | Exercises 1 and 2 do *not* require those dependencies, so you can work on 32 | them while compiling dependencies. 33 | 34 | Instructions for exercises: 35 | - [Exercise 1](Exercise1.md) 36 | - [Exercise 2](Exercise2.md) 37 | - [Exercise 3](Exercise3.md) 38 | 39 | [1]: http://www.degoesconsulting.com/lambdaconf-2015/ 40 | [2]: https://github.com/goldfirere/glambda 41 | 42 | More information about `glambda` appears below: 43 | 44 | The Glamorous Glambda Interpreter 45 | ================================= 46 | 47 | Glambda is a simply-typed lambda calculus interpreter. While it is intended 48 | to be easy-to-use and help users learn about the lambda calculus, its real 49 | strength is its implementation, which makes heavy use of GADTs, and is designed 50 | to serve as a showcase of writing a real-world program with extra compile-time 51 | guarantees. 52 | 53 | This manual focuses only on the user experience. The structure of the code 54 | will be described in a series of GADT programming tutorials coming out 55 | Real Soon Now. 56 | 57 | Example session 58 | --------------- 59 | 60 | Saying `cabal install glambda` will produce an executable `glam`. `glam` is 61 | the lambda-calculus interpreter. It is GHCi-like, accepting commands beginning 62 | with a `:`. Here is an example session: 63 | 64 | ~~~ 65 | \\\\\\ 66 | \\\\\\ 67 | /-\ \\\\\\ 68 | | | \\\\\\ 69 | \-/| \\\\\\ 70 | | //\\\\\\ 71 | \-/ ////\\\\\\ 72 | //////\\\\\\ 73 | ////// \\\\\\ 74 | ////// \\\\\\ 75 | Welcome to the Glamorous Glambda interpreter, version 1.0. 76 | λ> (\x:Int.x + 2) 5 77 | 7 : Int 78 | λ> revapp = \x:Int.\y:Int->Int.y x 79 | revapp = λ#. λ#. #0 #1 : Int -> (Int -> Int) -> Int 80 | λ> not = \b:Bool.if b then false else true 81 | not = λ#. if #0 then false else true : Bool -> Bool 82 | λ> revapp (3 < 4) not 83 | Bad function application. 84 | Function type: Int -> (Int -> Int) -> Int 85 | Argument type: Bool 86 | in the expression 'revapp (3 < 4)' 87 | λ> not (3 < 4) 88 | false : Bool 89 | λ> :type revapp (10 % 3) 90 | (λ#. λ#. #0 #1) (10 % 3) : (Int -> Int) -> Int 91 | λ> :step revapp (10 % 3) (\x:Int.x * 2) 92 | (λ#. λ#. #0 #1) (10 % 3) (λ#. #0 * 2) : Int 93 | --> (λ#. #0 (10 % 3)) (λ#. #0 * 2) : Int 94 | --> (λ#. #0 * 2) (10 % 3) : Int 95 | --> 10 % 3 * 2 : Int 96 | --> 1 * 2 : Int 97 | --> 2 : Int 98 | 2 : Int 99 | λ> :quit 100 | Good-bye. 101 | ~~~ 102 | 103 | As you can see, glambda uses [de Bruijn indices][3] to track variable binding. 104 | In the actual output (if your console supports it), the binders (`#`) and 105 | usage sites (`#0`, `#1`) are colored so that humans can easily tell which 106 | variable is used where. 107 | 108 | [3]: https://en.wikipedia.org/wiki/De_Bruijn_index 109 | 110 | You can also see above that the input to glambda must be fully annotated; 111 | glambda does *not* do type inference. However, note that types on binders 112 | do not appear in the output: once an input is type-checked, the type information 113 | is erased. Yet, because of the use of GADTs in the implementation, we 114 | can be sure that the reductions are type-safe. 115 | 116 | The Language 117 | ------------ 118 | 119 | The glambda language is an explicitly typed simply typed lambda calculus, 120 | with integers (`Int`) and booleans (`Bool`). The following operators are 121 | supported, with their usual meanings, associativity, and precedence: 122 | 123 | + - * / % < <= > >= == 124 | 125 | The only slightly unusual member of this list is `%`, which takes a modulus, 126 | like in C-inspired languages. The division operator `/` does integer division, 127 | naturally. 128 | 129 | Glambda supports a ternary conditional operator, demonstrated in the 130 | snippet above, as `if then else `. 131 | 132 | Integer constants must be positive. Subtract from 0 to get a negative integer. 133 | 134 | Boolean constants are spelled `false` and `true`. 135 | 136 | Comments are exactly as in Haskell: `--` starts a line comment, and 137 | `{- ... -}` is a block comment. Comments can be nested. 138 | 139 | Variable names are as in Haskell: names must start with a letter or 140 | underscore (although case is immaterial) and then may have letters, numbers, 141 | and underscores. 142 | 143 | The language is not whitespace-aware. 144 | 145 | Most of what we have seen are *expressions*. Glambda also supports *statements*. 146 | A statement is either an expression or has the form ` = `. 147 | This latter form assigns a global variable to the expression. These global 148 | variables are expanded during type-checking: they are more like macros than 149 | proper cells holding information. Statements can be separated by `;`. 150 | 151 | The Interface 152 | ------------- 153 | 154 | When you type an expression into the glambda interpreter, it is evaluated 155 | fully, and the value is printed, along with its type. 156 | 157 | When you type a global variable assignment, that variable is assigned, and 158 | its (unevaluated) contents are printed, along with its type. 159 | 160 | You can also run commands, as described below. Commands all start with a 161 | leading `:`, and that `:` must be the first character on the input line. 162 | Arguments to a command are given after the command itself. Commands can 163 | be abbreviated by typing an unambiguous prefix to a command. For example, 164 | `:t` can be used to get an expression's type, because no other command 165 | begins with `t`. 166 | 167 | Commands 168 | -------- 169 | 170 | `:quit` quits the glambda interpreter. 171 | 172 | `:lex` lexes the given text and pretty-prints the result. 173 | 174 | `:parse` parses the given text and pretty-prints the result. 175 | 176 | `:eval` type-checks and evaluates the given expression. This is 177 | the default behavior at the command line. 178 | 179 | `:step` runs the given expression through the single-step semantics. 180 | This shows you every step of the way from your expression down to 181 | a value. This uses a *different* evaluation strategy than `:eval` does, 182 | but the result should always be the same. 183 | 184 | `:type` gives you the type of an expression. 185 | 186 | `:all` runs both `:eval` and `:step` on an expression. 187 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /cabal.project.local: -------------------------------------------------------------------------------- 1 | 2 | package * 3 | ghc-location: ghc 4 | 5 | program-locations 6 | ghc-location: ghc 7 | -------------------------------------------------------------------------------- /exercises/Ex1.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | 3 | module Ex1 where 4 | 5 | -- | A very simple newtype wrapper 6 | newtype Wrap a = Wrap a 7 | 8 | -- | A type-indexed representation of a type 9 | data STy ty where 10 | SIntTy :: STy Int 11 | SBoolTy :: STy Bool 12 | SMaybeTy :: STy a -> STy (Maybe a) 13 | 14 | -- | Produce a "zero" of that type 15 | zero :: STy ty -> ty 16 | zero SIntTy = 0 17 | zero SBoolTy = False 18 | zero (SMaybeTy _) = Nothing 19 | -------------------------------------------------------------------------------- /exercises/Ex2.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs, DataKinds, PolyKinds, TypeOperators #-} 2 | {-# OPTIONS_GHC -fwarn-incomplete-patterns #-} 3 | 4 | module Ex2 where 5 | 6 | -- | An 'HList' is a heterogeneous list, indexed by a type-level list 7 | -- of types. 8 | data HList tys where 9 | Nil :: HList '[] 10 | (:>) :: h -> HList t -> HList (h ': t) 11 | infixr 5 :> 12 | 13 | -- | @Elem xs x@ is evidence that @x@ is in the list @xs@. 14 | -- @EZ :: Elem xs x@ is evidence that @x@ is the first element of @xs@. 15 | -- @ES ev :: Elem xs x@ is evidence that @x@ is one position later in 16 | -- @xs@ than is indicated in @ev@ 17 | data Elem list elt where 18 | EZ :: Elem (x ': xs) x 19 | ES :: Elem xs x -> Elem (y ': xs) x 20 | 21 | -- | Get retrieves an item out of a heterogeneous list 22 | get :: Elem tys ty -> HList tys -> ty 23 | get = undefined 24 | -------------------------------------------------------------------------------- /glambda.cabal: -------------------------------------------------------------------------------- 1 | name: glambda 2 | version: 1.0.2 3 | cabal-version: >= 1.10 4 | synopsis: A simply typed lambda calculus interpreter, written with GADTs 5 | homepage: https://github.com/goldfirere/glambda 6 | category: Compilers/Interpreters 7 | author: Richard Eisenberg 8 | maintainer: Richard Eisenberg 9 | bug-reports: https://github.com/goldfirere/glambda/issues 10 | stability: unknown 11 | extra-source-files: README.md, CHANGES.md 12 | license: BSD3 13 | license-file: LICENSE 14 | build-type: Simple 15 | description: 16 | This is an interpreter for the simply-typed lambda calculus. It is 17 | written making heavy use of generalized algebraic datatypes (GADTs), and is 18 | meant to serve as an example how how these GADTs can be useful. See 19 | the GitHub repo for more information about the syntax for the language 20 | and interpreter commands. 21 | 22 | source-repository this 23 | type: git 24 | location: https://github.com/goldfirere/glambda.git 25 | tag: v1.0.2 26 | 27 | library 28 | build-depends: base == 4.* 29 | , prettyprinter >= 1.7.0 30 | , prettyprinter-ansi-terminal >= 1.1.0 31 | , mtl >= 2.2.1 32 | , transformers >= 0.4.0.0 33 | , containers >= 0.5 34 | , parsec >= 3.1 35 | , haskeline >= 0.7.1.1 36 | , directory >= 1.2.0.1 37 | , text >= 2.1.1 38 | 39 | 40 | exposed-modules: Language.Glambda.Repl 41 | Language.Glambda.Check 42 | Language.Glambda.Eval 43 | Language.Glambda.Exp 44 | Language.Glambda.Globals 45 | Language.Glambda.Lex 46 | Language.Glambda.Monad 47 | Language.Glambda.Parse 48 | Language.Glambda.Pretty 49 | Language.Glambda.Shift 50 | Language.Glambda.Statement 51 | Language.Glambda.Token 52 | Language.Glambda.Type 53 | Language.Glambda.Unchecked 54 | Language.Glambda.Util 55 | 56 | hs-source-dirs: src 57 | ghc-options: -Wall -fno-warn-name-shadowing 58 | default-language: Haskell2010 59 | 60 | executable glam 61 | build-depends: base == 4.* 62 | , glambda 63 | 64 | hs-source-dirs: main 65 | ghc-options: -Wall -fno-warn-name-shadowing 66 | default-language: Haskell2010 67 | main-is: Main.hs 68 | 69 | test-suite tests 70 | type: exitcode-stdio-1.0 71 | hs-source-dirs: tests 72 | ghc-options: -Wall -fno-warn-name-shadowing -main-is Tests.Main 73 | default-language: Haskell2010 74 | main-is: Tests/Main.hs 75 | 76 | other-modules: Tests.Check 77 | Tests.Parse 78 | Tests.Lex 79 | Tests.Util 80 | 81 | build-depends: base == 4.* 82 | , glambda 83 | , template-haskell 84 | , prettyprinter >= 1.7.0 85 | , prettyprinter-ansi-terminal >= 1.1.0 86 | , mtl >= 2.2.1 87 | , transformers >= 0.4.0.0 88 | , parsec >= 3.1 89 | , tasty >= 0.8.1 90 | , tasty-hunit >= 0.9 91 | -------------------------------------------------------------------------------- /main/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import qualified Language.Glambda.Repl as Repl ( main ) 4 | 5 | main :: IO () 6 | main = Repl.main 7 | -------------------------------------------------------------------------------- /pres/G.hs: -------------------------------------------------------------------------------- 1 | -- Very simple GADT example 2 | -- Copyright (c) 2015 Richard Eisenberg 3 | 4 | {-# LANGUAGE GADTs #-} 5 | 6 | module G where 7 | 8 | data G a where 9 | MkGInt :: G Int 10 | MkGBool :: G Bool 11 | 12 | frob :: G a -> a 13 | frob MkGInt = 5 14 | frob MkGBool = False 15 | -------------------------------------------------------------------------------- /pres/README.md: -------------------------------------------------------------------------------- 1 | RAE's notes 2 | =========== 3 | 4 | This directory contains my notes and slides for the "Practical Introduction 5 | to Haskell GADTs" talk. There's nothing private in here, but no attempt has 6 | been made to make anything here sensible to anyone but me. 7 | -------------------------------------------------------------------------------- /pres/STy.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | 3 | module STy where 4 | 5 | data STy ty where 6 | SIntTy :: STy Int 7 | SBoolTy :: STy Bool 8 | SMaybeTy :: STy a -> STy (Maybe a) 9 | SArr :: STy a -> STy b -> STy (a -> b) 10 | 11 | zero :: STy ty -> ty 12 | zero SIntTy = 0 13 | zero SBoolTy = False 14 | zero (SMaybeTy _) = Nothing 15 | zero (SArr _ res) = const (zero res) 16 | 17 | eqSTy :: STy ty -> STy ty -> Bool 18 | eqSTy SIntTy SIntTy = True 19 | {- 20 | eqSTy SBoolTy SBoolTy = True 21 | eqSTy (SMaybeTy t1) (SMaybeTy t2) = t1 `eqSTy` t2 22 | eqSTy (t1 `SArr` t2) (t3 `SArr` t4) = t1 `eqSTy` t3 && t2 `eqSTy` t4 23 | -} 24 | -------------------------------------------------------------------------------- /pres/deBruijn.tex: -------------------------------------------------------------------------------- 1 | \documentclass{article} 2 | 3 | \usepackage{amssymb} 4 | \usepackage{amsmath} 5 | \usepackage{xcolor} 6 | \usepackage{upgreek} 7 | \usepackage{fullpage} 8 | 9 | \newcommand{\lam}{\uplambda} 10 | \newcommand{\ttt}{\text{\texttt{t}}} 11 | \newcommand{\kk}{\text{\texttt{k}}} 12 | \newcommand{\jj}{\text{\texttt{j}}} 13 | \newcommand{\sss}{\text{\texttt{s}}} 14 | \newcommand{\shiftup}{{\uparrow}} 15 | 16 | \begin{document} 17 | \Huge 18 | \colorbox{black}{\color{white} 19 | \begin{minipage}{\textwidth} 20 | \vspace{1cm} 21 | \[ 22 | \begin{array}{lcl} 23 | \shiftup^d_c(\kk) & = & \left\{ \begin{array}{ll} \kk & \text{if } \kk < c \\ \kk + d & \text{if } \kk \geq c \end{array} \right. \\ 24 | \shiftup^d_c(\lam.\ttt_1) &=& \lam. \shiftup^d_{c+1}(\ttt_1) \\ 25 | \shiftup^d_c(\ttt_1\ \ttt_2) &=& \shiftup^d_c(\ttt_1)\ \shiftup^d_c(\ttt_2) 26 | \end{array} 27 | \] 28 | \vspace{2cm} 29 | \[ 30 | \begin{array}{lcl} 31 | [\jj \mapsto \sss]\kk &=& \left\{ \begin{array}{ll} \sss & \text{if } \kk = \jj \\ \kk & \text{otherwise} \end{array} \right. \\{} 32 | [\jj \mapsto \sss](\lam.\ttt_1) &=& \lam.[\jj+1 \mapsto \shiftup^1_0(\sss)]\ttt_1 \\{} 33 | [\jj \mapsto \sss](\ttt_1\ \ttt_2) &=& [\jj \mapsto \sss]\ttt_1\ [\jj \mapsto \sss]\ttt_2 34 | \end{array} 35 | \] 36 | \vspace{1cm} 37 | \end{minipage} 38 | } 39 | 40 | 41 | 42 | \end{document} 43 | -------------------------------------------------------------------------------- /pres/notes.txt: -------------------------------------------------------------------------------- 1 | 2 | Prep: 3 | - ghc-7.10 4 | - ex3 branch 5 | - correctly-built glam 6 | 7 | 0. get folks to cabal install --only-dependencies -j<# of processors> (0:00-0:02)) 8 | 9 | I. Intro (0:02-0:07) 10 | - my background 11 | - ask about level of Haskell experience 12 | - ask about GADT experience 13 | - explain they will be working in pairs 14 | - goals 15 | - working toward glambda 16 | 17 | II. Simple GADTs (0:07-0:18)7 18 | - emacs with STy with Int + Bool + Maybe 19 | - back to slides 20 | 21 | III. Exercise 1 (0:18-0:25) 22 | - zero 23 | 24 | IV. GADT inference (0:25-0:33) 25 | - need signatures (even if it looks like it has a most general type) 26 | - ScopedTypeVariables 27 | - warnings (with monotyped `eqSTy`) 28 | - also talk about why monotyped eqSTy is very silly indeed 29 | 30 | V. HList (0:33-0:45) 31 | - emacs, from scratch, again. promoted datatypes (lists) 32 | - can't write get! 33 | - Write Elem type 34 | 35 | VI. Exercise 2 (0:45-1:00) 36 | - when discussing solution, show a kind signature 37 | 38 | -- BREAK (1:00-1:05) -- 39 | 40 | VII. Glambda 41 | - syntax (1:05-1:20) 42 | - revapp 3 plus1 43 | - conditionals 44 | - (no fix) 45 | - isPrime 46 | - :eval, :step, :type, :load 47 | - de Bruijn indices 48 | - :step (\x:Int. (\y:Int. x) 3 + x) 4 49 | 50 | - code: Exp (1:20-1:30) 51 | - Exp, starting with Int & Bool 52 | - Elem 53 | - Var 54 | 55 | VIII. Exercise: write `eval` and `apply`. (1:30-1:50) 56 | -------------------------------------------------------------------------------- /pres/slides.key: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/goldfirere/glambda/d3f3a4d3f83ef7b2649c7e32e2c2b0a3c9b96a69/pres/slides.key -------------------------------------------------------------------------------- /pres/slides.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/goldfirere/glambda/d3f3a4d3f83ef7b2649c7e32e2c2b0a3c9b96a69/pres/slides.pdf -------------------------------------------------------------------------------- /src/Language/Glambda/Check.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes, DataKinds, PolyKinds, GADTs, FlexibleContexts, CPP #-} 2 | {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} 3 | 4 | #ifdef __HADDOCK_VERSION__ 5 | {-# OPTIONS_GHC -fno-warn-unused-imports #-} 6 | #endif 7 | 8 | ----------------------------------------------------------------------------- 9 | -- | 10 | -- Module : Language.Glambda.Unchecked 11 | -- Copyright : (C) 2015 Richard Eisenberg 12 | -- License : BSD-style (see LICENSE) 13 | -- Maintainer : Richard Eisenberg (rae@cs.brynmawr.edu) 14 | -- Stability : experimental 15 | -- 16 | -- The glambda typechecker. 17 | -- 18 | ---------------------------------------------------------------------------- 19 | 20 | module Language.Glambda.Check ( check ) where 21 | 22 | import Language.Glambda.Exp 23 | import Language.Glambda.Shift 24 | import Language.Glambda.Token 25 | import Language.Glambda.Type 26 | import Language.Glambda.Unchecked 27 | import Language.Glambda.Util 28 | import Language.Glambda.Globals 29 | #ifdef __HADDOCK_VERSION__ 30 | import Language.Glambda.Monad ( GlamE ) 31 | #endif 32 | 33 | import Prettyprinter (Doc, (<+>), squotes, pretty, indent, vcat) 34 | import Prettyprinter.Render.Terminal (AnsiStyle) 35 | 36 | import Control.Monad.Reader 37 | import Control.Monad.Except 38 | 39 | -- | Abort with a type error in the given expression 40 | typeError :: MonadError (Doc AnsiStyle) m => UExp -> Doc AnsiStyle -> m a 41 | typeError e doc = throwError $ 42 | doc $$ pretty "in the expression" <+> squotes (prettyT e) 43 | 44 | ------------------------------------------------ 45 | -- The typechecker 46 | 47 | -- | Check the given expression, aborting on type errors. The resulting 48 | -- type and checked expression is given to the provided continuation. 49 | -- This is parameterized over the choice of monad in order to support 50 | -- pure operation during testing. 'GlamE' is the canonical choice for the 51 | -- monad. 52 | check :: (MonadError (Doc AnsiStyle) m, MonadReader Globals m) 53 | => UExp -> (forall t. STy t -> Exp '[] t -> m r) 54 | -> m r 55 | check = go emptyContext 56 | where 57 | go :: (MonadError (Doc AnsiStyle) m, MonadReader Globals m) 58 | => SCtx ctx -> UExp -> (forall t. STy t -> Exp ctx t -> m r) 59 | -> m r 60 | 61 | go ctx (UVar n) k 62 | = check_var ctx n $ \ty elem -> 63 | k ty (Var elem) 64 | 65 | go ctx (UGlobal n) k 66 | = do globals <- ask 67 | lookupGlobal globals n $ \ty exp -> 68 | k ty (shift_into_ctx ctx exp) 69 | 70 | go ctx (ULam ty body) k 71 | = refineTy ty $ \arg_ty -> 72 | go (arg_ty `SCons` ctx) body $ \res_ty body' -> 73 | k (arg_ty `SArr` res_ty) (Lam body') 74 | 75 | go ctx e@(UApp e1 e2) k 76 | = go ctx e1 $ \ty1 e1' -> 77 | go ctx e2 $ \ty2 e2' -> 78 | case (ty1, ty2) of 79 | (SArr arg_ty res_ty, arg_ty') 80 | | Just Refl <- arg_ty `eqSTy` arg_ty' 81 | -> k res_ty (App e1' e2') 82 | _ -> typeError e $ 83 | pretty "Bad function application." $$ 84 | indent 2 (vcat [ pretty "Function type:" <+> pretty ty1 85 | , pretty "Argument type:" <+> pretty ty2 ]) 86 | 87 | go ctx e@(UArith e1 (UArithOp op) e2) k 88 | = go ctx e1 $ \sty1 e1' -> 89 | go ctx e2 $ \sty2 e2' -> 90 | case (sty1, sty2) of 91 | (SIntTy, SIntTy) 92 | -> k sty (Arith e1' op e2') 93 | _ -> typeError e $ 94 | pretty "Bad arith operand(s)." $$ 95 | indent 2 (vcat [ pretty " Left-hand type:" <+> pretty sty1 96 | , pretty "Right-hand type:" <+> pretty sty2 ]) 97 | 98 | go ctx e@(UCond e1 e2 e3) k 99 | = go ctx e1 $ \sty1 e1' -> 100 | go ctx e2 $ \sty2 e2' -> 101 | go ctx e3 $ \sty3 e3' -> 102 | case sty1 of 103 | SBoolTy 104 | | Just Refl <- sty2 `eqSTy` sty3 105 | -> k sty2 (Cond e1' e2' e3') 106 | _ -> typeError e $ 107 | pretty "Bad conditional." $$ 108 | indent 2 (vcat [ pretty "Flag type:" <+> pretty sty1 109 | , squotes (pretty "true") <+> pretty "expression type:" 110 | <+> pretty sty2 111 | , squotes (pretty "false") <+> pretty "expression type:" 112 | <+> pretty sty3 ]) 113 | 114 | go ctx e@(UFix e1) k 115 | = go ctx e1 $ \sty1 e1' -> 116 | case sty1 of 117 | arg `SArr` res 118 | | Just Refl <- arg `eqSTy` res 119 | -> k arg (Fix e1') 120 | _ -> typeError e $ 121 | pretty "Bad fix over expression with type:" <+> pretty sty1 122 | 123 | go _ (UIntE n) k = k sty (IntE n) 124 | go _ (UBoolE b) k = k sty (BoolE b) 125 | 126 | check_var :: MonadError (Doc AnsiStyle) m 127 | => SCtx ctx -> Int 128 | -> (forall t. STy t -> Elem ctx t -> m r) 129 | -> m r 130 | check_var SNil _ _ = throwError (pretty "unbound variable") 131 | -- shouldn't happen. caught by parser. 132 | 133 | -- | Type-check a de Bruijn index variable 134 | check_var (SCons ty _) 0 k = k ty EZ 135 | check_var (SCons _ ctx) n k = check_var ctx (n-1) $ \ty elem -> 136 | k ty (ES elem) 137 | 138 | -- | Take a closed expression and shift its indices to make sense in 139 | -- a non-empty context. 140 | shift_into_ctx :: SCtx ctx -> Exp '[] ty -> Exp ctx ty 141 | shift_into_ctx SNil exp = exp 142 | shift_into_ctx (_ `SCons` ctx') exp = shift $ shift_into_ctx ctx' exp 143 | -------------------------------------------------------------------------------- /src/Language/Glambda/Eval.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes, TypeOperators, ScopedTypeVariables, 2 | DataKinds, TypeFamilies, PolyKinds, 3 | GADTs #-} 4 | {-# OPTIONS_GHC -fwarn-incomplete-patterns #-} 5 | 6 | ----------------------------------------------------------------------------- 7 | -- | 8 | -- Module : Language.Glambda.Eval 9 | -- Copyright : (C) 2015 Richard Eisenberg 10 | -- License : BSD-style (see LICENSE) 11 | -- Maintainer : Richard Eisenberg (rae@cs.brynmawr.edu) 12 | -- Stability : experimental 13 | -- 14 | -- Glambda expression evaluators for checked expressions. 15 | -- 16 | ---------------------------------------------------------------------------- 17 | 18 | module Language.Glambda.Eval ( eval, step ) where 19 | 20 | import Language.Glambda.Exp 21 | import Language.Glambda.Token 22 | import Language.Glambda.Shift 23 | 24 | -- | Given a lambda and an expression, beta-reduce. 25 | apply :: Val (arg -> res) -> Exp '[] arg -> Exp '[] res 26 | apply (LamVal body) arg = subst arg body 27 | 28 | -- | Apply an arithmetic operator to two values. 29 | arith :: Val Int -> ArithOp ty -> Val Int -> Exp '[] ty 30 | arith (IntVal n1) Plus (IntVal n2) = IntE (n1 + n2) 31 | arith (IntVal n1) Minus (IntVal n2) = IntE (n1 - n2) 32 | arith (IntVal n1) Times (IntVal n2) = IntE (n1 * n2) 33 | arith (IntVal n1) Divide (IntVal n2) = IntE (n1 `div` n2) 34 | arith (IntVal n1) Mod (IntVal n2) = IntE (n1 `mod` n2) 35 | arith (IntVal n1) Less (IntVal n2) = BoolE (n1 < n2) 36 | arith (IntVal n1) LessE (IntVal n2) = BoolE (n1 <= n2) 37 | arith (IntVal n1) Greater (IntVal n2) = BoolE (n1 > n2) 38 | arith (IntVal n1) GreaterE (IntVal n2) = BoolE (n1 >= n2) 39 | arith (IntVal n1) Equals (IntVal n2) = BoolE (n1 == n2) 40 | 41 | -- | Conditionally choose between two expressions 42 | cond :: Val Bool -> Exp '[] t -> Exp '[] t -> Exp '[] t 43 | cond (BoolVal True) e _ = e 44 | cond (BoolVal False) _ e = e 45 | 46 | -- | Unroll a `fix` one level 47 | unfix :: Val (ty -> ty) -> Exp '[] ty 48 | unfix (LamVal body) = subst (Fix (Lam body)) body 49 | 50 | -- | A well-typed variable in an empty context is impossible. 51 | impossibleVar :: Elem '[] x -> a 52 | impossibleVar _ = error "GHC's typechecker failed" 53 | -- GHC 7.8+ supports EmptyCase for this, but the warnings for that 54 | -- construct don't work yet. 55 | 56 | -- | Evaluate an expression, using big-step semantics. 57 | eval :: Exp '[] t -> Val t 58 | eval (Var v) = impossibleVar v 59 | eval (Lam body) = LamVal body 60 | eval (App e1 e2) = eval (apply (eval e1) e2) 61 | eval (Arith e1 op e2) = eval (arith (eval e1) op (eval e2)) 62 | eval (Cond e1 e2 e3) = eval (cond (eval e1) e2 e3) 63 | eval (Fix e) = eval (unfix (eval e)) 64 | eval (IntE n) = IntVal n 65 | eval (BoolE b) = BoolVal b 66 | 67 | -- | Step an expression, either to another expression or to a value. 68 | step :: Exp '[] t -> Either (Exp '[] t) (Val t) 69 | step (Var v) = impossibleVar v 70 | step (Lam body) = Right (LamVal body) 71 | step (App e1 e2) = case step e1 of 72 | Left e1' -> Left (App e1' e2) 73 | Right (LamVal body) -> Left (subst e2 body) 74 | step (Arith e1 op e2) = case step e1 of 75 | Left e1' -> Left (Arith e1' op e2) 76 | Right v1 -> case step e2 of 77 | Left e2' -> Left (Arith (val v1) op e2') 78 | Right v2 -> Left (arith v1 op v2) 79 | step (Cond e1 e2 e3) = case step e1 of 80 | Left e1' -> Left (Cond e1' e2 e3) 81 | Right v1 -> Left (cond v1 e2 e3) 82 | step (Fix e) = case step e of 83 | Left e' -> Left (Fix e') 84 | Right v -> Left (unfix v) 85 | step (IntE n) = Right (IntVal n) 86 | step (BoolE b) = Right (BoolVal b) 87 | -------------------------------------------------------------------------------- /src/Language/Glambda/Exp.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds, PolyKinds, GADTs, TypeOperators, TypeFamilies, 2 | ScopedTypeVariables #-} 3 | 4 | ----------------------------------------------------------------------------- 5 | -- | 6 | -- Module : Language.Glambda.Exp 7 | -- Copyright : (C) 2015 Richard Eisenberg 8 | -- License : BSD-style (see LICENSE) 9 | -- Maintainer : Richard Eisenberg (rae@cs.brynmawr.edu) 10 | -- Stability : experimental 11 | -- 12 | -- The Exp GADT. Glambda expressions encoded in an 'Exp' value are 13 | -- *always* well-typed. 14 | -- 15 | ---------------------------------------------------------------------------- 16 | 17 | module Language.Glambda.Exp ( 18 | Exp(..), Elem(..), GlamVal(..), Val(..), prettyVal, eqExp 19 | ) where 20 | 21 | import Language.Glambda.Pretty 22 | import Language.Glambda.Token 23 | import Language.Glambda.Util 24 | import Language.Glambda.Type 25 | 26 | import Prettyprinter (Pretty, pretty, Doc, nest) 27 | import Prettyprinter.Render.Terminal (AnsiStyle) 28 | 29 | -- | @Elem xs x@ is evidence that @x@ is in the list @xs@. 30 | -- @EZ :: Elem xs x@ is evidence that @x@ is the first element of @xs@. 31 | -- @ES ev :: Elem xs x@ is evidence that @x@ is one position later in 32 | -- @xs@ than is indicated in @ev@ 33 | data Elem :: [a] -> a -> * where 34 | EZ :: Elem (x ': xs) x 35 | ES :: Elem xs x -> Elem (y ': xs) x 36 | 37 | -- | Convert an 'Elem' to a proper de Bruijn index 38 | elemToInt :: Elem ctx ty -> Int 39 | elemToInt EZ = 0 40 | elemToInt (ES e) = 1 + elemToInt e 41 | 42 | -- | @Exp ctx ty@ is a well-typed expression of type @ty@ in context 43 | -- @ctx@. Note that a context is a list of types, where a type's index 44 | -- in the list indicates the de Bruijn index of the associated term-level 45 | -- variable. 46 | data Exp :: [*] -> * -> * where 47 | Var :: Elem ctx ty -> Exp ctx ty 48 | Lam :: Exp (arg ': ctx) res -> Exp ctx (arg -> res) 49 | App :: Exp ctx (arg -> res) -> Exp ctx arg -> Exp ctx res 50 | Arith :: Exp ctx Int -> ArithOp ty -> Exp ctx Int -> Exp ctx ty 51 | Cond :: Exp ctx Bool -> Exp ctx ty -> Exp ctx ty -> Exp ctx ty 52 | Fix :: Exp ctx (ty -> ty) -> Exp ctx ty 53 | IntE :: Int -> Exp ctx Int 54 | BoolE :: Bool -> Exp ctx Bool 55 | 56 | -- | Classifies types that can be values of glambda expressions 57 | class GlamVal t where 58 | -- | Well-typed closed values. Encoded as a data family with newtype 59 | -- instances in order to avoid runtime checking of values 60 | data Val t 61 | 62 | -- | Convert a glambda value back into a glambda expression 63 | val :: Val t -> Exp '[] t 64 | 65 | instance GlamVal Int where 66 | newtype Val Int = IntVal Int 67 | val (IntVal n) = IntE n 68 | 69 | instance GlamVal Bool where 70 | newtype Val Bool = BoolVal Bool 71 | val (BoolVal b) = BoolE b 72 | 73 | instance GlamVal (a -> b) where 74 | newtype Val (a -> b) = LamVal (Exp '[a] b) 75 | val (LamVal body) = Lam body 76 | 77 | ---------------------------------------------------- 78 | -- | Equality on expressions, needed for testing 79 | eqExp :: Exp ctx1 ty1 -> Exp ctx2 ty2 -> Bool 80 | eqExp (Var e1) (Var e2) = elemToInt e1 == elemToInt e2 81 | eqExp (Lam body1) (Lam body2) = body1 `eqExp` body2 82 | eqExp (App e1a e1b) (App e2a e2b) = e1a `eqExp` e2a && e1b `eqExp` e2b 83 | eqExp (Arith e1a op1 e1b) (Arith e2a op2 e2b) 84 | = e1a `eqExp` e2a && op1 `eqArithOp` op2 && e1b `eqExp` e2b 85 | eqExp (Cond e1a e1b e1c) (Cond e2a e2b e2c) 86 | = e1a `eqExp` e2a && e1b `eqExp` e2b && e1c `eqExp` e2c 87 | eqExp (IntE i1) (IntE i2) = i1 == i2 88 | eqExp (BoolE b1) (BoolE b2) = b1 == b2 89 | eqExp _ _ = False 90 | 91 | ---------------------------------------------------- 92 | -- Pretty-printing 93 | 94 | instance PrettyT (Exp ctx ty) where 95 | prettyT = defaultPretty 96 | 97 | instance PrettyExp (Exp ctx ty) where 98 | prettyExp = pretty_exp 99 | 100 | instance GlamVal ty => PrettyT (Val ty) where 101 | prettyT = defaultPretty 102 | 103 | instance GlamVal ty => PrettyExp (Val ty) where 104 | prettyExp coloring prec v = prettyExp coloring prec (val v) 105 | 106 | -- | Pretty-prints a 'Val'. This needs type information to know how to print. 107 | -- Pattern matching gives GHC enough information to be able to find the 108 | -- 'GlamVal' instance needed to construct the 'PrettyExp' instance. 109 | prettyVal :: Val t -> STy t -> Doc AnsiStyle 110 | prettyVal val SIntTy = prettyT val 111 | prettyVal val SBoolTy = prettyT val 112 | prettyVal val (_ `SArr` _) = prettyT val 113 | 114 | pretty_exp :: Coloring -> Prec -> Exp ctx ty -> Doc AnsiStyle 115 | pretty_exp c _ (Var n) = prettyVar c (elemToInt n) 116 | pretty_exp c prec (Lam body) = prettyLam c prec Nothing body 117 | pretty_exp c prec (App e1 e2) = prettyApp c prec e1 e2 118 | pretty_exp c prec (Arith e1 op e2) = prettyArith c prec e1 op e2 119 | pretty_exp c prec (Cond e1 e2 e3) = prettyIf c prec e1 e2 e3 120 | pretty_exp c prec (Fix e) = prettyFix c prec e 121 | pretty_exp _ _ (IntE n) = pretty n 122 | pretty_exp _ _ (BoolE True) = pretty "true" 123 | pretty_exp _ _ (BoolE False) = pretty "false" 124 | -------------------------------------------------------------------------------- /src/Language/Glambda/Globals.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs, DataKinds, RankNTypes, FlexibleContexts #-} 2 | {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} 3 | 4 | ----------------------------------------------------------------------------- 5 | -- | 6 | -- Module : Language.Glambda.Globals 7 | -- Copyright : (C) 2015 Richard Eisenberg 8 | -- License : BSD-style (see LICENSE) 9 | -- Maintainer : Richard Eisenberg (rae@cs.brynmawr.edu) 10 | -- Stability : experimental 11 | -- 12 | -- Manages the global variables in Glambda 13 | -- 14 | ---------------------------------------------------------------------------- 15 | 16 | module Language.Glambda.Globals ( 17 | Globals, emptyGlobals, extend, lookupGlobal ) where 18 | 19 | import Language.Glambda.Exp 20 | import Language.Glambda.Type 21 | 22 | import Prettyprinter (Doc, pretty, (<+>), squotes) 23 | import Prettyprinter.Render.Terminal (AnsiStyle) 24 | 25 | import Control.Monad.Except 26 | 27 | import Data.Map as Map 28 | 29 | -- | An existential wrapper around 'Exp', storing the expression and 30 | -- its type. 31 | data EExp where 32 | EExp :: STy ty -> Exp '[] ty -> EExp 33 | 34 | -- | The global variable environment maps variables to type-checked 35 | -- expressions 36 | newtype Globals = Globals (Map String EExp) 37 | 38 | -- | An empty global variable environment 39 | emptyGlobals :: Globals 40 | emptyGlobals = Globals Map.empty 41 | 42 | -- | Extend a 'Globals' with a new binding 43 | extend :: String -> STy ty -> Exp '[] ty -> Globals -> Globals 44 | extend var sty exp (Globals globals) 45 | = Globals $ Map.insert var (EExp sty exp) globals 46 | 47 | -- | Lookup a global variable. Fails with 'throwError' if the variable 48 | -- is not bound. 49 | lookupGlobal :: MonadError (Doc AnsiStyle) m 50 | => Globals -> String 51 | -> (forall ty. STy ty -> Exp '[] ty -> m r) 52 | -> m r 53 | lookupGlobal (Globals globals) var k 54 | = case Map.lookup var globals of 55 | Just (EExp sty exp) -> k sty exp 56 | Nothing -> throwError $ 57 | pretty "Global variable not in scope:" <+> 58 | squotes (pretty var) 59 | -------------------------------------------------------------------------------- /src/Language/Glambda/Lex.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Language.Glambda.Lex 4 | -- Copyright : (C) 2015 Richard Eisenberg 5 | -- License : BSD-style (see LICENSE) 6 | -- Maintainer : Richard Eisenberg (rae@cs.brynmawr.edu) 7 | -- Stability : experimental 8 | -- 9 | -- Lexes a Glambda program string into a sequence of tokens 10 | -- 11 | ---------------------------------------------------------------------------- 12 | 13 | module Language.Glambda.Lex ( lexG, lex ) where 14 | 15 | import Prelude hiding ( lex ) 16 | 17 | import Language.Glambda.Token 18 | import Language.Glambda.Monad 19 | import Language.Glambda.Util 20 | 21 | import Text.Parsec.Prim ( Parsec, parse, getPosition, try ) 22 | import Text.Parsec.Combinator 23 | import Text.Parsec.Char 24 | import Text.Parsec.Token as Parsec 25 | import Text.Parsec.Language 26 | 27 | import Data.Maybe 28 | 29 | import Control.Applicative 30 | import Control.Arrow as Arrow 31 | 32 | type Lexer = Parsec String () 33 | 34 | --------------------------------------------------- 35 | -- Utility 36 | string_ :: String -> Lexer () 37 | string_ = ignore . string 38 | 39 | --------------------------------------------------- 40 | -- | Lex some program text into a list of 'LToken's, aborting upon failure 41 | lexG :: String -> GlamE [LToken] 42 | lexG = eitherToGlamE . lex 43 | 44 | -- | Lex some program text into a list of 'LToken's 45 | lex :: String -> Either String [LToken] 46 | lex = Arrow.left show . parse lexer "" 47 | 48 | -- | Overall lexer 49 | lexer :: Lexer [LToken] 50 | lexer = (catMaybes <$> many lexer1_ws) <* eof 51 | 52 | -- | Lex either one token or some whitespace 53 | lexer1_ws :: Lexer (Maybe LToken) 54 | lexer1_ws 55 | = (Nothing <$ whitespace) 56 | <|> 57 | (Just <$> lexer1) 58 | 59 | -- | Lex some whitespace 60 | whitespace :: Lexer () 61 | whitespace 62 | = choice [ ignore $ some space 63 | , block_comment 64 | , line_comment ] 65 | 66 | -- | Lex a @{- ... -}@ comment (perhaps nested); consumes no input 67 | -- if the target doesn't start with @{-@. 68 | block_comment :: Lexer () 69 | block_comment = do 70 | try $ string_ "{-" 71 | comment_body 72 | 73 | -- | Lex a block comment, without the opening "{-" 74 | comment_body :: Lexer () 75 | comment_body 76 | = choice [ block_comment *> comment_body 77 | , try $ string_ "-}" 78 | , anyChar *> comment_body ] 79 | 80 | -- | Lex a line comment 81 | line_comment :: Lexer () 82 | line_comment = do 83 | try $ string_ "--" 84 | ignore $ manyTill anyChar (eof <|> ignore newline) 85 | 86 | -- | Lex one token 87 | lexer1 :: Lexer LToken 88 | lexer1 = do 89 | pos <- getPosition 90 | L pos <$> choice [ symbolic 91 | , word_token 92 | , Int . fromInteger <$> Parsec.natural haskell ] 93 | 94 | -- | Lex one non-alphanumeric token 95 | symbolic :: Lexer Token 96 | symbolic = choice [ LParen <$ char '(' 97 | , RParen <$ char ')' 98 | , Lambda <$ char '\\' 99 | , Dot <$ char '.' 100 | , Arrow <$ try (string "->") 101 | , Colon <$ char ':' 102 | , ArithOp <$> arith_op 103 | , Assign <$ char '=' 104 | , Semi <$ char ';' ] 105 | 106 | -- | Lex one arithmetic operator 107 | arith_op :: Lexer UArithOp 108 | arith_op = choice [ UArithOp Plus <$ char '+' 109 | , UArithOp Minus <$ char '-' 110 | , UArithOp Times <$ char '*' 111 | , UArithOp Divide <$ char '/' 112 | , UArithOp Mod <$ char '%' 113 | , UArithOp LessE <$ try (string "<=") 114 | , UArithOp Less <$ char '<' 115 | , UArithOp GreaterE <$ try (string ">=") 116 | , UArithOp Greater <$ char '>' 117 | , UArithOp Equals <$ try (string "==")] 118 | 119 | -- | Lex one alphanumeric token 120 | word_token :: Lexer Token 121 | word_token = to_token <$> word 122 | where 123 | to_token "true" = Bool True 124 | to_token "false" = Bool False 125 | to_token "if" = If 126 | to_token "then" = Then 127 | to_token "else" = Else 128 | to_token "fix" = FixT 129 | to_token other = Name other 130 | 131 | -- | Lex one word 132 | word :: Lexer String 133 | word = (:) <$> (letter <|> char '_') <*> 134 | many (alphaNum <|> char '_') 135 | -------------------------------------------------------------------------------- /src/Language/Glambda/Monad.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving, DefaultSignatures, 2 | FlexibleContexts, CPP, MultiParamTypeClasses #-} 3 | {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} 4 | 5 | ----------------------------------------------------------------------------- 6 | -- | 7 | -- Module : Language.Glambda.Monad 8 | -- Copyright : (C) 2015 Richard Eisenberg 9 | -- License : BSD-style (see LICENSE) 10 | -- Maintainer : Richard Eisenberg (rae@cs.brynmawr.edu) 11 | -- Stability : experimental 12 | -- 13 | -- The Glam monad, allowing for pretty-printed output to the user, failing 14 | -- with an error message, and tracking global variables. 15 | -- 16 | ---------------------------------------------------------------------------- 17 | 18 | module Language.Glambda.Monad ( 19 | -- * The 'Glam' monad 20 | Glam, runGlam, prompt, quit, 21 | 22 | -- * The 'GlamE' monad 23 | GlamE, runGlamE, issueError, eitherToGlamE, 24 | 25 | -- * General functions over both glamorous monads 26 | GlamM(..), 27 | ) where 28 | 29 | import Language.Glambda.Globals 30 | import Language.Glambda.Util 31 | 32 | import System.Console.Haskeline 33 | 34 | import Prettyprinter (Doc, hardline, pretty) 35 | import Prettyprinter.Render.Terminal (AnsiStyle, renderIO) 36 | 37 | import Control.Monad (mzero) 38 | import Control.Monad.Trans.Maybe 39 | import Control.Monad.Except 40 | import Control.Monad.Reader 41 | import Control.Monad.State 42 | import System.IO 43 | 44 | #if __GLASGOW_HASKELL__ < 709 45 | import Control.Applicative 46 | #endif 47 | 48 | -- | A monad giving Haskeline-like interaction, access to 'Globals', 49 | -- and the ability to abort with 'mzero'. 50 | newtype Glam a = Glam { unGlam :: MaybeT (StateT Globals (InputT IO)) a } 51 | deriving (Monad, Functor, Applicative, MonadState Globals, MonadIO) 52 | 53 | -- | Like the 'Glam' monad, but also supporting error messages via 'Doc's 54 | newtype GlamE a = GlamE { unGlamE :: ExceptT (Doc AnsiStyle) Glam a } 55 | deriving (Monad, Functor, Applicative, MonadError (Doc AnsiStyle)) 56 | 57 | instance MonadReader Globals GlamE where 58 | ask = GlamE get 59 | local f thing_inside = GlamE $ do 60 | old_globals <- get 61 | put (f old_globals) 62 | result <- unGlamE thing_inside 63 | put old_globals 64 | return result 65 | 66 | -- | Class for the two glamorous monads 67 | class GlamM m where 68 | -- | Print a 'Doc' without a newline at the end 69 | printDoc :: Doc AnsiStyle -> m () 70 | 71 | -- | Print a 'Doc' with a newline 72 | printLine :: Doc AnsiStyle -> m () 73 | 74 | instance GlamM Glam where 75 | printDoc = Glam . liftIO . renderIO stdout . toSimpleDoc 76 | printLine = Glam . liftIO . renderIO stdout . toSimpleDoc . (<> hardline) 77 | 78 | instance GlamM GlamE where 79 | printDoc = GlamE . lift . printDoc 80 | printLine = GlamE . lift . printLine 81 | 82 | -- | Prompt the user for input, returning a string if one is entered. 83 | -- Like 'getInputLine'. 84 | prompt :: String -> Glam (Maybe String) 85 | prompt = Glam . lift . lift . getInputLine 86 | 87 | -- | Abort the 'Glam' monad 88 | quit :: Glam a 89 | quit = do 90 | printLine (pretty "Good-bye.") 91 | Glam mzero 92 | 93 | -- | Abort the computation with an error 94 | issueError :: Doc AnsiStyle -> GlamE a 95 | issueError = GlamE . throwError 96 | 97 | -- | Hoist an 'Either' into 'GlamE' 98 | eitherToGlamE :: Either String a -> GlamE a 99 | eitherToGlamE (Left err) = issueError (pretty err) 100 | eitherToGlamE (Right x) = return x 101 | 102 | -- | Run a 'Glam' computation 103 | runGlam :: Glam () -> InputT IO () 104 | runGlam thing_inside 105 | = ignore $ flip evalStateT emptyGlobals $ runMaybeT $ unGlam thing_inside 106 | 107 | -- | Run a 'GlamE' computation 108 | runGlamE :: GlamE a -> Glam (Either (Doc AnsiStyle) a) 109 | runGlamE thing_inside 110 | = runExceptT $ unGlamE thing_inside 111 | -------------------------------------------------------------------------------- /src/Language/Glambda/Parse.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | 3 | ----------------------------------------------------------------------------- 4 | -- | 5 | -- Module : Language.Glambda.Parse 6 | -- Copyright : (C) 2015 Richard Eisenberg 7 | -- License : BSD-style (see LICENSE) 8 | -- Maintainer : Richard Eisenberg (rae@cs.brynmawr.edu) 9 | -- Stability : experimental 10 | -- 11 | -- Parses tokens into the un-type-checked AST. "Parsing", in glambda, 12 | -- also includes name resolution. This all might 13 | -- conceivably be done in a later pass, but there doesn't seem to be 14 | -- an incentive to do so. 15 | -- 16 | ---------------------------------------------------------------------------- 17 | 18 | module Language.Glambda.Parse ( 19 | parseStmtsG, parseStmts, 20 | parseStmtG, parseExpG, 21 | parseStmt, parseExp 22 | ) where 23 | 24 | import Language.Glambda.Unchecked 25 | import Language.Glambda.Statement 26 | import Language.Glambda.Token 27 | import Language.Glambda.Type 28 | import Language.Glambda.Monad 29 | import Language.Glambda.Util 30 | 31 | import Text.Parsec.Prim as Parsec hiding ( parse ) 32 | import Text.Parsec.Pos 33 | import Text.Parsec.Combinator 34 | 35 | import Prettyprinter (pretty, squotes, (<+>)) 36 | 37 | import Data.List as List 38 | 39 | import Control.Applicative 40 | import Control.Arrow as Arrow ( left ) 41 | import Control.Monad.Reader 42 | import Control.Monad (guard) 43 | 44 | -- | Parse a sequence of semicolon-separated statements, aborting with 45 | -- an error upon failure 46 | parseStmtsG :: [LToken] -> GlamE [Statement] 47 | parseStmtsG = eitherToGlamE . parseStmts 48 | 49 | -- | Parse a sequence of semicolon-separated statements 50 | parseStmts :: [LToken] -> Either String [Statement] 51 | parseStmts = parse stmts 52 | 53 | -- | Parse a 'Statement', aborting with an error upon failure 54 | parseStmtG :: [LToken] -> GlamE Statement 55 | parseStmtG = eitherToGlamE . parseStmt 56 | 57 | -- | Parse a 'Statement' 58 | parseStmt :: [LToken] -> Either String Statement 59 | parseStmt = parse stmt 60 | 61 | -- | Parse a 'UExp', aborting with an error upon failure 62 | parseExpG :: [LToken] -> GlamE UExp 63 | parseExpG = eitherToGlamE . parseExp 64 | 65 | -- | Parse a 'UExp' 66 | parseExp :: [LToken] -> Either String UExp 67 | parseExp = parse expr 68 | 69 | parse :: Parser a -> [LToken] -> Either String a 70 | parse p tokens = Arrow.left show $ 71 | runReader (runParserT (p <* eof) () "" tokens) [] 72 | 73 | ---------------------- 74 | -- Plumbing 75 | 76 | -- the "state" is a list of bound names. searching a bound name in the list 77 | -- gives you the correct deBruijn index 78 | type Parser = ParsecT [LToken] () (Reader [String]) 79 | 80 | -- | Bind a name over an expression 81 | bind :: String -> Parser a -> Parser a 82 | bind bound_var thing_inside 83 | = local (bound_var :) thing_inside 84 | 85 | -- | Parse the given nullary token 86 | tok :: Token -> Parser () 87 | tok t = tokenPrim (render . pretty) next_pos (guard . (t ==) . unLoc) 88 | 89 | -- | Parse the given unary token 90 | tok' :: (Token -> Maybe thing) -> Parser thing 91 | tok' matcher = tokenPrim (render . pretty) next_pos (matcher . unLoc) 92 | 93 | -- | Parse one of a set of 'ArithOp's 94 | arith_op :: [UArithOp] -> Parser UArithOp 95 | arith_op ops = tokenPrim (render . pretty) next_pos 96 | (\case L _ (ArithOp op) | op `elem` ops -> Just op 97 | _ -> Nothing) 98 | 99 | next_pos :: SourcePos -- ^ position of the current token 100 | -> LToken -- ^ current token 101 | -> [LToken] -- ^ remaining tokens 102 | -> SourcePos -- ^ location of the next token 103 | next_pos pos _ [] = pos 104 | next_pos _ _ (L pos _ : _) = pos 105 | 106 | -------------- 107 | -- Real work 108 | 109 | stmts :: Parser [Statement] 110 | stmts = stmt `sepEndBy` tok Semi 111 | 112 | stmt :: Parser Statement 113 | stmt = choice [ try $ NewGlobal <$> tok' unName <* tok Assign <*> expr 114 | , BareExp <$> expr ] 115 | 116 | expr :: Parser UExp 117 | expr = choice [ lam 118 | , cond 119 | , int_exp `chainl1` bool_op ] 120 | 121 | int_exp :: Parser UExp 122 | int_exp = term `chainl1` add_op 123 | 124 | term :: Parser UExp 125 | term = apps `chainl1` mul_op 126 | 127 | apps :: Parser UExp 128 | apps = choice [ UFix <$ tok FixT <*> expr 129 | , List.foldl1 UApp <$> some factor ] 130 | 131 | factor :: Parser UExp 132 | factor = choice [ between (tok LParen) (tok RParen) expr 133 | , UIntE <$> tok' unInt 134 | , UBoolE <$> tok' unBool 135 | , var ] 136 | 137 | lam :: Parser UExp 138 | lam = do 139 | tok Lambda 140 | bound_var <- tok' unName 141 | tok Colon 142 | typ <- ty 143 | tok Dot 144 | e <- bind bound_var expr 145 | return (ULam typ e) 146 | 147 | cond :: Parser UExp 148 | cond = UCond <$ tok If <*> expr <* tok Then <*> expr <* tok Else <*> expr 149 | 150 | var :: Parser UExp 151 | var = do 152 | n <- tok' unName 153 | m_index <- asks (elemIndex n) 154 | case m_index of 155 | Nothing -> return (UGlobal n) 156 | Just i -> return (UVar i) 157 | 158 | ty :: Parser Ty 159 | ty = chainr1 arg_ty (Arr <$ tok Arrow) 160 | 161 | arg_ty :: Parser Ty 162 | arg_ty = choice [ between (tok LParen) (tok RParen) ty 163 | , tycon ] 164 | 165 | tycon :: Parser Ty 166 | tycon = do 167 | n <- tok' unName 168 | case readTyCon n of 169 | Nothing -> unexpected $ render $ 170 | pretty "type" <+> squotes (pretty n) 171 | Just ty -> return ty 172 | 173 | add_op, mul_op, bool_op :: Parser (UExp -> UExp -> UExp) 174 | add_op = mk_op <$> arith_op [uPlus, uMinus] 175 | mul_op = mk_op <$> arith_op [uTimes, uDivide, uMod] 176 | bool_op = mk_op <$> arith_op [uLess, uLessE, uGreater, uGreaterE, uEquals] 177 | 178 | mk_op :: UArithOp -> UExp -> UExp -> UExp 179 | mk_op op e1 e2 = UArith e1 op e2 180 | -------------------------------------------------------------------------------- /src/Language/Glambda/Pretty.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ViewPatterns, GADTs, FlexibleInstances, UndecidableInstances, 2 | CPP #-} 3 | #if __GLASGOW_HASKELL__ <= 708 4 | {-# LANGUAGE OverlappingInstances #-} 5 | {-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-} 6 | #endif 7 | 8 | {-# OPTIONS_GHC -fno-warn-orphans #-} 9 | 10 | 11 | 12 | ----------------------------------------------------------------------------- 13 | -- | 14 | -- Module : Language.Glambda.Pretty 15 | -- Copyright : (C) 2015 Richard Eisenberg 16 | -- License : BSD-style (see LICENSE) 17 | -- Maintainer : Richard Eisenberg (rae@cs.brynmawr.edu) 18 | -- Stability : experimental 19 | -- 20 | -- Pretty-printing expressions. This allows reduction of code duplication 21 | -- between unchecked and checked expressions. 22 | -- 23 | ---------------------------------------------------------------------------- 24 | 25 | module Language.Glambda.Pretty ( 26 | PrettyExp(..), defaultPretty, 27 | Coloring, defaultColoring, 28 | prettyVar, prettyLam, prettyApp, prettyArith, prettyIf, prettyFix 29 | ) where 30 | 31 | import Language.Glambda.Token 32 | import Language.Glambda.Type 33 | import Language.Glambda.Util 34 | 35 | import Prettyprinter (Doc, annotate, nest, pretty, fillSep, (<+>), emptyDoc) 36 | import Prettyprinter.Render.Terminal (AnsiStyle, Color (Blue, Cyan, Green, Magenta, Red, Yellow), color) 37 | 38 | lamPrec, appPrec, appLeftPrec, appRightPrec, ifPrec :: Prec 39 | lamPrec = 1 40 | appPrec = 9 41 | appLeftPrec = 8.9 42 | appRightPrec = 9 43 | ifPrec = 1 44 | 45 | opPrec, opLeftPrec, opRightPrec :: ArithOp ty -> Prec 46 | opPrec (precInfo -> (x, _, _)) = x 47 | opLeftPrec (precInfo -> (_, x, _)) = x 48 | opRightPrec (precInfo -> (_, _, x)) = x 49 | 50 | -- | Returns (overall, left, right) precedences for an 'ArithOp' 51 | precInfo :: ArithOp ty -> (Prec, Prec, Prec) 52 | precInfo Plus = (5, 4.9, 5) 53 | precInfo Minus = (5, 4.9, 5) 54 | precInfo Times = (6, 5.9, 6) 55 | precInfo Divide = (6, 5.9, 6) 56 | precInfo Mod = (6, 5.9, 6) 57 | precInfo Less = (4, 4, 4) 58 | precInfo LessE = (4, 4, 4) 59 | precInfo Greater = (4, 4, 4) 60 | precInfo GreaterE = (4, 4, 4) 61 | precInfo Equals = (4, 4, 4) 62 | 63 | -- | A function that changes a 'Doc's color 64 | type ApplyColor = Doc AnsiStyle -> Doc AnsiStyle 65 | 66 | -- | Information about coloring in de Bruijn indexes and binders 67 | data Coloring = Coloring [ApplyColor] 68 | [ApplyColor] -- ^ a stream of remaining colors to use, 69 | -- and the colors used for bound variables 70 | 71 | -- | A 'Coloring' for an empty context 72 | defaultColoring :: Coloring 73 | defaultColoring = Coloring all_colors [] 74 | where 75 | all_colors = annotate (color Red) : annotate (color Green) : annotate (color Yellow) : annotate (color Blue) : 76 | annotate (color Magenta) : annotate (color Cyan) : all_colors 77 | 78 | -- | A class for expressions that can be pretty-printed 79 | class PrettyT exp => PrettyExp exp where 80 | prettyExp :: Coloring -> Prec -> exp -> Doc AnsiStyle 81 | 82 | -- | Convenient implementation of 'pretty' 83 | defaultPretty :: PrettyExp exp => exp -> Doc AnsiStyle 84 | defaultPretty = nest 2 . prettyExp defaultColoring topPrec 85 | 86 | -- | Print a variable 87 | prettyVar :: Coloring -> Int -> Doc AnsiStyle 88 | prettyVar (Coloring _ bound) n = nthDefault id n bound (pretty '#' <> pretty n) 89 | 90 | -- | Print a lambda expression 91 | prettyLam :: PrettyExp exp => Coloring -> Prec -> Maybe Ty -> exp -> Doc AnsiStyle 92 | prettyLam (Coloring (next : supply) existing) prec m_ty body 93 | = maybeParens (prec >= lamPrec) $ 94 | fillSep [ pretty 'λ' <> next (pretty '#') <> 95 | maybe emptyDoc (\ty -> pretty ":" <> pretty ty) m_ty <> pretty '.' 96 | , prettyExp (Coloring supply (next : existing)) topPrec body ] 97 | prettyLam _ _ _ _ = error "Infinite supply of colors ran out" 98 | 99 | -- | Print an application 100 | prettyApp :: (PrettyExp exp1, PrettyExp exp2) 101 | => Coloring -> Prec -> exp1 -> exp2 -> Doc AnsiStyle 102 | prettyApp coloring prec e1 e2 103 | = maybeParens (prec >= appPrec) $ 104 | fillSep [ prettyExp coloring appLeftPrec e1 105 | , prettyExp coloring appRightPrec e2 ] 106 | 107 | -- | Print an arithemtic expression 108 | prettyArith :: (PrettyExp exp1, PrettyExp exp2) 109 | => Coloring -> Prec -> exp1 -> ArithOp ty -> exp2 -> Doc AnsiStyle 110 | prettyArith coloring prec e1 op e2 111 | = maybeParens (prec >= opPrec op) $ 112 | fillSep [ prettyExp coloring (opLeftPrec op) e1 <+> pretty op 113 | , prettyExp coloring (opRightPrec op) e2 ] 114 | 115 | -- | Print a conditional 116 | prettyIf :: (PrettyExp exp1, PrettyExp exp2, PrettyExp exp3) 117 | => Coloring -> Prec -> exp1 -> exp2 -> exp3 -> Doc AnsiStyle 118 | prettyIf coloring prec e1 e2 e3 119 | = maybeParens (prec >= ifPrec) $ 120 | fillSep [ pretty "if" <+> prettyExp coloring topPrec e1 121 | , pretty "then" <+> prettyExp coloring topPrec e2 122 | , pretty "else" <+> prettyExp coloring topPrec e3 ] 123 | 124 | -- | Print a @fix@ 125 | prettyFix :: PrettyExp exp => Coloring -> Prec -> exp -> Doc AnsiStyle 126 | prettyFix coloring prec e 127 | = maybeParens (prec >= appPrec) $ 128 | pretty "fix" <+> prettyExp coloring topPrec e 129 | -------------------------------------------------------------------------------- /src/Language/Glambda/Repl.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances, 2 | UndecidableInstances, CPP, ViewPatterns, 3 | NondecreasingIndentation #-} 4 | #if __GLASGOW_HASKELL__ < 709 5 | {-# LANGUAGE OverlappingInstances #-} 6 | {-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-} 7 | #endif 8 | 9 | ----------------------------------------------------------------------------- 10 | -- | 11 | -- Module : Language.Glambda.Repl 12 | -- Copyright : (C) 2015 Richard Eisenberg 13 | -- License : BSD-style (see LICENSE) 14 | -- Maintainer : Richard Eisenberg (rae@cs.brynmawr.edu) 15 | -- Stability : experimental 16 | -- 17 | -- Implements a REPL for glambda. 18 | -- 19 | ---------------------------------------------------------------------------- 20 | 21 | module Language.Glambda.Repl ( main ) where 22 | 23 | import Prelude hiding ( lex ) 24 | 25 | import Language.Glambda.Check 26 | import Language.Glambda.Eval 27 | import Language.Glambda.Lex 28 | import Language.Glambda.Parse 29 | import Language.Glambda.Unchecked 30 | import Language.Glambda.Util 31 | import Language.Glambda.Statement 32 | import Language.Glambda.Globals 33 | import Language.Glambda.Monad 34 | import Language.Glambda.Exp 35 | import Language.Glambda.Type 36 | 37 | import Prettyprinter (Doc, Pretty, (<+>), pretty, colon, emptyDoc, squotes, parens, vcat, indent) 38 | import Prettyprinter.Render.Terminal (AnsiStyle) 39 | 40 | import System.Console.Haskeline 41 | import System.Directory 42 | 43 | import Control.Monad 44 | import Control.Monad.Reader 45 | import Control.Monad.State 46 | import Data.Char 47 | import Data.List as List 48 | 49 | #if __GLASGOW_HASKELL__ < 709 50 | import Control.Applicative 51 | #endif 52 | 53 | -- | The glamorous Glambda interpreter 54 | main :: IO () 55 | main = runInputT defaultSettings $ 56 | runGlam $ do 57 | helloWorld 58 | loop 59 | 60 | loop :: Glam () 61 | loop = do 62 | m_line <- prompt "λ> " 63 | case stripWhitespace <$> m_line of 64 | Nothing -> quit 65 | Just (':' : cmd) -> runCommand cmd 66 | Just str -> runStmts str 67 | loop 68 | 69 | -- | Prints welcome message 70 | helloWorld :: Glam () 71 | helloWorld = do 72 | printLine lambda 73 | printLine $ pretty "Welcome to the Glamorous Glambda interpreter, version" <+> 74 | pretty version <> pretty '.' 75 | 76 | -- | The welcome message 77 | lambda :: Doc AnsiStyle 78 | lambda 79 | = vcat $ List.map pretty 80 | [ " \\\\\\\\\\\\ " 81 | , " \\\\\\\\\\\\ " 82 | , " /-\\ \\\\\\\\\\\\ " 83 | , " | | \\\\\\\\\\\\ " 84 | , " \\-/| \\\\\\\\\\\\ " 85 | , " | //\\\\\\\\\\\\ " 86 | , " \\-/ ////\\\\\\\\\\\\ " 87 | , " //////\\\\\\\\\\\\ " 88 | , " ////// \\\\\\\\\\\\ " 89 | , " ////// \\\\\\\\\\\\ " 90 | ] 91 | 92 | -- | The current version of glambda 93 | version :: String 94 | version = "1.0" 95 | 96 | ------------------------------------------- 97 | -- running statements 98 | 99 | runStmts :: String -> Glam () 100 | runStmts str = reportErrors $ do 101 | toks <- lexG str 102 | stmts <- parseStmtsG toks 103 | doStmts stmts 104 | 105 | -- | Run a sequence of statements, returning the new global variables 106 | doStmts :: [Statement] -> GlamE Globals 107 | doStmts = foldr doStmt ask 108 | 109 | -- | Run a 'Statement' and then run another action with the global 110 | -- variables built in the 'Statement' 111 | doStmt :: Statement -> GlamE a -> GlamE a 112 | doStmt (BareExp uexp) thing_inside = check uexp $ \sty exp -> do 113 | printLine $ printValWithType (eval exp) sty 114 | thing_inside 115 | doStmt (NewGlobal g uexp) thing_inside = check uexp $ \sty exp -> do 116 | printLine $ pretty g <+> pretty '=' <+> printWithType exp sty 117 | local (extend g sty exp) thing_inside 118 | 119 | ------------------------------------------- 120 | -- commands 121 | 122 | -- | Interpret a command (missing the initial ':'). 123 | runCommand :: String -> Glam () 124 | runCommand = dispatchCommand cmdTable 125 | 126 | type CommandTable = [(String, String -> Glam ())] 127 | 128 | dispatchCommand :: CommandTable -> String -> Glam () 129 | dispatchCommand table line 130 | = case List.filter ((cmd `List.isPrefixOf`) . fst) table of 131 | [] -> printLine $ pretty "Unknown command:" <+> squotes (pretty cmd) 132 | [(_, action)] -> action arg 133 | many -> do printLine $ pretty "Ambiguous command:" <+> squotes (pretty cmd) 134 | printLine $ pretty "Possibilities:" $$ 135 | indent 2 (vcat $ List.map (pretty . fst) many) 136 | where (cmd, arg) = List.break isSpace line 137 | 138 | cmdTable :: CommandTable 139 | cmdTable = [ ("quit", quitCmd) 140 | , ("d-lex", lexCmd) 141 | , ("d-parse", parseCmd) 142 | , ("load", loadCmd) 143 | , ("eval", evalCmd) 144 | , ("step", stepCmd) 145 | , ("type", typeCmd) 146 | , ("all", allCmd) ] 147 | 148 | quitCmd :: String -> Glam () 149 | quitCmd _ = quit 150 | 151 | class Reportable a where 152 | report :: a -> Glam Globals 153 | 154 | instance Reportable (Doc AnsiStyle) where 155 | report x = printLine x >> get 156 | instance Reportable () where 157 | report _ = get 158 | instance Reportable Globals where 159 | report = return 160 | instance {-# OVERLAPPABLE #-} PrettyT a => Reportable a where 161 | report other = printLine (prettyT other) >> get 162 | 163 | reportErrors :: Reportable a => GlamE a -> Glam () 164 | reportErrors thing_inside = do 165 | result <- runGlamE thing_inside 166 | new_globals <- case result of 167 | Left err -> printLine err >> get 168 | Right x -> report x 169 | put new_globals 170 | 171 | parseLex :: String -> GlamE UExp 172 | parseLex = parseExpG <=< lexG 173 | 174 | printWithType :: (PrettyT exp, Pretty ty) => exp -> ty -> Doc AnsiStyle 175 | printWithType exp ty 176 | = prettyT exp <+> colon <+> pretty ty 177 | 178 | printValWithType :: Val ty -> STy ty -> Doc AnsiStyle 179 | printValWithType val sty 180 | = prettyVal val sty <+> colon <+> pretty sty 181 | 182 | lexCmd, parseCmd, evalCmd, stepCmd, typeCmd, allCmd, loadCmd 183 | :: String -> Glam () 184 | lexCmd expr = reportErrors $ lexG expr 185 | parseCmd = reportErrors . parseLex 186 | 187 | evalCmd expr = reportErrors $ do 188 | uexp <- parseLex expr 189 | check uexp $ \sty exp -> 190 | return $ printValWithType (eval exp) sty 191 | 192 | stepCmd expr = reportErrors $ do 193 | uexp <- parseLex expr 194 | check uexp $ \sty exp -> do 195 | printLine $ printWithType exp sty 196 | let loop e = case step e of 197 | Left e' -> do 198 | printLine $ pretty "-->" <+> printWithType e' sty 199 | loop e' 200 | Right v -> return v 201 | v <- loop exp 202 | return $ printValWithType v sty 203 | 204 | typeCmd expr = reportErrors $ do 205 | uexp <- parseLex expr 206 | check uexp $ \sty exp -> return (printWithType exp sty) 207 | 208 | allCmd expr = do 209 | printLine (pretty "Small step:") 210 | _ <- stepCmd expr 211 | 212 | printLine emptyDoc 213 | printLine (pretty "Big step:") 214 | evalCmd expr 215 | 216 | loadCmd (stripWhitespace -> file) = do 217 | file_exists <- liftIO $ doesFileExist file 218 | if not file_exists then file_not_found else do 219 | contents <- liftIO $ readFile file 220 | runStmts contents 221 | where 222 | file_not_found = do 223 | printLine (pretty "File not found:" <+> squotes (pretty file)) 224 | cwd <- liftIO getCurrentDirectory 225 | printLine (parens (pretty "Current directory:" <+> pretty cwd)) 226 | -------------------------------------------------------------------------------- /src/Language/Glambda/Shift.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables, DataKinds, PolyKinds, TypeOperators, 2 | TypeFamilies, GADTs #-} 3 | 4 | ----------------------------------------------------------------------------- 5 | -- | 6 | -- Module : Language.Glambda.Shift 7 | -- Copyright : (C) 2015 Richard Eisenberg 8 | -- License : BSD-style (see LICENSE) 9 | -- Maintainer : Richard Eisenberg (rae@cs.brynmawr.edu) 10 | -- Stability : experimental 11 | -- 12 | -- de Bruijn shifting and substitution 13 | -- 14 | ---------------------------------------------------------------------------- 15 | 16 | module Language.Glambda.Shift ( shift, subst ) where 17 | 18 | import Language.Glambda.Exp 19 | 20 | -- | @Length xs@ tells you how long a list @xs@ is. 21 | -- @LZ :: Length xs@ says that @xs@ is empty. 22 | -- @LS len :: Length xs@ tells you that @xs@ has one more element 23 | -- than @len@ says. 24 | data Length :: [a] -> * where 25 | LZ :: Length '[] 26 | LS :: Length xs -> Length (x ': xs) 27 | 28 | type family (xs :: [a]) ++ (ys :: [a]) :: [a] 29 | type instance '[] ++ ys = ys 30 | type instance (x ': xs) ++ ys = x ': (xs ++ ys) 31 | infixr 5 ++ 32 | 33 | -- | Convert an expression typed in one context to one typed in a larger 34 | -- context. Operationally, this amounts to de Bruijn index shifting. 35 | -- As a proposition, this is the weakening lemma. 36 | shift :: forall ts2 t ty. Exp ts2 ty -> Exp (t ': ts2) ty 37 | shift = go LZ 38 | where 39 | go :: forall ts1 ty. Length ts1 -> Exp (ts1 ++ ts2) ty -> Exp (ts1 ++ t ': ts2) ty 40 | go l_ts1 (Var v) = Var (shift_elem l_ts1 v) 41 | go l_ts1 (Lam body) = Lam (go (LS l_ts1) body) 42 | go l_ts1 (App e1 e2) = App (go l_ts1 e1) (go l_ts1 e2) 43 | go l_ts1 (Arith e1 op e2) = Arith (go l_ts1 e1) op (go l_ts1 e2) 44 | go l_ts1 (Cond e1 e2 e3) = Cond (go l_ts1 e1) (go l_ts1 e2) (go l_ts1 e3) 45 | go l_ts1 (Fix e) = Fix (go l_ts1 e) 46 | go _ (IntE n) = IntE n 47 | go _ (BoolE b) = BoolE b 48 | 49 | shift_elem :: Length ts1 -> Elem (ts1 ++ ts2) x 50 | -> Elem (ts1 ++ t ': ts2) x 51 | shift_elem LZ e = ES e 52 | shift_elem (LS _) EZ = EZ 53 | shift_elem (LS l) (ES e) = ES (shift_elem l e) 54 | 55 | -- | Substitute the first expression into the second. As a proposition, 56 | -- this is the substitution lemma. 57 | subst :: forall ts2 s t. 58 | Exp ts2 s -> Exp (s ': ts2) t -> Exp ts2 t 59 | subst e = go LZ 60 | where 61 | go :: forall ts1 t. Length ts1 -> Exp (ts1 ++ s ': ts2) t -> Exp (ts1 ++ ts2) t 62 | go len (Var v) = subst_var len v 63 | go len (Lam body) = Lam (go (LS len) body) 64 | go len (App e1 e2) = App (go len e1) (go len e2) 65 | go len (Arith e1 op e2) = Arith (go len e1) op (go len e2) 66 | go len (Cond e1 e2 e3) = Cond (go len e1) (go len e2) (go len e3) 67 | go len (Fix e) = Fix (go len e) 68 | go _ (IntE n) = IntE n 69 | go _ (BoolE b) = BoolE b 70 | 71 | subst_var :: forall ts1 t. 72 | Length ts1 -> Elem (ts1 ++ s ': ts2) t 73 | -> Exp (ts1 ++ ts2) t 74 | subst_var LZ EZ = e 75 | subst_var LZ (ES v) = Var v 76 | subst_var (LS _) EZ = Var EZ 77 | subst_var (LS len) (ES v) = shift (subst_var len v) 78 | -------------------------------------------------------------------------------- /src/Language/Glambda/Statement.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Language.Glambda.Statement 4 | -- Copyright : (C) 2015 Richard Eisenberg 5 | -- License : BSD-style (see LICENSE) 6 | -- Maintainer : Richard Eisenberg (rae@cs.brynmawr.edu) 7 | -- Stability : experimental 8 | -- 9 | -- Defines the Glambda Statement type, which can either be a bare 10 | -- expression or a global variable assignment. 11 | -- 12 | ---------------------------------------------------------------------------- 13 | 14 | module Language.Glambda.Statement ( Statement(..) ) where 15 | 16 | import Language.Glambda.Unchecked 17 | import Language.Glambda.Type (prettyT, PrettyT) 18 | 19 | import Prettyprinter (Pretty, pretty, (<+>)) 20 | 21 | -- | A statement can either be a bare expression, which will be evaluated, 22 | -- or an assignment to a global variable. 23 | data Statement = BareExp UExp 24 | | NewGlobal String UExp 25 | 26 | instance PrettyT Statement where 27 | prettyT (BareExp exp) = prettyT exp 28 | prettyT (NewGlobal v exp) = pretty v <+> pretty '=' <+> prettyT exp 29 | -------------------------------------------------------------------------------- /src/Language/Glambda/Token.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TupleSections, GADTs, StandaloneDeriving, DataKinds #-} 2 | 3 | ----------------------------------------------------------------------------- 4 | -- | 5 | -- Module : Language.Glambda.Token 6 | -- Copyright : (C) 2015 Richard Eisenberg 7 | -- License : BSD-style (see LICENSE) 8 | -- Maintainer : Richard Eisenberg (rae@cs.brynmawr.edu) 9 | -- Stability : experimental 10 | -- 11 | -- Defines a lexical token 12 | -- 13 | ---------------------------------------------------------------------------- 14 | 15 | module Language.Glambda.Token ( 16 | 17 | -- * Arithmetic operators 18 | ArithOp(..), UArithOp(..), eqArithOp, 19 | 20 | -- ** Unchecked synonyms for arithmetic operators 21 | uPlus, uMinus, uTimes, uDivide, uMod, uLess, uLessE, 22 | uGreater, uGreaterE, uEquals, 23 | 24 | -- * Tokens 25 | Token(..), LToken(..), unLoc, unArithOp, unInt, unBool, unName 26 | ) where 27 | 28 | import Language.Glambda.Type 29 | import Language.Glambda.Util 30 | 31 | import Prettyprinter (Pretty, pretty, Doc, prettyList, emptyDoc, (<+>), list, align) 32 | import Text.Parsec.Pos ( SourcePos ) 33 | 34 | import Data.List as List 35 | 36 | -- | An @ArithOp ty@ is an operator on numbers that produces a result 37 | -- of type @ty@ 38 | data ArithOp ty where 39 | Plus, Minus, Times, Divide, Mod :: ArithOp Int 40 | Less, LessE, Greater, GreaterE, Equals :: ArithOp Bool 41 | 42 | -- | 'UArithOp' ("unchecked 'ArithOp'") is an existential package for 43 | -- an 'ArithOp' 44 | data UArithOp where 45 | UArithOp :: ITy ty => ArithOp ty -> UArithOp 46 | 47 | uPlus, uMinus, uTimes, uDivide, uMod, uLess, uLessE, uGreater, 48 | uGreaterE, uEquals :: UArithOp 49 | uPlus = UArithOp Plus 50 | uMinus = UArithOp Minus 51 | uTimes = UArithOp Times 52 | uDivide = UArithOp Divide 53 | uMod = UArithOp Mod 54 | uLess = UArithOp Less 55 | uLessE = UArithOp LessE 56 | uGreater = UArithOp Greater 57 | uGreaterE = UArithOp GreaterE 58 | uEquals = UArithOp Equals 59 | 60 | -- | Compare two 'ArithOp's (potentially of different types) for equality 61 | eqArithOp :: ArithOp ty1 -> ArithOp ty2 -> Bool 62 | eqArithOp Plus Plus = True 63 | eqArithOp Minus Minus = True 64 | eqArithOp Times Times = True 65 | eqArithOp Divide Divide = True 66 | eqArithOp Mod Mod = True 67 | eqArithOp Less Less = True 68 | eqArithOp LessE LessE = True 69 | eqArithOp Greater Greater = True 70 | eqArithOp GreaterE GreaterE = True 71 | eqArithOp Equals Equals = True 72 | eqArithOp _ _ = False 73 | 74 | instance Eq (ArithOp ty) where 75 | (==) = eqArithOp 76 | 77 | instance Eq UArithOp where 78 | UArithOp op1 == UArithOp op2 = op1 `eqArithOp` op2 79 | 80 | -- | A lexed token 81 | data Token 82 | = LParen 83 | | RParen 84 | | Lambda 85 | | Dot 86 | | Arrow 87 | | Colon 88 | | ArithOp UArithOp 89 | | Int Int 90 | | Bool Bool 91 | | If 92 | | Then 93 | | Else 94 | | FixT 95 | | Assign 96 | | Semi 97 | | Name String 98 | deriving Eq 99 | 100 | -- | Perhaps extract a 'UArithOp' 101 | unArithOp :: Token -> Maybe UArithOp 102 | unArithOp (ArithOp x) = Just x 103 | unArithOp _ = Nothing 104 | 105 | -- | Perhaps extract an 'Int' 106 | unInt :: Token -> Maybe Int 107 | unInt (Int x) = Just x 108 | unInt _ = Nothing 109 | 110 | -- | Perhaps extract an 'Bool' 111 | unBool :: Token -> Maybe Bool 112 | unBool (Bool x) = Just x 113 | unBool _ = Nothing 114 | 115 | -- | Perhaps extract a 'String' 116 | unName :: Token -> Maybe String 117 | unName (Name x) = Just x 118 | unName _ = Nothing 119 | 120 | -- | A lexed token with location information attached 121 | data LToken = L SourcePos Token 122 | 123 | -- | Remove location information from an 'LToken' 124 | unLoc :: LToken -> Token 125 | unLoc (L _ t) = t 126 | 127 | instance Pretty (ArithOp ty) where 128 | pretty Plus = pretty '+' 129 | pretty Minus = pretty '-' 130 | pretty Times = pretty '*' 131 | pretty Divide = pretty '/' 132 | pretty Mod = pretty '%' 133 | pretty Less = pretty '<' 134 | pretty LessE = pretty "<=" 135 | pretty Greater = pretty '>' 136 | pretty GreaterE = pretty ">=" 137 | pretty Equals = pretty "==" 138 | 139 | instance Show (ArithOp ty) where 140 | show = render . pretty 141 | 142 | instance Pretty UArithOp where 143 | pretty (UArithOp op) = pretty op 144 | 145 | instance Show UArithOp where 146 | show = render . pretty 147 | 148 | instance Pretty Token where 149 | pretty = getDoc . printingInfo 150 | prettyList = printTogether . List.map printingInfo 151 | 152 | instance Show Token where 153 | show = render . pretty 154 | 155 | instance Pretty LToken where 156 | pretty = pretty . unLoc 157 | prettyList = prettyList . List.map unLoc 158 | 159 | instance PrettyT LToken where 160 | prettyT = pretty 161 | 162 | instance (PrettyT a) => PrettyT [a] where 163 | prettyT = align . list . map prettyT 164 | 165 | instance Show LToken where 166 | show = render . pretty 167 | 168 | type PrintingInfo ann = (Doc ann, Bool, Bool) 169 | -- the bools say whether or not to include a space before or a space after 170 | 171 | alone :: Doc ann -> PrintingInfo ann 172 | alone = (, True, True) 173 | 174 | getDoc :: PrintingInfo ann -> Doc ann 175 | getDoc (doc, _, _) = doc 176 | 177 | printingInfo :: Token -> PrintingInfo ann 178 | printingInfo LParen = (pretty '(', True, False) 179 | printingInfo RParen = (pretty ')', False, True) 180 | printingInfo Lambda = (pretty '\\', True, False) 181 | printingInfo Dot = (pretty '.', False, True) 182 | printingInfo Arrow = alone $ pretty "->" 183 | printingInfo Colon = (pretty ':', False, False) 184 | printingInfo (ArithOp a) = alone $ pretty a 185 | printingInfo (Int i) = alone $ pretty i 186 | printingInfo (Bool True) = alone $ pretty "true" 187 | printingInfo (Bool False) = alone $ pretty "false" 188 | printingInfo If = alone $ pretty "if" 189 | printingInfo Then = alone $ pretty "then" 190 | printingInfo Else = alone $ pretty "else" 191 | printingInfo FixT = alone $ pretty "fix" 192 | printingInfo Assign = alone $ pretty "=" 193 | printingInfo Semi = (pretty ';', False, True) 194 | printingInfo (Name t) = alone $ pretty t 195 | 196 | printTogether :: [PrintingInfo ann] -> Doc ann 197 | printTogether [] = emptyDoc 198 | printTogether pis = getDoc $ List.foldl1 combine pis 199 | where 200 | combine (doc1, before_space, inner_space1) (doc2, inner_space2, after_space) 201 | | inner_space1 && inner_space2 202 | = (doc1 <+> doc2, before_space, after_space) 203 | 204 | | otherwise 205 | = (doc1 <> doc2, before_space, after_space) 206 | -------------------------------------------------------------------------------- /src/Language/Glambda/Type.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds, TypeOperators, PolyKinds, 2 | GADTs, RankNTypes, FlexibleInstances, UndecidableInstances #-} 3 | 4 | ----------------------------------------------------------------------------- 5 | -- | 6 | -- Module : Language.Glambda.Type 7 | -- Copyright : (C) 2015 Richard Eisenberg 8 | -- License : BSD-style (see LICENSE) 9 | -- Maintainer : Richard Eisenberg (rae@cs.brynmawr.edu) 10 | -- Stability : experimental 11 | -- 12 | -- Defines types 13 | -- 14 | ---------------------------------------------------------------------------- 15 | 16 | module Language.Glambda.Type ( 17 | -- * Glambda types to be used in Haskell terms 18 | Ty(..), readTyCon, 19 | 20 | -- * Glambda types to be used in Haskell types 21 | STy(..), SCtx(..), ITy(..), 22 | emptyContext, refineTy, unrefineTy, eqSTy, 23 | PrettyT, prettyT 24 | ) where 25 | 26 | import Language.Glambda.Util 27 | 28 | import Prettyprinter (Doc, pretty, Pretty, hsep, (<+>)) 29 | import Prettyprinter.Render.Terminal (AnsiStyle) 30 | 31 | -- | Representation of a glambda type 32 | data Ty 33 | = Arr Ty Ty -- ^ A function type 34 | | IntTy 35 | | BoolTy 36 | deriving Eq 37 | infixr 1 `Arr` 38 | 39 | -- | Perhaps convert a string representation of a base type into a 'Ty' 40 | readTyCon :: String -> Maybe Ty 41 | readTyCon "Int" = Just IntTy 42 | readTyCon "Bool" = Just BoolTy 43 | readTyCon _ = Nothing 44 | 45 | -- | Singleton for a glambda type 46 | data STy :: * -> * where 47 | SArr :: STy arg -> STy res -> STy (arg -> res) 48 | SIntTy :: STy Int 49 | SBoolTy :: STy Bool 50 | infixr 1 `SArr` 51 | 52 | -- | An implicit 'STy', wrapped up in a class constraint 53 | class ITy ty where 54 | sty :: STy ty 55 | 56 | instance (ITy arg, ITy res) => ITy (arg -> res) where 57 | sty = sty `SArr` sty 58 | instance ITy Int where 59 | sty = SIntTy 60 | instance ITy Bool where 61 | sty = SBoolTy 62 | 63 | -- | Singleton for a typing context 64 | data SCtx :: [*] -> * where 65 | SNil :: SCtx '[] 66 | SCons :: STy h -> SCtx t -> SCtx (h ': t) 67 | infixr 5 `SCons` 68 | 69 | -- | The singleton for the empty context 70 | emptyContext :: SCtx '[] 71 | emptyContext = SNil 72 | 73 | -- | Convert a 'Ty' into an 'STy'. 74 | refineTy :: Ty -> (forall ty. STy ty -> r) -> r 75 | refineTy (ty1 `Arr` ty2) k 76 | = refineTy ty1 $ \sty1 -> 77 | refineTy ty2 $ \sty2 -> 78 | k (sty1 `SArr` sty2) 79 | refineTy IntTy k = k SIntTy 80 | refineTy BoolTy k = k SBoolTy 81 | 82 | -- | Convert an 'STy' into a 'Ty' 83 | unrefineTy :: STy ty -> Ty 84 | unrefineTy (arg `SArr` res) = unrefineTy arg `Arr` unrefineTy res 85 | unrefineTy SIntTy = IntTy 86 | unrefineTy SBoolTy = BoolTy 87 | 88 | -- | Compare two 'STy's for equality. 89 | eqSTy :: STy ty1 -> STy ty2 -> Maybe (ty1 :~: ty2) 90 | eqSTy (s1 `SArr` t1) (s2 `SArr` t2) 91 | | Just Refl <- s1 `eqSTy` s2 92 | , Just Refl <- t1 `eqSTy` t2 93 | = Just Refl 94 | eqSTy SIntTy SIntTy = Just Refl 95 | eqSTy SBoolTy SBoolTy = Just Refl 96 | eqSTy _ _ = Nothing 97 | 98 | ----------------------------------------- 99 | -- Pretty-printing 100 | 101 | class PrettyT a where 102 | prettyT :: a -> Doc AnsiStyle 103 | 104 | instance {-# OVERLAPPABLE #-} (Pretty a) => PrettyT a where 105 | prettyT = pretty 106 | 107 | instance (PrettyT a, PrettyT b) => PrettyT (Either a b) where 108 | prettyT (Right a) = pretty "Right" <+> prettyT a 109 | prettyT (Left b) = pretty "Left" <+> prettyT b 110 | 111 | instance Pretty Ty where 112 | pretty = pretty_ty topPrec 113 | 114 | instance Show Ty where 115 | show = render . pretty 116 | 117 | instance Pretty (STy ty) where 118 | pretty = pretty . unrefineTy 119 | 120 | arrowLeftPrec, arrowRightPrec, arrowPrec :: Prec 121 | arrowLeftPrec = 5 122 | arrowRightPrec = 4.9 123 | arrowPrec = 5 124 | 125 | pretty_ty :: Prec -> Ty -> Doc ann 126 | pretty_ty prec (Arr arg res) = maybeParens (prec >= arrowPrec) $ 127 | hsep [ pretty_ty arrowLeftPrec arg 128 | , pretty "->" 129 | , pretty_ty arrowRightPrec res ] 130 | pretty_ty _ IntTy = pretty "Int" 131 | pretty_ty _ BoolTy = pretty "Bool" 132 | -------------------------------------------------------------------------------- /src/Language/Glambda/Unchecked.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Language.Glambda.Unchecked 4 | -- Copyright : (C) 2015 Richard Eisenberg 5 | -- License : BSD-style (see LICENSE) 6 | -- Maintainer : Richard Eisenberg (rae@cs.brynmawr.edu) 7 | -- Stability : experimental 8 | -- 9 | -- Defines the AST for un-type-checked expressions 10 | -- 11 | ---------------------------------------------------------------------------- 12 | 13 | module Language.Glambda.Unchecked ( UExp(..) ) where 14 | 15 | import Language.Glambda.Pretty 16 | import Language.Glambda.Type 17 | import Language.Glambda.Token 18 | import Language.Glambda.Util 19 | 20 | import Prettyprinter (pretty, Doc) 21 | import Prettyprinter.Render.Terminal (AnsiStyle) 22 | 23 | -- | Unchecked expression 24 | data UExp 25 | = UVar Int -- ^ de Bruijn index for a variable 26 | | UGlobal String 27 | | ULam Ty UExp 28 | | UApp UExp UExp 29 | | UArith UExp UArithOp UExp 30 | | UCond UExp UExp UExp 31 | | UFix UExp 32 | | UIntE Int 33 | | UBoolE Bool 34 | 35 | instance PrettyT UExp where 36 | prettyT = defaultPretty 37 | 38 | instance PrettyExp UExp where 39 | prettyExp = pretty_exp 40 | 41 | pretty_exp :: Coloring -> Prec -> UExp -> Doc AnsiStyle 42 | pretty_exp c _ (UVar n) = prettyVar c n 43 | pretty_exp _ _ (UGlobal n) = pretty n 44 | pretty_exp c prec (ULam ty body) = prettyLam c prec (Just ty) body 45 | pretty_exp c prec (UApp e1 e2) = prettyApp c prec e1 e2 46 | pretty_exp c prec (UArith e1 (UArithOp op) e2) = prettyArith c prec e1 op e2 47 | pretty_exp c prec (UCond e1 e2 e3) = prettyIf c prec e1 e2 e3 48 | pretty_exp c prec (UFix body) = prettyFix c prec body 49 | pretty_exp _ _ (UIntE n) = pretty n 50 | pretty_exp _ _ (UBoolE True) = pretty "true" 51 | pretty_exp _ _ (UBoolE False) = pretty "false" 52 | -------------------------------------------------------------------------------- /src/Language/Glambda/Util.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs, PolyKinds, TypeOperators, CPP #-} 2 | {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-warnings-deprecations #-} 3 | 4 | ----------------------------------------------------------------------------- 5 | -- | 6 | -- Module : Language.Glambda.Util 7 | -- Copyright : (C) 2015 Richard Eisenberg 8 | -- License : BSD-style (see LICENSE) 9 | -- Maintainer : Richard Eisenberg (rae@cs.brynmawr.edu) 10 | -- Stability : experimental 11 | -- 12 | -- Utility exports (and re-exports) for glambda. This module is meant to 13 | -- be internal -- do not import it if you are not part of the glambda 14 | -- package! 15 | -- 16 | ---------------------------------------------------------------------------- 17 | 18 | module Language.Glambda.Util ( 19 | render, toSimpleDoc, maybeParens, ($$), 20 | Prec, topPrec, 21 | stripWhitespace, nthDefault, 22 | (:~:)(..), ignore 23 | ) where 24 | 25 | import Text.Parsec 26 | import Prettyprinter (Pretty, pretty, Doc, SimpleDocStream, layoutPretty, defaultLayoutOptions, parens, hardline) 27 | import Prettyprinter.Render.String (renderShowS) 28 | import Prettyprinter.Render.Terminal (AnsiStyle, renderStrict) 29 | import Data.Text (unpack) 30 | 31 | import Data.Char 32 | import Data.List 33 | 34 | #if __GLASGOW_HASKELL__ < 709 35 | import Data.Functor 36 | #endif 37 | 38 | #if __GLASGOW_HASKELL__ >= 707 39 | import Data.Type.Equality 40 | #else 41 | data a :~: b where 42 | Refl :: a :~: a 43 | #endif 44 | 45 | -- | Like 'Data.Functor.void' 46 | ignore :: Functor f => f a -> f () 47 | ignore = (() <$) 48 | 49 | instance Pretty ParseError where 50 | pretty = pretty . show 51 | 52 | -- | More perspicuous synonym for operator precedence 53 | type Prec = Rational 54 | 55 | -- | Precedence for top-level printing 56 | topPrec :: Prec 57 | topPrec = 0 58 | 59 | -- | Convert a 'Doc' to a 'String' 60 | render :: Doc AnsiStyle -> String 61 | render = unpack . renderStrict . toSimpleDoc 62 | 63 | -- | Convert a 'Doc' to a 'SimpleDoc' for further rendering 64 | toSimpleDoc :: Doc AnsiStyle -> SimpleDocStream AnsiStyle 65 | toSimpleDoc = layoutPretty defaultLayoutOptions 66 | 67 | -- | Enclose a 'Doc' in parens if the flag is 'True' 68 | maybeParens :: Bool -> Doc ann -> Doc ann 69 | maybeParens True = parens 70 | maybeParens False = id 71 | 72 | -- | Synonym for 'Pretty.<$>' 73 | ($$) :: Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle 74 | a $$ b = a <> hardline <> b 75 | 76 | -- | (Inefficiently) strips whitespace from a string 77 | stripWhitespace :: String -> String 78 | stripWhitespace = dropWhile isSpace . dropWhileEnd isSpace 79 | 80 | -- | Pluck out the nth item from a list, or use a default if the list 81 | -- is too short 82 | nthDefault :: a -> Int -> [a] -> a 83 | nthDefault _ 0 (x:_) = x 84 | nthDefault def n (_:xs) = nthDefault def (n-1) xs 85 | nthDefault def _ [] = def 86 | -------------------------------------------------------------------------------- /tests/Tests/Check.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | 3 | module Tests.Check where 4 | 5 | import Prelude hiding ( lex ) 6 | 7 | import Language.Glambda.Exp 8 | import Language.Glambda.Parse 9 | import Language.Glambda.Lex 10 | import Language.Glambda.Check 11 | import Language.Glambda.Type 12 | import Language.Glambda.Eval 13 | import Language.Glambda.Globals 14 | import Language.Glambda.Util 15 | 16 | import Control.Monad.Trans.Except 17 | import Control.Monad.Reader 18 | 19 | import Prettyprinter(pretty, unAnnotate) 20 | 21 | import Data.Maybe 22 | import Data.List as List 23 | import Control.Arrow as Arrow 24 | 25 | import Test.Tasty 26 | import Test.Tasty.HUnit 27 | 28 | checkTestCases :: [(String, Maybe (String, Ty, String))] 29 | checkTestCases = [ ("1", Just ("1", IntTy, "1")) 30 | , ("1 + true", Nothing) 31 | , ("(\\x:Int.x) 5", 32 | Just ("(λ#. #0) 5", IntTy, "5")) 33 | , ("(\\x:Int.\\y:Int->Int.y x) 4 (\\z:Int.z*2)", 34 | Just ("(λ#. λ#. #0 #1) 4 (λ#. #0 * 2)", 35 | IntTy, "8")) 36 | , ("1 + 2 * 3 / 4 - 10 % 3", 37 | Just ("1 + 2 * 3 / 4 - 10 % 3", IntTy, "1")) 38 | , ("if true then 1 else false", Nothing) 39 | , ("if 3 - 1 == 2 then \\x:Int.x else \\x:Int.3", 40 | Just ("if 3 - 1 == 2 then λ#. #0 else λ#. 3", 41 | IntTy `Arr` IntTy, "λ#. #0")) 42 | , ("1 > 2", Just ("1 > 2", BoolTy, "false")) 43 | , ("2 > 1", Just ("2 > 1", BoolTy, "true")) 44 | , ("1 > 1", Just ("1 > 1", BoolTy, "false")) 45 | , ("1 >= 1", Just ("1 >= 1", BoolTy, "true")) 46 | , ("1 < 2", Just ("1 < 2", BoolTy, "true")) 47 | , ("1 < 1", Just ("1 < 1", BoolTy, "false")) 48 | , ("1 <= 1", Just ("1 <= 1", BoolTy, "true")) 49 | , ("id_int (id_int 5)", Just ("(λ#. #0) ((λ#. #0) 5)", IntTy, "5")) 50 | ] 51 | 52 | checkTests :: TestTree 53 | checkTests = testGroup "Typechecker" $ 54 | List.map (\(expr_str, m_result) -> 55 | testCase ("`" ++ expr_str ++ "'") 56 | (case flip runReader id_globals $ runExceptT $ do 57 | uexp <- hoistEither $ Arrow.left pretty $ parseExp =<< lex expr_str 58 | check uexp $ \sty exp -> return $ 59 | case m_result of 60 | Just result 61 | -> (render (unAnnotate $ prettyT exp), unrefineTy sty, 62 | render (unAnnotate $ prettyVal (eval exp) sty)) 63 | @?= result 64 | _ -> assertFailure "unexpected type-check success" 65 | of 66 | Left _ -> assertBool "unexpected failure" (isNothing m_result) 67 | Right b -> b)) checkTestCases 68 | 69 | hoistEither :: Monad m => Either e a -> ExceptT e m a 70 | hoistEither = ExceptT . return 71 | 72 | id_globals :: Globals 73 | id_globals = extend "id_int" (SIntTy `SArr` SIntTy) (Lam (Var EZ)) emptyGlobals 74 | -------------------------------------------------------------------------------- /tests/Tests/Lex.hs: -------------------------------------------------------------------------------- 1 | module Tests.Lex where 2 | 3 | import Language.Glambda.Lex 4 | import Language.Glambda.Token 5 | import Tests.Util 6 | 7 | import Prelude hiding ( lex ) 8 | 9 | import Data.List as List 10 | import Control.Arrow as Arrow ( right ) 11 | 12 | lexTestCases :: [(String, [Token])] 13 | lexTestCases = [ ("", []) 14 | , (" ", []) 15 | , (" {- hi -} \n ", []) 16 | , (" {----} ", []) 17 | , (" {- foo {- bar -} blah -}", []) 18 | , (" {- foo {-- bar -}-}", []) 19 | , ("{- blah ---}", []) 20 | , ("{- froggle -} -- blah", []) 21 | , ("x", [Name "x"]) 22 | , ("(()", [LParen, LParen, RParen]) 23 | , ("++--++", [ArithOp uPlus, ArithOp uPlus]) 24 | , ("->->", [Arrow, Arrow]) 25 | , ("45+332-89/1*3%xyz", [ Int 45, ArithOp uPlus, Int 332 26 | , ArithOp uMinus, Int 89, ArithOp uDivide 27 | , Int 1, ArithOp uTimes, Int 3 28 | , ArithOp uMod, Name "xyz" ]) 29 | , ("===", [ArithOp uEquals, Assign]) 30 | , ("if x then y else z", [If, Name "x", Then, Name "y", Else, Name "z"]) 31 | , ("ifs trues falsee true-", [ Name "ifs", Name "trues", Name "falsee" 32 | , Bool True, ArithOp uMinus ]) 33 | , (":\\", [Colon, Lambda]) 34 | , (">>==<===<", [ ArithOp uGreater, ArithOp uGreaterE, Assign 35 | , ArithOp uLessE, ArithOp uEquals, ArithOp uLess ]) 36 | ] 37 | 38 | lexTests :: TestTree 39 | lexTests = testGroup "Lexer" $ 40 | List.map (\(str, out) -> testCase ("`" ++ str ++ "'") $ 41 | Arrow.right (List.map unLoc) 42 | (lex str) @?= Right out) 43 | lexTestCases 44 | -------------------------------------------------------------------------------- /tests/Tests/Main.hs: -------------------------------------------------------------------------------- 1 | -- Main testing module 2 | 3 | module Tests.Main where 4 | 5 | import Test.Tasty 6 | 7 | import Tests.Lex 8 | import Tests.Parse 9 | import Tests.Check 10 | 11 | allTests :: TestTree 12 | allTests = testGroup "Top" [lexTests, parseTests, checkTests] 13 | 14 | main :: IO () 15 | main = defaultMain allTests 16 | -------------------------------------------------------------------------------- /tests/Tests/Parse.hs: -------------------------------------------------------------------------------- 1 | module Tests.Parse where 2 | 3 | import Language.Glambda.Lex 4 | import Language.Glambda.Parse 5 | import Language.Glambda.Util 6 | import Language.Glambda.Type 7 | import Tests.Util 8 | 9 | import Prelude hiding ( lex ) 10 | 11 | import Prettyprinter (unAnnotate) 12 | 13 | import Data.List as List 14 | 15 | parseTestCases :: [(String, String)] 16 | parseTestCases = [ ("\\x:Int.x", "λ#:Int. #0") 17 | , ("\\x:Int.\\y:Int.x", "λ#:Int. λ#:Int. #1") 18 | , ("\\x:Int.\\x:Int.x", "λ#:Int. λ#:Int. #0") 19 | , ("1 + 2 + 3", "1 + 2 + 3") 20 | , ("1 + 2 * 4 % 5", "1 + 2 * 4 % 5") 21 | , ("if \\x:Int.x then 4 else (\\x:Int.x) (\\y:Int.y)", 22 | "if λ#:Int. #0 then 4 else (λ#:Int. #0) (λ#:Int. #0)") 23 | , ("true true true", "true true true") 24 | , ("true false (\\x:Int.x)", "true false (λ#:Int. #0)") 25 | , ("\\x:Int->Int.\\y:Int.x y", "λ#:Int -> Int. λ#:Int. #1 #0") 26 | , ("if 3 - 1 == 2 then \\x:Int.x else \\x:Int.3", 27 | "if 3 - 1 == 2 then λ#:Int. #0 else λ#:Int. 3") 28 | , ("\\x:Int.y", "λ#:Int. y") 29 | ] 30 | 31 | parserFailTestCases :: [String] 32 | parserFailTestCases = [ " {- " 33 | , "{-{- -}" ] 34 | 35 | parseTests :: TestTree 36 | parseTests = testGroup "Parser" 37 | [ testGroup "Success" $ 38 | List.map (\(str, out) -> testCase ("`" ++ str ++ "'") $ 39 | render (unAnnotate $ prettyT (parseExp =<< lex str)) @?= 40 | ("Right " ++ out)) 41 | parseTestCases 42 | , testGroup "Failure" $ 43 | List.map (\str -> testCase ("`" ++ str ++ "'") $ 44 | (case parseExp =<< lex str of Left _ -> True; _ -> False) @? 45 | "parse erroneously successful") 46 | parserFailTestCases ] 47 | -------------------------------------------------------------------------------- /tests/Tests/Util.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# OPTIONS_GHC -fno-warn-orphans #-} 3 | 4 | ----------------------------------------------------------------------------- 5 | -- | 6 | -- Module : Tests.Util 7 | -- Copyright : (C) 2015 Richard Eisenberg 8 | -- License : BSD-style (see LICENSE) 9 | -- Maintainer : Richard Eisenberg (rae@cs.brynmawr.edu) 10 | -- Stability : experimental 11 | -- 12 | -- Utility definnitions for testing glambda 13 | -- 14 | ---------------------------------------------------------------------------- 15 | 16 | module Tests.Util ( 17 | module Test.Tasty, 18 | testCase, 19 | (@?=), (@=?), (@?) ) 20 | where 21 | 22 | import Language.Glambda.Util 23 | 24 | import Test.Tasty 25 | import Test.Tasty.HUnit ( testCase, (@?), Assertion ) 26 | 27 | import Prettyprinter (Pretty, pretty, (<+>), squotes, semi) 28 | 29 | import Text.Parsec ( ParseError ) 30 | 31 | import Data.Function 32 | import Language.Haskell.TH 33 | 34 | prettyError :: Pretty a => a -> a -> String 35 | prettyError exp act = render $ pretty "Expected" <+> squotes (pretty exp) <> semi <+> 36 | pretty "got" <+> squotes (pretty act) 37 | 38 | (@?=) :: (Eq a, Pretty a) => a -> a -> Assertion 39 | act @?= exp = (act == exp) @? prettyError exp act 40 | 41 | (@=?) :: (Eq a, Pretty a) => a -> a -> Assertion 42 | exp @=? act = (act == exp) @? prettyError exp act 43 | 44 | $( do decs <- reifyInstances ''Eq [ConT ''ParseError] 45 | case decs of -- GHC 7.6 eagerly typechecks the instance, sometimes 46 | -- reporting a duplicate. Urgh. So we can't quote it. 47 | [] -> fmap (:[]) $ 48 | instanceD (return []) (appT (conT ''Eq) (conT ''ParseError)) 49 | [ valD (varP '(==)) (normalB [| (==) `on` show |]) [] ] 50 | _ -> return [] ) 51 | 52 | instance (Pretty a, Pretty b) => Pretty (Either a b) where 53 | pretty (Left x) = pretty "Left" <+> pretty x 54 | pretty (Right x) = pretty "Right" <+> pretty x 55 | -------------------------------------------------------------------------------- /tests/prime.glam: -------------------------------------------------------------------------------- 1 | -- A prime-number checker, written in glambda 2 | 3 | noDivisorsAbove = fix \nda: Int -> Int -> Bool. \tester:Int. \scrutinee:Int. 4 | if tester * tester > scrutinee then true else 5 | if scrutinee % tester == 0 then false else 6 | nda (tester+1) scrutinee ; 7 | 8 | isPrime = noDivisorsAbove 2 9 | -------------------------------------------------------------------------------- /tests/revapp.glam: -------------------------------------------------------------------------------- 1 | -- Glambda test file 2 | revapp = \x:Int. \y:Int->Int. y x; 3 | plus1 = \x:Int. x + 1 4 | --------------------------------------------------------------------------------