├── .gitignore ├── LICENSE ├── README.md ├── base ├── monad.sig └── result.sml ├── examples └── example.mtt └── src ├── base ├── monad.sig ├── result.cm └── result.sml ├── dynamics.cm ├── dynamics └── dynamics.sml ├── statics ├── .gitignore ├── normal_forms.cm ├── normal_forms.mlb ├── normal_forms.sml ├── readback.cm ├── readback.sig ├── readback.sml ├── syntax.sig └── syntax.sml ├── syntax.cm ├── syntax.mlb └── typing ├── type_env.cm ├── type_env.sig ├── type_env.sml ├── typing.cm ├── typing.sig └── typing.sml /.gitignore: -------------------------------------------------------------------------------- 1 | .cm/ 2 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2016 Ayberk Tosun 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Mini-TT 2 | A tiny type-theoretic language. 3 | -------------------------------------------------------------------------------- /base/monad.sig: -------------------------------------------------------------------------------- 1 | structure S = Syntax 2 | 3 | signature MONAD = 4 | sig 5 | type 'a result 6 | 7 | val >>= : ('a result * ('a -> 'b result)) -> 'b result 8 | 9 | val return : 'a -> 'a result 10 | val fail : S.name -> 'a result 11 | end 12 | -------------------------------------------------------------------------------- /base/result.sml: -------------------------------------------------------------------------------- 1 | structure Result : MONAD = 2 | struct 3 | datatype 'a result = SUCCESS of 'a | FAIL of S.name 4 | 5 | fun >>= (SUCCESS x, k) = k x 6 | | >>= (FAIL s, _) = FAIL s 7 | 8 | val return = fn x => SUCCESS x 9 | val fail = fn x => FAIL x 10 | end 11 | -------------------------------------------------------------------------------- /examples/example.mtt: -------------------------------------------------------------------------------- 1 | id : Π A:U. A → A = λA. λx. x 2 | 3 | Bool : U = Sum (true | false) 4 | 5 | rec Nat : U = Sum (zero | succ Nat) 6 | -------------------------------------------------------------------------------- /src/base/monad.sig: -------------------------------------------------------------------------------- 1 | structure S = Syntax 2 | 3 | signature MONAD = 4 | sig 5 | type 'a result 6 | 7 | val >>= : ('a result * ('a -> 'b result)) -> 'b result 8 | 9 | val return : 'a -> 'a result 10 | val fail : S.name -> 'a result 11 | end 12 | -------------------------------------------------------------------------------- /src/base/result.cm: -------------------------------------------------------------------------------- 1 | Group is 2 | ../syntax.cm 3 | monad.sig 4 | result.sml 5 | -------------------------------------------------------------------------------- /src/base/result.sml: -------------------------------------------------------------------------------- 1 | structure Result : MONAD = 2 | struct 3 | datatype 'a result = SUCCESS of 'a | FAIL of S.name 4 | 5 | fun >>= (SUCCESS x, k) = k x 6 | | >>= (FAIL s, _) = FAIL s 7 | 8 | val return = fn x => SUCCESS x 9 | val fail = fn x => FAIL x 10 | end 11 | -------------------------------------------------------------------------------- /src/dynamics.cm: -------------------------------------------------------------------------------- 1 | Library 2 | structure Syntax 3 | structure Dynamics 4 | is 5 | syntax.cm 6 | dynamics/dynamics.sml 7 | -------------------------------------------------------------------------------- /src/dynamics/dynamics.sml: -------------------------------------------------------------------------------- 1 | structure Dynamics = 2 | struct 3 | 4 | open Syntax 5 | infix 5 ** 6 | 7 | fun @@ (f, x) = f x 8 | infixr 1 @@ 9 | 10 | exception Todo 11 | 12 | fun patProj x y z = raise Todo 13 | 14 | infix 5 $$ 15 | fun eval e0 rho = 16 | case e0 of 17 | ESET => SET 18 | | EDEC (d, e) => eval e @@ UPDEC (rho, d) 19 | | ELAM (p, e) => LAM @@ makeClos p e rho 20 | | EAPP (e1, e2) => (eval e1 rho) $$ (eval e2 rho) 21 | | EPAIR (e1, e2) => PAIR (eval e1 rho, eval e2 rho) 22 | | ECON (c, e1) => CON (c, eval e1 rho) 23 | | EPI (p, a, b) => PI (eval a rho, makeClos p b rho) 24 | | ESIGMA (p, a, b) => SIGMA (eval a rho, makeClos p b rho) 25 | | EONE => ONE 26 | | EUNIT => UNIT 27 | | EFST e => vfst @@ eval e rho 28 | | ESND e => vsnd @@ eval e rho 29 | | EVAR x => getRho rho x 30 | | ESUM cas => SUM @@ SCL (cas, rho) 31 | | EFUN ces => FUN @@ SCL (ces, rho) 32 | | _ => raise Fail "Something went wrong in eval!" 33 | and getRho (UPVAR (r, p, v)) x = 34 | if inPat x p then patProj p x v else getRho r x 35 | | getRho (UPDEC (r, DEF (p, _, e))) x = 36 | if inPat x p then patProj p x (eval e r) else getRho r x 37 | | getRho (UPDEC (r, DREC (p, q, e))) x = 38 | if inPat x p 39 | then patProj p x @@ eval e @@ UPDEC (r, (DREC (p, q, e))) 40 | else getRho r x 41 | | getRho RNIL _ = raise Fail "getRho" 42 | and op$$ ((v1, v2) : value * value) : value = 43 | case (v1, v2) of 44 | (LAM f, v) => f ** v 45 | | (FUN (SCL (ces, rho)), CON (c, v)) => 46 | (eval (get c ces) rho) $$ v 47 | | (FUN (SCL s), NT k) => NT @@ NTFUN (SCL s, k) 48 | | (NT k, m) => NT @@ APP (k, m) 49 | | (_, _) => raise NoApplicationRule 50 | 51 | fun lRho RNIL = 0 52 | | lRho (UPVAR (rho, _, _)) = lRho rho + 1 53 | | lRho (UPDEC (rho, _)) = lRho rho 54 | 55 | end 56 | -------------------------------------------------------------------------------- /src/statics/.gitignore: -------------------------------------------------------------------------------- 1 | syntax 2 | normal_forms 3 | -------------------------------------------------------------------------------- /src/statics/normal_forms.cm: -------------------------------------------------------------------------------- 1 | Group is 2 | ../syntax.cm 3 | normal_forms.sml 4 | -------------------------------------------------------------------------------- /src/statics/normal_forms.mlb: -------------------------------------------------------------------------------- 1 | local 2 | $(SML_LIB)/basis/pervasive.mlb 3 | syntax.mlb 4 | normal_forms.sml 5 | in 6 | structure NormalForms 7 | end 8 | -------------------------------------------------------------------------------- /src/statics/normal_forms.sml: -------------------------------------------------------------------------------- 1 | structure NormalForms = 2 | struct 3 | 4 | structure Syn = Syntax 5 | 6 | datatype nexp = 7 | NLAM of int * nexp 8 | | NPAIR of nexp * nexp 9 | | NCON of Syn.name * nexp 10 | | NUNIT 11 | | NSET 12 | | NPI of nexp * int * nexp 13 | | NSIGMA of nexp * int * nexp 14 | | NONE 15 | | NFUN of nsclos 16 | | NSUM of nsclos 17 | | NNT of nneut 18 | and nneut = 19 | NGEN of int 20 | | NAPP of nneut * nexp 21 | | NFST of nneut 22 | | NSND of nneut 23 | | NNTFUN of nsclos * nneut 24 | and nrho = 25 | NRNIL 26 | | NUPVAR of nrho * Syn.patt * nexp 27 | | NUPDEC of nrho * Syn.decl 28 | and nsclos = NSCL of Syn.branch * nrho 29 | 30 | end 31 | -------------------------------------------------------------------------------- /src/statics/readback.cm: -------------------------------------------------------------------------------- 1 | Library 2 | signature READBACK 3 | structure Readback 4 | is 5 | ../syntax.cm 6 | readback.sig 7 | readback.sml 8 | normal_forms.sml 9 | -------------------------------------------------------------------------------- /src/statics/readback.sig: -------------------------------------------------------------------------------- 1 | local 2 | open Syntax 3 | open NormalForms 4 | in 5 | signature READBACK = 6 | sig 7 | val rbValue : int -> value -> nexp 8 | val rbNeut : int -> neut -> nneut 9 | val rbRho : int -> rho -> nrho 10 | val genValue : int -> Syntax.value 11 | end 12 | end 13 | -------------------------------------------------------------------------------- /src/statics/readback.sml: -------------------------------------------------------------------------------- 1 | structure Readback : READBACK = 2 | struct 3 | open NormalForms 4 | open Syntax 5 | infixr 5 ** 6 | 7 | exception Todo 8 | 9 | exception ReadbackError 10 | 11 | fun @@ (f, x) = f x 12 | infixr 1 @@ 13 | 14 | fun meet x y = (x, y) 15 | 16 | (* This should probably be in some other module. *) 17 | fun genValue (x : int) : value = raise Todo 18 | 19 | fun rbValue (k : int) (v0 : value) = 20 | case v0 of 21 | LAM f => NLAM (k, rbValue (k + 1) @@ f ** (genValue k)) 22 | | PAIR (u, v) => NPAIR (rbValue k u, rbValue k v) 23 | | CON (c, v) => NCON (c, rbValue k v) 24 | | UNIT => NUNIT 25 | | SET => NSET 26 | | ONE => NONE 27 | | PI (t, g) => NPI (rbValue k t, k, rbValue (k+1) @@ g ** genValue k) 28 | | SIGMA (t, g) => NSIGMA (rbValue k t, k, rbValue (k+1) @@ g ** genValue k) 29 | | FUN (SCL (s, rho)) => NFUN @@ NSCL @@ meet s (rbRho k rho) 30 | | SUM (SCL (s, rho)) => NSUM @@ NSCL @@ meet s (rbRho k rho) 31 | | _ => raise Todo 32 | and rbNeut i k0 = 33 | case k0 of 34 | GEN j => NGEN j 35 | | APP (k, m) => NAPP @@ meet (rbNeut i k) (rbValue i m) 36 | | FST k => NFST (rbNeut i k) 37 | | SND k => NSND (rbNeut i k) 38 | | NTFUN (SCL (s, rho), k) => NNTFUN (NSCL (s, rbRho i rho), rbNeut i k) 39 | and rbRho _ RNIL = NRNIL 40 | | rbRho i (UPVAR (rho, p, v)) = NUPVAR @@ (rbRho i rho, p, rbValue i v) 41 | | rbRho i (UPDEC (rho, d)) = NUPDEC @@ meet (rbRho i rho) d 42 | 43 | end 44 | -------------------------------------------------------------------------------- /src/statics/syntax.sig: -------------------------------------------------------------------------------- 1 | signature SYNTAX = sig 2 | 3 | type name 4 | 5 | exception EmptyEnv 6 | exception NoApplicationRule 7 | 8 | datatype exp = 9 | ELAM of patt * exp 10 | | ESET 11 | | EPI of patt * exp * exp 12 | | ESIGMA of patt * exp * exp 13 | | EONE 14 | | EUNIT 15 | | EPAIR of exp * exp 16 | | ECON of name * exp 17 | | ESUM of branch 18 | | EFUN of branch 19 | | EFST of exp 20 | | ESND of exp 21 | | EAPP of exp * exp 22 | | EVAR of name 23 | | EVOID 24 | | EDEC of decl * exp 25 | and decl = 26 | DEF of patt * exp * exp 27 | | DREC of patt * exp * exp 28 | and patt = 29 | PPAIR of patt * patt 30 | | PUNIT 31 | | PVAR of name 32 | and branch = ENV of (name * exp) list 33 | 34 | datatype value = 35 | LAM of clos 36 | | PAIR of value * value 37 | | CON of name * value 38 | | UNIT 39 | | SET 40 | | PI of value * clos 41 | | SIGMA of value * clos 42 | | ONE 43 | | FUN of sclos 44 | | SUM of sclos 45 | | NT of neut 46 | (* Function closures. *) 47 | and clos = 48 | CL of patt * exp * rho 49 | | CLCMP of clos * name 50 | and rho = 51 | RNIL 52 | | UPVAR of rho * patt * value 53 | | UPDEC of rho * decl 54 | and neut = 55 | GEN of int 56 | | APP of neut * value 57 | | FST of neut 58 | | SND of neut 59 | | NTFUN of sclos * neut 60 | and sclos = SCL of branch * rho 61 | 62 | val ** : clos * value -> value 63 | 64 | val makeClos : patt -> exp -> rho -> clos 65 | 66 | val clCmp : clos -> name -> clos 67 | 68 | val get : name -> branch -> exp 69 | 70 | val vfst : value -> value 71 | val vsnd : value -> value 72 | 73 | val inPat : name -> patt -> bool 74 | 75 | end 76 | -------------------------------------------------------------------------------- /src/statics/syntax.sml: -------------------------------------------------------------------------------- 1 | structure Syntax : SYNTAX = 2 | struct 3 | type name = string 4 | 5 | fun @@ (f, x) = f x 6 | infixr 1 @@ 7 | 8 | exception Todo 9 | 10 | exception EmptyEnv 11 | exception NoApplicationRule 12 | 13 | datatype exp = 14 | ELAM of patt * exp (* Lambda expression *) 15 | | ESET (* The set type i.e. universe *) 16 | | EPI of patt * exp * exp (* Π type *) 17 | | ESIGMA of patt * exp * exp (* Σ type *) 18 | | EONE 19 | | EUNIT 20 | | EPAIR of exp * exp 21 | | ECON of name * exp 22 | | ESUM of branch 23 | | EFUN of branch 24 | | EFST of exp 25 | | ESND of exp 26 | | EAPP of exp * exp 27 | | EVAR of name 28 | | EVOID 29 | | EDEC of decl * exp 30 | and decl = 31 | DEF of patt * exp * exp 32 | | DREC of patt * exp * exp 33 | and patt = 34 | PPAIR of patt * patt 35 | | PUNIT 36 | | PVAR of name 37 | and branch = ENV of (name * exp) list 38 | 39 | datatype value = 40 | LAM of clos 41 | | PAIR of value * value 42 | | CON of name * value 43 | | UNIT 44 | | SET 45 | | PI of value * clos 46 | | SIGMA of value * clos 47 | | ONE 48 | | FUN of sclos 49 | | SUM of sclos 50 | | NT of neut 51 | (* Function closures. *) 52 | and clos = 53 | CL of patt * exp * rho 54 | | CLCMP of clos * name 55 | and rho = 56 | RNIL 57 | | UPVAR of rho * patt * value 58 | | UPDEC of rho * decl 59 | and neut = 60 | GEN of int 61 | | APP of neut * value 62 | | FST of neut 63 | | SND of neut 64 | | NTFUN of sclos * neut 65 | and sclos = SCL of branch * rho 66 | 67 | fun ** (CL (p, e, rho), v) = raise Todo 68 | | ** (CLCMP (clos, s), v) = raise Todo 69 | infix ** 70 | 71 | fun makeClos p e r = CL (p, e, r) 72 | 73 | fun clCmp g c = CLCMP (g, c) 74 | 75 | fun get s (ENV []) = raise EmptyEnv 76 | | get s (ENV ((s1, u)::us)) = 77 | if s = s1 then u else get s (ENV us) 78 | 79 | val vfst = 80 | fn PAIR (u1, _) => u1 81 | | (NT k) => NT (FST k) 82 | | _ => raise Fail "fst of non-pair" 83 | 84 | val vsnd = 85 | fn PAIR (_, u2) => u2 86 | | NT k => NT (SND k) 87 | | _ => raise Fail "snd of non-pair" 88 | 89 | (* Check if a given name `x` occurs in a pattern. *) 90 | fun inPat x (PVAR y) = x = y 91 | | inPat x (PPAIR (p1, p2)) = inPat x p1 orelse inPat x p2 92 | | inPat _ PUNIT = false 93 | 94 | end 95 | -------------------------------------------------------------------------------- /src/syntax.cm: -------------------------------------------------------------------------------- 1 | Library 2 | signature SYNTAX 3 | structure Syntax 4 | is 5 | statics/syntax.sig 6 | statics/syntax.sml 7 | -------------------------------------------------------------------------------- /src/syntax.mlb: -------------------------------------------------------------------------------- 1 | local 2 | in 3 | local 4 | $(SML_LIB)/basis/pervasive.mlb 5 | local 6 | statics/syntax.sig 7 | in 8 | signature gs_0 = SYNTAX 9 | end 10 | local 11 | signature SYNTAX = gs_0 12 | statics/syntax.sml 13 | in 14 | structure gs_1 = Syntax 15 | end 16 | in 17 | signature SYNTAX = gs_0 18 | structure Syntax = gs_1 19 | end 20 | end 21 | -------------------------------------------------------------------------------- /src/typing/type_env.cm: -------------------------------------------------------------------------------- 1 | Group is 2 | $/smlnj-lib.cm 3 | $/basis.cm 4 | ../syntax.cm 5 | ../base/result.cm 6 | type_env.sig 7 | type_env.sml 8 | -------------------------------------------------------------------------------- /src/typing/type_env.sig: -------------------------------------------------------------------------------- 1 | local 2 | structure S = Syntax 3 | structure R = Result 4 | in 5 | signature TYPE_ENV = 6 | sig 7 | type gamma 8 | val lookupG : S.name -> gamma -> S.value 9 | val upG : gamma -> S.patt -> S.value -> S.value -> gamma R.result 10 | end 11 | end 12 | -------------------------------------------------------------------------------- /src/typing/type_env.sml: -------------------------------------------------------------------------------- 1 | structure Context = 2 | SplayMapFn( 3 | struct 4 | type ord_key = S.name 5 | val compare = String.compare 6 | end 7 | ) 8 | 9 | structure TypeEnv : TYPE_ENV = 10 | struct 11 | open Result 12 | infix 2 >>= 13 | infix 5 ** 14 | open Context 15 | open Syntax 16 | 17 | type gamma = S.value map 18 | 19 | fun lookupG s gma = lookup (gma, s) 20 | 21 | fun upG gma PUNIT _ _ = return gma 22 | | upG gma (PVAR x) t _ = return (Context.insert (gma, x, t)) 23 | | upG gma (PPAIR (p1, p2)) (SIGMA (t, g)) v = 24 | upG gma p1 t (vfst v) >>= (fn gma1 => 25 | upG gma1 p2 (g ** vfst v) (vsnd v)) 26 | | upG _ p _ _ = raise Fail "problem in upG" 27 | end 28 | -------------------------------------------------------------------------------- /src/typing/typing.cm: -------------------------------------------------------------------------------- 1 | Group is 2 | ../syntax.cm 3 | ../base/result.cm 4 | ../dynamics.cm 5 | ../statics/readback.cm 6 | type_env.cm 7 | typing.sig 8 | typing.sml 9 | -------------------------------------------------------------------------------- /src/typing/typing.sig: -------------------------------------------------------------------------------- 1 | local 2 | open Syntax 3 | open Result 4 | open TypeEnv 5 | in 6 | signature TYPECHECKER = 7 | sig 8 | (* ρ; Γ ⊢ A. Check that A is a correct type expression. *) 9 | val checkT : int -> rho -> gamma -> exp -> unit result 10 | 11 | (* ρ; Γ |- M ⇐ t. Check that M is a well-typed expression of type t. *) 12 | val check : int -> rho -> gamma -> exp -> value -> unit result 13 | 14 | (* ρ; Γ ⊢ M ⇒ t. Infers the type of M. *) 15 | val checkI : int -> rho -> gamma -> exp -> value result 16 | 17 | (* ρ; Γ |- D ⇒ Γ'. Checks that D is a valid declaration and 18 | * extends Γ to Γ'. *) 19 | val checkD : int -> rho -> gamma -> decl -> gamma result 20 | end 21 | end 22 | -------------------------------------------------------------------------------- /src/typing/typing.sml: -------------------------------------------------------------------------------- 1 | structure Typechecker : TYPECHECKER = 2 | struct 3 | open TypeEnv 4 | open Syntax 5 | open Result 6 | infixr 2 >>= 7 | open Dynamics 8 | open Readback 9 | exception Todo 10 | 11 | val success = return () 12 | val succeed = fn _ => success 13 | 14 | fun check k rho gma e0 t0 = raise Todo 15 | 16 | fun checkT k rho gma ESET = success 17 | | checkT k rho gma (EPI (p, a, b)) = 18 | checkT k rho gma a >>= (fn _ => 19 | upG gma p (eval a rho) (genValue k) >>= (fn gma1 => 20 | checkT (k+1) (UPVAR (rho, p, genValue k)) gma1 b)) 21 | | checkT k rho gma (ESIGMA (p, a, b)) = 22 | checkT k rho gma a >>= (fn _ => 23 | upG gma p (eval a rho) (genValue k) >>= (fn gma1 => 24 | checkT (k+1) (UPVAR (rho, p, genValue k)) gma1 b)) 25 | | checkT k rho gma e = 26 | check k rho gma e ESET >>= succeed 27 | 28 | fun checkI k rho gma e0 = raise Todo 29 | 30 | (* `d` is a correct declaration and extends gma to gma' *) 31 | fun checkD k rho gma d = raise Todo 32 | end 33 | --------------------------------------------------------------------------------