├── lp
├── .gitignore
├── Setup.hs
├── ChangeLog.md
├── app
    └── Main.hs
├── test
    └── Spec.hs
├── paper
    ├── LambdaPi.hi
    ├── LambdaPi.o
    ├── prelude.lp
    └── LambdaPi.hs
├── shell.nix
├── stack.yaml.lock
├── README.md
├── package.yaml
├── LICENSE
├── stack.yaml
└── src
    ├── BiSTLC.hs
    └── LambdaPi.hs


/lp:
--------------------------------------------------------------------------------
1 | stack runghc -- paper/LambdaPi.hs
2 | 


--------------------------------------------------------------------------------
/.gitignore:
--------------------------------------------------------------------------------
1 | .stack-work/
2 | lambda-pi.cabal
3 | *~
4 | 


--------------------------------------------------------------------------------
/Setup.hs:
--------------------------------------------------------------------------------
1 | import Distribution.Simple
2 | main = defaultMain
3 | 


--------------------------------------------------------------------------------
/ChangeLog.md:
--------------------------------------------------------------------------------
1 | # Changelog for lambda-pi 
2 | 
3 | ## Unreleased changes
4 | 


--------------------------------------------------------------------------------
/app/Main.hs:
--------------------------------------------------------------------------------
1 | module Main where
2 | 
3 | main :: IO ()
4 | main = pure ()
5 | 


--------------------------------------------------------------------------------
/test/Spec.hs:
--------------------------------------------------------------------------------
1 | main :: IO ()
2 | main = putStrLn "Test suite not yet implemented"
3 | 


--------------------------------------------------------------------------------
/paper/LambdaPi.hi:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/tdietert/lambda-pi/HEAD/paper/LambdaPi.hi


--------------------------------------------------------------------------------
/paper/LambdaPi.o:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/tdietert/lambda-pi/HEAD/paper/LambdaPi.o


--------------------------------------------------------------------------------
/shell.nix:
--------------------------------------------------------------------------------
 1 | {nixpkgs ? import <nixpkgs> { }, ghc ? nixpkgs.ghc}:
 2 | 
 3 | with nixpkgs;
 4 | 
 5 | haskell.lib.buildStackProject {
 6 |   inherit ghc;
 7 |   name = "types-as-specifications";
 8 |   buildInputs = [ glpk pcre readline70 ];
 9 | }
10 | 


--------------------------------------------------------------------------------
/stack.yaml.lock:
--------------------------------------------------------------------------------
 1 | # This file was autogenerated by Stack.
 2 | # You should not edit this file by hand.
 3 | # For more information, please see the documentation at:
 4 | #   https://docs.haskellstack.org/en/stable/lock_files
 5 | 
 6 | packages:
 7 | - completed:
 8 |     hackage: readline-1.0.3.0@sha256:db011062b90fbfbbc8b02666d835742c1d4de1f990a89fc056ef8082f3e3cba0,912
 9 |     pantry-tree:
10 |       size: 818
11 |       sha256: 661af71986cae04cb7dbffc3b0557ca94cf9e87ba163c70e91c59f4c5eaf5e64
12 |   original:
13 |     hackage: readline-1.0.3.0@sha256:db011062b90fbfbbc8b02666d835742c1d4de1f990a89fc056ef8082f3e3cba0,912
14 | snapshots:
15 | - completed:
16 |     size: 499889
17 |     url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/13/26.yaml
18 |     sha256: ecb02ee16829df8d7219e7d7fe6c310819820bf335b0b9534bce84d3ea896684
19 |   original: lts-13.26
20 | 


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
 1 | # lambda-pi 
 2 | 
 3 | This project is a toy implementation of the dependently typed lambda calculus
 4 | known as λ<sub>Π</sub>, based on the language and semantics presented in the 
 5 | paper [A tutorial implementation of a dependently typed lambda
 6 | calculus](https://www.andres-loeh.de/LambdaPi/LambdaPi.pdf), by Loh, McBride,
 7 | and Swierstra. Instead of the ad-hoc implementation of de Bruijn indices 
 8 | presented in the paper, we use the library [`unbound-generics`](https://hackage.haskell.org/package/unbound-generics)
 9 | for alpha equivalence and capture-avoiding substitution (CAS) of lambda 
10 | abstractions and pi terms. This project hopes to explore the implementation
11 | details of compiling dependently typed programming languages.
12 | 
13 | # LP Interpreter
14 | 
15 | To run the original interpreter from the paper and the "prelude" (standard
16 | library) defined in `paper/prelude.lp`, download the [nix](https://nixos.org/nix)
17 | package manager and run:
18 | 
19 | ```
20 | $ ./lp
21 | LP> :load paper/prelude.lp
22 | ```
23 | 


--------------------------------------------------------------------------------
/package.yaml:
--------------------------------------------------------------------------------
 1 | name:                lambda-pi
 2 | version:             0.1.0.0
 3 | github:              "githubuser/lambda-pi"
 4 | license:             BSD3
 5 | author:              "Author name here"
 6 | maintainer:          "example@example.com"
 7 | copyright:           "2019 Author name here"
 8 | 
 9 | extra-source-files:
10 | - README.md
11 | - ChangeLog.md
12 | 
13 | # Metadata used when publishing your package
14 | # synopsis:            Short description of your package
15 | # category:            Web
16 | 
17 | # To avoid duplicated efforts in documentation and dealing with the
18 | # complications of embedding Haddock markup inside cabal files, it is
19 | # common to point users to the README.md file.
20 | description:         Please see the README on GitHub at <https://github.com/githubuser/lambda-pi#readme>
21 | 
22 | dependencies:
23 | - base >= 4.7 && < 5
24 | - unbound-generics
25 | - containers
26 | - mtl
27 | - readline
28 | - pretty
29 | - parsec
30 | 
31 | library:
32 |   source-dirs: src
33 |   ghc-options:
34 |     - -fwarn-incomplete-patterns
35 |     - -fwarn-incomplete-uni-patterns
36 | 
37 | executables:
38 |   lambda-pi-exe:
39 |     main:                Main.hs
40 |     source-dirs:         app
41 |     ghc-options:
42 |     - -threaded
43 |     - -rtsopts
44 |     - -with-rtsopts=-N
45 |     dependencies:
46 |     - lambda-pi
47 | 
48 | tests:
49 |   lambda-pi-test:
50 |     main:                Spec.hs
51 |     source-dirs:         test
52 |     ghc-options:
53 |     - -threaded
54 |     - -rtsopts
55 |     - -with-rtsopts=-N
56 |     dependencies:
57 |     - lambda-pi
58 | 


--------------------------------------------------------------------------------
/LICENSE:
--------------------------------------------------------------------------------
 1 | Copyright Author name here (c) 2019
 2 | 
 3 | All rights reserved.
 4 | 
 5 | Redistribution and use in source and binary forms, with or without
 6 | modification, are permitted provided that the following conditions are met:
 7 | 
 8 |     * Redistributions of source code must retain the above copyright
 9 |       notice, this list of conditions and the following disclaimer.
10 | 
11 |     * Redistributions in binary form must reproduce the above
12 |       copyright notice, this list of conditions and the following
13 |       disclaimer in the documentation and/or other materials provided
14 |       with the distribution.
15 | 
16 |     * Neither the name of Author name here nor the names of other
17 |       contributors may be used to endorse or promote products derived
18 |       from this software without specific prior written permission.
19 | 
20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31 | 


--------------------------------------------------------------------------------
/stack.yaml:
--------------------------------------------------------------------------------
 1 | # This file was automatically generated by 'stack init'
 2 | #
 3 | # Some commonly used options have been documented as comments in this file.
 4 | # For advanced use and comprehensive documentation of the format, please see:
 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/
 6 | 
 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version.
 8 | # A snapshot resolver dictates the compiler version and the set of packages
 9 | # to be used for project dependencies. For example:
10 | #
11 | # resolver: lts-3.5
12 | # resolver: nightly-2015-09-21
13 | # resolver: ghc-7.10.2
14 | #
15 | # The location of a snapshot can be provided as a file or url. Stack assumes
16 | # a snapshot provided as a file might change, whereas a url resource does not.
17 | #
18 | # resolver: ./custom-snapshot.yaml
19 | # resolver: https://example.com/snapshots/2018-01-01.yaml
20 | resolver: lts-13.26
21 | 
22 | # User packages to be built.
23 | # Various formats can be used as shown in the example below.
24 | #
25 | # packages:
26 | # - some-directory
27 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz
28 | #   subdirs:
29 | #   - auto-update
30 | #   - wai
31 | packages:
32 | - .
33 | # Dependency packages to be pulled from upstream that are not in the resolver.
34 | # These entries can reference officially published versions as well as
35 | # forks / in-progress versions pinned to a git hash. For example:
36 | #
37 | # extra-deps:
38 | # - acme-missiles-0.3
39 | # - git: https://github.com/commercialhaskell/stack.git
40 | #   commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
41 | #
42 | extra-deps:
43 | - readline-1.0.3.0@sha256:db011062b90fbfbbc8b02666d835742c1d4de1f990a89fc056ef8082f3e3cba0,912
44 | 
45 | nix:
46 |   enable: true
47 |   shell-file: shell.nix
48 | 


--------------------------------------------------------------------------------
/src/BiSTLC.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE DeriveGeneric              #-}
  2 | {-# LANGUAGE DerivingStrategies         #-}
  3 | {-# LANGUAGE FlexibleContexts           #-}
  4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  5 | {-# LANGUAGE MultiParamTypeClasses      #-}
  6 | {-# LANGUAGE StandaloneDeriving         #-}
  7 | 
  8 | module BiSTLC
  9 |   ()
 10 | where
 11 | 
 12 | import           Control.Monad                    (unless)
 13 | import           Control.Monad.Except             (MonadError, throwError)
 14 | import           Data.Map                         (Map, insert, lookup)
 15 | import           Data.String                      (IsString)
 16 | import           GHC.Generics                     (Generic)
 17 | import           Prelude                          hiding (lookup)
 18 | import           Unbound.Generics.LocallyNameless
 19 | 
 20 | type Var = Name Syn
 21 | 
 22 | -- | Type-inferable terms
 23 | --
 24 | -- Somtimes called "synthesized" terms
 25 | --
 26 | data Syn
 27 |   = Var Var -- ^ Free and bound variables
 28 |   | Ann Chk Type -- ^ Annoted terms
 29 |   | App Syn Chk -- ^ Application
 30 |   deriving (Show, Generic)
 31 | 
 32 | instance Alpha Syn
 33 | 
 34 | instance Subst Syn Type
 35 | instance Subst Syn Chk
 36 | instance Subst Syn Syn where
 37 |   isvar (Var x) = Just (SubstName x)
 38 |   isvar _       = Nothing
 39 | 
 40 | -- | Type-checkable Terms
 41 | --
 42 | -- Sometimes called "checked" terms
 43 | --
 44 | data Chk
 45 |   = Inf Syn -- ^ Inferable terms embedded in checkable terms
 46 |   | Lam (Bind Var Chk) -- ^ Lambda term
 47 |   deriving (Show, Generic)
 48 | 
 49 | instance Alpha Chk
 50 | 
 51 | data Type
 52 |   = TFree Var -- ^ Free type variables
 53 |   | Type :-> Type -- ^ The type of lambda abstractions
 54 |   deriving (Show, Eq, Generic)
 55 | 
 56 | instance Alpha Type
 57 | 
 58 | data Kind
 59 |   = Star
 60 |   deriving (Show, Eq)
 61 | 
 62 | data TypeInfo
 63 |   = HasKind Kind
 64 |   | HasType Type
 65 |   deriving (Show, Eq)
 66 | 
 67 | type Context = Map Var TypeInfo
 68 | type Result = Either [Char]
 69 | 
 70 | -- | Assert that a given type is of a given kind
 71 | kind :: MonadError [Char] m => Context -> Type -> Kind -> m ()
 72 | kind ctx typ k = case (typ, k) of
 73 |   (TFree x, Star) -> case lookup x ctx of
 74 |     Nothing             -> throwError "unknown identifier"
 75 |     Just (HasType _   ) -> throwError "type should have kind"
 76 |     Just (HasKind Star) -> pure ()
 77 |   (tau :-> tau', Star) -> do
 78 |     kind ctx tau  Star
 79 |     kind ctx tau' Star
 80 | 
 81 | typecheck :: Context -> Syn -> Result Type
 82 | typecheck ctx' = runFreshMT . typeSyn ctx'
 83 |  where
 84 |   -- Types that should be synthesized
 85 |   typeSyn :: Context -> Syn -> FreshMT Result Type
 86 |   typeSyn ctx syn = case syn of
 87 |     Var x -> case lookup x ctx of
 88 |       Nothing          -> throwError "unknown identifier"
 89 |       Just (HasKind _) -> throwError "var should have type, not kind"
 90 |       Just (HasType t) -> pure t
 91 |     Ann e t -> do
 92 |       kind ctx t Star
 93 |       typeChk ctx e t
 94 |       pure t
 95 |     App e e' -> do
 96 |       sig <- typeSyn ctx e
 97 |       case sig of
 98 |         t :-> t' -> do
 99 |           typeChk ctx e' t
100 |           pure t'
101 |         _ -> throwError "illegal application"
102 | 
103 |   -- Types that should be "checked"
104 |   typeChk :: Context -> Chk -> Type -> FreshMT Result ()
105 |   typeChk ctx chk t = case chk of
106 |     Inf e -> do
107 |       t' <- typeSyn ctx e
108 |       unless (t == t') (throwError "type mismatch")
109 |     Lam binder -> case t of
110 |       t' :-> t'' -> do
111 |         -- Here we simply "unbind" the expression to get a globally fresh
112 |         -- variable 'x', and continue typechecking the body of the lambda
113 |         (x, body) <- unbind binder
114 |         typeChk (insert x (HasType t') ctx) body t''
115 |       _ -> throwError "type mismatch"
116 | 


--------------------------------------------------------------------------------
/paper/prelude.lp:
--------------------------------------------------------------------------------
  1 | 
  2 | -- identity and const
  3 | let id    = (\ a x -> x) :: forall (a :: *) . a -> a 
  4 | let const = (\ a b x y -> x) :: forall (a :: *) (b :: *) . a -> b -> a
  5 | 
  6 | -- addition of natural numbers
  7 | let plus =
  8 |   natElim
  9 |     ( \ _ -> Nat -> Nat )           -- motive
 10 |     ( \ n -> n )                    -- case for Zero
 11 |     ( \ p rec n -> Succ (rec n) )   -- case for Succ
 12 | 
 13 | -- predecessor, mapping 0 to 0
 14 | let pred =
 15 |   natElim
 16 |     ( \ _ -> Nat )
 17 |     Zero
 18 |     ( \ n' _rec -> n' )
 19 | 
 20 | -- a simpler elimination scheme for natural numbers
 21 | let natFold =
 22 |   ( \ m mz ms -> natElim
 23 |                    ( \ _ -> m )
 24 |                    mz
 25 |                    ( \ n' rec -> ms rec ) )
 26 |   :: forall (m :: *) . m -> (m -> m) -> Nat -> m
 27 | 
 28 | -- an eliminator for natural numbers that has special
 29 | -- cases for 0 and 1
 30 | let nat1Elim =
 31 |   ( \ m m0 m1 ms -> natElim m m0
 32 |                             (\ p rec -> natElim (\ n -> m (Succ n)) m1 ms p) )
 33 |   :: forall (m :: Nat -> *) . m 0 -> m 1 ->
 34 |      (forall n :: Nat . m (Succ n) -> m (Succ (Succ n))) ->
 35 |      forall (n :: Nat) . m n
 36 | 
 37 | -- an eliminator for natural numbers that has special
 38 | -- cases for 0, 1 and 2
 39 | let nat2Elim =
 40 |   ( \ m m0 m1 m2 ms -> nat1Elim m m0 m1
 41 |                                 (\ p rec -> natElim (\ n -> m (Succ (Succ n))) m2 ms p) )
 42 |   :: forall (m :: Nat -> *) . m 0 -> m 1 -> m 2 ->
 43 |      (forall n :: Nat . m (Succ (Succ n)) -> m (Succ (Succ (Succ n)))) ->
 44 |      forall (n :: Nat) . m n
 45 | -- increment by one
 46 | let inc = natFold Nat (Succ Zero) Succ
 47 | 
 48 | -- embed Fin into Nat
 49 | let finNat = finElim (\ _ _ -> Nat)
 50 |                      (\ _ -> Zero)
 51 |                      (\ _ _ rec -> Succ rec)
 52 | 
 53 | -- unit type
 54 | let Unit = Fin 1
 55 | -- constructor
 56 | let U = FZero 0
 57 | -- eliminator
 58 | let unitElim =
 59 |   ( \ m mu -> finElim ( nat1Elim (\ n -> Fin n -> *)
 60 |                                  (\ _ -> Unit)
 61 |                                  (\ x -> m x)
 62 |                                  (\ _ _ _ -> Unit) )
 63 |                       ( natElim (\ n -> natElim (\ n -> Fin (Succ n) -> *)
 64 |                                                 (\ x -> m x)
 65 |                                                 (\ _ _ _ -> Unit)
 66 |                                                 n (FZero n))
 67 |                                 mu
 68 |                                 (\ _ _ -> U) )
 69 |                       ( \ n f _ -> finElim (\ n f -> natElim (\ n -> Fin (Succ n) -> *)
 70 |                                                              (\ x -> m x)
 71 |                                                              (\ _ _ _ -> Unit)
 72 |                                                              n (FSucc n f))
 73 |                                            (\ _ -> U)
 74 |                                            (\ _ _ _ -> U)
 75 |                                            n f )
 76 |                       1 )
 77 |   :: forall (m :: Unit -> *) . m U -> forall (u :: Unit) . m u
 78 | 
 79 | -- empty type
 80 | let Void = Fin 0
 81 | -- eliminator
 82 | let voidElim =
 83 |   ( \ m -> finElim (natElim (\ n -> Fin n -> *)
 84 |                             (\ x -> m x)
 85 |                             (\ _ _ _ -> Unit))
 86 |                    (\ _ -> U)
 87 |                    (\ _ _ _ -> U)
 88 |                    0 )
 89 |   :: forall (m :: Void -> *) (v :: Void) . m v
 90 | 
 91 | -- type of booleans 
 92 | let Bool = Fin 2 
 93 | -- constructors
 94 | let False = FZero 1
 95 | let True  = FSucc 1 (FZero 0)
 96 | -- eliminator
 97 | let boolElim =
 98 |   ( \ m mf mt -> finElim ( nat2Elim (\ n -> Fin n -> *)
 99 |                                     (\ _ -> Unit) (\ _ -> Unit)
100 |                                     (\ x -> m x)
101 |                                     (\ _ _ _ -> Unit) )
102 |                          ( nat1Elim ( \ n -> nat1Elim (\ n -> Fin (Succ n) -> *)
103 |                                                       (\ _ -> Unit)
104 |                                                       (\ x -> m x)
105 |                                                       (\ _ _ _ -> Unit)
106 |                                                       n (FZero n))
107 |                                     U mf (\ _ _ -> U) )
108 |                          ( \ n f _ -> finElim ( \ n f -> nat1Elim (\ n -> Fin (Succ n) -> *)
109 |                                                                   (\ _ -> Unit)
110 |                                                                   (\ x -> m x)
111 |                                                                   (\ _ _ _ -> Unit)
112 |                                                                   n (FSucc n f) )
113 |                                               ( natElim
114 |                                                   ( \ n -> natElim
115 |                                                              (\ n -> Fin (Succ (Succ n)) -> *)
116 |                                                              (\ x -> m x)
117 |                                                              (\ _ _ _ -> Unit)
118 |                                                              n (FSucc (Succ n) (FZero n)) )
119 |                                                   mt (\ _ _ -> U) )
120 |                                               ( \ n f _ -> finElim
121 |                                                              (\ n f -> natElim
122 |                                                                          (\ n -> Fin (Succ (Succ n)) -> *)
123 |                                                                          (\ x -> m x)
124 |                                                                          (\ _ _ _ -> Unit)
125 |                                                                          n (FSucc (Succ n) (FSucc n f)))
126 |                                                              (\ _ -> U)
127 |                                                              (\ _ _ _ -> U)
128 |                                                              n f )
129 |                                               n f )
130 |                          2 )
131 |   :: forall (m :: Bool -> *) . m False -> m True -> forall (b :: Bool) . m b
132 | 
133 | -- boolean not, and, or, equivalence, xor
134 | let not = boolElim (\ _ -> Bool) True False
135 | let and = boolElim (\ _ -> Bool -> Bool) (\ _ -> False) (id Bool)
136 | let or  = boolElim (\ _ -> Bool -> Bool) (id Bool) (\ _ -> True)
137 | let iff = boolElim (\ _ -> Bool -> Bool) not (id Bool)
138 | let xor = boolElim (\ _ -> Bool -> Bool) (id Bool) not
139 | 
140 | -- even, odd, isZero, isSucc
141 | let even    = natFold Bool True not
142 | let odd     = natFold Bool False not
143 | let isZero  = natFold Bool True (\ _ -> False)
144 | let isSucc  = natFold Bool False (\ _ -> True)
145 | 
146 | -- equality on natural numbers
147 | let natEq =
148 |   natElim
149 |     ( \ _ -> Nat -> Bool )
150 |     ( natElim
151 |         ( \ _ -> Bool )
152 |         True
153 |         ( \ n' _ -> False ) )
154 |     ( \ m' rec_m' -> natElim
155 |                        ( \ _ -> Bool )
156 |                        False
157 |                        ( \ n' _ -> rec_m' n' ))
158 | 
159 | -- "oh so true"
160 | let Prop = boolElim (\ _ -> *) Void Unit
161 | 
162 | -- reflexivity of equality on natural numbers
163 | let pNatEqRefl =
164 |   natElim
165 |     (\ n -> Prop (natEq n n))
166 |     U
167 |     (\ n' rec -> rec)
168 |   :: forall (n :: Nat) . Prop (natEq n n)
169 | 
170 | -- alias for type-level negation 
171 | let Not = (\ a -> a -> Void) :: * -> *
172 | 
173 | -- Leibniz prinicple (look at the type signature)
174 | let leibniz =
175 |   ( \ a b f -> eqElim a
176 |                  (\ x y eq_x_y -> Eq b (f x) (f y))
177 |                  (\ x -> Refl b (f x)) )
178 |   :: forall (a :: *) (b :: *) (f :: a -> b) (x :: a) (y :: a) .
179 |      Eq a x y -> Eq b (f x) (f y)
180 | 
181 | -- symmetry of (general) equality
182 | let symm =
183 |   ( \ a -> eqElim a
184 |              (\ x y eq_x_y -> Eq a y x)
185 |              (\ x -> Refl a x) )
186 |   :: forall (a :: *) (x :: a) (y :: a) .
187 |      Eq a x y -> Eq a y x
188 | 
189 | -- transitivity of (general) equality
190 | let tran =
191 |   ( \ a x y z eq_x_y -> eqElim a
192 |                           (\ x y eq_x_y -> forall (z :: a) . Eq a y z -> Eq a x z)
193 |                           (\ x z eq_x_z -> eq_x_z)
194 |                           x y eq_x_y z )
195 |   :: forall (a :: *) (x :: a) (y :: a) (z :: a) .
196 |      Eq a x y -> Eq a y z -> Eq a x z
197 | 
198 | -- apply an equality proof on two types
199 | let apply =
200 |   eqElim * (\ a b _ -> a -> b) (\ _ x -> x)
201 |   :: forall (a :: *) (b :: *) (p :: Eq * a b) . a -> b
202 | 
203 | -- proof that 1 is not 0
204 | let p1IsNot0 =
205 |   (\ p -> apply Unit Void
206 |                 (leibniz Nat *
207 |                          (natElim (\ _ -> *) Void (\ _ _ -> Unit))
208 |                          1 0 p)
209 |                 U)
210 |   :: Not (Eq Nat 1 0)
211 | 
212 | -- proof that 0 is not 1
213 | let p0IsNot1 =
214 |   (\ p -> p1IsNot0 (symm Nat 0 1 p))
215 |   :: Not (Eq Nat 0 1)
216 | 
217 | -- proof that zero is not a successor
218 | let p0IsNoSucc = 
219 |   natElim
220 |     ( \ n -> Not (Eq Nat 0 (Succ n)) )
221 |     p0IsNot1
222 |     ( \ n' rec_n' eq_0_SSn' ->
223 |       rec_n' (leibniz Nat Nat pred Zero (Succ (Succ n')) eq_0_SSn') )
224 | 
225 | -- generate a vector of given length from a specified element (replicate)
226 | let replicate =
227 |   ( natElim
228 |       ( \ n -> forall (a :: *) . a -> Vec a n )
229 |       ( \ a _ -> Nil a )
230 |       ( \ n' rec_n' a x -> Cons a n' x (rec_n' a x) ) )
231 |   :: forall (n :: Nat) . forall (a :: *) . a -> Vec a n
232 | 
233 | -- alternative definition of replicate
234 | let replicate' =
235 |   (\ a n x -> natElim (Vec a)
236 |                       (Nil a)
237 |                       (\ n' rec_n' -> Cons a n' x rec_n') n)
238 |   :: forall (a :: *) (n :: Nat) . a -> Vec a n
239 | 
240 | -- generate a vector of given length n, containing the natural numbers smaller than n
241 | let fromto =
242 |   natElim
243 |     ( \ n -> Vec Nat n )
244 |     ( Nil Nat )
245 |     ( \ n' rec_n' -> Cons Nat n' n' rec_n' )
246 | 
247 | -- append two vectors
248 | let append =
249 |   ( \ a -> vecElim a
250 |              (\ m _ -> forall (n :: Nat) . Vec a n -> Vec a (plus m n))
251 |              (\ _ v -> v)
252 |              (\ m v vs rec n w -> Cons a (plus m n) v (rec n w)))
253 |   ::  forall (a :: *) (m :: Nat) (v :: Vec a m) (n :: Nat) (w :: Vec a n).
254 |       Vec a (plus m n)
255 | 
256 | -- helper function for tail, see below
257 | let tail' =
258 |   (\ a -> vecElim a ( \ m v -> forall (n :: Nat) . Eq Nat m (Succ n) -> Vec a n )
259 |                     ( \ n eq_0_SuccN -> voidElim ( \ _ -> Vec a n )
260 |                                                  ( p0IsNoSucc n eq_0_SuccN ) )
261 |                     ( \ m' v vs rec_m' n eq_SuccM'_SuccN ->
262 |                       eqElim Nat
263 |                              (\ m' n e -> Vec a m' -> Vec a n)
264 |                              (\ _ v -> v)
265 |                              m' n
266 |                              (leibniz Nat Nat pred (Succ m') (Succ n) eq_SuccM'_SuccN) vs))
267 |   :: forall (a :: *) (m :: Nat) . Vec a m -> forall (n :: Nat) . Eq Nat m (Succ n) -> Vec a n
268 | 
269 | -- compute the tail of a vector
270 | let tail =
271 |   (\ a n v -> tail' a (Succ n) v n (Refl Nat (Succ n)))
272 |   :: forall (a :: *) (n :: Nat) . Vec a (Succ n) -> Vec a n
273 | 
274 | -- projection out of a vector
275 | let at =
276 |   (\ a -> vecElim a ( \ n v -> Fin n -> a )
277 |                     ( \ f -> voidElim (\ _ -> a) f )
278 |                     ( \ n' v vs rec_n' f_SuccN' ->
279 |                       finElim ( \ n _ -> Eq Nat n (Succ n') -> a )
280 |                               ( \ n e -> v )
281 |                               ( \ n f_N _ eq_SuccN_SuccN' ->
282 |                                 rec_n' (eqElim Nat
283 |                                                (\ x y e -> Fin x -> Fin y)
284 |                                                (\ _ f -> f)
285 |                                                n n'
286 |                                                (leibniz Nat Nat pred
287 |                                                         (Succ n) (Succ n') eq_SuccN_SuccN')
288 |                                                f_N))
289 |                               (Succ n')
290 |                               f_SuccN'
291 |                               (Refl Nat (Succ n'))))
292 |   :: forall (a :: *) (n :: Nat) . Vec a n -> Fin n -> a
293 | 
294 | -- head of a vector
295 | let head =
296 |   (\ a n v -> at a (Succ n) v (FZero n))
297 |   :: forall (a :: *) (n :: Nat) . Vec a (Succ n) -> a
298 | 
299 | -- vector map
300 | let map =
301 |   (\ a b f -> vecElim a ( \ n _ -> Vec b n )
302 |                         ( Nil b )
303 |                         ( \ n x _ rec -> Cons b n (f x) rec ))
304 |   :: forall (a :: *) (b :: *) (f :: a -> b) (n :: Nat) . Vec a n -> Vec b n
305 | 
306 | -- proofs that 0 is the neutral element of addition
307 | -- one direction is trivial by definition of plus:
308 | let p0PlusNisN =
309 |   Refl Nat
310 |   :: forall n :: Nat . Eq Nat (plus 0 n) n
311 | 
312 | -- the other direction requires induction on N:
313 | let pNPlus0isN =
314 |   natElim ( \ n -> Eq Nat (plus n 0) n )
315 |           ( Refl Nat 0 )
316 |           ( \ n' rec -> leibniz Nat Nat Succ (plus n' 0) n' rec )
317 |   :: forall n :: Nat . Eq Nat (plus n 0) n
318 | 
319 | 


--------------------------------------------------------------------------------
/src/LambdaPi.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE ConstraintKinds            #-}
  2 | {-# LANGUAGE DeriveGeneric              #-}
  3 | {-# LANGUAGE DerivingStrategies         #-}
  4 | {-# LANGUAGE FlexibleContexts           #-}
  5 | {-# LANGUAGE FlexibleInstances          #-}
  6 | {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  7 | {-# LANGUAGE DeriveAnyClass             #-}
  8 | {-# LANGUAGE MultiParamTypeClasses      #-}
  9 | {-# LANGUAGE ScopedTypeVariables        #-}
 10 | {-# LANGUAGE StandaloneDeriving         #-}
 11 | {-# LANGUAGE LambdaCase                 #-}
 12 | 
 13 | module LambdaPi
 14 | where
 15 | 
 16 | import Control.Monad                    ((<=<), unless)
 17 | import Data.Foldable                    (foldlM)
 18 | import Control.Monad.Except             (MonadError, throwError)
 19 | import Data.Coerce                      (coerce)
 20 | import Data.Map                         (Map, fromList)
 21 | import qualified Data.Map               as Map
 22 | import Data.String                      (IsString)
 23 | import Data.Typeable                    (Typeable)
 24 | import Debug.Trace                      (trace, traceM)
 25 | import GHC.Exts                         (toList)
 26 | import GHC.Generics                     (Generic)
 27 | import GHC.Stack                        (HasCallStack, callStack)
 28 | import Prelude                          hiding (lookup, pi)
 29 | import Text.PrettyPrint                 (Doc, (<+>), brackets, char, colon, parens, render, text)
 30 | 
 31 | import Unbound.Generics.LocallyNameless
 32 | import Unbound.Generics.LocallyNameless.Name (Name(..))
 33 | 
 34 | ----------------------------------------
 35 | --  Lambda-Pi Terms
 36 | ----------------------------------------
 37 | 
 38 | -- | Variables for Type-synthesizable expressions
 39 | type Var = Name Syn
 40 | 
 41 | -- | The binding pattern for pi-terms
 42 | type PiBind expr = (Var, Embed expr)
 43 | 
 44 | type Rebindable expr = (Typeable expr, Alpha expr)
 45 | 
 46 | -- | Smart constructor for the PiBind type
 47 | mkPiBind :: Rebindable expr => [Char] -> expr -> PiBind expr
 48 | mkPiBind x e = (s2n x, Embed e)
 49 | 
 50 | -- | Type-inferable (synthesizable) terms
 51 | data Syn
 52 |   = Var Var -- ^ Free and bound variables
 53 |   | Ann Chk Chk -- ^ Annoted terms
 54 |   | App Syn Chk -- ^ Application
 55 |   | Pi (Bind (PiBind Chk) Chk)-- ^ The term for arrow types
 56 |   | Star -- ^ The term for kinds of types
 57 |   -- Natural Numbers
 58 |   | Nat -- Type of natural numbers
 59 |   | NatElim Chk Chk Chk Chk -- Natural number eliminator*
 60 |   | Zero -- Natural number '0'
 61 |   | Succ Chk -- Successor of Nat
 62 |   -- Length-indexed Vectors
 63 |   | Vec Chk Chk
 64 |   | Nil Chk
 65 |   | Cons Chk Chk Chk Chk
 66 |   | VecElim Chk Chk Chk Chk Chk Chk
 67 |   deriving (Show, Generic)
 68 | 
 69 | instance Alpha Syn
 70 | 
 71 | instance Subst Syn Syn where
 72 |   isvar (Var x) = Just (SubstName x)
 73 |   isvar _       = Nothing
 74 | 
 75 | -- | Terms whose types must be checked (we cannot infer them via context)
 76 | data Chk
 77 |   = Inf Syn -- ^ Inferable terms embedded in checkable terms
 78 |   | Lam (Bind Var Chk) -- ^ Lambda term, must be "checked"
 79 |   deriving (Show, Generic)
 80 | 
 81 | instance Alpha Chk
 82 | instance Subst Chk Syn
 83 | instance Subst Chk Chk
 84 | -- We must tell unbound-generics how to rebuild the Chk expr after digging in
 85 | -- and substituting the variable.
 86 | instance Subst Syn Chk where
 87 |   isCoerceVar (Inf (Var x)) = Just (SubstCoerce x (Just . Inf))
 88 |   isCoerceVar _ = Nothing
 89 | 
 90 | ----------------------------------------
 91 | -- Values
 92 | ----------------------------------------
 93 | 
 94 | type VVar = Name Value
 95 | 
 96 | type VPiBind = (VVar, Embed Value)
 97 | 
 98 | mkVPiBind :: [Char] -> Value -> VPiBind
 99 | mkVPiBind x e = (s2n x, Embed e)
100 | 
101 | -- | "Evaluated" expressions (Syn + Chck) are values
102 | --
103 | --  Note:
104 | --    Nested application values may need to be "normalized" after a substituion
105 | --    occurs while evaluating the parent application expression or after the LHS
106 | --    (lambda) expression is fully evaluated; For instance, the LHS of the
107 | --    application value may be a variable that is bound by some outer lambda
108 | --    abstraction, and could produce a value with redexes that needs to be
109 | --    normalized:
110 | --
111 | --      λa.NatElim (λ_.Nat -> Nat) (λn.n) (λk.λrec.λn.S((rec) (n))) a
112 | --
113 | --    The NatElim value can be further reduced after substitution of the
114 | --    variable 'a' for a value, returning either λn.n or λk.λrec.λn.S(rec n)
115 | --    depending on the value of 'a'.
116 | --
117 | data Value
118 |   = VLam (Bind VVar Value) -- ^ An evaluated lambda abstraction
119 |   | VStar -- ^ The evaluated type of 'Star'
120 |   | VPi (Bind VPiBind Value) -- ^ A type abstraction
121 |   | VVar VVar -- ^ A free variable, "neutral" term
122 |   | VApp Value Value -- ^ An evaluated application expression
123 |   | VNat -- ^ The type for Natural Numbers
124 |   | VZero -- ^ Peano Zero
125 |   | VSucc Value -- ^ Peano Successor
126 |   | VNatElim Value Value Value Value -- ^ The "Eliminator" for Natural Numbers
127 |   | VNil Value -- ^ The empty Vector
128 |   | VCons Value Value Value Value -- ^ The non-empty Vector
129 |   | VVec Value Value -- ^ The type of Vectors
130 |   | VVecElim Value Value Value Value Value Value -- ^ The "Eliminator" for Vectors
131 |   deriving (Show, Generic)
132 | 
133 | instance Alpha Value
134 | instance Subst Value Value where
135 |   isvar (VVar x) = Just (SubstName x)
136 |   isvar _         = Nothing
137 | 
138 | ----------------------------------------
139 | -- Evaluation & Typechecking
140 | ----------------------------------------
141 | 
142 | type Env = Map VVar Value
143 | type Result = Either [Char]
144 | 
145 | type TypecheckM a = FreshMT Result a
146 | 
147 | throwErrorTypecheckM :: (HasCallStack, MonadError e m) => e -> m a
148 | throwErrorTypecheckM err = do
149 |   mapM_ (traceM . show) (reverse $ toList callStack)
150 |   throwError err
151 | 
152 | eval :: Syn -> Result Value
153 | eval = unsafeEval mempty
154 | 
155 | unsafeEval :: Context -> Syn -> Result Value
156 | unsafeEval ctx = runFreshMT . evalSyn ctx
157 | 
158 | evalSynPretty :: Context -> Syn -> Result Doc
159 | evalSynPretty = evalPretty evalSyn
160 | 
161 | evalChkPretty :: Context -> Chk -> Result Doc
162 | evalChkPretty = evalPretty evalChk
163 | 
164 | evalPretty
165 |   :: (Context -> a -> TypecheckM Value)
166 |   -> Context
167 |   -> a
168 |   -> Result Doc
169 | evalPretty runTypecheckM ctx a = do
170 |   runFreshMT $ do
171 |     v <- runTypecheckM ctx a
172 |     ppr =<< normalize ctx v
173 | 
174 | -- | Evaluation of terms
175 | --
176 | -- We must write an evaluator as types can now depend on values, and in order to
177 | -- "compute the type" of a type, we must sometimes evaluate the "type expression"
178 | --
179 | evalSyn :: HasCallStack => Context -> Syn -> TypecheckM Value
180 | evalSyn ctx syn = case syn of
181 |   Var x ->
182 |     let vx = coerce x in
183 |     case lookupVar x ctx of
184 |       Nothing -> pure (VVar vx)
185 |       Just (VarInfo mv t) ->
186 |         case mv of
187 |           Nothing -> pure (VVar vx)
188 |           Just v -> pure v
189 |   Ann e _ -> evalChk ctx e
190 |   App e e' -> do
191 |     ve <- evalSyn ctx e
192 |     ve' <- evalChk ctx e'
193 |     vapp ctx ve ve'
194 |   Star -> pure VStar
195 |   Pi binding -> do
196 |     ((x, Embed p), p') <- unbind binding
197 |     let vx = coerce x
198 |     t <- evalChk ctx p
199 |     let varInfo = VarInfo Nothing t
200 |     t' <- evalChk (insertVar x varInfo ctx) p'
201 |     let xt = (vx, Embed t)
202 |     pure $ VPi (bind xt t')
203 |   Nat -> pure VNat
204 |   Zero -> pure VZero
205 |   Succ k -> pure . VSucc =<< evalChk ctx k
206 |   NatElim m mz ms k -> do
207 |     vk <- evalChk ctx k
208 |     case vk of
209 |       VZero -> evalChk ctx mz
210 |       VSucc l -> do
211 |         vm <- evalChk ctx m
212 |         vmz <- evalChk ctx mz
213 |         vms <- evalChk ctx ms
214 |         let rec = VNatElim vm vmz vms l
215 |         vmsl <- vapp ctx vms l
216 |         res <- vapp ctx vmsl rec
217 |         pure res
218 |       -- In the case that 'k' is a free variable:
219 |       VVar x -> do
220 |         vm <- evalChk ctx m
221 |         vmz <- evalChk ctx mz
222 |         vms <- evalChk ctx ms
223 |         pure (VNatElim vm vmz vms (VVar x))
224 |       _ -> throwErrorTypecheckM "evalSyn: NatElim"
225 |   VecElim a m mn mc k xs -> do
226 |     vmn <- evalChk ctx mn
227 |     vmc <- evalChk ctx mc
228 |     vxs <- evalChk ctx xs
229 |     case vxs of
230 |       VNil _ -> pure vmn
231 |       VCons _ vl' vx' vxs' -> do
232 |         va <- evalChk ctx a
233 |         vm <- evalChk ctx m
234 |         vk <- evalChk ctx k
235 |         let rec = VVecElim va vm vmn vmc vl' vxs'
236 |         vapps ctx vmc [vl', vx', vxs', rec]
237 |       VVar x -> do
238 |         va <- evalChk ctx a
239 |         vm <- evalChk ctx m
240 |         vk <- evalChk ctx k
241 |         pure (VVecElim va vm vmn vmc vk (VVar x))
242 |       _ -> throwErrorTypecheckM ("evalSyn: VecElim: " ++ show vxs)
243 |   Nil a -> pure . VNil =<< evalChk ctx a
244 |   Cons a k x xs ->
245 |     VCons <$> evalChk ctx a
246 |           <*> evalChk ctx k
247 |           <*> evalChk ctx x
248 |           <*> evalChk ctx xs
249 |   Vec a k ->
250 |     VVec <$> evalChk ctx a
251 |          <*> evalChk ctx k
252 | 
253 | -- | Helper function for applying lambda abstraction values to argument values
254 | -- that always normalizes its arguments and resulting value.
255 | vapp :: HasCallStack => Context -> Value -> Value -> TypecheckM Value
256 | vapp ctx ve ve' = do
257 |   case ve of
258 |     VLam binder -> do
259 |       (x, body) <- unbind binder
260 |       normalize ctx (subst x ve' body)
261 |     -- This case is for the rare occasion when we are constructing "neutral"
262 |     -- expressions for evaluation _during_ evaluation of another expressions, or
263 |     -- when fully evaluating the LHS of an application expression whose LHS
264 |     -- value is a bound variable that has not yet been substituted.
265 |     VVar x -> do
266 |       case lookupVar x ctx of
267 |         -- Free variable
268 |         Nothing -> pure $ VApp ve ve'
269 |         Just (VarInfo mv _) ->
270 |           case mv of
271 |             Nothing -> pure $ VApp ve ve'
272 |             Just v -> vapp ctx v ve'
273 |     VNatElim m mz ms k ->
274 |       case k of
275 |         VVar _ -> pure $ VApp ve ve'
276 |         _ -> error "wut"
277 |     VApp f _ -> do
278 |       case f of
279 |         VVar x -> pure $ VApp ve ve'
280 |         _ -> do
281 |           napp <- normalize ctx ve
282 |           vapp ctx napp ve'
283 |     _ -> throwErrorTypecheckM $ unlines
284 |            ["invalid apply:"
285 |            , show ve
286 |            , "  to"
287 |            , show ve'
288 |            ]
289 | 
290 | vapps :: HasCallStack => Context -> Value -> [Value] -> TypecheckM Value
291 | vapps ctx = foldlM (vapp ctx)
292 | 
293 | -- | Evaluate a checkable expression
294 | evalChk :: HasCallStack => Context -> Chk -> TypecheckM Value
295 | evalChk ctx chk = case chk of
296 |   Inf syn -> evalSyn ctx syn
297 |   Lam binding -> do
298 |     (x, e) <- unbind binding
299 |     ve <- evalChk ctx e
300 |     pure $ VLam (bind (coerce x) ve)
301 | 
302 | -- We store types in their evaluated form
303 | type Type = Value
304 | 
305 | -- | A Context maps a variable to the variables type and value
306 | --
307 | -- TODO Make a "Pretty" instance for debugging
308 | type Context = Map VVar VarInfo
309 | 
310 | insertVar :: Name a -> VarInfo -> Context -> Context
311 | insertVar nm vinfo ctx =
312 |   trace ("Inserting " ++ show nm ++ " as " ++ show vinfo) $
313 |     Map.insert (coerce nm) vinfo ctx
314 | 
315 | lookupVar :: Name a -> Context -> Maybe VarInfo
316 | lookupVar nm ctx =
317 |   trace ("Looking up " ++ show nm) $
318 |     Map.lookup (coerce nm) ctx
319 | 
320 | data VarInfo = VarInfo { varValue :: Maybe Value, varType :: Type }
321 |   deriving Show
322 | 
323 | -- | Typecheck an expression whose type is synthesizable
324 | typecheck :: HasCallStack => Syn -> Result Type
325 | typecheck = runFreshMT . typeSyn mempty
326 | 
327 | typecheckPretty :: HasCallStack => Syn -> Result Doc
328 | typecheckPretty syn =
329 |   trace ("typecheckPretty: " ++ show syn) $
330 |     typecheckPretty' mempty syn
331 | 
332 | typecheckPretty' :: HasCallStack => Context -> Syn -> Result Doc
333 | typecheckPretty' ctx = runFreshMT . (ppr <=< typeSyn ctx)
334 | 
335 | -- | Compute the type of a term whose type can be synthesized given a context
336 | typeSyn :: HasCallStack => Context -> Syn -> TypecheckM Type
337 | typeSyn ctx syn = case syn of
338 |   Var x -> case lookupVar x ctx of
339 |     Nothing -> throwErrorTypecheckM $
340 |       "typeSyn: unknown identifier: " ++ show x ++ " given " ++ show ctx
341 |     Just (VarInfo v t) -> pure t
342 |   Ann e p -> do
343 |     typeChk ctx p VStar
344 |     t <- evalChk ctx p
345 |     typeChk ctx e t
346 |     pure t
347 |   App e e' -> do
348 |     sigma <- typeSyn ctx e
349 |     case sigma of
350 |       VPi binding -> do
351 |         ((x, Embed t), t') <- unbind binding
352 |         typeChk ctx e' t
353 |         ve' <- evalChk ctx e'
354 |         normalize ctx (subst (coerce x) ve' t')
355 |       _ -> throwErrorTypecheckM ("illegal application: " ++ show sigma)
356 |   Star    -> pure VStar
357 |   Pi xp_p' -> do
358 |     ((x, Embed p), p') <- unbind xp_p'
359 |     typeChk ctx p VStar
360 |     t <- evalChk ctx p
361 |     let varInfo = VarInfo Nothing t
362 |     typeChk (insertVar x varInfo ctx) p' VStar
363 |     pure VStar
364 |   Nat -> pure VStar
365 |   Zero -> pure VNat
366 |   Succ k -> do
367 |     typeChk ctx k VNat
368 |     pure VNat
369 |   NatElim m mz ms k -> do
370 |     typeChk ctx m (tarr VNat VStar)
371 |     vm <- evalChk ctx m
372 |     typeChk ctx mz =<< vapp ctx vm VZero
373 |     vk <- evalChk ctx k
374 |     vmk <- vapp ctx vm vk
375 |     t' <-
376 |       pure . VPi . bind (mkVPiBind "l" VNat) . tarr vmk =<<
377 |         vapp ctx vm (VSucc (VVar (s2n "l")))
378 |     typeChk ctx ms t'
379 |     typeChk ctx k VNat
380 |     pure vmk
381 |   Vec a k -> do
382 |     typeChk ctx a VStar
383 |     typeChk ctx k VNat
384 |     pure VStar
385 |   Nil a -> do
386 |     typeChk ctx a VStar
387 |     va <- evalChk ctx a
388 |     pure (VVec va VZero)
389 |   Cons a k x xs -> do
390 |     typeChk ctx a VStar
391 |     va <- evalChk ctx a
392 |     typeChk ctx k VNat
393 |     vk <- evalChk ctx k
394 |     typeChk ctx x va
395 |     typeChk ctx xs (VVec va vk)
396 |     pure (VVec va (VSucc vk))
397 |   VecElim a m mn mc k vs -> do
398 |     typeChk ctx a VStar
399 |     va <- evalChk ctx a
400 |     -- typecheck m
401 |     mTyp <-
402 |       pure . VPi . bind (mkVPiBind "k" VNat) $
403 |         tarr (VVec va (VVar (s2n "k"))) VStar
404 |     typeChk ctx m mTyp
405 |     vm <- evalChk ctx m
406 |     -- typecheck mn
407 |     mnTyp <- vapps ctx vm [VZero, VNil va]
408 |     typeChk ctx mn mnTyp
409 |     vmn <- evalChk ctx mn
410 |     -- typecheck mc
411 |     let vl@(VVar (Fn lstr _)) = VVar (s2n "l")
412 |         vx@(VVar (Fn xstr _)) = VVar (s2n "x")
413 |         vxs@(VVar (Fn xsstr _)) = VVar (s2n "xs")
414 |     mcTyp <-
415 |       pure .
416 |         VPi . bind (mkVPiBind lstr VNat) .
417 |           VPi . bind (mkVPiBind xstr va) .
418 |             VPi . bind (mkVPiBind xsstr (VVec va vl)) =<< do
419 |               lhs <- vapps ctx vm [vl, vxs]
420 |               rhs <- vapps ctx vm [VSucc vl, VCons va vl vx vxs]
421 |               pure $ tarr lhs rhs
422 |     typeChk ctx mc mcTyp
423 |     vmc <- evalChk ctx mc
424 |     -- typecheck k
425 |     typeChk ctx k VNat
426 |     vk <- evalChk ctx k
427 |     -- typehcheck vs
428 |     typeChk ctx vs (VVec va vk)
429 |     vvs <- evalChk ctx vs
430 |     -- return type of VecElim
431 |     vapps ctx vm [vk, vvs]
432 | 
433 | 
434 | -- | A function type whose return type doesn't depend on the argument value
435 | tarr :: HasCallStack => Type -> Type -> Type
436 | tarr a b = VPi (bind (mkVPiBind "_" a) b)
437 | 
438 | -- | Check the type of a given type-checkable term
439 | typeChk :: HasCallStack => Context -> Chk -> Type -> TypecheckM ()
440 | typeChk ctx chk v = case chk of
441 |   Inf e -> do
442 |     v' <- typeSyn ctx e
443 |     -- If not alpha equivalent, fail
444 |     unless (aeq v v') $
445 |       throwErrorTypecheckM $ unlines
446 |         [ "type mismatch:"
447 |         , "  expected: "++ show v
448 |         , "  but got: " ++ show v'
449 |         ]
450 | 
451 |   Lam x_e -> case v of
452 |     VPi xt_t'-> do
453 |       (x, e) <- unbind x_e
454 |       ((_, Embed t), t') <- unbind xt_t'
455 |       let varInfo = VarInfo Nothing t
456 |       typeChk (insertVar x varInfo ctx) e t'
457 |     _ -> throwErrorTypecheckM $ unlines
458 |         [ "type mismatch lam: "
459 |         , "  expected VPi, but got: "++ show v
460 |         ]
461 | 
462 | ----------------------------------------
463 | -- Normalize
464 | ----------------------------------------
465 | 
466 | -- | Normalize a value constructed by a substitution
467 | --
468 | -- The need for this function stems from the evalution strategy
469 | -- implicitly chosen during this dependent type theory study: call by value.
470 | --
471 | -- Note:
472 | --   When function application is evaluated, or when typechecking the App
473 | --   expression, a variable substitution is performed to either compute the result
474 | --   of the function application, or compute the return type of a value. In both
475 | --   cases, a value is subsituted in place of a variable in the body of either a
476 | --   lambda or a pi term; The resulting body needs to be normalized, as a VApp
477 | --   value may contain a non-neutral term on the LHS that can be further
478 | --   normalized. Un-normalized terms cause the evalutor to choke and throw errors,
479 | --   as it always expects normalized terms. By calling 'normalize' on a resulting
480 | --   expression after a substitution is performed should prevent these errors;
481 | --   i.e. using `vapp` every time we wish to construct an application value.
482 | --
483 | -- TODO Decide how this interacts with 'evalSyn'... since we represent
484 | -- "unevaluated" terms as 'Syn' or 'Chk' expressions, but 'Value's can still be
485 | -- "unevaluated", we end up having to duplicate a lot of the evaluation logic
486 | -- for already-evaluated values (that may still contain redexes after
487 | -- substitution. *A potential solution* is to parameterize the 'Syn' and 'Chk'
488 | -- types with a type variable denoting if the expression could contain redexes
489 | -- or not (is it "evaluatable" or "fully evaluated"?); These types could imply
490 | -- when to recursively call 'eval', and prevent calling 'eval' on expressions
491 | -- that are fully evaluated (e.g. the 'App' expression can produce expressions
492 | -- that still need to be evaluated, preventing them from being prematurely
493 | -- returned from the 'eval' functions if we added such a type index).
494 | -- Furthermore, this would reduce the need for duplicating the AST between
495 | -- 'Syn', 'Chk', and 'Value'.
496 | --
497 | --   [digression: perhaps adding GADTs could even further constrain the AST
498 | --   preventing several invalid expression formations by types alone, but it may
499 | --   be too complex with such "eliminator" values and types/values with many
500 | --   term parameters ('VecElim', 'Cons', 'NatElim', etc.)]
501 | --
502 | normalize :: HasCallStack => Context -> Value -> TypecheckM Value
503 | normalize ctx v =
504 |   case v of
505 |     VVar x -> pure (VVar x)
506 |     VLam binder -> do
507 |       (x, body) <- unbind binder
508 |       pure . VLam . bind x =<< normalize ctx body
509 |     VStar -> pure VStar
510 |     VPi binder -> do
511 |       ((x, Embed t), t') <- unbind binder
512 |       nt <- normalize ctx t
513 |       let nxt = mkVPiBind (name2String x) nt
514 |       nt' <- normalize ctx t'
515 |       pure $ VPi (bind nxt nt')
516 |     VApp ve ve' -> do
517 |       nve <- normalize ctx ve
518 |       nve' <- normalize ctx ve'
519 |       vapp ctx nve nve'
520 |     VNat -> pure VNat
521 |     VZero -> pure VZero
522 |     VSucc v -> pure . VSucc =<< normalize ctx v
523 |     VNatElim m mz ms k -> do
524 |       nk <- normalize ctx k
525 |       case nk of
526 |         VZero -> normalize ctx mz
527 |         VSucc l -> do
528 |           nm <- normalize ctx m
529 |           nmz <- normalize ctx mz
530 |           nms <- normalize ctx ms
531 |           nl <- normalize ctx l
532 |           let rec = VNatElim nm nmz nms nl
533 |           nmsl <- vapp ctx nms l
534 |           vapp ctx nmsl rec
535 |         VVar x -> pure $ VNatElim m mz ms nk
536 |         _ -> throwErrorTypecheckM ("normalize: VNatElim: " ++ show nk)
537 |     VNil a -> pure . VNil =<< normalize ctx a
538 |     VCons a l x xs -> do
539 |       na <- normalize ctx a
540 |       nl <- normalize ctx l
541 |       nx <- normalize ctx x
542 |       nxs <- normalize ctx xs
543 |       pure $ VCons na nl nx nxs
544 |     -- TODO Cases for Vectors:
545 |     VVec a n -> do
546 |       na <- normalize ctx a
547 |       nn <- normalize ctx n
548 |       pure $ VVec na nn
549 |     VVecElim a m mn mc k xs -> do
550 |       -- here, we want to see if xs can be evaluated further:
551 |       vmn <- normalize ctx mn
552 |       vmc <- normalize ctx mc
553 |       vxs <- normalize ctx xs
554 |       case vxs of
555 |         VNil _ -> pure vmn
556 |         VCons _ vl' vx' vxs' -> do
557 |           va <- normalize ctx a
558 |           vm <- normalize ctx m
559 |           vk <- normalize ctx k
560 |           let rec = VVecElim va vm vmn vmc vl' vxs'
561 |           vapps ctx vmc [vl', vx', vxs', rec]
562 |         VVar x -> do
563 |           va <- normalize ctx a
564 |           vm <- normalize ctx m
565 |           vk <- normalize ctx k
566 |           pure (VVecElim va vm vmn vmc vk (VVar x))
567 |         _ -> throwErrorTypecheckM ("normalize: VecElim: " ++ show vxs)
568 | 
569 | ----------------------------------------
570 | -- DSL for term easier construction
571 | ----------------------------------------
572 | 
573 | chk = Inf
574 | svar = Var . s2n
575 | var = chk . svar
576 | vvar = VVar . s2n
577 | 
578 | lam x = Lam . bind (s2n x)
579 | vlam x = VLam . bind (s2n x)
580 | pi' x t t' = chk $ Pi (bind (mkPiBind x t) t')
581 | vpi x t t' = VPi (bind (mkVPiBind x t) t')
582 | 
583 | id' = lam "a" $ lam "x" (var "x")
584 | const' = lam "x" (lam "y" (var "x"))
585 | 
586 | annConst' = Ann
587 |   const'
588 |   (pi' "x"
589 |        (pi' "y" (var "b") (var "b"))
590 |        (pi' "z" (var "a") (pi' "w" (var "b") (var "b")))
591 |   )
592 | 
593 | -- | Apply an expression to one or more expressions
594 | apps :: Syn -> Chk -> [Chk] -> Syn
595 | apps f x xs = foldl (\g arg -> App g arg) f (x:xs)
596 | 
597 | -- | Annotate a "checkable" term
598 | ann :: Chk -> Chk -> Syn
599 | ann e t = Ann e t
600 | 
601 | (<|) :: Syn -> Chk -> Syn
602 | (<|) f x = App f x
603 | 
604 | zero, one, two :: Chk
605 | zero = Inf Zero
606 | one = Inf (succ' Zero)
607 | two = Inf (Succ one)
608 | 
609 | succ' :: Syn -> Syn
610 | succ' = Succ . Inf
611 | 
612 | natElim :: Value
613 | natElim =
614 |   vlam "x" $ vlam "y" $ vlam "z" $ vlam "a" $
615 |     VNatElim (vvar "x") (vvar "y") (vvar "z") (vvar "a")
616 | 
617 | -- | The type of natElim
618 | natElimTyp :: Type
619 | natElimTyp =
620 |   vpi "m" (varr VNat VStar) $
621 |     varr (VApp (vvar "m") (VZero)) $
622 |       varr (vpi "l" VNat (varr (VApp (vvar "m") (vvar "l")) (VApp (vvar "m") (VSucc (vvar "l"))))) $
623 |         vpi "k" VNat (VApp (vvar "m") (vvar "k"))
624 | 
625 | vecElim :: Value
626 | vecElim =
627 |   vlam "a" $ vlam "m" $ vlam "mNil" $ vlam "mCons" $ vlam "k" $ vlam "vs" $
628 |     VVecElim (vvar "a") (vvar "m") (vvar "mNil") (vvar "mCons") (vvar "k") (vvar "vs")
629 | 
630 | -- | The type of vecElim
631 | vecElimTyp :: Type
632 | vecElimTyp =
633 |   vpi "a" VStar $
634 |     vpi "m" (vpi "k" VNat (varr (VVec (vvar "a") (vvar "k")) VStar)) $
635 |       varr
636 |        (app2 (vvar "m") VZero (VNil (vvar "a")))
637 |        (varr
638 |          (vpi "l" VNat $
639 |            vpi "x" (vvar "a") $
640 |              vpi "xs" (VVec (vvar "a") (vvar "l")) $
641 |                varr
642 |                  (app2 (vvar "m") (vvar "l") (vvar "xs"))
643 |                  (app2 (vvar "m") (VSucc (vvar "l"))
644 |                    (VCons (vvar "a") (vvar "l") (vvar "x") (vvar "xs"))
645 |                  )
646 |          )
647 |          (vpi "k" VNat $
648 |            vpi "xs" (VVec (vvar "a") (vvar "k")) $
649 |              app2 (vvar "m") (vvar "k") (vvar "xs")
650 |          )
651 |        )
652 | 
653 | 
654 | app2 :: Type -> Type -> Type -> Type
655 | app2 a b c = VApp (VApp a b) c
656 | 
657 | arr = pi' "_"
658 | varr = vpi "_"
659 | 
660 | ----------------------------------------
661 | -- Example
662 | ----------------------------------------
663 | 
664 | stdlib :: Context
665 | stdlib = fromList
666 |   [ (s2n "natElim", VarInfo { varValue = Just natElim, varType = natElimTyp })
667 |   , (s2n "vecElim", VarInfo { varValue = Just vecElim, varType = vecElimTyp })
668 |   ]
669 | 
670 | stdlib_plus :: Syn
671 | stdlib_plus =
672 |   apps
673 |     (Var (s2n "natElim"))
674 |     (lam "_" $ arr (Inf Nat) (Inf Nat))
675 |     [ lam "n" (var "n")
676 |     , lam "k" $
677 |         lam "rec" $
678 |           lam "n" $
679 |             Inf (Succ (Inf (App (svar "rec") (var "n"))))
680 |     ]
681 | 
682 | stdlib_plus_typ :: Chk
683 | stdlib_plus_typ =
684 |   pi' "x" (chk Nat) .
685 |     pi' "y" (chk Nat) $
686 |       chk Nat
687 | 
688 | stdlib_append :: Syn
689 | stdlib_append = Ann stdlib_append' stdlib_append_typ
690 | 
691 | stdlib_append' :: Chk
692 | stdlib_append' =
693 |   lam "a" . chk $
694 |     apps
695 |       (svar "vecElim")
696 |       (var "a")
697 |       [ lam "m" $ lam "_" $
698 |           arr
699 |             (pi' "n" (Inf Nat) (Inf (Vec (var "a") (var "n"))))
700 |             (Inf (Vec (var "a") (chk $ apps stdlib_plus (var "m") [var "n"])))
701 |       , lam "_" $ lam "v" $ var "v"
702 |       , lam "m" $ lam "v" $ lam "vs" $ lam "rec" $ lam "n" $ lam "w" $
703 |           chk $ Cons
704 |             (var "a")
705 |             (chk $ apps stdlib_plus (var "m") [var "n"])
706 |             (var "v")
707 |             (chk $ apps (svar "rec") (var "n") [var "w"])
708 |       ]
709 | 
710 | stdlib_append_typ :: Chk
711 | stdlib_append_typ =
712 |   pi' "a" (chk Star) .
713 |     pi' "m" (chk Nat) .
714 |       pi' "v" (chk $ Vec (var "a") (var "m")) .
715 |         pi' "n" (chk Nat) .
716 |           pi' "w" (chk $ Vec (var "a") (var "n")) . chk $
717 |             Vec (var "a") (chk $ apps stdlib_plus (var "m") [var "n"])
718 | 
719 | ----------------------------------------
720 | -- Examples
721 | ----------------------------------------
722 | 
723 | -- | Evaluates 1 + 2
724 | --
725 | -- λ> plusExample
726 | -- Right (VSucc (VSucc (VSucc VZero)))
727 | --
728 | plusExample :: Result Value
729 | plusExample =
730 |     unsafeEval stdlib $
731 |       App (App stdlib_plus one) two
732 | 
733 | -- | Evaluates 'append [1] [0,1]'
734 | --
735 | -- λ> appendExample
736 | -- Right (VCons VNat (VSucc (VSucc (VSucc VZero))) VZero (VCons VNat (VSucc VZero) VZero (VCons VNat VZero (VSucc VZero) (VNil VNat))))
737 | --
738 | appendExample :: Result Value
739 | appendExample =
740 |     unsafeEval stdlib $
741 |       apps stdlib_append vecType [one, l, two, r]
742 |   where
743 |     vecType = Inf Nat
744 | 
745 |     -- Length-indexed vector with a single element: [1]
746 |     l =
747 |       Inf $
748 |         Cons vecType one zero $ Inf $
749 |             Nil vecType
750 | 
751 |     -- Length-indexed vector with two elements: [0,1]
752 |     r =
753 |       Inf $
754 |         Cons vecType one zero $ Inf $
755 |           Cons vecType zero one $ Inf $
756 |             Nil vecType
757 | 
758 | ----------------------------------------
759 | -- Pretty Printer
760 | ----------------------------------------
761 | 
762 | ppShow :: (Fresh m, Pretty a) => a -> m String
763 | ppShow = fmap render . ppr
764 | 
765 | class Pretty a where
766 |   ppr :: (Applicative m, Fresh m) => a -> m Doc
767 | 
768 | instance Pretty Syn where
769 |   ppr (Var x) = pure (pprNameLocal x)
770 |   ppr (App e e') = do
771 |     pe <- ppr e
772 |     pe' <- ppr e'
773 |     pure $ parens pe <+> parens pe'
774 |   ppr (Ann e t) = do
775 |     pe <- ppr e
776 |     pt <- ppr t
777 |     pure (parens pe <+> colon <+> pt)
778 |   ppr Star = pure (char '*')
779 |   ppr (Pi xt_t) = do
780 |     ((x, Embed t), e) <- unbind xt_t
781 |     pe <- ppr e
782 |     pt <- ppr t
783 |     let ppx = pprNameLocal x
784 |     if ppx == (text "_")
785 |       then pure $
786 |         pt <+> text "->" <+> pe
787 |       else pure $
788 |         char 'Π' <> parens (ppx <+> colon <+> pt) <> char '.' <> pe
789 | 
790 |   ppr Nat = pure $ text "Nat"
791 |   ppr Zero = pure $ char 'Z'
792 |   ppr (Succ k) = pure . (text "S" <>) . parens =<< ppr k
793 |   ppr (NatElim m mz ms k) = do
794 |     pm <- ppr m
795 |     pmz <- ppr mz
796 |     pms <- ppr ms
797 |     pk <- ppr k
798 |     pure $ text "NatElim" <+> pm <+> pmz <+> pms <+> pk
799 |   -- TODO
800 |   ppr _ = pure $ text "Not implemented yet"
801 | 
802 | instance Pretty Chk where
803 |   ppr (Inf s) = ppr s
804 |   ppr (Lam xe) = do
805 |     (x, e) <- unbind xe
806 |     pe <- ppr e
807 |     pure (char 'λ' <> pprNameLocal x <> (char '.' <+> pe))
808 | 
809 | instance Pretty Value where
810 |   ppr (VLam xv) = do
811 |     (x, v) <- unbind xv
812 |     pv <- ppr v
813 |     pure (char 'λ' <> pprNameLocal x <> char '.' <> pv)
814 |   ppr VStar = pure (char '*')
815 |   ppr (VPi xt_t)  = do
816 |     ((x, Embed t), e) <- unbind xt_t
817 |     pe <- ppr e
818 |     pt <- ppr t
819 |     let ppx = pprNameLocal x
820 |     if ppx == (text "_")
821 |       then pure $
822 |         pt <+> text "->" <+> pe
823 |       else pure $
824 |         char 'Π' <> parens (ppx <+> colon <+> pt) <> char '.' <> pe
825 |   ppr (VVar x) = pure (pprNameLocal x)
826 |   ppr (VApp f v) = do
827 |     pf <- ppr f
828 |     pv <- ppr v
829 |     pure $ parens pf <+> parens pv
830 | 
831 |   ppr VNat = pure (text "Nat")
832 |   ppr VZero = pure (char 'Z')
833 |   ppr (VSucc k) = pure . (text "S" <>) . parens =<< ppr k
834 |   ppr (VNatElim m mz ms k) = do
835 |     pm <- pprParens m
836 |     pmz <- pprParens mz
837 |     pms <- pprParens ms
838 |     pk <- pprParens k
839 |     pure $ text "NatElim" <+> pm <+> pmz <+> pms <+> pk
840 |   -- TODO
841 |   ppr _ = pure $ text "Not implemented yet"
842 | 
843 | instance Pretty (Name Value) where
844 |   ppr x = pure (pprNameLocal x)
845 | 
846 | pprParens :: (Applicative m, Fresh m, Pretty a) => a -> m Doc
847 | pprParens = fmap parens . ppr
848 | 
849 | pprNameLocal :: Name a -> Doc
850 | pprNameLocal = text . name2String
851 | 


--------------------------------------------------------------------------------
/paper/LambdaPi.hs:
--------------------------------------------------------------------------------
   1 | {-# LANGUAGE ScopedTypeVariables #-}
   2 | 
   3 | {-# LINE 149 "LP.lhs" #-}
   4 |   module LP where
   5 | {-# LINE 152 "LP.lhs" #-}
   6 | import           Prelude                                hiding (print, (<>))
   7 | {-# LINE 154 "LP.lhs" #-}
   8 | import           Control.Monad                          (foldM, unless, when)
   9 | import           Control.Exception                      (SomeException, catch)
  10 | import           Data.Char
  11 | import           Data.List
  12 | import           Debug.Trace                            (trace)
  13 | {-# LINE 159 "LP.lhs" #-}
  14 | import           Text.PrettyPrint.HughesPJ              hiding (parens)
  15 | import qualified Text.PrettyPrint.HughesPJ              as PP
  16 | {-# LINE 164 "LP.lhs" #-}
  17 | import           Text.ParserCombinators.Parsec          hiding (State, parse)
  18 | import qualified Text.ParserCombinators.Parsec          as P
  19 | import           Text.ParserCombinators.Parsec.Language
  20 | import           Text.ParserCombinators.Parsec.Token
  21 | {-# LINE 171 "LP.lhs" #-}
  22 | import           System.Console.Readline
  23 | import           System.IO                              hiding (print)
  24 | {-# LINE 176 "LP.lhs" #-}
  25 | putstrln x = putStrLn x
  26 | {-# LINE 5 "Parser.lhs" #-}
  27 | simplyTyped = makeTokenParser
  28 |   (haskellStyle { identStart    = letter <|> P.char '_'
  29 |                 , reservedNames = ["let", "assume", "putStrLn"]
  30 |                 }
  31 |   )
  32 | {-# LINE 9 "Parser.lhs" #-}
  33 | parseBindings
  34 |   :: CharParser () ([String], [Info])
  35 | parseBindings =
  36 |   (let rec :: [String] -> [Info] -> CharParser () ([String], [Info])
  37 |        rec e ts = do
  38 |          (x, t) <- parens
  39 |            lambdaPi
  40 |            (do
  41 |              x <- identifier simplyTyped
  42 |              reserved simplyTyped "::"
  43 |              t <- pInfo
  44 |              return (x, t)
  45 |            )
  46 |          (rec (x : e) (t : ts) <|> return (x : e, t : ts))
  47 |    in  rec [] []
  48 |     )
  49 |     <|> do
  50 |           x <- identifier simplyTyped
  51 |           reserved simplyTyped "::"
  52 |           t <- pInfo
  53 |           return ([x], [t])
  54 |  where
  55 |   pInfo = fmap HasType (parseType 0 [])
  56 |     <|> fmap (const (HasKind Star)) (reserved simplyTyped "*")
  57 | {-# LINE 30 "Parser.lhs" #-}
  58 | parseStmt
  59 |   :: [String] -> CharParser () (Stmt ITerm Info)
  60 | parseStmt e =
  61 |   do
  62 |       reserved simplyTyped "let"
  63 |       x <- identifier simplyTyped
  64 |       reserved simplyTyped "="
  65 |       t <- parseITerm 0 e
  66 |       return (Let x t)
  67 |     <|> do
  68 |           reserved simplyTyped "assume"
  69 |           (xs, ts) <- parseBindings
  70 |           return (Assume (reverse (zip xs ts)))
  71 |     <|> do
  72 |           reserved simplyTyped "putStrLn"
  73 |           x <- stringLiteral simplyTyped
  74 |           return (PutStrLn x)
  75 |     <|> do
  76 |           reserved lambdaPi "out"
  77 |           x <- option "" (stringLiteral simplyTyped)
  78 |           return (Out x)
  79 |     <|> fmap Eval (parseITerm 0 e)
  80 | {-# LINE 52 "Parser.lhs" #-}
  81 | parseType
  82 |   :: Int -> [String] -> CharParser () Type
  83 | parseType 0 e = try
  84 |   (do
  85 |     t <- parseType 1 e
  86 |     rest t <|> return t
  87 |   )
  88 |  where
  89 |   rest t = do
  90 |     reserved simplyTyped "->"
  91 |     t' <- parseType 0 e
  92 |     return (Fun t t')
  93 | parseType 1 e =
  94 |   do
  95 |       x <- identifier simplyTyped
  96 |       return (TFree (Global x))
  97 |     <|> parens simplyTyped (parseType 0 e)
  98 | {-# LINE 70 "Parser.lhs" #-}
  99 | parseITerm
 100 |   :: Int -> [String] -> CharParser () ITerm
 101 | parseITerm 0 e = try
 102 |   (do
 103 |     t <- parseITerm 1 e
 104 |     return t
 105 |   )
 106 | parseITerm 1 e =
 107 |   try
 108 |       (do
 109 |         t <- parseITerm 2 e
 110 |         rest (Inf t) <|> return t
 111 |       )
 112 |     <|> do
 113 |           t <- parens simplyTyped (parseLam e)
 114 |           rest t
 115 |  where
 116 |   rest t = do
 117 |     reserved simplyTyped "::"
 118 |     t' <- parseType 0 e
 119 |     return (Ann t t')
 120 | parseITerm 2 e = do
 121 |   t  <- parseITerm 3 e
 122 |   ts <- many (parseCTerm 3 e)
 123 |   return (foldl (:@:) t ts)
 124 | parseITerm 3 e =
 125 |   do
 126 |       x <- identifier simplyTyped
 127 |       case findIndex (== x) e of
 128 |         Just n  -> return (Bound n)
 129 |         Nothing -> return (Free (Global x))
 130 |     <|> parens simplyTyped (parseITerm 0 e)
 131 | 
 132 | parseCTerm :: Int -> [String] -> CharParser () CTerm
 133 | parseCTerm 0 e = parseLam e <|> fmap Inf (parseITerm 0 e)
 134 | parseCTerm p e =
 135 |   try (parens simplyTyped (parseLam e)) <|> fmap Inf (parseITerm p e)
 136 | 
 137 | parseLam :: [String] -> CharParser () CTerm
 138 | parseLam e = do
 139 |   reservedOp simplyTyped "\\"
 140 |   xs <- many1 (identifier simplyTyped)
 141 |   reservedOp simplyTyped "->"
 142 |   t <- parseCTerm 0 (reverse xs ++ e)
 143 |   --  reserved simplyTyped "."
 144 |   return (iterate Lam t !! length xs)
 145 | {-# LINE 122 "Parser.lhs" #-}
 146 | parseIO
 147 |   :: String -> CharParser () a -> String -> IO (Maybe a)
 148 | parseIO f p x =
 149 |   case P.parse (whiteSpace simplyTyped >> p >>= \x -> eof >> return x) f x of
 150 |     Left  e -> putStrLn (show e) >> return Nothing
 151 |     Right r -> return (Just r)
 152 | {-# LINE 5 "Printer.lhs" #-}
 153 | tPrint
 154 |   :: Int -> Type -> Doc
 155 | tPrint p (TFree (Global s)) = text s
 156 | tPrint p (Fun ty ty') =
 157 |   parensIf (p > 0) (sep [tPrint 0 ty <> text " ->", nest 2 (tPrint 0 ty')])
 158 | {-# LINE 10 "Printer.lhs" #-}
 159 | iPrint
 160 |   :: Int -> Int -> ITerm -> Doc
 161 | iPrint p ii (Ann c ty) =
 162 |   parensIf (p > 1) (cPrint 2 ii c <> text " :: " <> tPrint 0 ty)
 163 | iPrint p ii (Bound k         ) = text (vars !! (ii - k - 1))
 164 | iPrint p ii (Free  (Global s)) = text s
 165 | iPrint p ii (i :@: c) =
 166 |   parensIf (p > 2) (sep [iPrint 2 ii i, nest 2 (cPrint 3 ii c)])
 167 | iPrint p ii x = text ("[" ++ show x ++ "]")
 168 | {-# LINE 17 "Printer.lhs" #-}
 169 | cPrint
 170 |   :: Int -> Int -> CTerm -> Doc
 171 | cPrint p ii (Inf i) = iPrint p ii i
 172 | cPrint p ii (Lam c) = parensIf
 173 |   (p > 0)
 174 |   (text "\\ " <> text (vars !! ii) <> text " -> " <> cPrint 0 (ii + 1) c)
 175 | {-# LINE 21 "Printer.lhs" #-}
 176 | vars
 177 |   :: [String]
 178 | vars =
 179 |   [ c : n | n <- "" : map show [1 ..], c <- ['x', 'y', 'z'] ++ ['a' .. 'w'] ]
 180 | {-# LINE 24 "Printer.lhs" #-}
 181 | parensIf
 182 |   :: Bool -> Doc -> Doc
 183 | parensIf True  = PP.parens
 184 | parensIf False = id
 185 | {-# LINE 28 "Printer.lhs" #-}
 186 | print = render . cPrint 0 0
 187 | printType = render . tPrint 0
 188 | {-# LINE 5 "Parser-LP.lhs" #-}
 189 | lambdaPi = makeTokenParser
 190 |   (haskellStyle { identStart    = letter <|> P.char '_'
 191 |                 , reservedNames = ["forall", "let", "assume", "putStrLn", "out"]
 192 |                 }
 193 |   )
 194 | {-# LINE 9 "Parser-LP.lhs" #-}
 195 | parseStmt_
 196 |   :: [String] -> CharParser () (Stmt ITerm_ CTerm_)
 197 | parseStmt_ e =
 198 |   do
 199 |       reserved lambdaPi "let"
 200 |       x <- identifier lambdaPi
 201 |       reserved lambdaPi "="
 202 |       t <- parseITerm_ 0 e
 203 |       return (Let x t)
 204 |     <|> do
 205 |           reserved lambdaPi "assume"
 206 |           (xs, ts) <- parseBindings_ False []
 207 |           return (Assume (reverse (zip xs ts)))
 208 |     <|> do
 209 |           reserved lambdaPi "putStrLn"
 210 |           x <- stringLiteral lambdaPi
 211 |           return (PutStrLn x)
 212 |     <|> do
 213 |           reserved lambdaPi "out"
 214 |           x <- option "" (stringLiteral lambdaPi)
 215 |           return (Out x)
 216 |     <|> fmap Eval (parseITerm_ 0 e)
 217 | {-# LINE 31 "Parser-LP.lhs" #-}
 218 | parseBindings_
 219 |   :: Bool -> [String] -> CharParser () ([String], [CTerm_])
 220 | parseBindings_ b e =
 221 |   (let rec :: [String] -> [CTerm_] -> CharParser () ([String], [CTerm_])
 222 |        rec e ts = do
 223 |          (x, t) <- parens
 224 |            lambdaPi
 225 |            (do
 226 |              x <- identifier lambdaPi
 227 |              reserved lambdaPi "::"
 228 |              t <- parseCTerm_ 0 (if b then e else [])
 229 |              return (x, t)
 230 |            )
 231 |          (rec (x : e) (t : ts) <|> return (x : e, t : ts))
 232 |    in  rec e []
 233 |     )
 234 |     <|> do
 235 |           x <- identifier lambdaPi
 236 |           reserved lambdaPi "::"
 237 |           t <- parseCTerm_ 0 e
 238 |           return (x : e, [t])
 239 | {-# LINE 50 "Parser-LP.lhs" #-}
 240 | parseITerm_
 241 |   :: Int -> [String] -> CharParser () ITerm_
 242 | parseITerm_ 0 e =
 243 |   do
 244 |       -- Here, a list of variable names and their corresponding types (as
 245 |       -- CTerm_'s) (variable bindings) and the final lhs type is parsed.
 246 |       reserved lambdaPi "forall"
 247 |       (fe, t : ts) <- parseBindings_ True e
 248 |       reserved lambdaPi "."
 249 |       t' <- parseCTerm_ 0 fe
 250 |       return (foldl (\p t -> Pi_ t (Inf_ p)) (Pi_ t t') ts)
 251 |     <|> try
 252 |           (do
 253 |             t <- parseITerm_ 1 e
 254 |             rest (Inf_ t) <|> return t
 255 |           )
 256 |     <|> do
 257 |           t <- parens lambdaPi (parseLam_ e)
 258 |           rest t
 259 |  where
 260 |   rest t = do
 261 |     reserved lambdaPi "->"
 262 |     t' <- parseCTerm_ 0 ([] : e)
 263 |     return (Pi_ t t')
 264 | parseITerm_ 1 e =
 265 |   try
 266 |       (do
 267 |         t <- parseITerm_ 2 e
 268 |         rest (Inf_ t) <|> return t
 269 |       )
 270 |     <|> do
 271 |           t <- parens lambdaPi (parseLam_ e)
 272 |           rest t
 273 |  where
 274 |   rest t = do
 275 |     reserved lambdaPi "::"
 276 |     t' <- parseCTerm_ 0 e
 277 |     return (Ann_ t t')
 278 | parseITerm_ 2 e = do
 279 |   t  <- parseITerm_ 3 e
 280 |   ts <- many (parseCTerm_ 3 e)
 281 |   return (foldl (:$:) t ts)
 282 | parseITerm_ 3 e =
 283 |   do
 284 |       reserved lambdaPi "*"
 285 |       return Star_
 286 |     <|> do
 287 |           n <- natural lambdaPi
 288 |           return (toNat_ n)
 289 |     <|> do
 290 |           x <- identifier lambdaPi
 291 |           case findIndex (== x) e of
 292 |             Just n  -> return (Bound_ n)
 293 |             Nothing -> return (Free_ (Global x))
 294 |     <|> parens lambdaPi (parseITerm_ 0 e)
 295 | 
 296 | parseCTerm_ :: Int -> [String] -> CharParser () CTerm_
 297 | parseCTerm_ 0 e = parseLam_ e <|> fmap Inf_ (parseITerm_ 0 e)
 298 | parseCTerm_ p e =
 299 |   try (parens lambdaPi (parseLam_ e)) <|> fmap Inf_ (parseITerm_ p e)
 300 | 
 301 | parseLam_ :: [String] -> CharParser () CTerm_
 302 | parseLam_ e = do
 303 |   reservedOp lambdaPi "\\"
 304 |   xs <- many1 (identifier lambdaPi)
 305 |   reservedOp lambdaPi "->"
 306 |   t <- parseCTerm_ 0 (reverse xs ++ e)
 307 |   --  reserved lambdaPi "."
 308 |   return (iterate Lam_ t !! length xs)
 309 | {-# LINE 123 "Parser-LP.lhs" #-}
 310 | toNat_
 311 |   :: Integer -> ITerm_
 312 | toNat_ n = Ann_ (toNat_' n) (Inf_ Nat_)
 313 | {-# LINE 126 "Parser-LP.lhs" #-}
 314 | toNat_'
 315 |   :: Integer -> CTerm_
 316 | toNat_' 0 = Zero_
 317 | toNat_' n = Succ_ (toNat_' (n - 1))
 318 | {-# LINE 5 "Printer-LP.lhs" #-}
 319 | iPrint_
 320 |   :: Int -> Int -> ITerm_ -> Doc
 321 | iPrint_ p ii (Ann_ c ty) =
 322 |   parensIf (p > 1) (cPrint_ 2 ii c <> text " :: " <> cPrint_ 0 ii ty)
 323 | iPrint_ p ii Star_ = text "*"
 324 | iPrint_ p ii (Pi_ d (Inf_ (Pi_ d' r))) =
 325 |   parensIf (p > 0) (nestedForall_ (ii + 2) [(ii + 1, d'), (ii, d)] r)
 326 | iPrint_ p ii (Pi_ d r) = parensIf
 327 |   (p > 0)
 328 |   (sep
 329 |     [ text "forall "
 330 |     <> text (vars !! ii)
 331 |     <> text " :: "
 332 |     <> cPrint_ 0 ii d
 333 |     <> text " ."
 334 |     , cPrint_ 0 (ii + 1) r
 335 |     ]
 336 |   )
 337 | iPrint_ p ii (Bound_ k         ) = text (vars !! (ii - k - 1))
 338 | iPrint_ p ii (Free_  (Global s)) = text s
 339 | iPrint_ p ii (i :$: c) =
 340 |   parensIf (p > 2) (sep [iPrint_ 2 ii i, nest 2 (cPrint_ 3 ii c)])
 341 | iPrint_ p ii Nat_ = text "Nat"
 342 | iPrint_ p ii (NatElim_ m z s n) =
 343 |   iPrint_ p ii (Free_ (Global "natElim") :$: m :$: z :$: s :$: n)
 344 | iPrint_ p ii (Vec_ a n) = iPrint_ p ii (Free_ (Global "Vec") :$: a :$: n)
 345 | iPrint_ p ii (VecElim_ a m mn mc n xs) =
 346 |   iPrint_ p ii (Free_ (Global "vecElim") :$: a :$: m :$: mn :$: mc :$: n :$: xs)
 347 | iPrint_ p ii (Eq_ a x y) = iPrint_ p ii (Free_ (Global "Eq") :$: a :$: x :$: y)
 348 | iPrint_ p ii (EqElim_ a m mr x y eq) =
 349 |   iPrint_ p ii (Free_ (Global "eqElim") :$: a :$: m :$: mr :$: x :$: y :$: eq)
 350 | iPrint_ p ii (Fin_ n) = iPrint_ p ii (Free_ (Global "Fin") :$: n)
 351 | iPrint_ p ii (FinElim_ m mz ms n f) =
 352 |   iPrint_ p ii (Free_ (Global "finElim") :$: m :$: mz :$: ms :$: n :$: f)
 353 | iPrint_ p ii x = text ("[" ++ show x ++ "]")
 354 | {-# LINE 28 "Printer-LP.lhs" #-}
 355 | cPrint_
 356 |   :: Int -> Int -> CTerm_ -> Doc
 357 | cPrint_ p ii (Inf_ i) = iPrint_ p ii i
 358 | cPrint_ p ii (Lam_ c) = parensIf
 359 |   (p > 0)
 360 |   (text "\\ " <> text (vars !! ii) <> text " -> " <> cPrint_ 0 (ii + 1) c)
 361 | cPrint_ p ii Zero_     = fromNat_ 0 ii Zero_     --  text "Zero"
 362 | cPrint_ p ii (Succ_ n) = fromNat_ 0 ii (Succ_ n) --  iPrint_ p ii (Free_ (Global "Succ") :$: n)
 363 | cPrint_ p ii (Nil_  a) = iPrint_ p ii (Free_ (Global "Nil") :$: a)
 364 | cPrint_ p ii (Cons_ a n x xs) =
 365 |   iPrint_ p ii (Free_ (Global "Cons") :$: a :$: n :$: x :$: xs)
 366 | cPrint_ p ii (Refl_ a x ) = iPrint_ p ii (Free_ (Global "Refl") :$: a :$: x)
 367 | cPrint_ p ii (FZero_ n  ) = iPrint_ p ii (Free_ (Global "FZero") :$: n)
 368 | cPrint_ p ii (FSucc_ n f) = iPrint_ p ii (Free_ (Global "FSucc") :$: n :$: f)
 369 | {-# LINE 40 "Printer-LP.lhs" #-}
 370 | fromNat_
 371 |   :: Int -> Int -> CTerm_ -> Doc
 372 | fromNat_ n ii Zero_     = int n
 373 | fromNat_ n ii (Succ_ k) = fromNat_ (n + 1) ii k
 374 | fromNat_ n ii t         = parensIf True (int n <> text " + " <> cPrint_ 0 ii t)
 375 | {-# LINE 45 "Printer-LP.lhs" #-}
 376 | nestedForall_
 377 |   :: Int -> [(Int, CTerm_)] -> CTerm_ -> Doc
 378 | nestedForall_ ii ds (Inf_ (Pi_ d r)) = nestedForall_ (ii + 1) ((ii, d) : ds) r
 379 | nestedForall_ ii ds x                = sep
 380 |   [ text "forall "
 381 |   <> sep
 382 |        [ parensIf True (text (vars !! n) <> text " :: " <> cPrint_ 0 n d)
 383 |        | (n, d) <- reverse ds
 384 |        ]
 385 |   <> text " ."
 386 |   , cPrint_ 0 ii x
 387 |   ]
 388 | {-# LINE 5 "Interpreter.lhs" #-}
 389 | data Stmt i tinf = Let String i           --  let x = t
 390 |                  | Assume [(String,tinf)] --  assume x :: t, assume x :: *
 391 |                  | Eval i
 392 |                  | PutStrLn String        --  lhs2TeX hacking, allow to print "magic" string
 393 |                  | Out String             --  more lhs2TeX hacking, allow to print to files
 394 |   deriving (Show)
 395 | 
 396 | --  read-eval-print loop{-# LINE 13 "Interpreter.lhs" #-}
 397 | 
 398 | readevalprint
 399 |   :: Interpreter i c v t tinf inf -> State v inf -> IO ()
 400 | readevalprint int state@(inter, out, ve, te) =
 401 |   let rec int state = do
 402 |         x <- catch
 403 |           (if inter then readline (iprompt int) else fmap Just getLine)
 404 |           (\(_ :: SomeException) -> return Nothing)
 405 |         case x of
 406 |           Nothing -> return ()
 407 |           Just "" -> rec int state
 408 |           Just x  -> do
 409 |             when inter (addHistory x)
 410 |             c      <- interpretCommand x
 411 |             state' <- handleCommand int state c
 412 |             maybe (return ()) (rec int) state'
 413 |   in  do
 414 |           --  welcome
 415 |         when inter $ putStrLn
 416 |           ("Interpreter for " ++ iname int ++ ".\n" ++ "Type :? for help.")
 417 |         --  enter loop
 418 |         rec int state
 419 | {-# LINE 40 "Interpreter.lhs" #-}
 420 | data Command = TypeOf String
 421 |              | Compile CompileForm
 422 |              | Browse
 423 |              | Quit
 424 |              | Help
 425 |              | Noop
 426 | 
 427 | data CompileForm = CompileInteractive  String
 428 |                  | CompileFile         String
 429 | 
 430 | data InteractiveCommand = Cmd [String] String (String -> Command) String
 431 | 
 432 | type NameEnv v = [(Name, v)]
 433 | type Ctx inf = [(Name, inf)]
 434 | type State v inf = (Bool, String, NameEnv v, Ctx inf)
 435 | 
 436 | commands :: [InteractiveCommand]
 437 | commands =
 438 |   [ Cmd [":type"] "<expr>" TypeOf "print type of expression"
 439 |   , Cmd [":browse"] "" (const Browse) "browse names in scope"
 440 |   , Cmd [":load"] "<file>" (Compile . CompileFile) "load program from file"
 441 |   , Cmd [":quit"] "" (const Quit) "exit interpreter"
 442 |   , Cmd [":help", ":?"] "" (const Help) "display this list of commands"
 443 |   ]
 444 | 
 445 | helpTxt :: [InteractiveCommand] -> String
 446 | helpTxt cs =
 447 |   "List of commands:  Any command may be abbreviated to :c where\n"
 448 |     ++ "c is the first character in the full name.\n\n"
 449 |     ++ "<expr>                  evaluate expression\n"
 450 |     ++ "let <var> = <expr>      define variable\n"
 451 |     ++ "assume <var> :: <expr>  assume variable\n\n"
 452 |     ++ unlines
 453 |          (map
 454 |            (\(Cmd cs a _ d) ->
 455 |              let
 456 |                ct =
 457 |                  concat
 458 |                    (intersperse ", "
 459 |                                 (map (++ if null a then "" else " " ++ a) cs)
 460 |                    )
 461 |              in  ct ++ replicate ((24 - length ct) `max` 2) ' ' ++ d
 462 |            )
 463 |            cs
 464 |          )
 465 | 
 466 | 
 467 | interpretCommand :: String -> IO Command
 468 | interpretCommand x = if isPrefixOf ":" x
 469 |   then do
 470 |     let (cmd, t') = break isSpace x
 471 |         t         = dropWhile isSpace t'
 472 |     --  find matching commands
 473 |     let matching = filter (\(Cmd cs _ _ _) -> any (isPrefixOf cmd) cs) commands
 474 |     case matching of
 475 |       [] -> do
 476 |         putStrLn ("Unknown command `" ++ cmd ++ "'. Type :? for help.")
 477 |         return Noop
 478 |       [Cmd _ _ f _] -> do
 479 |         return (f t)
 480 |       x -> do
 481 |         putStrLn
 482 |           (  "Ambiguous command, could be "
 483 |           ++ concat (intersperse ", " [ head cs | Cmd cs _ _ _ <- matching ])
 484 |           ++ "."
 485 |           )
 486 |         return Noop
 487 |   else return (Compile (CompileInteractive x))
 488 | 
 489 | handleCommand
 490 |   :: Interpreter i c v t tinf inf
 491 |   -> State v inf
 492 |   -> Command
 493 |   -> IO (Maybe (State v inf))
 494 | handleCommand int state@(inter, out, ve, te) cmd = case cmd of
 495 |   Quit     -> when (not inter) (putStrLn "!@#$^&*") >> return Nothing
 496 |   Noop     -> return (Just state)
 497 |   Help     -> putStr (helpTxt commands) >> return (Just state)
 498 |   TypeOf x -> do
 499 |     x <- parseIO "<interactive>" (iiparse int) x
 500 |     t <- maybe (return Nothing) (iinfer int ve te) x
 501 |     maybe (return ()) (\u -> putStrLn (render (itprint int u))) t
 502 |     return (Just state)
 503 |   Browse -> do
 504 |     putStr (unlines [ s | Global s <- reverse (nub (map fst te)) ])
 505 |     return (Just state)
 506 |   Compile c -> do
 507 |     state <- case c of
 508 |       CompileInteractive s -> compilePhrase int state s
 509 |       CompileFile        f -> compileFile int state f
 510 |     return (Just state)
 511 | 
 512 | compileFile
 513 |   :: Interpreter i c v t tinf inf -> State v inf -> String -> IO (State v inf)
 514 | compileFile int state@(inter, out, ve, te) f = do
 515 |   x     <- readFile f
 516 |   stmts <- parseIO f (many (isparse int)) x
 517 |   maybe (return state) (foldM (handleStmt int) state) stmts
 518 | 
 519 | compilePhrase
 520 |   :: Interpreter i c v t tinf inf -> State v inf -> String -> IO (State v inf)
 521 | compilePhrase int state@(inter, out, ve, te) x = do
 522 |   x <- parseIO "<interactive>" (isparse int) x
 523 |   maybe (return state) (handleStmt int state) x
 524 | 
 525 | data Interpreter i c v t tinf inf =
 526 |   I { iname    :: String,
 527 |       iprompt  :: String,
 528 |       iitype   :: NameEnv v -> Ctx inf -> i -> Result t,
 529 |       iquote   :: v -> c,
 530 |       ieval    :: NameEnv v -> i -> v,
 531 |       ihastype :: t -> inf,
 532 |       icprint  :: c -> Doc,
 533 |       itprint  :: t -> Doc,
 534 |       iiparse  :: CharParser () i,
 535 |       isparse  :: CharParser () (Stmt i tinf),
 536 |       iassume  :: State v inf -> (String, tinf) -> IO (State v inf) }
 537 | 
 538 | st :: Interpreter ITerm CTerm Value Type Info Info
 539 | st = I
 540 |   { iname    = "the simply typed lambda calculus"
 541 |   , iprompt  = "ST> "
 542 |   , iitype   = \v c -> iType 0 c
 543 |   , iquote   = quote0
 544 |   , ieval    = \e x -> iEval x (e, [])
 545 |   , ihastype = HasType
 546 |   , icprint  = cPrint 0 0
 547 |   , itprint  = tPrint 0
 548 |   , iiparse  = parseITerm 0 []
 549 |   , isparse  = parseStmt []
 550 |   , iassume  = \s (x, t) -> stassume s x t
 551 |   }
 552 | 
 553 | lp :: Interpreter ITerm_ CTerm_ Value_ Value_ CTerm_ Value_
 554 | lp = I
 555 |   { iname    = "lambda-Pi"
 556 |   , iprompt  = "LP> "
 557 |   , iitype   = \v c -> iType_ 0 (v, c)
 558 |   , iquote   = \x -> trace (show (quote0_ x)) (quote0_ x)
 559 |   , ieval    = \e x -> iEval_ x (e, [])
 560 |   , ihastype = id
 561 |   , icprint  = cPrint_ 0 0
 562 |   , itprint  = cPrint_ 0 0 . quote0_
 563 |   , iiparse  = parseITerm_ 0 []
 564 |   , isparse  = parseStmt_ []
 565 |   , iassume  = \s (x, t) -> lpassume s x t
 566 |   }
 567 | 
 568 | lpte :: Ctx Value_
 569 | lpte =
 570 |   [ (Global "Zero", VNat_)
 571 |   , (Global "Succ", VPi_ VNat_ (\_ -> VNat_))
 572 |   , (Global "Nat" , VStar_)
 573 |   , ( Global "natElim"
 574 |     , VPi_
 575 |       (VPi_ VNat_ (\_ -> VStar_))
 576 |       (\m -> VPi_
 577 |         (m `vapp_` VZero_)
 578 |         (\_ -> VPi_
 579 |           (VPi_ VNat_ (\k -> VPi_ (m `vapp_` k) (\_ -> (m `vapp_` (VSucc_ k)))))
 580 |           (\_ -> VPi_ VNat_ (\n -> m `vapp_` n))
 581 |         )
 582 |       )
 583 |     )
 584 |   , (Global "Nil", VPi_ VStar_ (\a -> VVec_ a VZero_))
 585 |   , ( Global "Cons"
 586 |     , VPi_
 587 |       VStar_
 588 |       (\a -> VPi_
 589 |         VNat_
 590 |         (\n -> VPi_ a (\_ -> VPi_ (VVec_ a n) (\_ -> VVec_ a (VSucc_ n))))
 591 |       )
 592 |     )
 593 |   , (Global "Vec", VPi_ VStar_ (\_ -> VPi_ VNat_ (\_ -> VStar_)))
 594 |   , ( Global "vecElim"
 595 |     , VPi_
 596 |       VStar_
 597 |       (\a -> VPi_
 598 |         (VPi_ VNat_ (\n -> VPi_ (VVec_ a n) (\_ -> VStar_)))
 599 |         (\m -> VPi_
 600 |           (m `vapp_` VZero_ `vapp_` (VNil_ a))
 601 |           (\_ -> VPi_
 602 |             (VPi_
 603 |               VNat_
 604 |               (\n -> VPi_
 605 |                 a
 606 |                 (\x -> VPi_
 607 |                   (VVec_ a n)
 608 |                   (\xs -> VPi_
 609 |                     (m `vapp_` n `vapp_` xs)
 610 |                     (\_ -> m `vapp_` VSucc_ n `vapp_` VCons_ a n x xs)
 611 |                   )
 612 |                 )
 613 |               )
 614 |             )
 615 |             (\_ -> VPi_
 616 |               VNat_
 617 |               (\n -> VPi_ (VVec_ a n) (\xs -> m `vapp_` n `vapp_` xs))
 618 |             )
 619 |           )
 620 |         )
 621 |       )
 622 |     )
 623 |   , (Global "Refl", VPi_ VStar_ (\a -> VPi_ a (\x -> VEq_ a x x)))
 624 |   , (Global "Eq"  , VPi_ VStar_ (\a -> VPi_ a (\x -> VPi_ a (\y -> VStar_))))
 625 |   , ( Global "eqElim"
 626 |     , VPi_
 627 |       VStar_
 628 |       (\a -> VPi_
 629 |         (VPi_ a (\x -> VPi_ a (\y -> VPi_ (VEq_ a x y) (\_ -> VStar_))))
 630 |         (\m -> VPi_
 631 |           (VPi_ a (\x -> m `vapp_` x `vapp_` x `vapp_` VRefl_ a x))
 632 |           (\_ -> VPi_
 633 |             a
 634 |             (\x -> VPi_
 635 |               a
 636 |               (\y -> VPi_ (VEq_ a x y) (\eq -> m `vapp_` x `vapp_` y `vapp_` eq)
 637 |               )
 638 |             )
 639 |           )
 640 |         )
 641 |       )
 642 |     )
 643 |   , (Global "FZero", VPi_ VNat_ (\n -> VFin_ (VSucc_ n)))
 644 |   , (Global "FSucc", VPi_ VNat_ (\n -> VPi_ (VFin_ n) (\f -> VFin_ (VSucc_ n))))
 645 |   , (Global "Fin"  , VPi_ VNat_ (\n -> VStar_))
 646 |   , ( Global "finElim"
 647 |     , VPi_
 648 |       (VPi_ VNat_ (\n -> VPi_ (VFin_ n) (\_ -> VStar_)))
 649 |       (\m -> VPi_
 650 |         (VPi_ VNat_ (\n -> m `vapp_` (VSucc_ n) `vapp_` (VFZero_ n)))
 651 |         (\_ -> VPi_
 652 |           (VPi_
 653 |             VNat_
 654 |             (\n -> VPi_
 655 |               (VFin_ n)
 656 |               (\f -> VPi_ (m `vapp_` n `vapp_` f)
 657 |                           (\_ -> m `vapp_` (VSucc_ n) `vapp_` (VFSucc_ n f))
 658 |               )
 659 |             )
 660 |           )
 661 |           (\_ -> VPi_ VNat_ (\n -> VPi_ (VFin_ n) (\f -> m `vapp_` n `vapp_` f))
 662 |           )
 663 |         )
 664 |       )
 665 |     )
 666 |   ]
 667 | 
 668 | lpve :: Ctx Value_
 669 | lpve =
 670 |   [ (Global "Zero", VZero_)
 671 |   , (Global "Succ", VLam_ (\n -> VSucc_ n))
 672 |   , (Global "Nat" , VNat_)
 673 |   , ( Global "natElim"
 674 |     , cEval_
 675 |       (Lam_
 676 |         (Lam_
 677 |           (Lam_
 678 |             (Lam_
 679 |               (Inf_
 680 |                 (NatElim_ (Inf_ (Bound_ 3))
 681 |                           (Inf_ (Bound_ 2))
 682 |                           (Inf_ (Bound_ 1))
 683 |                           (Inf_ (Bound_ 0))
 684 |                 )
 685 |               )
 686 |             )
 687 |           )
 688 |         )
 689 |       )
 690 |       ([], [])
 691 |     )
 692 |   , (Global "Nil", VLam_ (\a -> VNil_ a))
 693 |   , ( Global "Cons"
 694 |     , VLam_ (\a -> VLam_ (\n -> VLam_ (\x -> VLam_ (\xs -> VCons_ a n x xs))))
 695 |     )
 696 |   , (Global "Vec", VLam_ (\a -> VLam_ (\n -> VVec_ a n)))
 697 |   , ( Global "vecElim"
 698 |     , cEval_
 699 |       (Lam_
 700 |         (Lam_
 701 |           (Lam_
 702 |             (Lam_
 703 |               (Lam_
 704 |                 (Lam_
 705 |                   (Inf_
 706 |                     (VecElim_ (Inf_ (Bound_ 5))
 707 |                               (Inf_ (Bound_ 4))
 708 |                               (Inf_ (Bound_ 3))
 709 |                               (Inf_ (Bound_ 2))
 710 |                               (Inf_ (Bound_ 1))
 711 |                               (Inf_ (Bound_ 0))
 712 |                     )
 713 |                   )
 714 |                 )
 715 |               )
 716 |             )
 717 |           )
 718 |         )
 719 |       )
 720 |       ([], [])
 721 |     )
 722 |   , (Global "Refl", VLam_ (\a -> VLam_ (\x -> VRefl_ a x)))
 723 |   , (Global "Eq"  , VLam_ (\a -> VLam_ (\x -> VLam_ (\y -> VEq_ a x y))))
 724 |   , ( Global "eqElim"
 725 |     , cEval_
 726 |       (Lam_
 727 |         (Lam_
 728 |           (Lam_
 729 |             (Lam_
 730 |               (Lam_
 731 |                 (Lam_
 732 |                   (Inf_
 733 |                     (EqElim_ (Inf_ (Bound_ 5))
 734 |                              (Inf_ (Bound_ 4))
 735 |                              (Inf_ (Bound_ 3))
 736 |                              (Inf_ (Bound_ 2))
 737 |                              (Inf_ (Bound_ 1))
 738 |                              (Inf_ (Bound_ 0))
 739 |                     )
 740 |                   )
 741 |                 )
 742 |               )
 743 |             )
 744 |           )
 745 |         )
 746 |       )
 747 |       ([], [])
 748 |     )
 749 |   , (Global "FZero", VLam_ (\n -> VFZero_ n))
 750 |   , (Global "FSucc", VLam_ (\n -> VLam_ (\f -> VFSucc_ n f)))
 751 |   , (Global "Fin"  , VLam_ (\n -> VFin_ n))
 752 |   , ( Global "finElim"
 753 |     , cEval_
 754 |       (Lam_
 755 |         (Lam_
 756 |           (Lam_
 757 |             (Lam_
 758 |               (Lam_
 759 |                 (Inf_
 760 |                   (FinElim_ (Inf_ (Bound_ 4))
 761 |                             (Inf_ (Bound_ 3))
 762 |                             (Inf_ (Bound_ 2))
 763 |                             (Inf_ (Bound_ 1))
 764 |                             (Inf_ (Bound_ 0))
 765 |                   )
 766 |                 )
 767 |               )
 768 |             )
 769 |           )
 770 |         )
 771 |       )
 772 |       ([], [])
 773 |     )
 774 |   ]
 775 | {-# LINE 225 "Interpreter.lhs" #-}
 776 | repLP
 777 |   :: Bool -> IO ()
 778 | repLP b = readevalprint lp (b, [], lpve, lpte)
 779 | 
 780 | repST :: Bool -> IO ()
 781 | repST b = readevalprint st (b, [], [], [])
 782 | 
 783 | iinfer int d g t = case iitype int d g t of
 784 |   Left  e -> putStrLn e >> return Nothing
 785 |   Right v -> return (Just v)
 786 | 
 787 | handleStmt
 788 |   :: Interpreter i c v t tinf inf
 789 |   -> State v inf
 790 |   -> Stmt i tinf
 791 |   -> IO (State v inf)
 792 | handleStmt int state@(inter, out, ve, te) stmt = do
 793 |   case stmt of
 794 |     Assume ass -> foldM (iassume int) state ass
 795 |     Let x e    -> checkEval x e
 796 |     Eval     e -> checkEval it e
 797 |     PutStrLn x -> putStrLn x >> return state
 798 |     Out      f -> return (inter, f, ve, te)
 799 |  where
 800 |   --  checkEval :: String -> i -> IO (State v inf)
 801 |   checkEval i t = check
 802 |     int
 803 |     state
 804 |     i
 805 |     t
 806 |     (\(y, v) -> do
 807 |       --  ugly, but we have limited space in the paper
 808 |       --  usually, you'd want to have the bound identifier *and*
 809 |       --  the result of evaluation
 810 |       let outtext = if i == it
 811 |             then render
 812 |               (icprint int (iquote int v) <> text " :: " <> itprint int y)
 813 |             else render (text i <> text " :: " <> itprint int y)
 814 |       putStrLn outtext
 815 |       unless (null out) (writeFile out (process outtext))
 816 |     )
 817 |     (\(y, v) -> (inter, "", (Global i, v) : ve, (Global i, ihastype int y) : te)
 818 |     )
 819 | 
 820 | check
 821 |   :: Interpreter i c v t tinf inf
 822 |   -> State v inf
 823 |   -> String
 824 |   -> i
 825 |   -> ((t, v) -> IO ())
 826 |   -> ((t, v) -> State v inf)
 827 |   -> IO (State v inf)
 828 | check int state@(inter, out, ve, te) i t kp k = do
 829 |   --  typecheck and evaluate
 830 |   x <- iinfer int ve te t
 831 |   case x of
 832 |     Nothing -> do
 833 |       --  putStrLn "type error"
 834 |       return state
 835 |     Just y -> do
 836 |       let v = ieval int ve t
 837 |       kp (y, v)
 838 |       return (k (y, v))
 839 | 
 840 | stassume state@(inter, out, ve, te) x t =
 841 |   return (inter, out, ve, (Global x, t) : te)
 842 | lpassume state@(inter, out, ve, te) x t = check
 843 |   lp
 844 |   state
 845 |   x
 846 |   (Ann_ t (Inf_ Star_))
 847 |   (\(y, v) -> return ()) --  putStrLn (render (text x <> text " :: " <> cPrint_ 0 0 (quote0_ v))))
 848 |   (\(y, v) -> (inter, out, ve, (Global x, v) : te))
 849 | 
 850 | 
 851 | it = "it"
 852 | {-# LINE 288 "Interpreter.lhs" #-}
 853 | process
 854 |   :: String -> String
 855 | process = unlines . map (\x -> "< " ++ x) . lines
 856 | {-# LINE 293 "Interpreter.lhs" #-}
 857 | main
 858 |   :: IO ()
 859 | main = repLP True
 860 | {-# LINE 670 "LP.lhs" #-}
 861 | data ITerm
 862 |    =  Ann    CTerm Type
 863 |    |  Bound  Int
 864 |    |  Free   Name
 865 |    |  ITerm :@: CTerm
 866 |   deriving (Show, Eq)
 867 | 
 868 | data CTerm
 869 |    =  Inf  ITerm
 870 |    |  Lam  CTerm
 871 |   deriving (Show, Eq)
 872 | 
 873 | data Name
 874 |    =  Global  String
 875 |    |  Local   Int
 876 |    |  Quote   Int
 877 |   deriving (Show, Eq)
 878 | {-# LINE 705 "LP.lhs" #-}
 879 | data Type
 880 |    =  TFree  Name
 881 |    |  Fun    Type Type
 882 |   deriving (Show, Eq)
 883 | {-# LINE 712 "LP.lhs" #-}
 884 | data Value
 885 |    =  VLam      (Value -> Value)
 886 |    |  VNeutral  Neutral
 887 | {-# LINE 725 "LP.lhs" #-}
 888 | data Neutral
 889 |    =  NFree  Name
 890 |    |  NApp   Neutral Value
 891 | {-# LINE 732 "LP.lhs" #-}
 892 | vfree
 893 |   :: Name -> Value
 894 | vfree n = VNeutral (NFree n)
 895 | {-# LINE 786 "LP.lhs" #-}
 896 | data Kind = Star
 897 |   deriving (Show)
 898 | 
 899 | data Info
 900 |    =  HasKind  Kind
 901 |    |  HasType  Type
 902 |   deriving (Show)
 903 | 
 904 | type Context = [(Name, Info)]
 905 | {-# LINE 801 "LP.lhs" #-}
 906 | type Env = [Value]
 907 | 
 908 | iEval :: ITerm -> (NameEnv Value, Env) -> Value
 909 | iEval (Ann e _) d = cEval e d
 910 | iEval (Free x ) d = case lookup x (fst d) of
 911 |   Nothing -> (vfree x)
 912 |   Just v  -> v
 913 | iEval (Bound ii ) d = (snd d) !! ii
 914 | iEval (e1 :@: e2) d = vapp (iEval e1 d) (cEval e2 d)
 915 | 
 916 | vapp :: Value -> Value -> Value
 917 | vapp (VLam     f) v = f v
 918 | vapp (VNeutral n) v = VNeutral (NApp n v)
 919 | 
 920 | cEval :: CTerm -> (NameEnv Value, Env) -> Value
 921 | cEval (Inf ii) d = iEval ii d
 922 | cEval (Lam e ) d = VLam (\x -> cEval e (((\(e, d) -> (e, (x : d))) d)))
 923 | {-# LINE 840 "LP.lhs" #-}
 924 | cKind
 925 |   :: Context -> Type -> Kind -> Result ()
 926 | cKind g (TFree x) Star = case lookup x g of
 927 |   Just (HasKind Star) -> return ()
 928 |   Nothing             -> throwError "unknown identifier"
 929 | cKind g (Fun kk kk') Star = do
 930 |   cKind g kk  Star
 931 |   cKind g kk' Star
 932 | 
 933 | iType0 :: Context -> ITerm -> Result Type
 934 | iType0 = iType 0
 935 | 
 936 | iType :: Int -> Context -> ITerm -> Result Type
 937 | iType ii g (Ann e ty) = do
 938 |   cKind g ty Star
 939 |   cType ii g e ty
 940 |   return ty
 941 | iType ii g (Free x) = case lookup x g of
 942 |   Just (HasType ty) -> return ty
 943 |   Nothing           -> throwError "unknown identifier"
 944 | iType ii g (e1 :@: e2) = do
 945 |   si <- iType ii g e1
 946 |   case si of
 947 |     Fun ty ty' -> do
 948 |       cType ii g e2 ty
 949 |       return ty'
 950 |     _ -> throwError "illegal application"
 951 | 
 952 | cType :: Int -> Context -> CTerm -> Type -> Result ()
 953 | cType ii g (Inf e) ty = do
 954 |   ty' <- iType ii g e
 955 |   unless (ty == ty') (throwError "type mismatch")
 956 | cType ii g (Lam e) (Fun ty ty') = cType (ii + 1)
 957 |                                         ((Local ii, HasType ty) : g)
 958 |                                         (cSubst 0 (Free (Local ii)) e)
 959 |                                         ty'
 960 | cType ii g _ _ = throwError "type mismatch"
 961 | {-# LINE 888 "LP.lhs" #-}
 962 | type Result a = Either String a
 963 | 
 964 | throwError :: String -> Result a
 965 | throwError = Left
 966 | {-# LINE 931 "LP.lhs" #-}
 967 | iSubst
 968 |   :: Int -> ITerm -> ITerm -> ITerm
 969 | iSubst ii r (Ann e ty ) = Ann (cSubst ii r e) ty
 970 | iSubst ii r (Bound j  ) = if ii == j then r else Bound j
 971 | iSubst ii r (Free  y  ) = Free y
 972 | iSubst ii r (e1 :@: e2) = iSubst ii r e1 :@: cSubst ii r e2
 973 | 
 974 | cSubst :: Int -> ITerm -> CTerm -> CTerm
 975 | cSubst ii r (Inf e) = Inf (iSubst ii r e)
 976 | cSubst ii r (Lam e) = Lam (cSubst (ii + 1) r e)
 977 | {-# LINE 964 "LP.lhs" #-}
 978 | quote0
 979 |   :: Value -> CTerm
 980 | quote0 = quote 0
 981 | 
 982 | quote :: Int -> Value -> CTerm
 983 | quote ii (VLam     f) = Lam (quote (ii + 1) (f (vfree (Quote ii))))
 984 | quote ii (VNeutral n) = Inf (neutralQuote ii n)
 985 | 
 986 | neutralQuote :: Int -> Neutral -> ITerm
 987 | neutralQuote ii (NFree x ) = boundfree ii x
 988 | neutralQuote ii (NApp n v) = neutralQuote ii n :@: quote ii v
 989 | {-# LINE 996 "LP.lhs" #-}
 990 | boundfree
 991 |   :: Int -> Name -> ITerm
 992 | boundfree ii (Quote k) = Bound (ii - k - 1)
 993 | boundfree ii x         = Free x
 994 | {-# LINE 1036 "LP.lhs" #-}
 995 | id' = Lam (Inf (Bound 0))
 996 | const' = Lam (Lam (Inf (Bound 1)))
 997 | 
 998 | tfree a = TFree (Global a)
 999 | free x = Inf (Free (Global x))
1000 | 
1001 | term1 = Ann id' (Fun (tfree "a") (tfree "a")) :@: free "y"
1002 | term2 =
1003 |   Ann
1004 |       const'
1005 |       (Fun (Fun (tfree "b") (tfree "b"))
1006 |            (Fun (tfree "a") (Fun (tfree "b") (tfree "b")))
1007 |       )
1008 |     :@: id'
1009 |     :@: free "y"
1010 | 
1011 | env1 = [(Global "y", HasType (tfree "a")), (Global "a", HasKind Star)]
1012 | env2 = [(Global "b", HasKind Star)] ++ env1
1013 | {-# LINE 1058 "LP.lhs" #-}
1014 | test_eval1 = quote0 (iEval term1 ([], []))
1015 |  {-  \eval{test_eval1}  -}
1016 | 
1017 | test_eval2 = quote0 (iEval term2 ([], []))
1018 |  {-  \eval{test_eval2}  -}
1019 | 
1020 | test_type1 = iType0 env1 term1
1021 |  {-  \eval{test_type1}  -}
1022 | 
1023 | test_type2 = iType0 env2 term2
1024 |  {-  \eval{test_type2}  -}
1025 | {-# LINE 1514 "LP.lhs" #-}
1026 | data CTerm_
1027 |    =  Inf_  ITerm_
1028 |    |  Lam_  CTerm_
1029 | {-# LINE 2 "CTerm_Nat.lhs" #-}
1030 |    |  Zero_
1031 |    |  Succ_ CTerm_
1032 | {-# LINE 2 "CTerm_Vec.lhs" #-}
1033 |   |  Nil_ CTerm_
1034 |   |  Cons_ CTerm_ CTerm_ CTerm_ CTerm_
1035 | {-# LINE 2 "CTerm_Eq.lhs" #-}
1036 |    |  Refl_ CTerm_ CTerm_
1037 | {-# LINE 2 "CTerm_Fin.lhs" #-}
1038 |   |  FZero_ CTerm_
1039 |   |  FSucc_ CTerm_ CTerm_
1040 | {-# LINE 1523 "LP.lhs" #-}
1041 |   deriving (Show, Eq)
1042 | {-# LINE 1548 "LP.lhs" #-}
1043 | data ITerm_
1044 |    =  Ann_ CTerm_ CTerm_
1045 |    |  Star_
1046 |    |  Pi_ CTerm_ CTerm_
1047 |    |  Bound_  Int
1048 |    |  Free_  Name
1049 |    |  ITerm_ :$: CTerm_
1050 | {-# LINE 2 "ITerm_Nat.lhs" #-}
1051 |    |  Nat_
1052 |    |  NatElim_ CTerm_ CTerm_ CTerm_ CTerm_
1053 | {-# LINE 2 "ITerm_Vec.lhs" #-}
1054 |   |  Vec_ CTerm_ CTerm_
1055 |   |  VecElim_ CTerm_ CTerm_ CTerm_ CTerm_ CTerm_ CTerm_
1056 | {-# LINE 2 "ITerm_Eq.lhs" #-}
1057 |    |  Eq_ CTerm_ CTerm_ CTerm_
1058 |    |  EqElim_ CTerm_ CTerm_ CTerm_ CTerm_ CTerm_ CTerm_
1059 | {-# LINE 2 "ITerm_Fin.lhs" #-}
1060 |    |  Fin_ CTerm_
1061 |    |  FinElim_ CTerm_ CTerm_ CTerm_ CTerm_ CTerm_
1062 | {-# LINE 1564 "LP.lhs" #-}
1063 |   deriving (Show, Eq)
1064 | {-# LINE 1569 "LP.lhs" #-}
1065 | data Value_
1066 |    =  VLam_  (Value_ -> Value_)
1067 |    |  VStar_
1068 |    |  VPi_ Value_ (Value_ -> Value_)
1069 |    |  VNeutral_ Neutral_
1070 | {-# LINE 2 "Value_Nat.lhs" #-}
1071 |   |  VNat_
1072 |   |  VZero_
1073 |   |  VSucc_ Value_
1074 | {-# LINE 2 "Value_Vec.lhs" #-}
1075 |   |  VNil_ Value_
1076 |   |  VCons_ Value_ Value_ Value_ Value_
1077 |   |  VVec_ Value_ Value_
1078 | {-# LINE 2 "Value_Eq.lhs" #-}
1079 |   |  VEq_ Value_ Value_ Value_
1080 |   |  VRefl_ Value_ Value_
1081 | {-# LINE 2 "Value_Fin.lhs" #-}
1082 |   |  VFZero_ Value_
1083 |   |  VFSucc_ Value_ Value_
1084 |   |  VFin_ Value_
1085 | {-# LINE 1582 "LP.lhs" #-}
1086 | data Neutral_
1087 |    =  NFree_  Name
1088 |    |  NApp_  Neutral_ Value_
1089 | {-# LINE 2 "Neutral_Nat.lhs" #-}
1090 |   |  NNatElim_ Value_ Value_ Value_ Neutral_
1091 | {-# LINE 2 "Neutral_Vec.lhs" #-}
1092 |   |  NVecElim_ Value_ Value_ Value_ Value_ Value_ Neutral_
1093 | {-# LINE 2 "Neutral_Eq.lhs" #-}
1094 |   |  NEqElim_ Value_ Value_ Value_ Value_ Value_ Neutral_
1095 | {-# LINE 2 "Neutral_Fin.lhs" #-}
1096 |   |  NFinElim_ Value_ Value_ Value_ Value_ Neutral_
1097 | {-# LINE 1620 "LP.lhs" #-}
1098 | type Env_ = [Value_]
1099 | 
1100 | vapp_ :: Value_ -> Value_ -> Value_
1101 | vapp_ (VLam_     f) v = f v
1102 | vapp_ (VNeutral_ n) v = VNeutral_ (NApp_ n v)
1103 | 
1104 | vfree_ :: Name -> Value_
1105 | vfree_ n = VNeutral_ (NFree_ n)
1106 | 
1107 | cEval_ :: CTerm_ -> (NameEnv Value_, Env_) -> Value_
1108 | cEval_ (Inf_ ii) d = iEval_ ii d
1109 | cEval_ (Lam_ c ) d = VLam_ (\x -> cEval_ c (((\(e, d) -> (e, (x : d))) d)))
1110 | {-# LINE 2 "cEval_Nat.lhs" #-}
1111 | cEval_ Zero_ d =
1112 |   VZero_
1113 | cEval_ (Succ_ k) d = VSucc_ (cEval_ k d)
1114 | {-# LINE 2 "cEval_Vec.lhs" #-}
1115 | cEval_ (Nil_ a) d =
1116 |   VNil_ (cEval_ a d)
1117 | cEval_ (Cons_ a n x xs) d =
1118 |   VCons_ (cEval_ a d) (cEval_ n d) (cEval_ x d) (cEval_ xs d)
1119 | {-# LINE 2 "cEval_Eq.lhs" #-}
1120 | cEval_ (Refl_ a x) d =
1121 |   VRefl_ (cEval_ a d) (cEval_ x d)
1122 | {-# LINE 2 "cEval_Fin.lhs" #-}
1123 | cEval_ (FZero_ n) d =
1124 |   VFZero_ (cEval_ n d)
1125 | cEval_ (FSucc_ n f) d = VFSucc_ (cEval_ n d) (cEval_ f d)
1126 | {-# LINE 1654 "LP.lhs" #-}
1127 | iEval_
1128 |   :: ITerm_ -> (NameEnv Value_, Env_) -> Value_
1129 | iEval_ (Ann_ c _) d = cEval_ c d
1130 | {-# LINE 1659 "LP.lhs" #-}
1131 | iEval_ Star_ d =
1132 |   VStar_
1133 | iEval_ (Pi_ ty ty') d =
1134 |   VPi_ (cEval_ ty d) (\x -> cEval_ ty' (((\(e, d) -> (e, (x : d))) d)))
1135 | {-# LINE 1664 "LP.lhs" #-}
1136 | iEval_ (Free_ x) d = case lookup x (fst d) of
1137 |   Nothing -> (vfree_ x)
1138 |   Just v  -> v
1139 | iEval_ (Bound_ ii) d = (snd d) !! ii
1140 | iEval_ (i :$: c  ) d = vapp_ (iEval_ i d) (cEval_ c d)
1141 | {-# LINE 2 "iEval_Nat.lhs" #-}
1142 | iEval_ Nat_ d =
1143 |   VNat_
1144 | iEval_ (NatElim_ m mz ms n) d =
1145 |   let mzVal = cEval_ mz d
1146 |       msVal = cEval_ ms d
1147 |       rec nVal = case nVal of
1148 |         VZero_      -> mzVal
1149 |         VSucc_    k -> msVal `vapp_` k `vapp_` rec k
1150 |         VNeutral_ n -> VNeutral_ (NNatElim_ (cEval_ m d) mzVal msVal n)
1151 |         _           -> error "internal: eval natElim"
1152 |   in  rec (cEval_ n d)
1153 | {-# LINE 3 "iEval_Vec.lhs" #-}
1154 | iEval_ (Vec_ a n) d =
1155 |   VVec_ (cEval_ a d) (cEval_ n d)
1156 | {-# LINE 7 "iEval_Vec.lhs" #-}
1157 | iEval_ (VecElim_ a m mn mc n xs) d =
1158 |   let mnVal = cEval_ mn d
1159 |       mcVal = cEval_ mc d
1160 |       rec nVal xsVal = case xsVal of
1161 |         VNil_ _         -> mnVal
1162 |         VCons_ _ k x xs -> foldl vapp_ mcVal [k, x, xs, rec k xs]
1163 |         VNeutral_ n ->
1164 |           VNeutral_ (NVecElim_ (cEval_ a d) (cEval_ m d) mnVal mcVal nVal n)
1165 |         _ -> error "internal: eval vecElim"
1166 |   in  rec (cEval_ n d) (cEval_ xs d)
1167 | {-# LINE 2 "iEval_Eq.lhs" #-}
1168 | iEval_ (Eq_ a x y) d =
1169 |   VEq_ (cEval_ a d) (cEval_ x d) (cEval_ y d)
1170 | iEval_ (EqElim_ a m mr x y eq) d
1171 |   = let
1172 |       mrVal = cEval_ mr d
1173 |       rec eqVal = case eqVal of
1174 |         VRefl_ _ z -> mrVal `vapp_` z
1175 |         VNeutral_ n ->
1176 |           VNeutral_
1177 |             (NEqElim_ (cEval_ a d)
1178 |                       (cEval_ m d)
1179 |                       mrVal
1180 |                       (cEval_ x d)
1181 |                       (cEval_ y d)
1182 |                       n
1183 |             )
1184 |         _ -> error "internal: eval eqElim"
1185 |     in
1186 |       rec (cEval_ eq d)
1187 | {-# LINE 2 "iEval_Fin.lhs" #-}
1188 | iEval_ (Fin_ n) d =
1189 |   VFin_ (cEval_ n d)
1190 | iEval_ (FinElim_ m mz ms n f) d
1191 |   = let
1192 |       mzVal = cEval_ mz d
1193 |       msVal = cEval_ ms d
1194 |       rec fVal = case fVal of
1195 |         VFZero_ k    -> mzVal `vapp_` k
1196 |         VFSucc_ k g  -> foldl vapp_ msVal [k, g, rec g]
1197 |         VNeutral_ n' -> VNeutral_
1198 |           (NFinElim_ (cEval_ m d) (cEval_ mz d) (cEval_ ms d) (cEval_ n d) n')
1199 |         _ -> error "internal: eval finElim"
1200 |     in
1201 |       rec (cEval_ f d)
1202 | {-# LINE 1679 "LP.lhs" #-}
1203 | iSubst_
1204 |   :: Int -> ITerm_ -> ITerm_ -> ITerm_
1205 | iSubst_ ii i' (Ann_ c c') = Ann_ (cSubst_ ii i' c) (cSubst_ ii i' c')
1206 | {-# LINE 1684 "LP.lhs" #-}
1207 | 
1208 | iSubst_ ii r Star_ =
1209 |   Star_
1210 | iSubst_ ii r (Pi_ ty ty') = Pi_ (cSubst_ ii r ty) (cSubst_ (ii + 1) r ty')
1211 | {-# LINE 1690 "LP.lhs" #-}
1212 | iSubst_ ii i' (Bound_ j) =
1213 |   if ii == j then i' else Bound_ j
1214 | iSubst_ ii i' (Free_ y) = Free_ y
1215 | iSubst_ ii i' (i :$: c) = iSubst_ ii i' i :$: cSubst_ ii i' c
1216 | {-# LINE 2 "iSubst_Nat.lhs" #-}
1217 | iSubst_ ii r Nat_ =
1218 |   Nat_
1219 | iSubst_ ii r (NatElim_ m mz ms n) = NatElim_ (cSubst_ ii r m)
1220 |                                              (cSubst_ ii r mz)
1221 |                                              (cSubst_ ii r ms)
1222 |                                              (cSubst_ ii r ms)
1223 | {-# LINE 2 "iSubst_Vec.lhs" #-}
1224 | iSubst_ ii r (Vec_ a n) =
1225 |   Vec_ (cSubst_ ii r a) (cSubst_ ii r n)
1226 | iSubst_ ii r (VecElim_ a m mn mc n xs) = VecElim_ (cSubst_ ii r a)
1227 |                                                   (cSubst_ ii r m)
1228 |                                                   (cSubst_ ii r mn)
1229 |                                                   (cSubst_ ii r mc)
1230 |                                                   (cSubst_ ii r n)
1231 |                                                   (cSubst_ ii r xs)
1232 | {-# LINE 2 "iSubst_Eq.lhs" #-}
1233 | iSubst_ ii r (Eq_ a x y) =
1234 |   Eq_ (cSubst_ ii r a) (cSubst_ ii r x) (cSubst_ ii r y)
1235 | iSubst_ ii r (EqElim_ a m mr x y eq) = VecElim_ (cSubst_ ii r a)
1236 |                                                 (cSubst_ ii r m)
1237 |                                                 (cSubst_ ii r mr)
1238 |                                                 (cSubst_ ii r x)
1239 |                                                 (cSubst_ ii r y)
1240 |                                                 (cSubst_ ii r eq)
1241 | {-# LINE 2 "iSubst_Fin.lhs" #-}
1242 | iSubst_ ii r (Fin_ n) =
1243 |   Fin_ (cSubst_ ii r n)
1244 | iSubst_ ii r (FinElim_ m mz ms n f) = FinElim_ (cSubst_ ii r m)
1245 |                                                (cSubst_ ii r mz)
1246 |                                                (cSubst_ ii r ms)
1247 |                                                (cSubst_ ii r n)
1248 |                                                (cSubst_ ii r f)
1249 | {-# LINE 1701 "LP.lhs" #-}
1250 | cSubst_
1251 |   :: Int -> ITerm_ -> CTerm_ -> CTerm_
1252 | cSubst_ ii i' (Inf_ i) = Inf_ (iSubst_ ii i' i)
1253 | cSubst_ ii i' (Lam_ c) = Lam_ (cSubst_ (ii + 1) i' c)
1254 | {-# LINE 2 "cSubst_Nat.lhs" #-}
1255 | cSubst_ ii r Zero_ =
1256 |   Zero_
1257 | cSubst_ ii r (Succ_ n) = Succ_ (cSubst_ ii r n)
1258 | {-# LINE 2 "cSubst_Vec.lhs" #-}
1259 | cSubst_ ii r (Nil_ a) =
1260 |   Nil_ (cSubst_ ii r a)
1261 | cSubst_ ii r (Cons_ a n x xs) =
1262 |   Cons_ (cSubst_ ii r a) (cSubst_ ii r x) (cSubst_ ii r x) (cSubst_ ii r xs)
1263 | {-# LINE 2 "cSubst_Eq.lhs" #-}
1264 | cSubst_ ii r (Refl_ a x) =
1265 |   Refl_ (cSubst_ ii r a) (cSubst_ ii r x)
1266 | {-# LINE 2 "cSubst_Fin.lhs" #-}
1267 | cSubst_ ii r (FZero_ n) =
1268 |   FZero_ (cSubst_ ii r n)
1269 | cSubst_ ii r (FSucc_ n k) = FSucc_ (cSubst_ ii r n) (cSubst_ ii r k)
1270 | {-# LINE 1712 "LP.lhs" #-}
1271 | quote_
1272 |   :: Int -> Value_ -> CTerm_
1273 | quote_ ii (VLam_ t) = Lam_ (quote_ (ii + 1) (t (vfree_ (Quote ii))))
1274 | {-# LINE 1718 "LP.lhs" #-}
1275 | 
1276 | quote_ ii VStar_ =
1277 |   Inf_ Star_
1278 | quote_ ii (VPi_ v f) =
1279 |   Inf_ (Pi_ (quote_ ii v) (quote_ (ii + 1) (f (vfree_ (Quote ii)))))
1280 | {-# LINE 1725 "LP.lhs" #-}
1281 | quote_ ii (VNeutral_ n) =
1282 |   Inf_ (neutralQuote_ ii n)
1283 | {-# LINE 2 "quote_Nat.lhs" #-}
1284 | quote_ ii VNat_ =
1285 |   Inf_ Nat_
1286 | quote_ ii VZero_     = Zero_
1287 | quote_ ii (VSucc_ n) = Succ_ (quote_ ii n)
1288 | {-# LINE 2 "quote_Vec.lhs" #-}
1289 | quote_ ii (VVec_ a n) =
1290 |   Inf_ (Vec_ (quote_ ii a) (quote_ ii n))
1291 | quote_ ii (VNil_ a) = Nil_ (quote_ ii a)
1292 | quote_ ii (VCons_ a n x xs) =
1293 |   Cons_ (quote_ ii a) (quote_ ii n) (quote_ ii x) (quote_ ii xs)
1294 | {-# LINE 2 "quote_Eq.lhs" #-}
1295 | quote_ ii (VEq_ a x y) =
1296 |   Inf_ (Eq_ (quote_ ii a) (quote_ ii x) (quote_ ii y))
1297 | quote_ ii (VRefl_ a x) = Refl_ (quote_ ii a) (quote_ ii x)
1298 | {-# LINE 2 "quote_Fin.lhs" #-}
1299 | quote_ ii (VFin_ n) =
1300 |   Inf_ (Fin_ (quote_ ii n))
1301 | quote_ ii (VFZero_ n  ) = FZero_ (quote_ ii n)
1302 | quote_ ii (VFSucc_ n f) = FSucc_ (quote_ ii n) (quote_ ii f)
1303 | {-# LINE 1735 "LP.lhs" #-}
1304 | neutralQuote_
1305 |   :: Int -> Neutral_ -> ITerm_
1306 | neutralQuote_ ii (NFree_ v ) = boundfree_ ii v
1307 | neutralQuote_ ii (NApp_ n v) = neutralQuote_ ii n :$: quote_ ii v
1308 | {-# LINE 2 "neutralQuote_Nat.lhs" #-}
1309 | neutralQuote_ ii (NNatElim_ m z s n) =
1310 |   NatElim_ (quote_ ii m) (quote_ ii z) (quote_ ii s) (Inf_ (neutralQuote_ ii n))
1311 | {-# LINE 2 "neutralQuote_Vec.lhs" #-}
1312 | neutralQuote_ ii (NVecElim_ a m mn mc n xs) = VecElim_
1313 |   (quote_ ii a)
1314 |   (quote_ ii m)
1315 |   (quote_ ii mn)
1316 |   (quote_ ii mc)
1317 |   (quote_ ii n)
1318 |   (Inf_ (neutralQuote_ ii xs))
1319 | {-# LINE 2 "neutralQuote_Eq.lhs" #-}
1320 | neutralQuote_ ii (NEqElim_ a m mr x y eq) = EqElim_
1321 |   (quote_ ii a)
1322 |   (quote_ ii m)
1323 |   (quote_ ii mr)
1324 |   (quote_ ii x)
1325 |   (quote_ ii y)
1326 |   (Inf_ (neutralQuote_ ii eq))
1327 | {-# LINE 2 "neutralQuote_Fin.lhs" #-}
1328 | neutralQuote_ ii (NFinElim_ m mz ms n f) = FinElim_
1329 |   (quote_ ii m)
1330 |   (quote_ ii mz)
1331 |   (quote_ ii ms)
1332 |   (quote_ ii n)
1333 |   (Inf_ (neutralQuote_ ii f))
1334 | {-# LINE 1746 "LP.lhs" #-}
1335 | boundfree_
1336 |   :: Int -> Name -> ITerm_
1337 | boundfree_ ii (Quote k) = Bound_ ((ii - k - 1) `max` 0)
1338 | boundfree_ ii x         = Free_ x
1339 | {-# LINE 1751 "LP.lhs" #-}
1340 | instance Show Value_ where
1341 |   show = show . quote0_
1342 | {-# LINE 1775 "LP.lhs" #-}
1343 | type Type_     =  Value_
1344 | type Context_    =  [(Name, Type_)]
1345 | {-# LINE 1818 "LP.lhs" #-}
1346 | quote0_
1347 |   :: Value_ -> CTerm_
1348 | quote0_ = quote_ 0
1349 | 
1350 | iType0_ :: (NameEnv Value_, Context_) -> ITerm_ -> Result Type_
1351 | iType0_ = iType_ 0
1352 | {-# LINE 1826 "LP.lhs" #-}
1353 | iType_
1354 |   :: Int -> (NameEnv Value_, Context_) -> ITerm_ -> Result Type_
1355 | iType_ ii g (Ann_ e tyt) = do
1356 |   cType_ ii g tyt VStar_
1357 |   let ty = cEval_ tyt (fst g, [])
1358 |   cType_ ii g e ty
1359 |   return ty
1360 | iType_ ii g Star_          = return VStar_
1361 | iType_ ii g (Pi_ tyt tyt') = do
1362 |   cType_ ii g tyt VStar_
1363 |   let ty = cEval_ tyt (fst g, [])
1364 |   cType_ (ii + 1)
1365 |          ((\(d, g) -> (d, ((Local ii, ty) : g))) g)
1366 |          (cSubst_ 0 (Free_ (Local ii)) tyt')
1367 |          VStar_
1368 |   return VStar_
1369 | iType_ ii g (Free_ x) = case lookup x (snd g) of
1370 |   Just ty -> return ty
1371 |   Nothing ->
1372 |     throwError ("unknown identifier: " ++ render (iPrint_ 0 0 (Free_ x)))
1373 | iType_ ii g (e1 :$: e2) = do
1374 |   si <- iType_ ii g e1
1375 |   case si of
1376 |     VPi_ ty ty' -> do
1377 |       cType_ ii g e2 ty
1378 |       return (ty' (cEval_ e2 (fst g, [])))
1379 |     _ -> throwError "illegal application"
1380 | {-# LINE 2 "iType_Nat.lhs" #-}
1381 | iType_ ii g Nat_ =
1382 |   return VStar_
1383 | iType_ ii g (NatElim_ m mz ms n) = do
1384 |   cType_ ii g m (VPi_ VNat_ (const VStar_))
1385 |   let mVal = cEval_ m (fst g, [])
1386 |   cType_ ii g mz (mVal `vapp_` VZero_)
1387 |   cType_
1388 |     ii
1389 |     g
1390 |     ms
1391 |     (VPi_ VNat_ (\k -> VPi_ (mVal `vapp_` k) (\_ -> mVal `vapp_` VSucc_ k)))
1392 |   cType_ ii g n VNat_
1393 |   let nVal = cEval_ n (fst g, [])
1394 |   return (mVal `vapp_` nVal)
1395 | {-# LINE 2 "iType_Vec.lhs" #-}
1396 | iType_ ii g (Vec_ a n) = do
1397 |   cType_ ii g a VStar_
1398 |   cType_ ii g n VNat_
1399 |   return VStar_
1400 | iType_ ii g (VecElim_ a m mn mc n vs) = do
1401 |   cType_ ii g a VStar_
1402 |   let aVal = cEval_ a (fst g, [])
1403 |   cType_ ii g m (VPi_ VNat_ (\n -> VPi_ (VVec_ aVal n) (\_ -> VStar_)))
1404 |   let mVal = cEval_ m (fst g, [])
1405 |   cType_ ii g mn (foldl vapp_ mVal [VZero_, VNil_ aVal])
1406 |   cType_
1407 |     ii
1408 |     g
1409 |     mc
1410 |     (VPi_
1411 |       VNat_
1412 |       (\n -> VPi_
1413 |         aVal
1414 |         (\y -> VPi_
1415 |           (VVec_ aVal n)
1416 |           (\ys -> VPi_
1417 |             (foldl vapp_ mVal [n, ys])
1418 |             (\_ -> (foldl vapp_ mVal [VSucc_ n, VCons_ aVal n y ys]))
1419 |           )
1420 |         )
1421 |       )
1422 |     )
1423 |   cType_ ii g n VNat_
1424 |   let nVal = cEval_ n (fst g, [])
1425 |   cType_ ii g vs (VVec_ aVal nVal)
1426 |   let vsVal = cEval_ vs (fst g, [])
1427 |   return (foldl vapp_ mVal [nVal, vsVal])
1428 | {-# LINE 2 "iType_Eq.lhs" #-}
1429 | iType_ i g (Eq_ a x y) = do
1430 |   cType_ i g a VStar_
1431 |   let aVal = cEval_ a (fst g, [])
1432 |   cType_ i g x aVal
1433 |   cType_ i g y aVal
1434 |   return VStar_
1435 | iType_ i g (EqElim_ a m mr x y eq) = do
1436 |   cType_ i g a VStar_
1437 |   let aVal = cEval_ a (fst g, [])
1438 |   cType_
1439 |     i
1440 |     g
1441 |     m
1442 |     (VPi_ aVal (\x -> VPi_ aVal (\y -> VPi_ (VEq_ aVal x y) (\_ -> VStar_))))
1443 |   let mVal = cEval_ m (fst g, [])
1444 |   cType_ i g mr (VPi_ aVal (\x -> foldl vapp_ mVal [x, x]))
1445 |   cType_ i g x  aVal
1446 |   let xVal = cEval_ x (fst g, [])
1447 |   cType_ i g y aVal
1448 |   let yVal = cEval_ y (fst g, [])
1449 |   cType_ i g eq (VEq_ aVal xVal yVal)
1450 |   let eqVal = cEval_ eq (fst g, [])
1451 |   return (foldl vapp_ mVal [xVal, yVal])
1452 | {-# LINE 1857 "LP.lhs" #-}
1453 | 
1454 | {-# LINE 1860 "LP.lhs" #-}
1455 | cType_
1456 |   :: Int -> (NameEnv Value_, Context_) -> CTerm_ -> Type_ -> Result ()
1457 | cType_ ii g (Inf_ e) v = do
1458 |   v' <- iType_ ii g e
1459 |   unless
1460 |     (quote0_ v == quote0_ v')
1461 |     (throwError
1462 |       (  "type mismatch:\n"
1463 |       ++ "type inferred:  "
1464 |       ++ render (cPrint_ 0 0 (quote0_ v'))
1465 |       ++ "\n"
1466 |       ++ "type expected:  "
1467 |       ++ render (cPrint_ 0 0 (quote0_ v))
1468 |       ++ "\n"
1469 |       ++ "for expression: "
1470 |       ++ render (iPrint_ 0 0 e)
1471 |       )
1472 |     )
1473 | cType_ ii g (Lam_ e) (VPi_ ty ty') = cType_
1474 |   (ii + 1)
1475 |   ((\(d, g) -> (d, ((Local ii, ty) : g))) g)
1476 |   (cSubst_ 0 (Free_ (Local ii)) e)
1477 |   (ty' (vfree_ (Local ii)))
1478 | {-# LINE 2 "cType_Nat.lhs" #-}
1479 | cType_ ii g Zero_ VNat_ =
1480 |   return ()
1481 | cType_ ii g (Succ_ k) VNat_               = cType_ ii g k VNat_
1482 | {-# LINE 2 "cType_Vec.lhs" #-}
1483 | cType_ ii g (Nil_  a) (VVec_ bVal VZero_) = do
1484 |   cType_ ii g a VStar_
1485 |   let aVal = cEval_ a (fst g, [])
1486 |   unless (quote0_ aVal == quote0_ bVal) (throwError "type mismatch")
1487 | cType_ ii g (Cons_ a n x xs) (VVec_ bVal (VSucc_ k)) = do
1488 |   cType_ ii g a VStar_
1489 |   let aVal = cEval_ a (fst g, [])
1490 |   unless (quote0_ aVal == quote0_ bVal) (throwError "type mismatch")
1491 |   cType_ ii g n VNat_
1492 |   let nVal = cEval_ n (fst g, [])
1493 |   unless (quote0_ nVal == quote0_ k) (throwError "number mismatch")
1494 |   cType_ ii g x  aVal
1495 |   cType_ ii g xs (VVec_ bVal k)
1496 | {-# LINE 2 "cType_Eq.lhs" #-}
1497 | cType_ ii g (Refl_ a z) (VEq_ bVal xVal yVal) = do
1498 |   cType_ ii g a VStar_
1499 |   let aVal = cEval_ a (fst g, [])
1500 |   unless (quote0_ aVal == quote0_ bVal) (throwError "type mismatch")
1501 |   cType_ ii g z aVal
1502 |   let zVal = cEval_ z (fst g, [])
1503 |   unless (quote0_ zVal == quote0_ xVal && quote0_ zVal == quote0_ yVal)
1504 |          (throwError "type mismatch")
1505 | {-# LINE 1873 "LP.lhs" #-}
1506 | cType_ ii g _ _ =
1507 |   throwError "type mismatch"
1508 | {-# LINE 1992 "LP.lhs" #-}
1509 | data Nat = Zero | Succ Nat
1510 | {-# LINE 2004 "LP.lhs" #-}
1511 | plus
1512 |   :: Nat -> Nat -> Nat
1513 | plus Zero     n = n
1514 | plus (Succ k) n = Succ (plus k n)
1515 | 


--------------------------------------------------------------------------------