├── dune-project ├── dune ├── .gitignore ├── bin ├── main.ml └── dune ├── .github ├── FUNDING.yml └── workflows │ ├── ocaml.yml │ └── odoc.yml ├── basis ├── SymbolMap.ml ├── PpExn.mli ├── SymbolMap.mli ├── dune ├── Basis.ml ├── Basis.mli ├── Symbol.mli ├── Pp.mli ├── Symbol.ml ├── Error.mli ├── PpExn.ml ├── Monad.mli ├── Reader.mli ├── Bwd.mli ├── Reader.ml ├── Error.ml ├── Monad.ml ├── Pp.ml └── Bwd.ml ├── README.md ├── core ├── dune ├── Equate.mli ├── Eval.mli ├── Logic.mli ├── Env.ml ├── Core.ml ├── Env.mli ├── EffectOps.ml ├── Effect.mli ├── Logic.ml ├── Effect.ml ├── Equate.ml ├── Core.mli ├── Syntax.ml ├── Refiner.ml └── Eval.ml ├── frontend ├── dune ├── Frontend.ml ├── Distiller.ml ├── Code.ml ├── Frontend.mli └── Elaborator.ml ├── test └── runtests.sh ├── index.mld ├── dreamtt.opam └── LICENSE /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.7) 2 | -------------------------------------------------------------------------------- /dune: -------------------------------------------------------------------------------- 1 | (documentation (package dreamtt)) 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | *.merlin* 3 | *.DS_Store 4 | -------------------------------------------------------------------------------- /bin/main.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | print_endline "Hello, world" 3 | -------------------------------------------------------------------------------- /.github/FUNDING.yml: -------------------------------------------------------------------------------- 1 | # These are supported funding model platforms 2 | 3 | github: jonsterling 4 | -------------------------------------------------------------------------------- /basis/SymbolMap.ml: -------------------------------------------------------------------------------- 1 | include Map.Make (Symbol) 2 | 3 | let pp _ih fmt _table = 4 | Format.fprintf fmt "" 5 | -------------------------------------------------------------------------------- /basis/PpExn.mli: -------------------------------------------------------------------------------- 1 | exception Unrecognized 2 | 3 | val pp : exn Pp.printer 4 | val install_printer : exn Pp.printer -> unit -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # dreamtt 2 | 3 | A pedagogic implementation of abstract bidirectional elaboration for dependent type theory. 4 | -------------------------------------------------------------------------------- /basis/SymbolMap.mli: -------------------------------------------------------------------------------- 1 | include Map.S with type key = Symbol.t 2 | 3 | val pp : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit 4 | -------------------------------------------------------------------------------- /core/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name Core) 3 | (libraries dreamtt.basis) 4 | (flags 5 | (:standard -w -32-26-27-37)) 6 | (public_name dreamtt.core)) 7 | 8 | -------------------------------------------------------------------------------- /basis/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name Basis) 3 | (libraries uuseg uuseg.string uutf) 4 | (flags 5 | (:standard -w -37)) 6 | (public_name dreamtt.basis)) 7 | 8 | -------------------------------------------------------------------------------- /frontend/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name Frontend) 3 | (libraries dreamtt.basis dreamtt.core) 4 | (flags 5 | (:standard -w -37)) 6 | (public_name dreamtt.frontend)) 7 | 8 | 9 | -------------------------------------------------------------------------------- /frontend/Frontend.ml: -------------------------------------------------------------------------------- 1 | (* {1 The source language} *) 2 | 3 | include Code 4 | 5 | (* {1 Elaborator} *) 6 | 7 | module Elaborator = Elaborator 8 | module Distiller = Distiller 9 | -------------------------------------------------------------------------------- /bin/dune: -------------------------------------------------------------------------------- 1 | (executables 2 | (names main) 3 | (libraries dreamtt.core)) 4 | 5 | (install 6 | (section bin) 7 | (package dreamtt) 8 | (files 9 | (main.exe as dreamtt))) 10 | -------------------------------------------------------------------------------- /basis/Basis.ml: -------------------------------------------------------------------------------- 1 | module Error = Error 2 | module Monad = Monad 3 | module Reader = Reader 4 | module Symbol = Symbol 5 | module Pp = Pp 6 | module PpExn = PpExn 7 | 8 | module StringMap = Map.Make (String) 9 | -------------------------------------------------------------------------------- /basis/Basis.mli: -------------------------------------------------------------------------------- 1 | module Error = Error 2 | module Monad = Monad 3 | module Reader = Reader 4 | module Pp = Pp 5 | module PpExn = PpExn 6 | module Symbol = Symbol 7 | 8 | module StringMap : Map.S with type key = string 9 | -------------------------------------------------------------------------------- /basis/Symbol.mli: -------------------------------------------------------------------------------- 1 | type t 2 | 3 | val fresh : unit -> t 4 | val named : string -> t 5 | val named_opt : string option -> t 6 | 7 | val compare : t -> t -> int 8 | val equal : t -> t -> bool 9 | 10 | val pp : t Pp.printer 11 | -------------------------------------------------------------------------------- /core/Equate.mli: -------------------------------------------------------------------------------- 1 | (** The equational theory of types *) 2 | 3 | exception UnequalTypes 4 | 5 | open Effect 6 | 7 | val equate_gtp : Syntax.gtp -> Syntax.gtp -> unit lm 8 | val equate_gtele : Syntax.gtele -> Syntax.gtele -> unit lm 9 | -------------------------------------------------------------------------------- /core/Eval.mli: -------------------------------------------------------------------------------- 1 | open Syntax 2 | open Effect 3 | 4 | val eval : ltm -> gtm lm 5 | val eval_tp : ltp -> gtp lm 6 | val eval_tele : ltele -> gtele lm 7 | 8 | val gapp : gtm -> gtm -> gtm gm 9 | val gproj : string -> gtm -> gtm gm 10 | 11 | val whnf : gtm -> gtm gm 12 | val whnf_tp : gtp -> gtp gm 13 | -------------------------------------------------------------------------------- /core/Logic.mli: -------------------------------------------------------------------------------- 1 | type prop = Syntax.gprop 2 | 3 | type thy 4 | 5 | val emp : thy 6 | val ext : thy -> prop -> thy 7 | 8 | val consistency : thy -> [`Consistent | `Inconsistent] 9 | val test : thy -> prop list -> prop -> bool 10 | 11 | type update = 12 | [`Ext of prop] 13 | 14 | val update : update -> thy -> thy 15 | -------------------------------------------------------------------------------- /core/Env.ml: -------------------------------------------------------------------------------- 1 | type 'a t = 'a list 2 | type ix = Ix of int 3 | type lvl = Lvl of int 4 | let int_of_lvl (Lvl lvl) = lvl 5 | let empty = [] 6 | let size = List.length 7 | let append xs x = x :: xs 8 | let proj xs (Ix i) = List.nth xs i 9 | let lvl_to_ix xs (Lvl l) = Ix (size xs - l - 1) 10 | 11 | let fresh xs = Lvl (size xs) 12 | -------------------------------------------------------------------------------- /test/runtests.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | # No `.dream` files? Alright. 4 | shopt -s nullglob 5 | 6 | TEST_DIR="$(cd "$(dirname "${BASH_SOURCE[0]}")" >/dev/null 2>&1 && pwd)" 7 | 8 | for file in "${TEST_DIR}"/*.dream; do 9 | echo "Checking ${file}" 10 | opam exec dune -- exec dreamtt -- "${file}" || exit 1 11 | done 12 | 13 | echo DONE 14 | -------------------------------------------------------------------------------- /core/Core.ml: -------------------------------------------------------------------------------- 1 | include Equate 2 | 3 | module Env = Env 4 | module Equate = Equate 5 | module Syntax = Syntax 6 | module Logic = Logic 7 | module Effect = Effect 8 | include Syntax 9 | 10 | module Proof = 11 | struct 12 | type 'a t = 'a 13 | let out x = x 14 | end 15 | 16 | type tp = gtp Proof.t 17 | type tm = gtm Proof.t 18 | 19 | let tp_of_tm = tp_of_gtm 20 | 21 | module Refiner = Refiner 22 | -------------------------------------------------------------------------------- /.github/workflows/ocaml.yml: -------------------------------------------------------------------------------- 1 | name: Build and test 2 | on: [push,pull_request] 3 | jobs: 4 | run: 5 | name: Build 6 | runs-on: ${{ matrix.operating-system }} 7 | strategy: 8 | matrix: 9 | operating-system: [ubuntu-latest] 10 | ocaml-version: ['4.10.0'] 11 | steps: 12 | - uses: actions/checkout@v2 13 | - uses: avsm/setup-ocaml@v1 14 | with: 15 | ocaml-version: ${{ matrix.ocaml-version }} 16 | - run: opam pin add -y dreamtt . 17 | - run: opam exec -- dune build 18 | -------------------------------------------------------------------------------- /basis/Pp.mli: -------------------------------------------------------------------------------- 1 | type 'a printer = Format.formatter -> 'a -> unit 2 | 3 | module Env : 4 | sig 5 | type t 6 | 7 | exception EmptyEnv 8 | exception UnboundVariable of {ix : int; env: t} 9 | 10 | val emp : t 11 | 12 | (** May raise {!UnboundVariable}. *) 13 | val var : int -> t -> string 14 | val bind : t -> string option -> string * t 15 | val bindn : t -> string option list -> string list * t 16 | 17 | (** May raise {!EmptyEnv}. *) 18 | val proj : t -> t 19 | val names : t -> string list 20 | end 21 | 22 | type env = Env.t 23 | -------------------------------------------------------------------------------- /core/Env.mli: -------------------------------------------------------------------------------- 1 | (** Representation of contexts and variables. *) 2 | 3 | (** An abstract type representing environments that are extended on the right. *) 4 | type 'a t 5 | 6 | (** A pointer to a cell in the environment, counted from the right. *) 7 | type ix 8 | 9 | (** A pointer to a cell in the environment, counted from the left. *) 10 | type lvl 11 | val int_of_lvl : lvl -> int 12 | 13 | val empty : 'a t 14 | 15 | val append : 'a t -> 'a -> 'a t 16 | val proj : 'a t -> ix -> 'a 17 | 18 | val lvl_to_ix : 'a t -> lvl -> ix 19 | val fresh : 'a t -> lvl 20 | -------------------------------------------------------------------------------- /basis/Symbol.ml: -------------------------------------------------------------------------------- 1 | type t = {gen : int; name : string option} 2 | 3 | let global = ref 0 4 | 5 | let compare s1 s2 = 6 | Int.compare s1.gen s2.gen 7 | 8 | let equal s1 s2 = 9 | s1.gen = s2.gen 10 | 11 | let named_opt ostr = 12 | let i = !global in 13 | let s = {gen = i; name = ostr} in 14 | global := i + 1; 15 | s 16 | 17 | let named str = named_opt (Some str) 18 | let fresh () = named_opt None 19 | 20 | let pp fmt sym = 21 | match sym.name with 22 | | Some nm -> 23 | Format.fprintf fmt "%a" Uuseg_string.pp_utf_8 nm 24 | | None -> 25 | Format.fprintf fmt "#%i" sym.gen 26 | -------------------------------------------------------------------------------- /.github/workflows/odoc.yml: -------------------------------------------------------------------------------- 1 | name: GitHub Pages by odoc 2 | on: 3 | push: 4 | branches: 5 | - main 6 | - doc* 7 | jobs: 8 | odoc: 9 | runs-on: ubuntu-latest 10 | steps: 11 | - uses: actions/checkout@v2 12 | - uses: avsm/setup-ocaml@v1 13 | with: 14 | ocaml-version: '4.10.0' 15 | - run: opam install odoc -y 16 | - run: opam pin . -y 17 | - run: opam exec -- dune build @doc 18 | - uses: peaceiris/actions-gh-pages@v3 19 | with: 20 | github_token: ${{ secrets.GITHUB_TOKEN }} 21 | publish_dir: ./_build/default/_doc/_html/ 22 | -------------------------------------------------------------------------------- /basis/Error.mli: -------------------------------------------------------------------------------- 1 | module type Ops = 2 | sig 3 | type 'a m 4 | 5 | (** Throw an exception to be captured within the monad. *) 6 | val throw : exn -> 'a m 7 | 8 | (** Handle an exception within the monad. *) 9 | val catch : 'a m -> (('a, exn) Result.t -> 'b m) -> 'b m 10 | end 11 | 12 | module type T = 13 | sig 14 | include Monad.Trans 15 | include Ops with type 'a m := 'a m 16 | 17 | val run : 'a m -> (('a, exn) Result.t -> 'b n) -> 'b n 18 | val run_exn : 'a m -> 'a n 19 | end 20 | 21 | module type S = T with type 'a n = 'a 22 | 23 | module MakeT (M : Monad.S) : T with type 'a n = 'a M.m 24 | module M : T with type 'a n = 'a 25 | -------------------------------------------------------------------------------- /index.mld: -------------------------------------------------------------------------------- 1 | {0 dreamtt} 2 | 3 | Welcome to [dreamtt]'s documentation! 4 | 5 | {1 Overview} 6 | 7 | [dreamtt]is a pedagogic implementation of abstract bidirectional elaboration for dependent type theory. 8 | 9 | It is internally organized into 3 parts: 10 | 11 | - {!Basis} defines functional concepts such as {!Basis.Monad} and technical utilities like {!Basis.Pp} (some utilities useful for pretty printers) 12 | - {!Core} implements the internal AST and the key algorithms 13 | - {!Frontend} provides the user-facing parts, i.e., the surface language 14 | 15 | {1 API documentation} 16 | 17 | {!modules: 18 | Basis 19 | Core 20 | Frontend 21 | } 22 | -------------------------------------------------------------------------------- /basis/PpExn.ml: -------------------------------------------------------------------------------- 1 | exception Unrecognized 2 | 3 | let printers = Stack.create () 4 | 5 | let install_printer printer = 6 | Stack.push printer printers; 7 | Printexc.register_printer @@ fun exn -> 8 | try 9 | printer Format.str_formatter exn; 10 | Some (Format.flush_str_formatter ()) 11 | with 12 | | Unrecognized -> 13 | None 14 | 15 | let pp fmt exn = 16 | let exception Break in 17 | let go printer = 18 | try 19 | printer fmt exn; 20 | raise Break 21 | with 22 | | Unrecognized -> () 23 | in 24 | try 25 | Stack.iter go printers; 26 | Format.fprintf fmt "%s" @@ Printexc.to_string exn 27 | with 28 | | Break -> () 29 | -------------------------------------------------------------------------------- /core/EffectOps.ml: -------------------------------------------------------------------------------- 1 | open Basis 2 | open Syntax 3 | 4 | module type G = 5 | sig 6 | type 'a m 7 | include Error.Ops with type 'a m := 'a m 8 | 9 | (** Access the current logical theory. *) 10 | val theory : Logic.thy m 11 | 12 | (** Perform a monotone update to the current logical theory within a scope. *) 13 | val scope_thy : Logic.update -> 'a m -> 'a m 14 | end 15 | 16 | module type L = 17 | sig 18 | include G 19 | 20 | (** Access the local variable environment *) 21 | val env : env m 22 | 23 | (** Bind a variable of a given type within a scope. *) 24 | val bind_tm : gtp -> (gtm -> 'a m) -> 'a m 25 | 26 | (** Append a term to the local environment within a scope. *) 27 | val append_tm : gtm -> 'a m -> 'a m 28 | end 29 | -------------------------------------------------------------------------------- /dreamtt.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | name: "dreamtt" 3 | version: "0.1" 4 | synopsis: "A minimal implementation of abstract bidirectional elaboration" 5 | description: """ 6 | A minimal implementation of abstract bidirectional elaboration 7 | """ 8 | maintainer: "Jonathan Sterling " 9 | authors: "Jonathan Sterling " 10 | license: "Apache-2.0" 11 | homepage: "http://jonsterling.github.io/dreamtt/" 12 | bug-reports: "https://github.com/jonsterling/dreamtt/issues" 13 | dev-repo: "git+https://github.com/jonsterling/dreamtt" 14 | depends: [ 15 | "dune" {>= "2.0"} 16 | "ocaml" {>= "4.10.0"} 17 | "cmdliner" {>= "1.0"} 18 | "menhir" {>= "20180703"} 19 | "uuseg" {>= "12.0.0"} 20 | "uutf" {>= "1.0.2"} 21 | ] 22 | build: [["dune" "build" "-p" name "-j" jobs]] 23 | -------------------------------------------------------------------------------- /basis/Monad.mli: -------------------------------------------------------------------------------- 1 | module type S = 2 | sig 3 | type 'a m 4 | val ret : 'a -> 'a m 5 | val bind : 'a m -> ('a -> 'b m) -> 'b m 6 | end 7 | 8 | module type Trans = 9 | sig 10 | type 'a n 11 | include S 12 | val lift : 'a n -> 'a m 13 | end 14 | 15 | module Identity : S with type 'a m = 'a 16 | 17 | module type Notation = 18 | sig 19 | type 'a m 20 | val (let*) : 'a m -> ('a -> 'b m) -> 'b m 21 | val (and*) : 'a m -> 'b m -> ('a * 'b) m 22 | val (let+) : 'a m -> ('a -> 'b) -> 'b m 23 | val (and+) : 'a m -> 'b m -> ('a * 'b) m 24 | val (<@>) : ('a -> 'b) -> 'a m -> 'b m 25 | val (|>>) : 'a m -> ('a -> 'b m) -> 'b m 26 | val (@<<) : ('a -> 'b m) -> 'a m -> 'b m 27 | val (<&>) : 'a m -> 'b m -> ('a * 'b) m 28 | end 29 | 30 | module Notation (M : S) : Notation with type 'a m := 'a M.m 31 | 32 | module MapUtil (M : S) (N : Map.S) : 33 | sig 34 | val flat_map : ('a -> 'b M.m) -> 'a N.t -> 'b N.t M.m 35 | end 36 | -------------------------------------------------------------------------------- /basis/Reader.mli: -------------------------------------------------------------------------------- 1 | (** This module contains the interface and functors for access and scoped updates of local state. *) 2 | 3 | (** The operations of a reader monad *) 4 | module type Ops = 5 | sig 6 | type 'a m 7 | type local 8 | 9 | val read : local m 10 | val locally : (local -> local) -> 'a m -> 'a m 11 | end 12 | 13 | (** The reader monad transformer interface. *) 14 | module type T = 15 | sig 16 | include Monad.Trans 17 | include Ops with type 'a m := 'a m 18 | 19 | val read : local m 20 | val locally : (local -> local) -> 'a m -> 'a m 21 | 22 | val reader : (local -> 'a n) -> 'a m 23 | val run : local -> 'a m -> 'a n 24 | end 25 | 26 | (** The reader monad, i.e. the instance of the transformer at the identity monad. *) 27 | module type S = T with type 'a n = 'a 28 | 29 | module MakeT (L : sig type local end) (M : Monad.S) : T with type 'a n = 'a M.m and type local = L.local 30 | module Make (L : sig type local end) : S with type local = L.local 31 | -------------------------------------------------------------------------------- /core/Effect.mli: -------------------------------------------------------------------------------- 1 | open Basis 2 | open Syntax 3 | 4 | (** This module contains two effect monads that are used across [dreamtt]; one 5 | for "global" computations that do not depend on the local variable 6 | environment, and one for "local" computations that do depend on the local 7 | variable environment. 8 | *) 9 | 10 | (** Monad for computations that don't depend on the local environment. *) 11 | type 'a gm 12 | 13 | (** Monad for computations that do depend on the local environment. *) 14 | type 'a lm 15 | 16 | module G : 17 | sig 18 | include Monad.S with type 'a m = 'a gm 19 | include EffectOps.G with type 'a m := 'a m 20 | 21 | (** Execute with a local variable environment. *) 22 | val local : env -> 'a lm -> 'a m 23 | end 24 | 25 | module L : 26 | sig 27 | include Monad.S with type 'a m = 'a lm 28 | include EffectOps.L with type 'a m := 'a m 29 | 30 | (** Forget the local variable environment. *) 31 | val global : 'a gm -> 'a m 32 | end 33 | -------------------------------------------------------------------------------- /basis/Bwd.mli: -------------------------------------------------------------------------------- 1 | (** Backward lists (notation inspired by Conor McBride) *) 2 | 3 | type 'a t = 4 | | Emp 5 | | Snoc of 'a t * 'a 6 | 7 | val nth : 'a t -> int -> 'a 8 | val length : 'a t -> int 9 | val mem : 'a -> 'a t -> bool 10 | val exists : ('a -> bool) -> 'a t -> bool 11 | val for_all : ('a -> bool) -> 'a t -> bool 12 | val iter : ('a -> unit) -> 'a t -> unit 13 | val map : ('a -> 'b) -> 'a t -> 'b t 14 | val mapi : (int -> 'a -> 'b) -> 'a t -> 'b t 15 | val filter_map : ('a -> 'b option) -> 'a t -> 'b t 16 | val flat_map : ('a -> 'b list) -> 'a t -> 'b t 17 | val filter : ('a -> bool) -> 'a t -> 'a t 18 | val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a 19 | val fold_right : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b 20 | val fold_right2 : ('a -> 'b -> 'c -> 'c) -> 'a t -> 'b t -> 'c -> 'c 21 | val to_list : 'a t -> 'a list 22 | val from_list : 'a list -> 'a t 23 | 24 | module Notation : 25 | sig 26 | val (<.>) : 'a t -> 'a t -> 'a t 27 | val (#<) : 'a t -> 'a -> 'a t 28 | val (<><) : 'a t -> 'a list -> 'a t 29 | val (<>>) : 'a t -> 'a list -> 'a list 30 | end 31 | 32 | -------------------------------------------------------------------------------- /basis/Reader.ml: -------------------------------------------------------------------------------- 1 | (** The operations of a reader monad *) 2 | module type Ops = 3 | sig 4 | type 'a m 5 | type local 6 | 7 | val read : local m 8 | val locally : (local -> local) -> 'a m -> 'a m 9 | end 10 | 11 | (** The reader monad transformer interface. *) 12 | module type T = 13 | sig 14 | include Monad.Trans 15 | include Ops with type 'a m := 'a m 16 | 17 | val read : local m 18 | val locally : (local -> local) -> 'a m -> 'a m 19 | 20 | val reader : (local -> 'a n) -> 'a m 21 | val run : local -> 'a m -> 'a n 22 | end 23 | 24 | module type S = T with type 'a n = 'a 25 | 26 | module MakeT (L : sig type local end) (M : Monad.S) : T with type 'a n = 'a M.m and type local = L.local = 27 | struct 28 | include L 29 | type 'a n = 'a M.m 30 | type 'a m = local -> 'a n 31 | 32 | let lift m _ = m 33 | 34 | let ret a _ = M.ret a 35 | 36 | let bind (m : 'a m) (k : 'a -> 'b m) = 37 | fun l -> 38 | M.bind (m l) @@ fun x -> 39 | k x l 40 | 41 | let locally f m l = m (f l) 42 | let reader f = f 43 | let run l m = m l 44 | let read l = M.ret l 45 | end 46 | 47 | module Make (L : sig type local end) = MakeT (L) (Monad.Identity) 48 | 49 | 50 | -------------------------------------------------------------------------------- /core/Logic.ml: -------------------------------------------------------------------------------- 1 | module Var = 2 | struct 3 | type t = Env.lvl 4 | let compare = compare 5 | end 6 | 7 | module VarSet = Set.Make (Var) 8 | 9 | open Syntax 10 | type prop = gprop 11 | 12 | type thy = 13 | | Consistent of {true_vars : VarSet.t} 14 | | Inconsistent 15 | 16 | let emp = 17 | Consistent {true_vars = VarSet.empty} 18 | 19 | let ext thy phi = 20 | match thy with 21 | | Inconsistent -> Inconsistent 22 | | Consistent {true_vars} -> 23 | match phi with 24 | | PVar x -> 25 | Consistent {true_vars = VarSet.add x true_vars} 26 | | PTop -> 27 | thy 28 | | PBot -> 29 | Inconsistent 30 | 31 | let consistency = 32 | function 33 | | Consistent _ -> `Consistent 34 | | Inconsistent -> `Inconsistent 35 | 36 | let test_closed thy phi = 37 | match thy with 38 | | Inconsistent -> true 39 | | Consistent {true_vars} -> 40 | match phi with 41 | | PVar x -> VarSet.mem x true_vars 42 | | PTop -> true 43 | | PBot -> false 44 | 45 | let test thy cx phi = 46 | let thy' = List.fold_left ext thy cx in 47 | test_closed thy' phi 48 | 49 | type update = 50 | [`Ext of prop] 51 | 52 | let update (`Ext phi) thy = 53 | ext thy phi 54 | -------------------------------------------------------------------------------- /frontend/Distiller.ml: -------------------------------------------------------------------------------- 1 | open Basis 2 | open Core 3 | open Code 4 | 5 | module L = struct type local = string Env.t end 6 | module M = Reader.Make (L) 7 | 8 | open Monad.Notation (M) 9 | module StringMapUtil = Monad.MapUtil (M) (StringMap) 10 | 11 | include M 12 | 13 | let scope k = 14 | reader @@ fun env -> 15 | let x = "x" ^ string_of_int @@ Env.int_of_lvl @@ Env.fresh env in 16 | run (Env.append env x) @@ k x 17 | 18 | 19 | let rec distill_ltm : Syntax.ltm -> code m = 20 | function 21 | | LVar ix -> 22 | let+ env = read in 23 | let x = Env.proj env ix in 24 | L (Var x) 25 | 26 | | LTt -> 27 | ret @@ R Tt 28 | 29 | | LFf -> 30 | ret @@ R Ff 31 | 32 | | LLam (_, tm) -> 33 | scope @@ fun x -> 34 | let+ code = distill_ltm tm in 35 | R (Lam (x, code)) 36 | 37 | | LApp (tm0, tm1) -> 38 | let+ code0 = distill_ltm tm0 39 | and+ code1 = distill_ltm tm1 in 40 | L (App (code0, code1)) 41 | 42 | | LRcd (_, _, lmap) -> 43 | let+ code_map = StringMapUtil.flat_map distill_ltm lmap in 44 | R (Rcd code_map) 45 | 46 | | LProj (lbl, tm) -> 47 | let+ code = distill_ltm tm in 48 | L (Proj (lbl, code)) 49 | 50 | | LAbort -> 51 | ret @@ R Abort 52 | -------------------------------------------------------------------------------- /frontend/Code.ml: -------------------------------------------------------------------------------- 1 | open Basis 2 | open Core 3 | 4 | (** The central idea to the elaboration algorithm is to distinguish 5 | introduction forms from elimination forms; unlike some classic 6 | bidirectional algorithms, this distinction does not line up exactly with {i 7 | checking} vs. {i synthesis}, but it interacts with it in a non-trivial way: 8 | we only synthesize elimination forms at positive types. *) 9 | type code = 10 | | R of rcode 11 | | L of lcode 12 | 13 | (** [rcode] is a type of introduction forms *) 14 | and rcode = 15 | | Bool 16 | | Pi of string * code * code 17 | | RcdTp of tele_code 18 | | Sg of string * code * code 19 | | Tt 20 | | Ff 21 | | Lam of string * code 22 | | Pair of code * code 23 | | Rcd of code StringMap.t 24 | | Abort 25 | 26 | (** [lcode] is a type of elimination forms. Included via {!Core} is the 27 | collection of all core-language terms; this embedding is used to crucial 28 | effect by the elaborator. *) 29 | and lcode = 30 | | Var of string 31 | | App of code * code 32 | | Fst of code 33 | | Snd of code 34 | | Proj of string * code 35 | | Core of tm 36 | 37 | and tele_code = 38 | | TlNil 39 | | TlCons of string * code * tele_code 40 | 41 | -------------------------------------------------------------------------------- /basis/Error.ml: -------------------------------------------------------------------------------- 1 | module type Ops = 2 | sig 3 | type 'a m 4 | val throw : exn -> 'a m 5 | val catch : 'a m -> (('a, exn) Result.t -> 'b m) -> 'b m 6 | end 7 | 8 | module type T = 9 | sig 10 | include Monad.Trans 11 | include Ops with type 'a m := 'a m 12 | 13 | val run : 'a m -> (('a, exn) Result.t -> 'b n) -> 'b n 14 | val run_exn : 'a m -> 'a n 15 | end 16 | 17 | module type S = T with type 'a n = 'a 18 | 19 | module MakeT (M : Monad.S) : T with type 'a n = 'a M.m = 20 | struct 21 | type 'a n = 'a M.m 22 | type 'a m = ('a, exn) Result.t n 23 | 24 | let ret : 'a -> 'a m = 25 | fun a -> 26 | M.ret @@ Ok a 27 | 28 | let bind (m : 'a m) (k : 'a -> 'b m) : 'b m = 29 | M.bind m @@ function 30 | | Ok a -> 31 | k a 32 | | Error e -> 33 | M.ret @@ Error e 34 | 35 | let catch (m : 'a m) (k : ('a, exn) Result.t -> 'b m) : 'b m = 36 | M.bind m k 37 | 38 | let run (m : 'a m) (k : ('a, exn) Result.t -> 'b n) : 'b n = 39 | M.bind m k 40 | 41 | let run_exn m = 42 | M.bind m @@ function 43 | | Ok a -> M.ret a 44 | | Error e -> raise e 45 | 46 | let throw e = 47 | M.ret @@ Error e 48 | 49 | let lift n = 50 | M.bind n @@ fun x -> 51 | M.ret @@ Ok x 52 | end 53 | 54 | module M = MakeT (Monad.Identity) 55 | -------------------------------------------------------------------------------- /core/Effect.ml: -------------------------------------------------------------------------------- 1 | open Basis 2 | open Syntax 3 | 4 | module E = 5 | struct 6 | type local = {thy : Logic.thy; env : env} 7 | let update_thy upd {thy; env} = 8 | {thy = Logic.update upd thy; env} 9 | 10 | let append_tm tm {thy; env} = 11 | {thy; env = Env.append env @@ `Tm tm} 12 | 13 | let set_env env {thy; _} = 14 | {thy; env} 15 | end 16 | 17 | module L = 18 | struct 19 | module M = Reader.MakeT (E) (Error.M) 20 | include M 21 | open Monad.Notation (M) 22 | 23 | let global m = m 24 | let local e m = locally (E.set_env e) m 25 | 26 | let catch (m : 'a m) (k : ('a, exn) Result.t -> 'b m) : 'b m = 27 | reader @@ fun env -> 28 | Error.M.run (run env m) @@ fun res -> 29 | run env @@ k res 30 | 31 | let throw e = 32 | lift @@ Error.M.throw e 33 | 34 | let theory = 35 | let+ x = read in 36 | x.thy 37 | 38 | let env = 39 | let+ x = read in 40 | x.env 41 | 42 | let scope_thy upd m = 43 | locally (E.update_thy upd) m 44 | 45 | let bind_tm gtp kont = 46 | let* e = env in 47 | let lvl = Env.fresh e in 48 | let glued = stable_glued gtp @@ GVar lvl in 49 | let var = Glued glued in 50 | locally (E.append_tm var) @@ kont var 51 | 52 | let append_tm gtm m = 53 | locally (E.append_tm gtm) m 54 | end 55 | 56 | module G = L 57 | 58 | type 'a gm = 'a G.m 59 | type 'a lm = 'a L.m 60 | -------------------------------------------------------------------------------- /frontend/Frontend.mli: -------------------------------------------------------------------------------- 1 | open Basis 2 | 3 | (** {1 The source language} 4 | 5 | We begin by defining a naive source language. 6 | *) 7 | 8 | include module type of Code 9 | 10 | 11 | (** {1 Elaboration} *) 12 | 13 | module R := Core.Refiner 14 | 15 | module Elaborator : 16 | sig 17 | type resolver 18 | include Reader.S with type local = resolver 19 | 20 | (** The main entry-point: check a piece of code against a type. *) 21 | val elab_chk_code : code -> R.chk_rule m 22 | 23 | (** Checking introduction forms against their types. *) 24 | val elab_chk_rcode : rcode -> R.chk_rule m 25 | 26 | (** Rather than transitioning immediately to synthesize when we hit an [lcode], 27 | we perform type-directed eta expansion. This is the main ingredient to 28 | enable smooth elaboration of subtypes, including the "retyping principles" 29 | familiar from ML modules. *) 30 | val elab_chk_lcode : lcode -> R.chk_rule m 31 | 32 | (** Elaborating an elimination form. *) 33 | val elab_syn_lcode : lcode -> R.syn_rule m 34 | 35 | (** Elaborate a type *) 36 | val elab_tp_code : code -> R.tp_rule m 37 | val elab_tp_rcode : rcode -> R.tp_rule m 38 | end 39 | 40 | 41 | (** {1 Distillation} *) 42 | 43 | (** The distiller takes a core-language term and turns it into a source language code. *) 44 | module Distiller : sig 45 | include Monad.S 46 | val run : string Core.Env.t -> 'a m -> 'a 47 | val distill_ltm : Core.Syntax.ltm -> code m 48 | end 49 | -------------------------------------------------------------------------------- /basis/Monad.ml: -------------------------------------------------------------------------------- 1 | module type S = 2 | sig 3 | type 'a m 4 | val ret : 'a -> 'a m 5 | val bind : 'a m -> ('a -> 'b m) -> 'b m 6 | end 7 | 8 | module type Trans = 9 | sig 10 | type 'a n 11 | include S 12 | val lift : 'a n -> 'a m 13 | end 14 | 15 | module type Notation = 16 | sig 17 | type 'a m 18 | val (let*) : 'a m -> ('a -> 'b m) -> 'b m 19 | val (and*) : 'a m -> 'b m -> ('a * 'b) m 20 | val (let+) : 'a m -> ('a -> 'b) -> 'b m 21 | val (and+) : 'a m -> 'b m -> ('a * 'b) m 22 | val (<@>) : ('a -> 'b) -> 'a m -> 'b m 23 | val (|>>) : 'a m -> ('a -> 'b m) -> 'b m 24 | val (@<<) : ('a -> 'b m) -> 'a m -> 'b m 25 | val (<&>) : 'a m -> 'b m -> ('a * 'b) m 26 | end 27 | 28 | module Notation (M : S) : Notation with type 'a m := 'a M.m = 29 | struct 30 | let (let*) = M.bind 31 | 32 | let (and*) m n = 33 | let* x = m in 34 | let* y = n in 35 | M.ret (x, y) 36 | 37 | let (let+) m f = M.bind m (fun x -> M.ret (f x)) 38 | 39 | let (and+) m n = (and*) m n 40 | 41 | let (<@>) f m = (let+) m f 42 | let (|>>) = (let*) 43 | let (@<<) f m = m |>> f 44 | let (<&>) = (and+) 45 | end 46 | 47 | 48 | module Identity : S with type 'a m = 'a = 49 | struct 50 | type 'a m = 'a 51 | let ret a = a 52 | let bind x f = f x 53 | end 54 | 55 | 56 | module MapUtil (M : S) (N : Map.S) = 57 | struct 58 | open Notation (M) 59 | let flat_map (f : 'a -> 'b M.m) (map : 'a N.t) : 'b N.t M.m = 60 | let rec loop out = 61 | function 62 | | [] -> M.ret out 63 | | (lbl, x) :: xs -> 64 | let* y = f x in 65 | loop (N.add lbl y out) xs 66 | in 67 | loop N.empty @@ N.bindings map 68 | end 69 | -------------------------------------------------------------------------------- /basis/Pp.ml: -------------------------------------------------------------------------------- 1 | type 'a printer = Format.formatter -> 'a -> unit 2 | 3 | open Bwd.Notation 4 | 5 | module Env = 6 | struct 7 | type t = string Bwd.t 8 | 9 | exception EmptyEnv 10 | exception UnboundVariable of {ix : int; env: t} 11 | 12 | let emp = Bwd.Emp 13 | 14 | let nat_to_suffix n = 15 | let formatted = string_of_int n in 16 | let lookup : int -> string = List.nth ["₀";"₁";"₂";"₃";"₄";"₅";"₆";"₇";"₈";"₉"] in 17 | String.concat "" @@ 18 | List.init (String.length formatted) @@ 19 | fun n -> lookup (Char.code (String.get formatted n) - Char.code '0') 20 | 21 | let rec rename xs x i = 22 | let suffix = nat_to_suffix i in 23 | let new_x = x ^ suffix in 24 | if Bwd.mem new_x xs then (rename [@tailcall]) xs x (i + 1) else new_x 25 | 26 | let choose_name (env : t) (x : string) = 27 | if Bwd.mem x env then rename env x 1 else x 28 | 29 | let var i env = 30 | if i < Bwd.length env then 31 | Bwd.nth env i 32 | else 33 | raise @@ UnboundVariable {ix = i; env} 34 | 35 | let proj = 36 | function 37 | | Bwd.Emp -> raise EmptyEnv 38 | | Bwd.Snoc (xs, _) -> xs 39 | 40 | let bind (env : t) (nm : string option) : string * t = 41 | let x = 42 | match nm with 43 | | None -> choose_name env "_x" 44 | | Some x -> choose_name env x 45 | in 46 | x, env #< x 47 | 48 | let rec bindn (env : t) (nms : string option list) : string list * t = 49 | match nms with 50 | | [] -> 51 | [], env 52 | | nm :: nms -> 53 | let x, env' = bind env nm in 54 | let xs, env'' = bindn env' nms in 55 | (x :: xs), env'' 56 | 57 | let names (env : t) : string list = 58 | env <>> [] 59 | end 60 | 61 | type env = Env.t 62 | -------------------------------------------------------------------------------- /basis/Bwd.ml: -------------------------------------------------------------------------------- 1 | type 'a t = 2 | | Emp 3 | | Snoc of 'a t * 'a 4 | 5 | module Notation = 6 | struct 7 | let (#<) xs x = 8 | Snoc (xs, x) 9 | 10 | let rec (<.>) xs ys = 11 | match ys with 12 | | Emp -> xs 13 | | Snoc (ys, y) -> 14 | Snoc (xs <.> ys, y) 15 | 16 | 17 | let rec (<><) xs ys = 18 | match ys with 19 | | [] -> xs 20 | | y :: ys -> (xs #< y) <>< ys 21 | 22 | let rec (<>>) xs ys = 23 | match xs with 24 | | Emp -> ys 25 | | Snoc (xs, x) -> xs <>> x :: ys 26 | end 27 | 28 | open Notation 29 | 30 | let rec nth xs i = 31 | match xs with 32 | | Emp -> 33 | failwith "Bwd.nth" 34 | | Snoc (_, x) when i = 0 -> x 35 | | Snoc (xs, _) -> nth xs @@ i - 1 36 | 37 | let rec mem a xs = 38 | match xs with 39 | | Emp -> false 40 | | Snoc (xs, x) -> 41 | a = x || (mem[@tailcall]) a xs 42 | 43 | let rec exists p xs = 44 | match xs with 45 | | Emp -> false 46 | | Snoc (xs, x) -> 47 | p x || (exists[@tailcall]) p xs 48 | 49 | let rec for_all p xs = 50 | match xs with 51 | | Emp -> true 52 | | Snoc (xs, x) -> 53 | p x && (for_all[@tailcall]) p xs 54 | 55 | let rec iter p xs = 56 | match xs with 57 | | Emp -> () 58 | | Snoc (xs, x) -> 59 | p x; (iter[@tailcall]) p xs 60 | 61 | let rec length = 62 | function 63 | | Emp -> 0 64 | | Snoc (xs, _) -> 65 | 1 + length xs 66 | 67 | let rec map f = 68 | function 69 | | Emp -> Emp 70 | | Snoc (xs, x) -> Snoc (map f xs, f x) 71 | 72 | let rec filter_map f = 73 | function 74 | | Emp -> Emp 75 | | Snoc (xs, x) -> 76 | match f x with 77 | | None -> filter_map f xs 78 | | Some fx -> Snoc (filter_map f xs, fx) 79 | 80 | let mapi f = 81 | let rec go i = 82 | function 83 | | Emp -> Emp 84 | | Snoc (xs, x) -> Snoc (go (i + 1) xs, f i x) 85 | in 86 | go 0 87 | 88 | let rec flat_map f = 89 | function 90 | | Emp -> Emp 91 | | Snoc (xs, x) -> flat_map f xs <>< f x 92 | 93 | let rec filter f = 94 | function 95 | | Emp -> Emp 96 | | Snoc (xs, x) -> 97 | let xs' = filter f xs in 98 | if f x then Snoc (xs', x) else xs' 99 | 100 | let rec fold_left f e = 101 | function 102 | | Emp -> e 103 | | Snoc (xs, x) -> 104 | f (fold_left f e xs) x 105 | 106 | let rec fold_right f l e = 107 | match l with 108 | | Emp -> e 109 | | Snoc (l, x) -> 110 | let e = f x e in 111 | (fold_right[@tailcall]) f l e 112 | 113 | let rec fold_right2 f l0 l1 e = 114 | match l0, l1 with 115 | | Emp, Emp -> e 116 | | Snoc (l0, x0), Snoc (l1, x1) -> 117 | let e = f x0 x1 e in 118 | (fold_right2[@tailcall]) f l0 l1 e 119 | | _ -> raise @@ Invalid_argument "Bwd.fold_right2" 120 | let to_list xs = 121 | xs <>> [] 122 | 123 | let from_list xs = 124 | Emp <>< xs 125 | 126 | (* favonia: the following is considered ILL-TYPED! 127 | * 128 | * let rev xs = from_list @@ List.rev @@ to_list xs *) 129 | -------------------------------------------------------------------------------- /core/Equate.ml: -------------------------------------------------------------------------------- 1 | open Basis 2 | open Syntax 3 | open Effect 4 | 5 | exception UnequalTypes 6 | exception UnequalTerms 7 | exception Impossible 8 | exception Todo 9 | 10 | open Monad.Notation (L) 11 | 12 | let guard m = 13 | let* thy = L.theory in 14 | match Logic.consistency thy with 15 | | `Inconsistent -> L.ret () 16 | | `Consistent -> m 17 | 18 | let gfam_to_gtele gbase lfam env = 19 | GTlCons (gbase, LTlCons (lfam, LTlNil), env) 20 | 21 | let rec equate_gtp : gtp -> gtp -> unit L.m = 22 | fun gtp0 gtp1 -> 23 | guard @@ 24 | let* gtp0 = L.global @@ Eval.whnf_tp gtp0 in 25 | let* gtp1 = L.global @@ Eval.whnf_tp gtp0 in 26 | match gtp0, gtp1 with 27 | | GBool, GBool -> L.ret () 28 | | GPi (gbase0, lfam0, env0), GPi (gbase1, lfam1, env1) -> 29 | let gtl0 = gfam_to_gtele gbase0 lfam0 env0 in 30 | let gtl1 = gfam_to_gtele gbase1 lfam1 env1 in 31 | equate_gtele gtl0 gtl1 32 | | GRcdTp (lbls0, gtl0), GRcdTp (lbls1, gtl1) when lbls0 = lbls1 -> 33 | equate_gtele gtl0 gtl1 34 | | _ -> 35 | L.throw UnequalTypes 36 | 37 | and equate_gtele : gtele -> gtele -> unit L.m = 38 | fun gtl0 gtl1 -> 39 | guard @@ 40 | match gtl0, gtl1 with 41 | | GTlNil, GTlNil -> L.ret () 42 | | GTlCons (gtp0, ltl0, env0), GTlCons (gtp1, ltl1, env1) -> 43 | let gfib env gtp ltl = L.global @@ G.local env @@ L.bind_tm gtp @@ fun _ -> Eval.eval_tele ltl in 44 | let* gfib0 = gfib env0 gtp0 ltl0 in 45 | let* gfib1 = gfib env1 gtp1 ltl1 in 46 | equate_gtele gfib0 gfib1 47 | | _ -> 48 | L.throw UnequalTypes 49 | 50 | and equate_gtm : gtp -> gtm -> gtm -> unit L.m = 51 | fun gtp gtm0 gtm1 -> 52 | L.global @@ Eval.whnf_tp gtp |>> 53 | function 54 | | GPi (gbase, lfam, env) -> 55 | equate_fun gbase lfam env gtm0 gtm1 56 | | GRcdTp (lbls, gtl) -> 57 | equate_rcd lbls gtl gtm0 gtm1 58 | | GBool -> 59 | equate_base gtm0 gtm1 60 | | GAbortTp -> 61 | L.ret () 62 | 63 | and equate_base gtm0 gtm1 = 64 | let* gtm0 = L.global @@ Eval.whnf gtm0 in 65 | let* gtm1 = L.global @@ Eval.whnf gtm1 in 66 | match gtm0, gtm1 with 67 | | GTt, GTt | GFf, GFf -> 68 | L.ret () 69 | | Glued _, Glued _ -> 70 | raise Todo 71 | | _ -> 72 | raise UnequalTerms 73 | 74 | and equate_fun gbase lfam env gf0 gf1 = 75 | L.bind_tm gbase @@ fun var -> 76 | let* gv0 = L.global @@ Eval.gapp gf0 var in 77 | let* gv1 = L.global @@ Eval.gapp gf1 var in 78 | let* gfib = L.global @@ G.local env @@ L.append_tm var @@ Eval.eval_tp lfam in 79 | equate_gtm gfib gv0 gv1 80 | 81 | and equate_rcd lbls gtl gr0 gr1 = 82 | let rec loop lbls gtl = 83 | match lbls, gtl with 84 | | [], GTlNil -> 85 | L.ret () 86 | | lbl::lbls, GTlCons (gbase, ltl, env) -> 87 | let* gv0 = L.global @@ Eval.gproj lbl gr0 in 88 | let* gv1 = L.global @@ Eval.gproj lbl gr1 in 89 | let* () = equate_gtm gbase gv0 gv1 in 90 | let* gfib = L.global @@ G.local env @@ L.append_tm gv0 @@ Eval.eval_tele ltl in 91 | loop lbls gfib 92 | | _ -> 93 | L.throw Impossible 94 | in 95 | loop lbls gtl 96 | -------------------------------------------------------------------------------- /core/Core.mli: -------------------------------------------------------------------------------- 1 | (** {1 Core language} 2 | 3 | The representation of the core language is {i not} exposed. Instead, an 4 | abstract type is provided of both core language types and core language 5 | terms. Both terms and types support silent weakening: hence an element of 6 | {!tp} or {!tm} can be used in any scope. 7 | *) 8 | 9 | open Basis 10 | 11 | module Env = Env 12 | module Syntax = Syntax 13 | module Equate = Equate 14 | module Logic = Logic 15 | module Effect = Effect 16 | 17 | (** {2 Proof abstraction boundary} *) 18 | 19 | (** We wrap the syntax in an abstraction boundary as in LCF. *) 20 | 21 | module Proof : 22 | sig 23 | type 'a t 24 | val out : 'a t -> 'a 25 | end 26 | 27 | type tp = Syntax.gtp Proof.t 28 | type tm = Syntax.gtm Proof.t 29 | 30 | val tp_of_tm : tm -> tp 31 | 32 | (** {2 Inspecting types} *) 33 | 34 | type tp_head = [`Pi | `Rcd of string list | `Bool | `Abort] 35 | 36 | (** The head of a type can be exposed in order to guide the elaborator. It is 37 | (surprisingly) unnecessary to expose any more data of a type to the 38 | elaborator.*) 39 | val tp_head : tp -> tp_head 40 | 41 | (** {1 Constructing well-typed terms} *) 42 | 43 | (** The refiner is the only way to construct terms. Any term constructed by the refiner is 44 | guaranteed to be well-typed, in the tradition of LCF. *) 45 | module Refiner : sig 46 | (** {1 Rule types} 47 | 48 | The refiner follows a version of the bidirectional typing discipline, 49 | dividing proofs into {!chk_rule} and {!syn_rule}. The purpose of the bidirectional 50 | division of labor is to enable many steps of refinement that would 51 | otherwise induce dozens of conversion checks to be collated in such a way 52 | that only one conversion check is required. 53 | 54 | A related side-effect is that the refinement scripts contain very few 55 | annotations, drawing annotations inward from the goal and outward from 56 | the context. 57 | *) 58 | 59 | type tp_rule 60 | type chk_rule 61 | type syn_rule 62 | type tele_rule 63 | 64 | (** {1 Inference rules} *) 65 | 66 | (** {2 Telescopes} *) 67 | val tl_nil : tele_rule 68 | val tl_cons : string -> tp_rule -> (tm -> tele_rule) -> tele_rule 69 | 70 | (** {2 Booleans} *) 71 | 72 | val bool : tp_rule 73 | val tt : chk_rule 74 | val ff : chk_rule 75 | 76 | (** {2 Dependent product types} *) 77 | 78 | val pi : tp_rule -> (tm -> tp_rule) -> tp_rule 79 | val lam : (tm -> chk_rule) -> chk_rule 80 | val app : syn_rule -> chk_rule -> syn_rule 81 | 82 | (** {2 Dependent record types} *) 83 | 84 | val rcd_tp : tele_rule -> tp_rule 85 | val rcd : chk_rule StringMap.t -> chk_rule 86 | val proj : string -> syn_rule -> syn_rule 87 | 88 | (** {2 Dependent sum types} *) 89 | 90 | val sg : tp_rule -> (tm -> tp_rule) -> tp_rule 91 | val pair : chk_rule -> chk_rule -> chk_rule 92 | val fst : syn_rule -> syn_rule 93 | val snd : syn_rule -> syn_rule 94 | 95 | (** {2 Logical layer} *) 96 | val chk_abort : chk_rule 97 | 98 | 99 | (** {2 Structural rules} *) 100 | 101 | (** Every core language term carries has a unique type, and can hence be syn_rulethesized. *) 102 | val core : tm -> syn_rule 103 | 104 | (** The {i conversion rule} appears in the bidirectional setting as the 105 | transition from synthesis to checking. *) 106 | val conv : syn_rule -> chk_rule 107 | 108 | 109 | (** {1 Rule combinators} *) 110 | 111 | val with_tp : (tp -> chk_rule) -> chk_rule 112 | 113 | (** {2 Failing rules} 114 | The following rules will fail with an exception. 115 | *) 116 | 117 | val fail_tp : exn -> tp_rule 118 | val fail_chk : exn -> chk_rule 119 | val fail_syn : exn -> syn_rule 120 | end 121 | -------------------------------------------------------------------------------- /frontend/Elaborator.ml: -------------------------------------------------------------------------------- 1 | open Basis 2 | open Code 3 | 4 | module R = Core.Refiner 5 | 6 | type resolver = Core.tm StringMap.t 7 | 8 | module M = Reader.Make (struct type local = resolver end) 9 | module StringMapUtil = Monad.MapUtil (M) (StringMap) 10 | include M 11 | open Monad.Notation (M) 12 | 13 | exception ElabError 14 | 15 | let commute rule f : _ m = 16 | M.reader @@ fun res -> 17 | rule @@ fun x -> 18 | M.run res @@ f x 19 | 20 | let add_var x var = 21 | locally @@ StringMap.add x var 22 | 23 | let rec elab_chk_code : code -> R.chk_rule m = 24 | function 25 | | R rcode -> 26 | elab_chk_rcode rcode 27 | | L lcode -> 28 | elab_chk_lcode lcode 29 | 30 | and elab_syn_code : code -> R.syn_rule m = 31 | function 32 | | L lcode -> 33 | elab_syn_lcode lcode 34 | | R _ -> 35 | ret @@ R.fail_syn ElabError 36 | 37 | and elab_chk_rcode : rcode -> R.chk_rule m = 38 | function 39 | | Tt -> ret R.tt 40 | | Ff -> ret R.ff 41 | | Lam (x, codex) -> 42 | commute R.lam @@ fun var -> 43 | add_var x var @@ 44 | elab_chk_code codex 45 | | Pair (code0, code1) -> 46 | let+ chk0 = elab_chk_code code0 47 | and+ chk1 = elab_chk_code code1 in 48 | R.pair chk0 chk1 49 | | Rcd code_map -> 50 | let* chk_map = StringMapUtil.flat_map elab_chk_code code_map in 51 | ret @@ R.rcd chk_map 52 | | _ -> 53 | ret @@ R.fail_chk ElabError 54 | 55 | and elab_chk_lcode (lcode : lcode) : R.chk_rule m = 56 | commute R.with_tp @@ fun gtp -> 57 | match Core.tp_head gtp with 58 | | `Pi -> 59 | commute R.lam @@ fun var -> 60 | elab_chk_lcode @@ App (L lcode, L (Core var)) 61 | | `Bool -> 62 | let+ syn = elab_syn_lcode lcode in 63 | R.conv syn 64 | | `Rcd lbls -> 65 | let rec loop chk_map lbls = 66 | match lbls with 67 | | [] -> ret chk_map 68 | | lbl :: lbls -> 69 | let* chk = elab_chk_lcode @@ Proj (lbl, L (lcode)) in 70 | loop (StringMap.add lbl chk chk_map) lbls 71 | in 72 | let+ chk_map = loop StringMap.empty lbls in 73 | R.rcd chk_map 74 | | `Abort -> 75 | ret @@ R.chk_abort 76 | 77 | and elab_syn_lcode : lcode -> R.syn_rule m = 78 | function 79 | | Var x -> 80 | let+ res = read in 81 | R.core @@ StringMap.find x res 82 | | App (fn, arg) -> 83 | let+ syn = elab_syn_code fn 84 | and+ chk = elab_chk_code arg in 85 | R.app syn chk 86 | | Fst code -> 87 | let+ syn = elab_syn_code code in 88 | R.fst syn 89 | | Snd code -> 90 | let+ syn = elab_syn_code code in 91 | R.snd syn 92 | | Proj (lbl, code) -> 93 | let+ syn = elab_syn_code code in 94 | R.proj lbl syn 95 | | Core tm -> 96 | ret @@ R.core tm 97 | 98 | and elab_tp_code : code -> R.tp_rule m = 99 | function 100 | | R rcode -> 101 | elab_tp_rcode rcode 102 | | _ -> 103 | ret @@ R.fail_tp ElabError 104 | 105 | and elab_tp_rcode : rcode -> R.tp_rule m = 106 | function 107 | | Bool -> 108 | ret R.bool 109 | | Pi (x, code0, code1) -> 110 | let* tp_base = elab_tp_code code0 in 111 | commute (R.pi tp_base) @@ fun var -> 112 | add_var x var @@ 113 | elab_tp_code code1 114 | | Sg (x, code0, code1) -> 115 | let* tp_base = elab_tp_code code0 in 116 | commute (R.sg tp_base) @@ fun var -> 117 | add_var x var @@ 118 | elab_tp_code code1 119 | | RcdTp tele_code -> 120 | let+ tele = elab_tele_code tele_code in 121 | R.rcd_tp tele 122 | | _ -> 123 | ret @@ R.fail_tp ElabError 124 | 125 | and elab_tele_code : tele_code -> R.tele_rule m = 126 | function 127 | | TlNil -> 128 | ret R.tl_nil 129 | | TlCons (lbl, code0, code1) -> 130 | let* tp_base = elab_tp_code code0 in 131 | commute (R.tl_cons lbl tp_base) @@ fun var -> 132 | add_var lbl var @@ 133 | elab_tele_code code1 134 | -------------------------------------------------------------------------------- /core/Syntax.ml: -------------------------------------------------------------------------------- 1 | (** The core language syntax representation *) 2 | 3 | open Basis 4 | 5 | (** {1 Core language representations } 6 | 7 | The core language syntax is split into two representations, after Coquand: 8 | a local form that is sensitive to the context (using De Bruijn indices), 9 | and a global form that is insensitive to the context (using De Bruijn 10 | levels). 11 | 12 | 13 | The "local" syntax corresponds to ordinary syntax, and the "global" syntax 14 | corresponds to weak head normal forms in many NbE-style implementations. We 15 | make no attempt to restrict local syntax to normal forms; unlike 16 | conventional implementation, we freely interleave the local and the global 17 | syntax when it saves us some computations (see the annotations on {!LLam} 18 | and {!LRcd} for instance). 19 | *) 20 | 21 | (** {2 Logical layer} *) 22 | 23 | type 'v prop = 24 | | PVar of 'v 25 | | PTop 26 | | PBot 27 | 28 | type gprop = Env.lvl prop 29 | type lprop = Env.ix prop 30 | 31 | 32 | (** {2 Representation of types} *) 33 | 34 | type ltp = 35 | | LPi of ltp * ltp 36 | | LRcdTp of string list * ltele 37 | | LBool 38 | | LAbortTp 39 | | LTpVar of Env.ix 40 | 41 | and gtp = 42 | | GPi of gfam 43 | | GRcdTp of string list * gtele 44 | | GBool 45 | | GAbortTp 46 | 47 | and gfam = gtp * ltp * env 48 | 49 | 50 | and gtele = 51 | | GTlNil 52 | | GTlCons of gtp * ltele * env 53 | 54 | and ltele = 55 | | LTlNil 56 | | LTlCons of ltp * ltele 57 | 58 | 59 | (** {2 Representation of terms} *) 60 | 61 | and ltm = 62 | | LVar of Env.ix 63 | | LTt | LFf 64 | 65 | | LLam of gfam * ltm 66 | | LApp of ltm * ltm 67 | 68 | | LRcd of string list * gtele * ltm StringMap.t 69 | | LProj of string * ltm 70 | | LAbort 71 | 72 | and gtm = 73 | | GTt | GFf 74 | | GLam of gfam * ltm * env 75 | | GRcd of string list * gtele * gtm StringMap.t 76 | | Glued of (gneu, ltm) glued 77 | | GAbort 78 | 79 | and gneu = 80 | | GVar of Env.lvl 81 | | GSnoc of gneu * gfrm 82 | 83 | and gfrm = 84 | | GProj of string 85 | | GApp of gtm 86 | 87 | (** A glued term combines a total element {!glued.base} with a compatible 88 | partial element {!glued.part} under {!glued.supp}; the invariant is that 89 | when {!glued.supp} is true, {!glued.base} shall have destabilized to carry 90 | no semantic information. The main use-case is when {!glued.base} is a 91 | neutral that must compute under {!glued.supp} to the element determined by 92 | {!glued.part}. 93 | *) 94 | 95 | and ('b, 'a) glued = Gl of {supp : gprop; gtp : gtp; base : 'b; part : 'a; env : env} 96 | 97 | and 'a part = Prt of {supp : gprop; part : 'a; env : env} 98 | 99 | and env = cell Env.t 100 | 101 | and cell = [`Tm of gtm | `Tp of gtp | `Prop of gprop] 102 | 103 | 104 | (** {1 Convenience } *) 105 | 106 | type tp_head = [`Pi | `Rcd of string list | `Bool | `Abort] 107 | 108 | (** Project the name of the head constructor of a type; useful for guiding elaboration. *) 109 | let tp_head : gtp -> tp_head = 110 | function 111 | | GBool -> `Bool 112 | | GPi _ -> `Pi 113 | | GRcdTp (lbls, _) -> `Rcd lbls 114 | | GAbortTp -> `Abort 115 | 116 | 117 | (** Project the type of a term: this is efficient and non-recursive. *) 118 | let tp_of_gtm : gtm -> gtp = 119 | function 120 | | GTt | GFf -> GBool 121 | | GLam (gfam, _, _) -> 122 | GPi gfam 123 | | GRcd (lbls, gtele, _) -> 124 | GRcdTp (lbls, gtele) 125 | | Glued (Gl glued) -> 126 | glued.gtp 127 | | GAbort -> 128 | GAbortTp 129 | 130 | (** {3 Glued terms} *) 131 | 132 | 133 | (** Project the partial element from a glued term. *) 134 | let glued_to_part : ('b, 'a) glued -> 'a part = 135 | function 136 | | Gl {supp; part; env; _} -> 137 | Prt {supp; part; env} 138 | 139 | (** Construct a stable glued term, i.e. one form whom the base is nowhere unstable. *) 140 | let stable_glued : gtp -> 'b -> ('b, ltm) glued = 141 | fun gtp base -> 142 | Gl {supp = PBot; gtp; base; part = LAbort; env = Env.empty} 143 | 144 | (** {3 Restricting to partial elements} *) 145 | 146 | (** Restrict a total term to a partial term. *) 147 | let gtm_to_part : gprop -> gtm -> ltm part = 148 | fun supp gtm -> 149 | let part, env = 150 | let env0 = Env.empty in 151 | let lvl = Env.fresh env0 in 152 | let env = Env.append env0 @@ `Tm gtm in 153 | let ix = Env.lvl_to_ix env lvl in 154 | LVar ix, env 155 | in 156 | Prt {supp; part; env} 157 | 158 | (** Restrict a total type to a partial type. *) 159 | let gtp_to_part : gprop -> gtp -> ltp part = 160 | fun supp gtp -> 161 | let part, env = 162 | let env0 = Env.empty in 163 | let lvl = Env.fresh env0 in 164 | let env = Env.append env0 @@ `Tp gtp in 165 | let ix = Env.lvl_to_ix env lvl in 166 | LTpVar ix, env 167 | in 168 | Prt {supp; part; env} 169 | 170 | (** {3 Projecting boundaries} 171 | 172 | The following functions project the partial (terms, types) that a (term, 173 | type) must compute to; when the input has a stable head constructor, the 174 | empty partial element is returned. 175 | *) 176 | 177 | let gtm_bdry : gtm -> ltm part = 178 | function 179 | | Glued glued -> 180 | glued_to_part glued 181 | | gtm -> 182 | gtm_to_part PBot GAbort 183 | 184 | let gtp_bdry : gtp -> ltp part = 185 | function 186 | | gtp -> 187 | gtp_to_part PBot GAbortTp 188 | 189 | 190 | -------------------------------------------------------------------------------- /core/Refiner.ml: -------------------------------------------------------------------------------- 1 | open Basis 2 | open Syntax 3 | open Effect 4 | 5 | exception TypeError 6 | 7 | open Monad.Notation (L) 8 | 9 | type tp_rule = ltp L.m 10 | type chk_rule = gtp -> ltm L.m 11 | type syn_rule = gtm L.m 12 | 13 | let with_tp kont tp = 14 | kont tp tp 15 | 16 | let inst_tp_fam : ltp -> env -> gtm -> gtp G.m = 17 | fun lfam env gtm -> 18 | let envx = Env.append env @@ `Tm gtm in 19 | G.local envx @@ Eval.eval_tp lfam 20 | 21 | let inst_tm_fam : ltm -> env -> gtm -> gtm G.m = 22 | fun lfam env gtm -> 23 | let envx = Env.append env @@ `Tm gtm in 24 | G.local envx @@ Eval.eval lfam 25 | 26 | 27 | let core = 28 | L.ret 29 | 30 | let bool : tp_rule = 31 | L.ret LBool 32 | 33 | let tt : chk_rule = 34 | function 35 | | GBool -> L.ret LTt 36 | | _ -> L.throw TypeError 37 | 38 | let ff : chk_rule = 39 | function 40 | | GBool -> L.ret LFf 41 | | _ -> L.throw TypeError 42 | 43 | 44 | (* invariant: does not return unless the list of labels has no shadowing *) 45 | type tele_rule = (string list * ltele) L.m 46 | 47 | let tl_nil : tele_rule = 48 | L.ret ([], LTlNil) 49 | 50 | let rec freshen lbl lbls = 51 | if List.mem lbl lbls then 52 | freshen (lbl ^ "'") lbls 53 | else 54 | lbl 55 | 56 | let tl_cons lbl tp_rule tele_rule = 57 | let* lbase = tp_rule in 58 | let* gbase = Eval.eval_tp lbase in 59 | L.bind_tm gbase @@ fun var -> 60 | let+ lbls, lfam = tele_rule var in 61 | let lbl' = freshen lbl lbls in 62 | lbl' :: lbls, LTlCons (lbase, lfam) 63 | 64 | let pi (base : tp_rule) (fam : gtm -> tp_rule) : tp_rule = 65 | let* lbase = base in 66 | let* gbase = Eval.eval_tp lbase in 67 | L.bind_tm gbase @@ fun var -> 68 | let+ lfam = fam var in 69 | LPi (lbase, lfam) 70 | 71 | 72 | let rcd_tp (tele : tele_rule) : tp_rule = 73 | let+ lbls, ltl = tele in 74 | LRcdTp (lbls, ltl) 75 | 76 | 77 | let lam (bdy : gtm -> chk_rule) : chk_rule = 78 | function 79 | | GPi ((gbase, lfam, env) as gfam) -> 80 | L.bind_tm gbase @@ fun var -> 81 | let+ lbdy = bdy var @<< L.global @@ inst_tp_fam lfam env var in 82 | LLam (gfam, lbdy) 83 | | _ -> 84 | L.throw TypeError 85 | 86 | let rcd (chk_map : chk_rule StringMap.t) : chk_rule = 87 | function 88 | | GRcdTp (lbls, gtl) -> 89 | let rec loop tmap lbls gtl = 90 | match lbls, gtl with 91 | | [], GTlNil -> L.ret tmap 92 | | lbl :: lbls, GTlCons (gtp, ltl, tlenv) -> 93 | begin 94 | match StringMap.find_opt lbl chk_map with 95 | | Some chk_rule -> 96 | let* ltm = chk_rule gtp in 97 | let* gtm = Eval.eval ltm in 98 | let* gtl' = L.global @@ G.local tlenv @@ L.append_tm gtm @@ Eval.eval_tele ltl in 99 | let tmap' = StringMap.add lbl ltm tmap in 100 | loop tmap' lbls gtl' 101 | | None -> 102 | L.throw TypeError 103 | end 104 | | _ -> 105 | L.throw TypeError 106 | in 107 | let* tmap = loop StringMap.empty lbls gtl in 108 | L.ret @@ LRcd (lbls, gtl, tmap) 109 | | _ -> 110 | L.throw TypeError 111 | 112 | let app (fn : syn_rule) (arg : chk_rule) : syn_rule = 113 | let* gtm0 = fn in 114 | match tp_of_gtm gtm0 with 115 | | GPi (gbase, _, _) -> 116 | let* larg = arg gbase in 117 | let* gtm1 = Eval.eval larg in 118 | L.global @@ Eval.gapp gtm0 gtm1 119 | | _ -> 120 | L.throw TypeError 121 | 122 | let proj lbl (syn_rule : syn_rule) : syn_rule = 123 | let* gtm = syn_rule in 124 | match tp_of_gtm gtm with 125 | | GRcdTp (lbls, _) when List.mem lbl lbls -> 126 | L.global @@ Eval.gproj lbl gtm 127 | | _ -> 128 | L.throw TypeError 129 | 130 | let fst (syn_rule : syn_rule) : syn_rule = 131 | proj "fst" syn_rule 132 | 133 | let snd (syn_rule : syn_rule) : syn_rule = 134 | proj "snd" syn_rule 135 | 136 | let sg (base : tp_rule) (fam : gtm -> tp_rule) : tp_rule = 137 | rcd_tp @@ 138 | tl_cons "fst" base @@ fun var -> 139 | tl_cons "snd" (fam var) @@ fun _ -> 140 | tl_nil 141 | 142 | let pair (chk_rule0 : chk_rule) (chk_rule1 : chk_rule) : chk_rule = 143 | StringMap.empty 144 | |> StringMap.add "fst" chk_rule0 145 | |> StringMap.add "snd" chk_rule1 146 | |> rcd 147 | 148 | let chk_abort : chk_rule = 149 | fun _ -> 150 | let* thy = L.theory in 151 | match Logic.consistency thy with 152 | | `Inconsistent -> L.ret LAbort 153 | | `Consistent -> L.throw TypeError 154 | 155 | 156 | let rec conv_ : gtm -> chk_rule = 157 | function 158 | | GTt -> tt 159 | | GFf -> ff 160 | | GLam (_, ltm, env) -> 161 | lam @@ fun var gfib -> 162 | let* gtm = L.global @@ inst_tm_fam ltm env var in 163 | conv_ gtm gfib 164 | | GRcd (_, _, gmap) -> 165 | rcd @@ StringMap.map conv_ gmap 166 | | Glued glued -> 167 | conv_glued_ glued 168 | | GAbort -> 169 | chk_abort 170 | 171 | 172 | and conv_glued_ : (gneu, ltm) glued -> chk_rule = 173 | fun (Gl glued) gtp -> 174 | let* gtm = L.global @@ G.local glued.env @@ Eval.eval glued.part in 175 | let* () = Equate.equate_gtp gtp glued.gtp in 176 | let* thy = L.theory in 177 | if Logic.test thy [] glued.supp then 178 | conv_ gtm gtp 179 | else 180 | conv_neu_ glued.base 181 | 182 | and conv_neu_ : gneu -> ltm L.m = 183 | function 184 | | GVar lvl -> 185 | let+ env = L.env in 186 | let ix = Env.lvl_to_ix env lvl in 187 | LVar ix 188 | 189 | | GSnoc (gneu, gfrm) -> 190 | let* ltm = conv_neu_ gneu in 191 | match gfrm with 192 | | GProj lbl -> L.ret @@ LProj (lbl, ltm) 193 | | GApp arg -> 194 | let* ltm = conv_neu_ gneu in 195 | let tp_arg = tp_of_gtm arg in 196 | let* larg = conv_ arg tp_arg in 197 | L.ret @@ LApp (ltm, larg) 198 | 199 | let conv : syn_rule -> chk_rule = 200 | fun syn gtp -> 201 | let* gtm = syn in 202 | conv_ gtm gtp 203 | 204 | 205 | let fail_tp exn = L.throw exn 206 | let fail_chk exn _ = L.throw exn 207 | let fail_syn exn = L.throw exn 208 | -------------------------------------------------------------------------------- /core/Eval.ml: -------------------------------------------------------------------------------- 1 | open Basis 2 | open Syntax 3 | open Effect 4 | 5 | exception Impossible 6 | 7 | module rec Eval : sig 8 | val eval : ltm -> gtm lm 9 | val eval_tp : ltp -> gtp lm 10 | val eval_tele : ltele -> gtele lm 11 | val eval_prop : lprop -> gprop lm 12 | end = 13 | struct 14 | open Compute 15 | open Monad.Notation (L) 16 | 17 | module LStringMapUtil = Monad.MapUtil (L) (StringMap) 18 | 19 | let rec eval : ltm -> gtm lm = 20 | fun ltm -> 21 | match ltm with 22 | | LLam (gfam, ltm) -> 23 | let+ env = L.env in 24 | GLam (gfam, ltm, env) 25 | | LVar ix -> 26 | let* env = L.env in 27 | begin 28 | match Env.proj env ix with 29 | | `Tm x -> L.ret x 30 | | _ -> L.throw Impossible 31 | end 32 | | LTt -> L.ret GTt 33 | | LFf -> L.ret GFf 34 | | LApp (ltm0, ltm1) -> 35 | let* gtm0 = eval ltm0 in 36 | let* gtm1 = eval ltm1 in 37 | L.global @@ gapp gtm0 gtm1 38 | | LProj (lbl, ltm) -> 39 | let* gtm = eval ltm in 40 | L.global @@ gproj lbl gtm 41 | | LRcd (lbls, gtele, lmap) -> 42 | let+ gmap = LStringMapUtil.flat_map eval lmap in 43 | GRcd (lbls, gtele, gmap) 44 | | LAbort -> 45 | L.ret GAbort 46 | 47 | and eval_tp : ltp -> gtp lm = 48 | function 49 | | LPi (lbase, lfam) -> 50 | let* gbase = eval_tp lbase in 51 | let+ env = L.env in 52 | GPi (gbase, lfam, env) 53 | | LBool -> 54 | L.ret GBool 55 | | LRcdTp (lbls, ltl) -> 56 | let+ gtl = eval_tele ltl in 57 | GRcdTp (lbls, gtl) 58 | | LAbortTp -> 59 | L.ret GAbortTp 60 | | LTpVar ix -> 61 | let* env = L.env in 62 | begin 63 | match Env.proj env ix with 64 | | `Tp x -> L.ret x 65 | | _ -> L.throw Impossible 66 | end 67 | 68 | and eval_tele : ltele -> gtele lm = 69 | function 70 | | LTlNil -> L.ret GTlNil 71 | | LTlCons (ltp, ltele) -> 72 | let* gtp = eval_tp ltp in 73 | let+ env = L.env in 74 | GTlCons (gtp, ltele, env) 75 | 76 | let eval_prop : lprop -> gprop lm = 77 | function 78 | | PTop -> L.ret PTop 79 | | PBot -> L.ret PBot 80 | | PVar ix -> 81 | let* env = L.env in 82 | begin 83 | match Env.proj env ix with 84 | | `Prop x -> L.ret x 85 | | _ -> L.throw Impossible 86 | end 87 | 88 | end 89 | and Compute : sig 90 | val whnf : gtm -> gtm gm 91 | val whnf_tp : gtp -> gtp gm 92 | 93 | val gapp : gtm -> gtm -> gtm gm 94 | val gproj : string -> gtm -> gtm gm 95 | end = 96 | struct 97 | open Eval 98 | open Monad.Notation (G) 99 | 100 | let guard ~abort m = 101 | let* thy = G.theory in 102 | match Logic.consistency thy with 103 | | `Consistent -> m 104 | | `Inconsistent -> G.ret abort 105 | 106 | 107 | let rec whnf : gtm -> gtm gm = 108 | fun gtm -> 109 | proj_part gtm @@ gtm_bdry gtm |>> 110 | function 111 | | `Done -> G.ret gtm 112 | | `Step gtm -> whnf gtm 113 | 114 | and whnf_tp : gtp -> gtp gm = 115 | fun gtp -> 116 | proj_tp_part gtp (gtp_bdry gtp) |>> 117 | function 118 | | `Done -> G.ret gtp 119 | | `Step gtp -> whnf_tp gtp 120 | 121 | and tp_of_rcd_field lbls gtl lbl gtm = 122 | guard ~abort:GAbortTp @@ 123 | match lbls, gtl with 124 | | [], GTlNil -> 125 | G.throw Impossible 126 | | lbl' :: _, GTlCons (gtp, _, _) when lbl = lbl' -> 127 | G.ret gtp 128 | | lbl' :: lbls, GTlCons (_, ltl, env) -> 129 | let* gtm = gproj lbl' gtm in 130 | let* gtl' = G.local env @@ L.append_tm gtm @@ eval_tele ltl in 131 | tp_of_rcd_field lbls gtl' lbl gtm 132 | | _ -> 133 | G.throw Impossible 134 | 135 | and proj_part : gtm -> ltm part -> [`Done | `Step of gtm] gm = 136 | fun gtm (Prt part) -> 137 | let* thy = G.theory in 138 | if Logic.test thy [] part.supp then 139 | let+ gtm = G.local part.env @@ eval part.part in 140 | `Step gtm 141 | else 142 | G.ret `Done 143 | 144 | and proj_tp_part : gtp -> ltp part -> [`Done | `Step of gtp] gm = 145 | fun gtp (Prt part) -> 146 | let* thy = G.theory in 147 | if Logic.test thy [] part.supp then 148 | let+ gtp = G.local part.env @@ eval_tp part.part in 149 | `Step gtp 150 | else 151 | G.ret `Done 152 | 153 | 154 | and gapp gtm0 gtm1 = 155 | guard ~abort:GAbort @@ 156 | match gtm0 with 157 | | GLam (_, ltm, tm_env) -> 158 | G.local (Env.append tm_env @@ `Tm gtm1) @@ eval ltm 159 | | Glued glued -> 160 | let+ glued' = gapp_glued glued gtm1 in 161 | Glued glued' 162 | | _ -> 163 | G.throw Impossible 164 | 165 | and gproj lbl gtm = 166 | guard ~abort:GAbort @@ 167 | match gtm with 168 | | GRcd (_, _, gmap) -> 169 | begin 170 | match StringMap.find_opt lbl gmap with 171 | | Some gtm -> G.ret gtm 172 | | None -> G.throw Impossible 173 | end 174 | | Glued glued -> 175 | let+ glued' = gproj_glued lbl glued in 176 | Glued glued' 177 | | _ -> 178 | G.throw Impossible 179 | 180 | and gapp_glued (Gl glued) arg = 181 | whnf_tp glued.gtp |>> function 182 | | GPi (gtp, lfam, env) -> 183 | let supp = glued.supp in 184 | let base = GSnoc (glued.base, GApp arg) in 185 | let part, env = 186 | let env = glued.env in 187 | let lvl = Env.fresh env in 188 | let env = Env.append env @@ `Tm arg in 189 | LApp (glued.part, LVar (Env.lvl_to_ix env lvl)), env 190 | in 191 | let+ gfib = G.local env @@ L.append_tm arg @@ eval_tp lfam in 192 | Gl {gtp = gfib; base; supp; part; env} 193 | | _ -> 194 | G.throw Impossible 195 | 196 | and gproj_glued lbl (Gl glued) = 197 | whnf_tp glued.gtp |>> 198 | function 199 | | GRcdTp (lbls, gtl) -> 200 | let+ gtp = tp_of_rcd_field lbls gtl lbl (Glued (Gl glued)) in 201 | let supp = glued.supp in 202 | let base = GSnoc (glued.base, GProj lbl) in 203 | let part, env = LProj (lbl, glued.part), glued.env in 204 | Gl {gtp; base; supp; part; env} 205 | | _ -> 206 | G.throw Impossible 207 | end 208 | 209 | include Eval 210 | include Compute 211 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Apache License 2 | Version 2.0, January 2004 3 | http://www.apache.org/licenses/ 4 | 5 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 6 | 7 | 1. Definitions. 8 | 9 | "License" shall mean the terms and conditions for use, reproduction, 10 | and distribution as defined by Sections 1 through 9 of this document. 11 | 12 | "Licensor" shall mean the copyright owner or entity authorized by 13 | the copyright owner that is granting the License. 14 | 15 | "Legal Entity" shall mean the union of the acting entity and all 16 | other entities that control, are controlled by, or are under common 17 | control with that entity. For the purposes of this definition, 18 | "control" means (i) the power, direct or indirect, to cause the 19 | direction or management of such entity, whether by contract or 20 | otherwise, or (ii) ownership of fifty percent (50%) or more of the 21 | outstanding shares, or (iii) beneficial ownership of such entity. 22 | 23 | "You" (or "Your") shall mean an individual or Legal Entity 24 | exercising permissions granted by this License. 25 | 26 | "Source" form shall mean the preferred form for making modifications, 27 | including but not limited to software source code, documentation 28 | source, and configuration files. 29 | 30 | "Object" form shall mean any form resulting from mechanical 31 | transformation or translation of a Source form, including but 32 | not limited to compiled object code, generated documentation, 33 | and conversions to other media types. 34 | 35 | "Work" shall mean the work of authorship, whether in Source or 36 | Object form, made available under the License, as indicated by a 37 | copyright notice that is included in or attached to the work 38 | (an example is provided in the Appendix below). 39 | 40 | "Derivative Works" shall mean any work, whether in Source or Object 41 | form, that is based on (or derived from) the Work and for which the 42 | editorial revisions, annotations, elaborations, or other modifications 43 | represent, as a whole, an original work of authorship. For the purposes 44 | of this License, Derivative Works shall not include works that remain 45 | separable from, or merely link (or bind by name) to the interfaces of, 46 | the Work and Derivative Works thereof. 47 | 48 | "Contribution" shall mean any work of authorship, including 49 | the original version of the Work and any modifications or additions 50 | to that Work or Derivative Works thereof, that is intentionally 51 | submitted to Licensor for inclusion in the Work by the copyright owner 52 | or by an individual or Legal Entity authorized to submit on behalf of 53 | the copyright owner. For the purposes of this definition, "submitted" 54 | means any form of electronic, verbal, or written communication sent 55 | to the Licensor or its representatives, including but not limited to 56 | communication on electronic mailing lists, source code control systems, 57 | and issue tracking systems that are managed by, or on behalf of, the 58 | Licensor for the purpose of discussing and improving the Work, but 59 | excluding communication that is conspicuously marked or otherwise 60 | designated in writing by the copyright owner as "Not a Contribution." 61 | 62 | "Contributor" shall mean Licensor and any individual or Legal Entity 63 | on behalf of whom a Contribution has been received by Licensor and 64 | subsequently incorporated within the Work. 65 | 66 | 2. Grant of Copyright License. Subject to the terms and conditions of 67 | this License, each Contributor hereby grants to You a perpetual, 68 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 69 | copyright license to reproduce, prepare Derivative Works of, 70 | publicly display, publicly perform, sublicense, and distribute the 71 | Work and such Derivative Works in Source or Object form. 72 | 73 | 3. Grant of Patent License. Subject to the terms and conditions of 74 | this License, each Contributor hereby grants to You a perpetual, 75 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 76 | (except as stated in this section) patent license to make, have made, 77 | use, offer to sell, sell, import, and otherwise transfer the Work, 78 | where such license applies only to those patent claims licensable 79 | by such Contributor that are necessarily infringed by their 80 | Contribution(s) alone or by combination of their Contribution(s) 81 | with the Work to which such Contribution(s) was submitted. If You 82 | institute patent litigation against any entity (including a 83 | cross-claim or counterclaim in a lawsuit) alleging that the Work 84 | or a Contribution incorporated within the Work constitutes direct 85 | or contributory patent infringement, then any patent licenses 86 | granted to You under this License for that Work shall terminate 87 | as of the date such litigation is filed. 88 | 89 | 4. Redistribution. You may reproduce and distribute copies of the 90 | Work or Derivative Works thereof in any medium, with or without 91 | modifications, and in Source or Object form, provided that You 92 | meet the following conditions: 93 | 94 | (a) You must give any other recipients of the Work or 95 | Derivative Works a copy of this License; and 96 | 97 | (b) You must cause any modified files to carry prominent notices 98 | stating that You changed the files; and 99 | 100 | (c) You must retain, in the Source form of any Derivative Works 101 | that You distribute, all copyright, patent, trademark, and 102 | attribution notices from the Source form of the Work, 103 | excluding those notices that do not pertain to any part of 104 | the Derivative Works; and 105 | 106 | (d) If the Work includes a "NOTICE" text file as part of its 107 | distribution, then any Derivative Works that You distribute must 108 | include a readable copy of the attribution notices contained 109 | within such NOTICE file, excluding those notices that do not 110 | pertain to any part of the Derivative Works, in at least one 111 | of the following places: within a NOTICE text file distributed 112 | as part of the Derivative Works; within the Source form or 113 | documentation, if provided along with the Derivative Works; or, 114 | within a display generated by the Derivative Works, if and 115 | wherever such third-party notices normally appear. The contents 116 | of the NOTICE file are for informational purposes only and 117 | do not modify the License. You may add Your own attribution 118 | notices within Derivative Works that You distribute, alongside 119 | or as an addendum to the NOTICE text from the Work, provided 120 | that such additional attribution notices cannot be construed 121 | as modifying the License. 122 | 123 | You may add Your own copyright statement to Your modifications and 124 | may provide additional or different license terms and conditions 125 | for use, reproduction, or distribution of Your modifications, or 126 | for any such Derivative Works as a whole, provided Your use, 127 | reproduction, and distribution of the Work otherwise complies with 128 | the conditions stated in this License. 129 | 130 | 5. Submission of Contributions. Unless You explicitly state otherwise, 131 | any Contribution intentionally submitted for inclusion in the Work 132 | by You to the Licensor shall be under the terms and conditions of 133 | this License, without any additional terms or conditions. 134 | Notwithstanding the above, nothing herein shall supersede or modify 135 | the terms of any separate license agreement you may have executed 136 | with Licensor regarding such Contributions. 137 | 138 | 6. Trademarks. This License does not grant permission to use the trade 139 | names, trademarks, service marks, or product names of the Licensor, 140 | except as required for reasonable and customary use in describing the 141 | origin of the Work and reproducing the content of the NOTICE file. 142 | 143 | 7. Disclaimer of Warranty. Unless required by applicable law or 144 | agreed to in writing, Licensor provides the Work (and each 145 | Contributor provides its Contributions) on an "AS IS" BASIS, 146 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 147 | implied, including, without limitation, any warranties or conditions 148 | of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A 149 | PARTICULAR PURPOSE. You are solely responsible for determining the 150 | appropriateness of using or redistributing the Work and assume any 151 | risks associated with Your exercise of permissions under this License. 152 | 153 | 8. Limitation of Liability. In no event and under no legal theory, 154 | whether in tort (including negligence), contract, or otherwise, 155 | unless required by applicable law (such as deliberate and grossly 156 | negligent acts) or agreed to in writing, shall any Contributor be 157 | liable to You for damages, including any direct, indirect, special, 158 | incidental, or consequential damages of any character arising as a 159 | result of this License or out of the use or inability to use the 160 | Work (including but not limited to damages for loss of goodwill, 161 | work stoppage, computer failure or malfunction, or any and all 162 | other commercial damages or losses), even if such Contributor 163 | has been advised of the possibility of such damages. 164 | 165 | 9. Accepting Warranty or Additional Liability. While redistributing 166 | the Work or Derivative Works thereof, You may choose to offer, 167 | and charge a fee for, acceptance of support, warranty, indemnity, 168 | or other liability obligations and/or rights consistent with this 169 | License. However, in accepting such obligations, You may act only 170 | on Your own behalf and on Your sole responsibility, not on behalf 171 | of any other Contributor, and only if You agree to indemnify, 172 | defend, and hold each Contributor harmless for any liability 173 | incurred by, or claims asserted against, such Contributor by reason 174 | of your accepting any such warranty or additional liability. 175 | 176 | END OF TERMS AND CONDITIONS 177 | 178 | APPENDIX: How to apply the Apache License to your work. 179 | 180 | To apply the Apache License to your work, attach the following 181 | boilerplate notice, with the fields enclosed by brackets "[]" 182 | replaced with your own identifying information. (Don't include 183 | the brackets!) The text should be enclosed in the appropriate 184 | comment syntax for the file format. We also recommend that a 185 | file or class name and description of purpose be included on the 186 | same "printed page" as the copyright notice for easier 187 | identification within third-party archives. 188 | 189 | Copyright 2021 Jonathan Sterling 190 | 191 | Licensed under the Apache License, Version 2.0 (the "License"); 192 | you may not use this file except in compliance with the License. 193 | You may obtain a copy of the License at 194 | 195 | http://www.apache.org/licenses/LICENSE-2.0 196 | 197 | Unless required by applicable law or agreed to in writing, software 198 | distributed under the License is distributed on an "AS IS" BASIS, 199 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 200 | See the License for the specific language governing permissions and 201 | limitations under the License. 202 | --------------------------------------------------------------------------------