28 Aoû '20
Laurent Huberdeau pushed new branch laurent/elab_cache at Stefan / Typer
--
View it on GitLab: https://gitlab.com/monnier/typer/-/tree/laurent/elab_cache
You're receiving this email because of your account on gitlab.com.
3
6
Laurent Huberdeau pushed to branch laurent/elab_cache at Stefan / Typer
Commits:
d5df9cb4 by Laurent at 2020-08-25T14:17:53-04:00
Many changes
- - - - -
3 changed files:
- src/elab.ml
- src/serialization.ml
- src/serialization_types
Changes:
=====================================
src/elab.ml
=====================================
@@ -1802,14 +1802,16 @@ let sform_load usr_elctx loc sargs ot =
let file_string = String.concat "" (read_lines file_path) in
let file_hash = Hashtbl.hash file_string in
let cached_file_name = file_name ^ string_of_int file_hash in
- let cached_file_path = "cache/" ^ cached_file_name ^ ".tco" in
+ (* Different serialized value if in pervasive *)
+ let cached_file_path = if !in_pervasive
+ then "cache/" ^ cached_file_name ^ ".ptco"
+ else "cache/" ^ cached_file_name ^ ".tco" in
if Sys.file_exists cached_file_path then
let store_str = String.concat "" (read_lines cached_file_path) in
let store = Serialization_types_j.store_of_string store_str in
- let dsctx: Serialization.dsctx = { lexp_refs = Hashtbl.create 1000; subst_refs = Hashtbl.create 1000 } in
- let res = Serialization.deserialize_lexp dsctx store 0 in
- (res, Lazy)
+ let tuple = Serialization.deserialize_lexp store in
+ (tuple, Lazy)
else
(* get lexp_context *)
@@ -1834,10 +1836,8 @@ let sform_load usr_elctx loc sargs ot =
else
(Lexp.mkSusp tuple (S.shift (usr_len - dflt_len))) in
- (* Cache result *)
- let sctx: Serialization.sctx = {
- lexp_refs = Serialization.LexpMap.create 1000;
- subst_refs = Serialization.SubstMap.create 1000 } in
+ (* Save result to disk *)
+ let sctx: Serialization.sctx = { lexp_refs = Serialization.LexpMap.create 1000 } in
let _ = Serialization.serialize_lexp sctx tuple' in
let store = Serialization.sctxToStore sctx in
=====================================
src/serialization.ml
=====================================
@@ -6,40 +6,41 @@ open Util
open Prelexer
open Serialization_types_j
-module LexpMap = Hashtbl.Make (struct type t = Lexp.lexp let hash = Hashtbl.hash let equal = (==) end)
-module SubstMap = Hashtbl.Make (struct type t = Lexp.subst let hash = Hashtbl.hash let equal = (==) end)
+type lexp_or_subst =
+ | Lexp of Lexp.lexp
+ | Subst of Lexp.subst
+
+module LexpMap = Hashtbl.Make
+ (struct type t = lexp_or_subst let hash = Hashtbl.hash let equal = (==) end)
(* Serialization context
- HashMap from lexp/subst to the position of the serialized lexp/subst when serialized.
- The serialized value is also stored as an optional but should always
- contain an element after serialize_lexp finishes. *)
+ HashMap from lexp/subst to the position of the serialized lexp/subst when
+ serialized. *)
type sctx = {
- lexp_refs: (int * Serialization_types_j.lexp option) LexpMap.t;
- subst_refs: (int * Serialization_types_j.subst_lexp option) SubstMap.t;
+ lexp_refs: (int * Serialization_types_j.lexp) LexpMap.t;
}
(* Deserialization context *)
type dsctx = {
- lexp_refs: (int, Lexp.lexp) Hashtbl.t;
- subst_refs: (int, Lexp.subst) Hashtbl.t;
+ lexp_refs: (lexp_or_subst option) array;
}
-(* Raised in `sctxToStore` when the option invariant of sctx is false. *)
-exception MissingSerializedValue
+(* Raised when deserialization fails because the TCO object is corrupted. *)
+exception CorruptedSerializedObject
(* Converts from the serialization context to the final, serialization format *)
let sctxToStore (sctx: sctx): Serialization_types_j.store =
- let toElem (k, (ix, e)) = match e with
- | Some x -> (ix, x)
- | None -> raise MissingSerializedValue in
+ let toElem (_, (_, e)) = e in
+ let cmpIx (_, (i1, _)) (_, (i2, _)) = compare i1 i2 in
{
- lexp_refs = List.of_seq (Seq.map toElem (LexpMap.to_seq sctx.lexp_refs));
- subst_refs = List.of_seq (Seq.map toElem (SubstMap.to_seq sctx.subst_refs));
+ lexp_refs = List.map toElem (* Index of entry == index in the array *)
+ (List.sort cmpIx (* Sort the entries by their index *)
+ (List.of_seq (LexpMap.to_seq sctx.lexp_refs)))
}
(* Functions serializing lexp and its components.
Because of hash consing, sharing must be preserved for lexp and subst.
- Other components are serialized as values and copied whenever encountered. (TODO: May be an optimization?)
+ Other components are serialized as values and copied.
*)
let serialize_loc (loc: Util.location): Serialization_types_j.location =
{ file=loc.file;
@@ -62,86 +63,133 @@ let rec serialize_pretoken (pretok: Prelexer.pretoken): Serialization_types_j.pr
match pretok with
| Pretoken (loc, str) -> `Pretoken (serialize_loc loc, str)
| Prestring (loc, str) -> `Prestring (serialize_loc loc, str)
- | Preblock (loc1, ptks, loc2) -> `Preblock (serialize_loc loc1, List.map serialize_pretoken ptks, serialize_loc loc2)
+ | Preblock (loc1, ptks, loc2) ->
+ `Preblock ( serialize_loc loc1
+ , List.map serialize_pretoken ptks, serialize_loc loc2)
let rec serialize_sexp (exp: Sexp.sexp): Serialization_types_j.sexp =
match exp with
- | Block (loc1, ptks, loc2) -> `Block (serialize_loc loc1, List.map serialize_pretoken ptks, serialize_loc loc2)
+ | Block (loc1, ptks, loc2) -> `Block (serialize_loc loc1
+ , List.map serialize_pretoken ptks
+ , serialize_loc loc2)
| Symbol (loc, str) -> `Symbol (serialize_loc loc, str)
| String (loc, str) -> `String (serialize_loc loc, str)
| Integer (loc, num) -> `Integer (serialize_loc loc, num)
| Float (loc, fl) -> `Float (serialize_loc loc, fl)
- | Node (s, ss) -> `Node (serialize_sexp s, List.map serialize_sexp ss)
+ | Node (s, ss) -> `Node ( serialize_sexp s
+ , List.map serialize_sexp ss)
let rec serialize_subst_lexp (sctx: sctx) (exp: Lexp.subst): Serialization_types_j.subst_lexp_ref =
- match SubstMap.find_opt sctx.subst_refs exp with
+ match LexpMap.find_opt sctx.lexp_refs (Subst exp) with
| Some (ix, _) -> ix
| None ->
- let ix = SubstMap.length sctx.subst_refs in
- let addToCtx v = SubstMap.replace sctx.subst_refs exp (ix, Some v); ix in
- SubstMap.replace sctx.subst_refs exp (ix, None);
- (* let addToCtx v = let k = SubstMap.length sctx.subst_refs in SubstMap.replace sctx.subst_refs exp (k, v); k in *)
- match exp with
- | Identity db_offset -> addToCtx (`Identity db_offset)
- | Cons (lexp, subst, db_offset) -> addToCtx (`Cons (serialize_lexp sctx lexp, serialize_subst_lexp sctx subst, db_offset))
-
- and serialize_lexp (sctx: sctx) (exp: Lexp.lexp): int =
- match LexpMap.find_opt sctx.lexp_refs exp with
+ let addToCtx v =
+ let ix = LexpMap.length sctx.lexp_refs in
+ LexpMap.replace sctx.lexp_refs (Subst exp) (ix, v); ix in
+ addToCtx (match exp with
+ | Identity db_offset -> `SubstIdentity db_offset
+ | Cons (lexp, subst, db_offset) -> `SubstCons
+ ( serialize_lexp sctx lexp
+ , serialize_subst_lexp sctx subst
+ , db_offset))
+
+ and serialize_lexp (sctx: sctx) (exp: Lexp.lexp): lexp_ref =
+ match LexpMap.find_opt sctx.lexp_refs (Lexp exp) with
| Some (ix, _) -> ix
| None ->
- let ix = LexpMap.length sctx.lexp_refs in
- LexpMap.replace sctx.lexp_refs exp (ix, None);
- let addToCtx v = LexpMap.replace sctx.lexp_refs exp (ix, Some v); ix in
- match exp with
- | Imm sexp -> addToCtx (`Imm (serialize_sexp sexp))
- | Sort (loc, Stype lexp) -> addToCtx (`Sort (serialize_loc loc, `Stype (serialize_lexp sctx lexp)))
- | Sort (loc, StypeOmega) -> addToCtx (`Sort (serialize_loc loc, `StypeOmega))
- | Sort (loc, StypeLevel) -> addToCtx (`Sort (serialize_loc loc, `StypeLevel))
- | SortLevel SLz -> addToCtx (`SortLevel `SLz)
- | SortLevel (SLsucc lexp) -> addToCtx (`SortLevel (`SLsucc (serialize_lexp sctx lexp)))
- | SortLevel (SLlub (lexp1, lexp2)) -> addToCtx (`SortLevel (`SLlub (serialize_lexp sctx lexp1, serialize_lexp sctx lexp2)))
- | Var ((loc, mayName), db_ix) -> addToCtx (`Var ((serialize_loc loc, mayName), db_ix))
- | Builtin (sym, lexp, atts) ->
+ let addToCtx v =
+ let ix = LexpMap.length sctx.lexp_refs in
+ LexpMap.replace sctx.lexp_refs (Lexp exp) (ix, v); ix in
+ addToCtx (match exp with
+ | Imm sexp ->
+ `Imm (serialize_sexp sexp)
+
+ | Sort (loc, Stype lexp) ->
+ `Sort (serialize_loc loc, `Stype (serialize_lexp sctx lexp))
+
+ | Sort (loc, StypeOmega) ->
+ `Sort (serialize_loc loc, `StypeOmega)
+
+ | Sort (loc, StypeLevel) ->
+ `Sort (serialize_loc loc, `StypeLevel)
+
+ | SortLevel SLz ->
+ `SortLevel `SLz
+
+ | SortLevel (SLsucc lexp) ->
+ `SortLevel (`SLsucc (serialize_lexp sctx lexp))
+
+ | SortLevel (SLlub (lexp1, lexp2)) ->
+ `SortLevel (`SLlub (serialize_lexp sctx lexp1, serialize_lexp sctx lexp2))
+
+ | Var ((loc, mayName), db_ix) ->
+ `Var ((serialize_loc loc, mayName), db_ix)
+
+ | Builtin (sym, lexp, atts) ->
let serialize_att ((i, s), lexp) = ((i, s), serialize_lexp sctx lexp) in
- addToCtx (`Builtin ( serialize_symbol sym
- , serialize_lexp sctx lexp
- , Option.map (fun atts -> List.of_seq (Seq.map serialize_att (AttributeMap.to_seq atts))) atts))
+ `Builtin ( serialize_symbol sym
+ , serialize_lexp sctx lexp
+ , Option.map (fun atts -> List.of_seq
+ (Seq.map serialize_att
+ (AttributeMap.to_seq atts)))
+ atts)
- | Susp (lexp, subst_lexp) -> addToCtx (`Susp (serialize_lexp sctx lexp, serialize_subst_lexp sctx subst_lexp))
- | Let (loc, bindings, lexp) ->
- let serialize_binding (vname, lexp, ltype) = (serialize_vname vname, serialize_lexp sctx lexp, serialize_lexp sctx ltype) in
- addToCtx (`Let (serialize_loc loc, List.map serialize_binding bindings, serialize_lexp sctx lexp))
+ | Susp (lexp, subst_lexp) ->
+ `Susp (serialize_lexp sctx lexp, serialize_subst_lexp sctx subst_lexp)
+
+ | Let (loc, bindings, lexp) ->
+ let serialize_binding (vname, lexp, ltype) =
+ (serialize_vname vname, serialize_lexp sctx lexp, serialize_lexp sctx ltype) in
+ `Let (serialize_loc loc, List.map serialize_binding bindings, serialize_lexp sctx lexp)
| Arrow (arg_kind, vname, lexp1, a_loc, lexp2) ->
- addToCtx (`Arrow ( serialize_arg_kind arg_kind
- , serialize_vname vname
- , serialize_lexp sctx lexp1
- , serialize_loc a_loc
- , serialize_lexp sctx lexp2))
+ `Arrow ( serialize_arg_kind arg_kind
+ , serialize_vname vname
+ , serialize_lexp sctx lexp1
+ , serialize_loc a_loc
+ , serialize_lexp sctx lexp2)
+
+ | Lambda (arg_kind, vname, lexp1, lexp2) ->
+ `Lambda ( serialize_arg_kind arg_kind
+ , serialize_vname vname
+ , serialize_lexp sctx lexp1
+ , serialize_lexp sctx lexp2)
- | Lambda (arg_kind, vname, lexp1, lexp2) -> addToCtx (`Lambda (serialize_arg_kind arg_kind, serialize_vname vname, serialize_lexp sctx lexp1, serialize_lexp sctx lexp2))
| Call (fun_exp, args) ->
- let serialize_arg (arg_kind, arg_exp) = (serialize_arg_kind arg_kind, serialize_lexp sctx arg_exp) in
- addToCtx (`Call (serialize_lexp sctx fun_exp, List.map serialize_arg args))
+ let serialize_arg (arg_kind, arg_exp) =
+ (serialize_arg_kind arg_kind, serialize_lexp sctx arg_exp) in
+ `Call (serialize_lexp sctx fun_exp
+ , List.map serialize_arg args)
+
| Inductive (loc, sym, l1, l2) ->
- let serialize_elem (arg_kind, vname, lexp) = (serialize_arg_kind arg_kind, serialize_vname vname, serialize_lexp sctx lexp) in
+ let serialize_elem (arg_kind, vname, lexp) =
+ (serialize_arg_kind arg_kind, serialize_vname vname, serialize_lexp sctx lexp) in
let serialize_map (key, e) = (key, List.map serialize_elem e) in
- addToCtx (`Inductive ( serialize_loc loc
- , serialize_symbol sym
- , List.map serialize_elem l1
- , List.of_seq (Seq.map serialize_map (SMap.to_seq l2))
- ))
- | Cons (lexp, sym) -> addToCtx (`Cons (serialize_lexp sctx lexp, serialize_symbol sym))
+ `Inductive ( serialize_loc loc
+ , serialize_symbol sym
+ , List.map serialize_elem l1
+ , List.of_seq (Seq.map serialize_map (SMap.to_seq l2))
+ )
+ | Cons (lexp, sym) ->
+ `Cons (serialize_lexp sctx lexp, serialize_symbol sym)
+
| Case (loc, lexp, ltype, cases, default) ->
- let serialize_arg (arg_kind, vname) = (serialize_arg_kind arg_kind, serialize_vname vname) in
- let serialize_case (k, (loc, args, lexp)) = (k, (serialize_loc loc, List.map serialize_arg args, serialize_lexp sctx lexp)) in
- let serialize_default (vname, lexp) = (serialize_vname vname, serialize_lexp sctx lexp) in
- addToCtx (`Case ( serialize_loc loc
- , serialize_lexp sctx lexp
- , serialize_lexp sctx ltype
- , List.of_seq (Seq.map serialize_case (SMap.to_seq cases))
- , Option.map serialize_default default))
- | Metavar (meta_id, subst_lexp, vname) -> addToCtx (`Metavar (meta_id, serialize_subst_lexp sctx subst_lexp, serialize_vname vname))
+ let serialize_arg (arg_kind, vname) =
+ (serialize_arg_kind arg_kind, serialize_vname vname) in
+ let serialize_case (k, (loc, args, lexp)) =
+ (k, (serialize_loc loc, List.map serialize_arg args, serialize_lexp sctx lexp)) in
+ let serialize_default (vname, lexp) =
+ (serialize_vname vname, serialize_lexp sctx lexp) in
+ `Case ( serialize_loc loc
+ , serialize_lexp sctx lexp
+ , serialize_lexp sctx ltype
+ , List.of_seq (Seq.map serialize_case (SMap.to_seq cases))
+ , Option.map serialize_default default)
+
+ | Metavar (meta_id, subst_lexp, vname) ->
+ `Metavar ( meta_id
+ , serialize_subst_lexp sctx subst_lexp
+ , serialize_vname vname))
(* Deserialization functions *)
let deserialize_loc (loc: Serialization_types_j.location): Util.location =
@@ -163,80 +211,146 @@ let deserialize_arg_kind (arg_kind: Serialization_types_j.arg_kind): Pexp.arg_ki
let rec deserialize_pretoken (pretok: Serialization_types_j.pretoken): Prelexer.pretoken =
match pretok with
- | `Pretoken (loc, str) -> Pretoken (deserialize_loc loc, str)
- | `Prestring (loc, str) -> Prestring (deserialize_loc loc, str)
- | `Preblock (loc1, ptks, loc2) -> Preblock (deserialize_loc loc1, List.map deserialize_pretoken ptks, deserialize_loc loc2)
+ | `Pretoken (loc, str) ->
+ Pretoken (deserialize_loc loc, str)
+ | `Prestring (loc, str) ->
+ Prestring (deserialize_loc loc, str)
+ | `Preblock (loc1, ptks, loc2) ->
+ Preblock ( deserialize_loc loc1
+ , List.map deserialize_pretoken ptks
+ , deserialize_loc loc2)
let rec deserialize_sexp (exp: Serialization_types_j.sexp): Sexp.sexp =
match exp with
- | `Block (loc1, ptks, loc2) -> Block (deserialize_loc loc1, List.map deserialize_pretoken ptks, deserialize_loc loc2)
- | `Symbol (loc, str) -> Symbol (deserialize_loc loc, str)
- | `String (loc, str) -> String (deserialize_loc loc, str)
- | `Integer (loc, num) -> Integer (deserialize_loc loc, num)
- | `Float (loc, fl) -> Float (deserialize_loc loc, fl)
- | `Node (s, ss) -> Node (deserialize_sexp s, List.map deserialize_sexp ss)
-
-let rec deserialize_subst_lexp (dsctx: dsctx) (store: Serialization_types_j.store) (ref: Serialization_types_j.subst_lexp_ref): Lexp.subst =
- match Hashtbl.find_opt dsctx.subst_refs ref with
- | Some subst -> subst
- | None -> match List.assoc_opt ref store.subst_refs with
- | None -> raise MissingSerializedValue
- | Some (`Identity db_offset) -> Identity db_offset
- | Some (`Cons (lexp, subst, db_offset)) -> Cons (deserialize_lexp dsctx store lexp, deserialize_subst_lexp dsctx store subst, db_offset)
-
- and deserialize_lexp (dsctx: dsctx) (store: Serialization_types_j.store) (ref: Serialization_types_j.lexp_ref): Lexp.lexp =
- match Hashtbl.find_opt dsctx.lexp_refs ref with
- | Some subst -> subst
- | None -> Lexp.hc (match List.assoc_opt ref store.lexp_refs with
- | None -> raise MissingSerializedValue
- | Some (`Imm sexp) -> Imm (deserialize_sexp sexp)
- | Some (`Sort (loc, (`Stype lexp))) -> Sort (deserialize_loc loc, Stype (deserialize_lexp dsctx store lexp))
- | Some (`Sort (loc, `StypeOmega)) -> Sort (deserialize_loc loc, StypeOmega)
- | Some (`Sort (loc, `StypeLevel)) -> Sort (deserialize_loc loc, StypeLevel)
- | Some (`SortLevel `SLz) -> SortLevel SLz
- | Some (`SortLevel (`SLsucc lexp)) -> SortLevel (SLsucc (deserialize_lexp dsctx store lexp))
- | Some (`SortLevel (`SLlub (lexp1, lexp2))) -> SortLevel (SLlub (deserialize_lexp dsctx store lexp1, deserialize_lexp dsctx store lexp2))
- | Some (`Var ((loc, mayName), db_ix)) -> Var ((deserialize_loc loc, mayName), db_ix)
- | Some (`Builtin (sym, lexp, atts)) ->
- let deserialize_att ((i, s), lexp) = ((i, s), deserialize_lexp dsctx store lexp) in
- Builtin ( deserialize_symbol sym
- , deserialize_lexp dsctx store lexp
- , Option.map (fun atts -> AttributeMap.of_seq (Seq.map deserialize_att (List.to_seq atts))) atts)
- | Some (`Susp (lexp, subst_lexp)) -> Susp (deserialize_lexp dsctx store lexp, deserialize_subst_lexp dsctx store subst_lexp)
- | Some (`Let (loc, bindings, lexp)) ->
- let deserialize_binding (vname, lexp, ltype) = (deserialize_vname vname, deserialize_lexp dsctx store lexp, deserialize_lexp dsctx store ltype) in
- Let (deserialize_loc loc, List.map deserialize_binding bindings, deserialize_lexp dsctx store lexp)
-
- | Some (`Arrow (arg_kind, vname, lexp1, a_loc, lexp2)) ->
- Arrow ( deserialize_arg_kind arg_kind
- , deserialize_vname vname
- , deserialize_lexp dsctx store lexp1
- , deserialize_loc a_loc
- , deserialize_lexp dsctx store lexp2)
-
-
- | Some (`Inductive (loc, sym, l1, l2)) ->
- let deserialize_elem (arg_kind, vname, lexp) = (deserialize_arg_kind arg_kind, deserialize_vname vname, deserialize_lexp dsctx store lexp) in
- let deserialize_map (key, e) = (key, List.map deserialize_elem e) in
- Inductive ( deserialize_loc loc
- , deserialize_symbol sym
- , List.map deserialize_elem l1
- , SMap.of_seq (Seq.map deserialize_map (List.to_seq l2))
- )
-
- | Some (`Lambda (arg_kind, vname, lexp1, lexp2)) -> Lambda (deserialize_arg_kind arg_kind, deserialize_vname vname, deserialize_lexp dsctx store lexp1, deserialize_lexp dsctx store lexp2)
- | Some (`Call (fun_exp, args)) ->
- let deserialize_arg (arg_kind, arg_exp) = (deserialize_arg_kind arg_kind, deserialize_lexp dsctx store arg_exp) in
- Call (deserialize_lexp dsctx store fun_exp, List.map deserialize_arg args)
-
- | Some (`Cons (lexp, sym)) -> Cons (deserialize_lexp dsctx store lexp, deserialize_symbol sym)
- | Some (`Case (loc, lexp, ltype, cases, default)) ->
- let deserialize_arg (arg_kind, vname) = (deserialize_arg_kind arg_kind, deserialize_vname vname) in
- let deserialize_case (k, (loc, args, lexp)) = (k, (deserialize_loc loc, List.map deserialize_arg args, deserialize_lexp dsctx store lexp)) in
- let deserialize_default (vname, lexp) = (deserialize_vname vname, deserialize_lexp dsctx store lexp) in
- Case ( deserialize_loc loc
- , deserialize_lexp dsctx store lexp
- , deserialize_lexp dsctx store ltype
- , SMap.of_seq (Seq.map deserialize_case (List.to_seq cases))
- , Option.map deserialize_default default)
- | Some (`Metavar (meta_id, subst_lexp, vname)) -> Metavar (meta_id, deserialize_subst_lexp dsctx store subst_lexp, deserialize_vname vname))
+ | `Block (loc1, ptks, loc2) ->
+ Block (deserialize_loc loc1, List.map deserialize_pretoken ptks, deserialize_loc loc2)
+ | `Symbol (loc, str) ->
+ Symbol (deserialize_loc loc, str)
+ | `String (loc, str) ->
+ String (deserialize_loc loc, str)
+ | `Integer (loc, num) ->
+ Integer (deserialize_loc loc, num)
+ | `Float (loc, fl) ->
+ Float (deserialize_loc loc, fl)
+ | `Node (s, ss) ->
+ Node (deserialize_sexp s, List.map deserialize_sexp ss)
+
+let rec lookup_subst (dsctx: dsctx) (index: Serialization_types_j.subst_lexp_ref): Lexp.subst =
+ match Array.get dsctx.lexp_refs index with
+ | Some (Subst subst) -> subst
+ | _ -> raise CorruptedSerializedObject
+
+ and lookup_lexp (dsctx: dsctx) (index: Serialization_types_j.lexp_ref): Lexp.lexp =
+ match Array.get dsctx.lexp_refs index with
+ | Some (Lexp lexp) -> lexp
+ | _ -> raise CorruptedSerializedObject
+
+ and deserialize_lexp (store: Serialization_types_j.store): Lexp.lexp =
+ let count = List.length store.lexp_refs in
+ let dsctx: dsctx = { lexp_refs = Array.make count None } in
+ for i = 0 to count - 1 do
+ deserialize_lexp_step dsctx store i
+ done;
+ lookup_lexp dsctx (count - 1)
+
+ and deserialize_lexp_step (dsctx: dsctx) (store: Serialization_types_j.store) (index: Serialization_types_j.lexp_ref) =
+ let add_val_to_cxt (v : lexp_or_subst): unit =
+ Array.set dsctx.lexp_refs index (Some v) in
+
+ add_val_to_cxt (match List.nth store.lexp_refs index with
+ | `Imm sexp -> Lexp (Lexp.mkImm (deserialize_sexp sexp))
+
+ | `Sort (loc, (`Stype lexp)) ->
+ Lexp (Lexp.mkSort (deserialize_loc loc, Stype (lookup_lexp dsctx lexp)))
+
+ | `Sort (loc, `StypeOmega) ->
+ Lexp (Lexp.mkSort (deserialize_loc loc, StypeOmega))
+
+ | `Sort (loc, `StypeLevel) ->
+ Lexp (Lexp.mkSort (deserialize_loc loc, StypeLevel))
+
+ | `SortLevel `SLz ->
+ Lexp (Lexp.mkSortLevel SLz)
+
+ | `SortLevel (`SLsucc lexp) ->
+ Lexp (Lexp.mkSortLevel (Lexp.mkSLsucc (lookup_lexp dsctx lexp)))
+
+ | `SortLevel (`SLlub (lexp1, lexp2)) ->
+ Lexp (Lexp.mkSortLevel (Lexp.mkSLlub' (lookup_lexp dsctx lexp1, lookup_lexp dsctx lexp2)))
+
+ | `Var ((loc, mayName), db_ix) ->
+ Lexp (Lexp.mkVar ((deserialize_loc loc, mayName), db_ix))
+
+ | `Builtin (sym, lexp, atts) ->
+ let deserialize_att ((i, s), lexp) = ((i, s), lookup_lexp dsctx lexp) in
+ Lexp (Lexp.mkBuiltin ( deserialize_symbol sym
+ , lookup_lexp dsctx lexp
+ , Option.map (fun atts ->
+ AttributeMap.of_seq
+ (Seq.map deserialize_att
+ (List.to_seq atts))) atts))
+
+ | `Susp (lexp, subst_lexp) ->
+ Lexp (Lexp.mkSusp (lookup_lexp dsctx lexp) (lookup_subst dsctx subst_lexp))
+
+ | `Let (loc, bindings, lexp)->
+ let deserialize_binding (vname, lexp, ltype) =
+ (deserialize_vname vname, lookup_lexp dsctx lexp, lookup_lexp dsctx ltype) in
+ Lexp (Lexp.mkLet ( deserialize_loc loc
+ , List.map deserialize_binding bindings
+ , lookup_lexp dsctx lexp))
+
+ | `Arrow (arg_kind, vname, lexp1, a_loc, lexp2) ->
+ Lexp (Lexp.mkArrow ( deserialize_arg_kind arg_kind
+ , deserialize_vname vname
+ , lookup_lexp dsctx lexp1
+ , deserialize_loc a_loc
+ , lookup_lexp dsctx lexp2))
+
+ | `Inductive (loc, sym, l1, l2) ->
+ let deserialize_elem (arg_kind, vname, lexp) =
+ (deserialize_arg_kind arg_kind, deserialize_vname vname, lookup_lexp dsctx lexp) in
+ let deserialize_map (key, e) = (key, List.map deserialize_elem e) in
+ Lexp (Lexp.mkInductive ( deserialize_loc loc
+ , deserialize_symbol sym
+ , List.map deserialize_elem l1
+ , SMap.of_seq (Seq.map deserialize_map (List.to_seq l2))))
+
+ | `Lambda (arg_kind, vname, lexp1, lexp2) ->
+ Lexp (Lexp.mkLambda ( deserialize_arg_kind arg_kind
+ , deserialize_vname vname
+ , lookup_lexp dsctx lexp1
+ , lookup_lexp dsctx lexp2))
+
+ | `Call (fun_exp, args) ->
+ let deserialize_arg (arg_kind, arg_exp) =
+ (deserialize_arg_kind arg_kind, lookup_lexp dsctx arg_exp) in
+ Lexp (Lexp.mkCall ( lookup_lexp dsctx fun_exp
+ , List.map deserialize_arg args))
+
+ | `Cons (lexp, sym) ->
+ Lexp (Lexp.mkCons (lookup_lexp dsctx lexp, deserialize_symbol sym))
+
+ | `Case (loc, lexp, ltype, cases, default) ->
+ let deserialize_arg (arg_kind, vname) =
+ (deserialize_arg_kind arg_kind, deserialize_vname vname) in
+ let deserialize_case (k, (loc, args, lexp)) =
+ (k, (deserialize_loc loc, List.map deserialize_arg args, lookup_lexp dsctx lexp)) in
+ let deserialize_default (vname, lexp) =
+ (deserialize_vname vname, lookup_lexp dsctx lexp) in
+ Lexp (Lexp.mkCase ( deserialize_loc loc
+ , lookup_lexp dsctx lexp
+ , lookup_lexp dsctx ltype
+ , SMap.of_seq (Seq.map deserialize_case (List.to_seq cases))
+ , Option.map deserialize_default default))
+
+ | `Metavar (meta_id, subst_lexp, vname) ->
+ Lexp (Lexp.mkMetavar ( meta_id
+ , lookup_subst dsctx subst_lexp
+ , deserialize_vname vname))
+
+ | `SubstIdentity db_offset ->
+ Subst (Identity db_offset)
+
+ | `SubstCons (lexp, subst, db_offset) ->
+ Subst (Cons (lookup_lexp dsctx lexp, lookup_subst dsctx subst, db_offset)))
=====================================
src/serialization_types
=====================================
@@ -1,6 +1,12 @@
+(*Types for serialiation of lexps
+ Very similar to the types in lexp.ml and sexp.ml, except that recursive
+ types are replaced with the index of the object pointed to in the
+ serialization store.
+ *)
+(* TODO: Find way to automatically generate them to reduce duplication *)
+
type store = {
- lexp_refs: (int * lexp) list;
- subst_refs: (int * subst_lexp) list;
+ lexp_refs: lexp list;
}
type location = {
@@ -39,10 +45,6 @@ type vref = (vname * db_index)
type lexp_ref = int
type subst_lexp_ref = int
-type subst_lexp = [
- | Identity of db_offset
- | Cons of (lexp_ref * subst_lexp_ref * db_offset)
-]
type arg_kind = [ Anormal | Aimplicit | Aerasable ]
@@ -66,6 +68,8 @@ type lexp = [
* (string * (location * (arg_kind * vname) list * lexp_ref)) list
* (vname * lexp_ref) option)
| Metavar of (meta_id * subst_lexp_ref * vname)
+ | SubstIdentity of db_offset
+ | SubstCons of (lexp_ref * subst_lexp_ref * db_offset)
]
type sort = [
View it on GitLab: https://gitlab.com/monnier/typer/-/commit/d5df9cb43fa33eb55fc77d0d3490f3b2c…
--
View it on GitLab: https://gitlab.com/monnier/typer/-/commit/d5df9cb43fa33eb55fc77d0d3490f3b2c…
You're receiving this email because of your account on gitlab.com.
1
0
[Git][monnier/typer][laurent/elab_cache] 2 commits: Use tco instead of json for serialized lexp files
by Laurent Huberdeau 25 Aoû '20
by Laurent Huberdeau 25 Aoû '20
25 Aoû '20
Laurent Huberdeau pushed to branch laurent/elab_cache at Stefan / Typer
Commits:
a1e36f7f by Laurent at 2020-08-25T10:27:21-04:00
Use tco instead of json for serialized lexp files
- - - - -
1cb32a06 by Laurent at 2020-08-25T14:16:55-04:00
Many changes
- - - - -
1 changed file:
- src/elab.ml
Changes:
=====================================
src/elab.ml
=====================================
@@ -1802,14 +1802,16 @@ let sform_load usr_elctx loc sargs ot =
let file_string = String.concat "" (read_lines file_path) in
let file_hash = Hashtbl.hash file_string in
let cached_file_name = file_name ^ string_of_int file_hash in
- let cached_file_path = "cache/" ^ cached_file_name ^ ".json" in
+ (* Different serialized value if in pervasive *)
+ let cached_file_path = if !in_pervasive
+ then "cache/" ^ cached_file_name ^ ".ptco"
+ else "cache/" ^ cached_file_name ^ ".tco" in
if Sys.file_exists cached_file_path then
let store_str = String.concat "" (read_lines cached_file_path) in
let store = Serialization_types_j.store_of_string store_str in
- let dsctx: Serialization.dsctx = { lexp_refs = Hashtbl.create 1000; subst_refs = Hashtbl.create 1000 } in
- let res = Serialization.deserialize_lexp dsctx store 0 in
- (res, Lazy)
+ let tuple = Serialization.deserialize_lexp store in
+ (tuple, Lazy)
else
(* get lexp_context *)
@@ -1834,10 +1836,8 @@ let sform_load usr_elctx loc sargs ot =
else
(Lexp.mkSusp tuple (S.shift (usr_len - dflt_len))) in
- (* Cache result *)
- let sctx: Serialization.sctx = {
- lexp_refs = Serialization.LexpMap.create 1000;
- subst_refs = Serialization.SubstMap.create 1000 } in
+ (* Save result to disk *)
+ let sctx: Serialization.sctx = { lexp_refs = Serialization.LexpMap.create 1000 } in
let _ = Serialization.serialize_lexp sctx tuple' in
let store = Serialization.sctxToStore sctx in
View it on GitLab: https://gitlab.com/monnier/typer/-/compare/1718b1111f11cc933aaa67e449e47c49…
--
View it on GitLab: https://gitlab.com/monnier/typer/-/compare/1718b1111f11cc933aaa67e449e47c49…
You're receiving this email because of your account on gitlab.com.
1
0
[Git][monnier/typer][ja-barszcz] 23 commits: Fix `lexp_whnf` for Case
by Jean-Alexandre Barszcz 24 Aoû '20
by Jean-Alexandre Barszcz 24 Aoû '20
24 Aoû '20
Jean-Alexandre Barszcz pushed to branch ja-barszcz at Stefan / Typer
Commits:
ecf0604b by Jean-Alexandre Barszcz at 2020-08-24T17:55:49-04:00
Fix `lexp_whnf` for Case
A substitution built with `cons`es happens all at once, in the sense
that the terms in such a list are substituted independently, and thus
should not be shifted one relative to another.
This commit removes such a shift that was made by mistake in the
computation of the WHNF of a `Case` redex. The shift caused debruijn
indexing errors in the body of branches with multiple fields.
Additionnally, this commit removes the arguments to the inductive type
from the substitution applied to the branch, since they are not bound
by the case.
- - - - -
fc0eca14 by Jean-Alexandre Barszcz at 2020-08-24T17:55:49-04:00
[WIP] Make unification symmetric
- - - - -
781bb80b by Jean-Alexandre Barszcz at 2020-08-24T17:55:49-04:00
[WIP] Handle variables earlier during unification
- - - - -
6a15b3d8 by Jean-Alexandre Barszcz at 2020-08-24T17:55:49-04:00
[WIP] experiments with Decidable and proofs
- - - - -
32df061f by Jean-Alexandre Barszcz at 2020-08-24T17:55:49-04:00
[WIP] unify instead of conv_p in sform_lambda
- - - - -
03d9edec by Jean-Alexandre Barszcz at 2020-08-24T17:55:49-04:00
[WIP] proof of Decidable (a < b)
- - - - -
a3b4be48 by Jean-Alexandre Barszcz at 2020-08-24T17:55:49-04:00
[WIP] First draft of an instance search algorithm
- - - - -
6ebb745f by Jean-Alexandre Barszcz at 2020-08-24T17:55:49-04:00
WIP WIP WIP
- - - - -
1c718ddf by Jean-Alexandre Barszcz at 2020-08-24T17:55:49-04:00
WIP WIP getting there
- - - - -
265eb152 by Jean-Alexandre Barszcz at 2020-08-24T17:55:49-04:00
[WIP] Add a set of typeclasses to the elab context
- - - - -
113e45b5 by Jean-Alexandre Barszcz at 2020-08-24T17:55:49-04:00
[WIP] Add a syntax for records
- - - - -
9e65db64 by Jean-Alexandre Barszcz at 2020-08-24T17:55:49-04:00
[WIP] Extend the Decidable sample with conjunction (dep on records)
- - - - -
9cd4cc78 by Jean-Alexandre Barszcz at 2020-08-24T17:55:49-04:00
Resolve instances in the REPL (since exprs. are not generalized)
- - - - -
7f6c7124 by Jean-Alexandre Barszcz at 2020-08-24T17:55:49-04:00
Resolve instances for recursive definitions
- - - - -
bf2ab158 by Jean-Alexandre Barszcz at 2020-08-24T17:55:49-04:00
[WIP] Do the set_getenv
IIRC these were missing to correctly handle the elab context for macro
expansion and Elab_... primitives. Perhaps it would be simpler to call
set_getenv once before macro expansion rather than everywhere where
the context can change. Needs some experimentation and tests.
- - - - -
777c472a by Jean-Alexandre Barszcz at 2020-08-24T17:55:49-04:00
Num class example
- - - - -
fc4cf72d by Jean-Alexandre Barszcz at 2020-08-24T17:55:49-04:00
Num class (with records)
- - - - -
83432703 by Jean-Alexandre Barszcz at 2020-08-24T17:55:49-04:00
Allow non-inductives to be typeclasses (Eq for instance)
- - - - -
6291b3f5 by Jean-Alexandre Barszcz at 2020-08-24T17:55:49-04:00
Move the Eq builtin to debruijn.ml to make it available for elab.
- - - - -
189bd1af by Jean-Alexandre Barszcz at 2020-08-24T17:55:49-04:00
Make Eq.refl available to the ocaml code
* src/debruijn.ml : Add a definition of the lexp for Eq.refl
* src/builtin.ml : Register the constant Eq.refl
* btl/builtins.typer (Eq_refl) : Use the builtin variable ##Eq.refl
instead of registering the builtin with the `Built-in` form. This
ensures that we have the right variable and type, and might help to
keep things in sync between the ocaml and typer code.
- - - - -
d9f84fc5 by Jean-Alexandre Barszcz at 2020-08-24T17:55:49-04:00
[WIP] Add Eq to case
- - - - -
402cde7b by Jean-Alexandre Barszcz at 2020-08-24T17:55:49-04:00
[WIP] Adding Eq to Case: mutual rec for (whnf & get_type) + conv_p of case?
- - - - -
7619fb6c by Jean-Alexandre Barszcz at 2020-08-24T19:47:59-04:00
Algebra classes sample with proofs for the additive monoid for Nats
- - - - -
21 changed files:
- btl/builtins.typer
- btl/pervasive.typer
- + btl/records.typer
- + samples/alg_classes.typer
- + samples/decidable.typer
- + samples/num_class.typer
- + samples/num_class_recs.typer
- src/REPL.ml
- src/builtin.ml
- src/debruijn.ml
- src/elab.ml
- src/eval.ml
- + src/instances.ml
- src/inverse_subst.ml
- src/lexp.ml
- src/log.ml
- src/myers.ml
- src/opslexp.ml
- src/unification.ml
- tests/elab_test.ml
- tests/unify_test.ml
Changes:
=====================================
btl/builtins.typer
=====================================
@@ -48,7 +48,7 @@ Void = typecons Void;
%% Eq : (l : TypeLevel) ≡> (t : Type_ l) ≡> t -> t -> Type_ l
%% Eq' : (l : TypeLevel) ≡> Type_ l -> Type_ l -> Type_ l
Eq_refl : ((x : ?t) ≡> Eq x x);
-Eq_refl = Built-in "Eq.refl";
+Eq_refl = ##Eq\.refl;
Eq_cast : (x : ?) ≡> (y : ?)
≡> (p : Eq x y)
@@ -363,6 +363,12 @@ Elab_isbound = Built-in "Elab.isbound" : String -> Elab_Context -> Bool;
Elab_isconstructor = Built-in "Elab.isconstructor"
: String -> Elab_Context -> Bool;
+%%
+%% Check if a symbol is an inductive in a particular context
+%%
+Elab_isinductive = Built-in "Elab.isinductive"
+ : String -> Elab_Context -> Bool;
+
%%
%% Check if the n'th field of a constructor is erasable
%% If the constructor isn't defined it will always return false
@@ -389,6 +395,20 @@ Elab_nth-arg' = Built-in "Elab.nth-arg" : String -> Int -> Elab_Context -> Strin
%%
Elab_arg-pos' = Built-in "Elab.arg-pos" : String -> String -> Elab_Context -> Int;
+%%
+%% Get the position of a field in a constructor
+%% It return -1 in case the field isn't defined
+%% see pervasive.typer for a more convenient function
+%%
+Elab_ind-ctor-arg-pos' = Built-in "Elab.ind-ctor-arg-pos" : String -> String -> String -> Elab_Context -> Int;
+
+%%
+%% Get the number of fields in a constructor
+%% It return -1 in case the field isn't defined
+%% see pervasive.typer for a more convenient function
+%%
+Elab_count-ctor-args' = Built-in "Elab.count-ctor-args" : String -> String -> Elab_Context -> Int;
+
%%
%% Get the docstring associated with a symbol
%%
=====================================
btl/pervasive.typer
=====================================
@@ -394,7 +394,7 @@ BoolMod = (##datacons
Pair = typecons (Pair (a : Type) (b : Type)) (pair (fst : a) (snd : b));
pair = datacons Pair pair;
-__\.__ =
+dot-impl =
let mksel o f =
let constructor = Sexp_node (Sexp_symbol "##datacons")
(cons (Sexp_symbol "?")
@@ -411,14 +411,15 @@ __\.__ =
(cons (Sexp_node (Sexp_symbol "_|_")
(cons o (cons branch nil)))
nil)
- in macro (lambda args
- -> IO_return
- case args
- | cons o tail
- => (case tail
- | cons f _ => mksel o f
- | nil => Sexp_error)
- | nil => Sexp_error);
+ in (lambda args ->
+ IO_return case args
+ | cons o tail
+ => (case tail
+ | cons f _ => mksel o f
+ | nil => Sexp_error)
+ | nil => Sexp_error);
+
+__\.__ = macro dot-impl;
%% Triplet (tuple with 3 values)
type Triplet (a : Type) (b : Type) (c : Type)
@@ -458,7 +459,8 @@ Not prop = prop -> False;
%% We don't use the `type` macro here because it would make these `true`
%% and `false` constructors override `Bool`'s, and we currently don't
%% want that.
-Decidable = typecons (Decidable (prop : Type_ ?ℓ))
+%% FIXME generalize typecons formal arguments
+Decidable = typecons (Decidable (ℓ ::: TypeLevel) (prop : Type_ ℓ))
(true (p ::: prop)) (false (p ::: Not prop));
%% Testing generalization in inductive type constructors.
@@ -547,6 +549,32 @@ in case (Int_eq r (-1))
| true => (none)
| false => (some r);
+%%
+%% If `Elab_ind-ctor-arg-pos'` returns (-1) it means:
+%% A- The constructor isn't defined, or
+%% B- The constructor has no argument named like this
+%%
+%% So in those case this function returns `none`
+%%
+Elab_ind-ctor-arg-pos a b c d = let
+ r = Elab_ind-ctor-arg-pos' a b c d;
+in case (Int_eq r (-1))
+ | true => (none)
+ | false => (some r);
+
+%%
+%% If `Elab_count-ctor-args'` returns (-1) it means:
+%% A- The constructor isn't defined, or
+%% B- The constructor has no argument named like this
+%%
+%% So in those case this function returns `none`
+%%
+Elab_count-ctor-args a b c = let
+ r = Elab_count-ctor-args' a b c;
+in case (Int_eq r (-1))
+ | true => (none)
+ | false => (some r);
+
%%%%
%%%% Common library
%%%%
@@ -634,6 +662,15 @@ plain-let_in_ = let lib = load "btl/plain-let.typer" in lib.plain-let-macro;
%%
_|_ = let lib = load "btl/polyfun.typer" in lib._|_;
+%%
+%% records : a simple datatype when there is only one case
+%%
+define-operator "#" 200 ();
+records = load "btl/records.typer";
+record = records.record;
+__\.__ = records.__\.__;
+_# = records._#;
+
%%%% Unit tests function for doing file
%% It's hard to do a primitive which execute test file
=====================================
btl/records.typer
=====================================
@@ -0,0 +1,82 @@
+record-impl : List Sexp -> IO Sexp;
+record-impl args =
+ let
+ %% Get a name (symbol) from a sexp
+ %% - (name t) -> name
+ %% - name -> name
+ get-name : Sexp -> Sexp;
+ get-name sxp =
+ case Sexp_wrap sxp
+ | node op _ => get-name op
+ | symbol _ => sxp
+ | _ => Sexp_error;
+
+ %% head is (Sexp_node type-name (arg list))
+ name-args = List_head Sexp_error args;
+ fields = List_tail args;
+
+ type-name = get-name name-args;
+
+ %% Create the inductive type definition.
+ inductive = Sexp_node (Sexp_symbol "typecons")
+ (cons name-args
+ (cons (Sexp_node (Sexp_symbol "rec") fields)
+ nil));
+
+ decl = make-decl type-name inductive;
+
+ in IO_return decl;
+
+record = macro record-impl;
+
+record-get-impl : List Sexp -> IO Sexp;
+record-get-impl args =
+ let
+ get tc f idx nargs ectx =
+ let arg_pats : Sexp -> Int -> Int -> List Sexp;
+ arg_pats s i n =
+ if (Int_eq n 0) then nil
+ else (if (Int_eq i 0)
+ then (cons s (arg_pats s (i - 1) (n - 1)))
+ else (cons (Sexp_symbol "_") (arg_pats s (i - 1) (n - 1))));
+
+ pat = (Sexp_node (quote (datacons (uquote (Sexp_symbol tc)) rec))
+ (arg_pats (Sexp_symbol "v") idx nargs));
+
+ branch = (quote ((uquote pat) => v));
+ in
+ (quote (lambda rec -> (##case_ (_|_ rec (uquote branch)))));
+
+ try-rec-get : List Sexp -> Elab_Context -> Option Sexp;
+ try-rec-get arg ectx =
+ case args
+ | (cons tc (cons f nil)) =>
+ (case (Sexp_wrap tc, Sexp_wrap f)
+ | (symbol tcstr, symbol fstr) =>
+ (case (Elab_count-ctor-args tcstr "rec" ectx,
+ Elab_ind-ctor-arg-pos tcstr "rec" fstr ectx)
+ | (some nargs, some idx) => some (get tcstr fstr idx nargs ectx)
+ | _ => none)
+ | _ => none)
+ | _ => none;
+ in
+ do {
+ ectx <- Elab_getenv ();
+ case try-rec-get args ectx
+ | some sxp => IO_return sxp
+ | _ => dot-impl args; %% Fallback on default dot implementation
+ };
+
+__\.__ = macro record-get-impl;
+
+record-make-impl : List Sexp -> IO Sexp;
+record-make-impl args =
+ IO_return case args
+ | (cons tc nil) => (quote (datacons (uquote tc) rec))
+ | _ => Sexp_error;
+
+_# = macro record-make-impl; %% I was going for a syntax close to
+ %% Erlang's, but the # doesn't separate
+ %% tokens ... Meh.
+
+record (Pair (a : Type) (b : Type)) (fst : a) (snd : a);
=====================================
samples/alg_classes.typer
=====================================
@@ -0,0 +1,111 @@
+case_ = ##case_; %% To ease debugging
+
+type Magma (α : Type)
+ | mkMagma (op : α -> α -> α);
+
+typeclass Magma;
+
+magma_op =
+ lambda magma_inst =>
+ case magma_inst
+ | mkMagma op => op;
+
+Associativity (op : ?α -> ?α -> ?α) =
+ (x : ?α) -> (y : ?α) -> (z : ?α) -> Eq (op (op x y) z) (op x (op y z));
+
+type Semigroup (α : Type)
+ | mkSemigroup (magma : Magma α) (assoc ::: Associativity magma_op);
+
+typeclass Semigroup;
+
+semigroup_magma =
+ lambda semigroup_inst =>
+ case semigroup_inst
+ | mkSemigroup magma => magma;
+
+IsLeftIdentity (id : ?α) (op : ?α -> ?α -> ?α) =
+ (x : ?α) -> Eq (op id x) x;
+
+IsRightIdentity (id : ?α) (op : ?α -> ?α -> ?α) =
+ (x : ?α) -> Eq (op x id) x;
+
+IsIdentity (id : ?α) (op : ?α -> ?α -> ?α) =
+ (Pair (IsLeftIdentity id op) (IsRightIdentity id op));
+
+type Monoid (α : Type)
+ | mkMonoid (semigroup : Semigroup α)
+ (identity : α)
+ (isIdent ::: IsIdentity identity magma_op);
+
+typeclass Monoid;
+
+type Nat
+ | Zero
+ | Succ Nat;
+
+plus : Nat -> Nat -> Nat;
+plus x y =
+ case x
+ | Zero => y
+ | Succ x' => Succ (plus x' y);
+
+natAdditiveMagma =
+ mkMagma plus;
+
+Eq_cong : % not sure about levels here
+ (t : (Type_ ?ℓ)) ≡> (r : (Type_ ?ℓ)) ≡>
+ (x : t) ≡> (y : t) ≡> (p : (Eq x y)) ≡>
+ (f : (t -> r)) -> (Eq (f x) (f y));
+Eq_cong f =
+ Eq_cast (p := p) (f := lambda xy -> Eq (f x) (f xy)) Eq_refl;
+
+natPlusAssoc : Associativity plus;
+natPlusAssoc x y z =
+ let
+ typeclass Eq
+ in
+ case x
+ | Zero => Eq_cast
+ (x := Zero)
+ (y := x)
+ (p := Eq_comm (instance ()))
+ (f := (lambda (Zx : Nat) -> Eq (plus (plus Zx y) z) (plus Zx (plus y z))))
+ Eq_refl
+ | Succ x' =>
+ Eq_cast
+ (x := Succ x')
+ (y := x)
+ (p := Eq_comm (instance ()))
+ (f := (lambda (sx'x : Nat) -> Eq (plus (plus sx'x y) z) (plus sx'x (plus y z))))
+ (Eq_cong (p := natPlusAssoc x' y z) Succ);
+
+natAdditiveSemigroup : Semigroup Nat;
+natAdditiveSemigroup =
+ mkSemigroup natAdditiveMagma (assoc := natPlusAssoc);
+
+zeroIsPlusLIdent : IsLeftIdentity Zero plus;
+zeroIsPlusLIdent x = Eq_refl (x := x);
+
+zeroIsPlusRIdent : IsRightIdentity Zero plus;
+zeroIsPlusRIdent x =
+ let
+ typeclass Eq;
+ in case x
+ | Zero => Eq_cast
+ (x := Zero)
+ (y := x)
+ (p := Eq_comm (instance ()))
+ (f := (lambda (Zx : Nat) ->
+ Eq (plus Zx Zero) Zx))
+ Eq_refl
+ | Succ x' => Eq_cast
+ (x := Succ x')
+ (y := x)
+ (p := Eq_comm (instance ()))
+ (f := (lambda (Sx'x : Nat) ->
+ Eq (plus Sx'x Zero) Sx'x))
+ (Eq_cong (p := zeroIsPlusRIdent x') Succ);
+
+natAdditiveMonoid : Monoid Nat;
+natAdditiveMonoid = mkMonoid natAdditiveSemigroup Zero
+ (isIdent := pair zeroIsPlusLIdent zeroIsPlusRIdent);
=====================================
samples/decidable.typer
=====================================
@@ -0,0 +1,168 @@
+False = Void;
+True = Unit;
+
+% FIXME improved "case" fails with no branches
+exfalso : False -> ?a;
+exfalso f = ##case_ f;
+
+%type Decidable (prop : Type)
+% | yes (p ::: prop)
+% | no (p ::: Not prop);
+yes = datacons Decidable true;
+no = datacons Decidable false;
+
+typeclass Decidable;
+
+Eq_trans :
+ (x : ?t) => (y : ?t) => (a : ?t) ->
+ (ax : Eq a x) => (ay : Eq a y) => Eq x y;
+Eq_trans a =
+ lambda (ax : Eq a x) (ay : Eq a y) =>
+ Eq_cast (f := lambda ax -> Eq ax y) ay;
+
+Eq_cong : % not sure about levels here
+ (t : (Type_ ?ℓ)) ≡> (r : (Type_ ?ℓ)) ≡>
+ (x : t) ≡> (y : t) ≡> (p : (Eq x y)) ≡>
+ (f : (t -> r)) -> (Eq (f x) (f y));
+Eq_cong f =
+ Eq_cast (p := p) (f := lambda xy -> Eq (f x) (f xy)) Eq_refl;
+
+discriminate_nocheck =
+ macro (lambda args ->
+ case args
+ | cons x (cons y nil) =>
+ do {
+ sd <- gensym ();
+ sp <- gensym ();
+ IO_return
+ (quote ((lambda (uquote sp) ->
+ (Eq_cast (p := (uquote sp))
+ (f := (lambda (uquote sd) ->
+ (case uquote sd
+ | (uquote x) => True
+ | _ => False)))
+ ())) : Not (Eq (uquote x) (uquote y))))
+ }
+ | _ => IO_return Sexp_error);
+
+discriminate =
+ macro (lambda args ->
+ case args
+ | cons x (cons y nil) =>
+ (case (Sexp_wrap x, Sexp_wrap y)
+ | (symbol sx, symbol sy) => % FIXME get the constructor even when its a call
+ do {
+ env <- Elab_getenv ();
+ if (and (Elab_isconstructor sx env)
+ (and (Elab_isconstructor sy env)
+ (not (Sexp_eq x y))))
+ then
+ Macro_expand discriminate_nocheck args
+ else (IO_return Sexp_error)
+ }
+ | _ => IO_return Sexp_error)
+ | _ => IO_return Sexp_error);
+
+test : (Not (Eq true false));
+test = discriminate true false;
+
+absurd =
+ lambda (p : ?prop) ->
+ lambda (contra : (Not ?prop)) ->
+ contra p;
+
+% We can't (usefully) have a `Decidable Bool` because it's
+% impossible to have a `Not Bool`. Instead, we can decide boolean
+% equality:
+
+decideBoolEq : (a : Bool) => (b : Bool) => Decidable (Eq a b);
+decideBoolEq =
+ lambda (a : Bool) (b : Bool) =>
+ case (a, b)
+ | (false, false) => yes (p := Eq_trans false)
+ | (false, true) => no (p := lambda (p : Eq a b) ->
+ absurd (Eq_trans (ax := Eq_trans a) b) (discriminate false true))
+ | (true, false) => no (p := lambda (p : Eq a b) ->
+ absurd (Eq_trans (ax := Eq_trans a) b) (discriminate true false))
+ | (true, true) => yes (p := Eq_trans true);
+
+type Nat
+ | zero
+ | succ Nat;
+
+type even (a : Nat)
+ | eZ (p ::: Eq a zero)
+ | eSS (p :: even ?a) (pss ::: Eq a (succ (succ ?a)));
+
+decideEven : (a : Nat) => Decidable (even a);
+decideEven =
+ lambda (a : Nat) =>
+ case a
+ | zero => yes (p := eZ)
+ | succ zero => no (p :=
+ lambda (p : even a) ->
+ case p
+ | eZ => absurd (Eq_trans a) (discriminate_nocheck zero (succ zero))
+ | eSS => absurd (Eq_trans a) (discriminate_nocheck (succ (succ ?)) (succ zero)))
+ | succ (succ a') =>
+ case (decideEven : Decidable (even a'))
+ | yes => yes (p := eSS)
+ | no => no (p :=
+ lambda (p : even a) ->
+ case p
+ | eZ => absurd (Eq_trans a) (discriminate_nocheck zero (succ (succ ?)))
+ | eSS => absurd (? : even a') (? : Not (even a')));
+
+type _<_ (a : Nat) (b : Nat)
+ | ltZ (pa ::: Eq a zero) (pb ::: Eq b (succ ?b))
+ | ltS (p :: (?a < ?b)) (pa ::: Eq a (succ ?a)) (pb ::: Eq b (succ ?b));
+
+decideLT : (a : Nat) => (b : Nat) => Decidable (a < b);
+decideLT =
+ lambda a b =>
+ case b
+ | zero => no (p :=
+ lambda (p : (a < b)) ->
+ case p
+ | ltZ => absurd (Eq_trans b) (discriminate_nocheck zero (succ ?))
+ | ltS => absurd (Eq_trans b) (discriminate_nocheck zero (succ ?)))
+ | succ b' =>
+ case a
+ | zero => yes (p := ltZ)
+ | succ a' =>
+ case (decideLT : (Decidable (a' < b')))
+ | yes => yes (p := ltS)
+ | no => no (p :=
+ lambda (p : (a < b)) ->
+ case p
+ | ltZ => absurd (Eq_trans a) (discriminate_nocheck zero (succ ?))
+ | ltS => absurd (? : (a' < b')) (? : Not (a' < b')));
+
+define-operator "∧" 111 130;
+
+record ((a : Type) ∧ (b : Type)) (fst : a) (snd : b);
+
+decideAnd : (P : Type) ≡> (Q : Type) ≡>
+ (Decidable P) => (Decidable Q) => (Decidable (P ∧ Q));
+decideAnd =
+ lambda P Q ≡>
+ lambda (decP : Decidable P) (decQ : Decidable Q) =>
+ case (decP, decQ)
+ | (yes (p := pP), yes (p := pQ)) => yes (p := _∧_ # pP pQ)
+ | (no (p := nP), _) =>
+ no (p := (lambda (proofs : P ∧ Q) -> absurd (_∧_.fst proofs) nP))
+ | (_, no (p := nQ)) =>
+ no (p := (lambda (proofs : P ∧ Q) -> absurd (_∧_.snd proofs) nQ));
+
+if_then_else_
+ = macro (lambda args ->
+ let e1 = List_nth 0 args Sexp_error;
+ e2 = List_nth 1 args Sexp_error;
+ e3 = List_nth 2 args Sexp_error;
+ in IO_return (quote (case (instance () : (Decidable (uquote e1)))
+ | yes => uquote e2
+ | no => uquote e3)));
+
+test2 : Bool;
+test2 = if ((even (succ zero)) ∧ (zero < zero)) then false else true;
+
=====================================
samples/num_class.typer
=====================================
@@ -0,0 +1,39 @@
+type Num (α : Type)
+ | mkNum (Num_+ : α -> α -> α)
+ (Num_- : α -> α -> α)
+ (Num_* : α -> α -> α)
+ (Num_/ : α -> α -> α);
+
+typeclass Num;
+
+_+_ = lambda numInst => case numInst | mkNum _+_ _ _ _ => _+_;
+_-_ = lambda numInst => case numInst | mkNum _ _-_ _ _ => _-_;
+_*_ = lambda numInst => case numInst | mkNum _ _ _*_ _ => _*_;
+_/_ = lambda numInst => case numInst | mkNum _ _ _ _/_ => _/_;
+
+IntNum : Num Int;
+IntNum =
+ mkNum (Num_+ := Int_+) (Num_- := Int_-) (Num_* := Int_*) (Num_/ := Int_/);
+
+IntegerNum : Num Integer;
+IntegerNum =
+ mkNum (Num_+ := Integer_+) (Num_- := Integer_-)
+ (Num_* := Integer_*) (Num_/ := Integer_/);
+
+FloatNum : Num Float;
+FloatNum =
+ mkNum (Num_+ := Float_+) (Num_- := Float_-)
+ (Num_* := Float_*) (Num_/ := Float_/);
+
+type FromInt (α : Type)
+ | mkFromInt (FromInt_fromInt : Int -> α);
+
+typeclass FromInt;
+
+fromInt = lambda fromIntInst => case fromIntInst | mkFromInt fromInt => fromInt;
+
+IntFromInt : FromInt Int;
+IntFromInt = mkFromInt (lambda x -> x);
+
+IntegerFromInt : FromInt Integer;
+IntegerFromInt = mkFromInt Int->Integer;
=====================================
samples/num_class_recs.typer
=====================================
@@ -0,0 +1,33 @@
+record (Num (α : Type))
+ (_+_ : α -> α -> α)
+ (_-_ : α -> α -> α)
+ (_*_ : α -> α -> α)
+ (_/_ : α -> α -> α);
+
+typeclass Num;
+
+_+_ = lambda numInst => Num._+_ numInst;
+_-_ = lambda numInst => Num._-_ numInst;
+_*_ = lambda numInst => Num._*_ numInst;
+_/_ = lambda numInst => Num._/_ numInst;
+
+IntNum : Num Int;
+IntNum = Num # Int_+ Int_- Int_* Int_/;
+
+IntegerNum : Num Integer;
+IntegerNum = Num # Integer_+ Integer_- Integer_* Integer_/;
+
+FloatNum : Num Float;
+FloatNum = Num # Float_+ Float_- Float_* Float_/;
+
+record (FromInt (α : Type)) (fromInt : Int -> α);
+
+typeclass FromInt;
+
+fromInt = lambda fromIntInst => FromInt.fromInt fromIntInst;
+
+IntFromInt : FromInt Int;
+IntFromInt = FromInt # (lambda x -> x);
+
+IntegerFromInt : FromInt Integer;
+IntegerFromInt = FromInt # Int->Integer;
=====================================
src/REPL.ml
=====================================
@@ -139,6 +139,7 @@ let ilexp_parse pexps lctx: ((ldecl list list * lexpr list) * elab_context) =
unparsed tokens directly instead *)
let ldecls, lctx = Elab.lexp_p_decls pdecls [] lctx in
let lexprs = Elab.lexp_parse_all pexprs lctx in
+ List.iter Elab.resolve_instances lexprs;
List.iter (fun lxp -> ignore (OL.check (ectx_to_lctx lctx) lxp))
lexprs;
(ldecls, lexprs), lctx
=====================================
src/builtin.ml
=====================================
@@ -99,19 +99,6 @@ let dloc = DB.dloc
let op_binary t = mkArrow (Anormal, (dloc, None), t, dloc,
mkArrow (Anormal, (dloc, None), t, dloc, t))
-let type_eq =
- let lv = (dloc, Some "l") in
- let tv = (dloc, Some "t") in
- mkArrow (Aerasable, lv,
- DB.type_level, dloc,
- mkArrow (Aerasable, tv,
- mkSort (dloc, Stype (mkVar (lv, 0))), dloc,
- mkArrow (Anormal, (dloc, None),
- mkVar (tv, 0), dloc,
- mkArrow (Anormal, (dloc, None),
- mkVar (tv, 1), dloc,
- mkSort (dloc, Stype (mkVar (lv, 3)))))))
-
let o2l_bool ctx b = get_predef (if b then "true" else "false") ctx
(* Typer list as seen during runtime. *)
@@ -161,7 +148,9 @@ let register_builtin_csts () =
add_builtin_cst "Integer" DB.type_integer;
add_builtin_cst "Float" DB.type_float;
add_builtin_cst "String" DB.type_string;
- add_builtin_cst "Elab_Context" DB.type_elabctx
+ add_builtin_cst "Elab_Context" DB.type_elabctx;
+ add_builtin_cst "Eq" DB.type_eq;
+ add_builtin_cst "Eq.refl" DB.eq_refl
let register_builtin_types () =
let _ = new_builtin_type "Sexp" DB.type0 in
@@ -175,7 +164,6 @@ let register_builtin_types () =
"Array" (mkArrow (Anormal, (dloc, None),
DB.type0, dloc, DB.type0)) in
let _ = new_builtin_type "FileHandle" DB.type0 in
- let _ = new_builtin_type "Eq" type_eq in
()
let _ = register_builtin_csts ();
=====================================
src/debruijn.ml
=====================================
@@ -94,6 +94,37 @@ let type_integer = mkBuiltin ((dloc, "Integer"), type0, None)
let type_float = mkBuiltin ((dloc, "Float"), type0, None)
let type_string = mkBuiltin ((dloc, "String"), type0, None)
let type_elabctx = mkBuiltin ((dloc, "Elab_Context"), type0, None)
+let type_eq_type =
+ let lv = (dloc, Some "l") in
+ let tv = (dloc, Some "t") in
+ mkArrow (Aerasable, lv,
+ type_level, dloc,
+ mkArrow (Aerasable, tv,
+ mkSort (dloc, Stype (mkVar (lv, 0))), dloc,
+ mkArrow (Anormal, (dloc, None),
+ mkVar (tv, 0), dloc,
+ mkArrow (Anormal, (dloc, None),
+ mkVar (tv, 1), dloc,
+ mkSort (dloc, Stype (mkVar (lv, 3)))))))
+let type_eq = mkBuiltin ((dloc, "Eq"), type_eq_type, None)
+let eq_refl =
+ let lv = (dloc, Some "l") in
+ let tv = (dloc, Some "t") in
+ let xv = (dloc, Some "x") in
+ mkBuiltin ((dloc, "Eq.refl"),
+ mkArrow (Aerasable, lv,
+ type_level, dloc,
+ mkArrow (Aerasable, tv,
+ mkSort (dloc, Stype (mkVar (lv, 0))), dloc,
+ mkArrow (Aerasable, xv,
+ mkVar (tv, 0), dloc,
+ mkCall (type_eq,
+ [Aerasable, mkVar (lv, 2);
+ Aerasable, mkVar (tv, 1);
+ Anormal, mkVar (xv, 0);
+ Anormal, mkVar (xv, 0)])))),
+ None)
+
(* easier to debug with type annotations *)
type env_elem = (vname * varbind * ltype)
@@ -112,26 +143,29 @@ type meta_scope
* lctx_length (* Length of ctx when the scope is added. *)
* (meta_id SMap.t ref) (* Metavars already known in this scope. *)
+type typeclass_ctx
+ = (ltype * lctx_length) list (* FIXME make it a set of lexps ? *)
+
(* This is the *elaboration context* (i.e. a context that holds
* a lexp context plus some side info. *)
type elab_context
- = Grammar.grammar * senv_type * lexp_context * meta_scope
+ = Grammar.grammar * senv_type * lexp_context * meta_scope * typeclass_ctx
let get_size (ctx : elab_context)
- = let (_, (n, _), lctx, _) = ctx in
+ = let (_, (n, _), lctx, _, _) = ctx in
assert (n = M.length lctx); n
let ectx_to_grm (ectx : elab_context) : Grammar.grammar =
- let (grm,_, _, _) = ectx in grm
+ let (grm,_, _, _, _) = ectx in grm
(* Extract the lexp context from the context used during elaboration. *)
let ectx_to_lctx (ectx : elab_context) : lexp_context =
- let (_,_, lctx, _) = ectx in lctx
+ let (_,_, lctx, _, _) = ectx in lctx
-let ectx_to_scope_level ((_, _, _, (sl, _, _)) : elab_context) : scope_level
+let ectx_to_scope_level ((_, _, _, (sl, _, _), _) : elab_context) : scope_level
= sl
-let ectx_local_scope_size ((_, (n, _), _, (_, slen, _)) as ectx) : int
+let ectx_local_scope_size ((_, (n, _), _, (_, slen, _), _) as ectx) : int
= get_size ectx - slen
(* Public methods: DO USE
@@ -142,7 +176,7 @@ let empty_lctx = M.nil
let empty_elab_context : elab_context
= (Grammar.default_grammar, empty_senv, empty_lctx,
- (0, 0, ref SMap.empty))
+ (0, 0, ref SMap.empty), [])
(* senv_lookup caller were using Not_found exception *)
exception Senv_Lookup_Fail of (string list)
@@ -150,7 +184,7 @@ let senv_lookup_fail relateds = raise (Senv_Lookup_Fail relateds)
(* Return its current DeBruijn index. *)
let senv_lookup (name: string) (ctx: elab_context): int =
- let (_, (n, map), _, _) = ctx in
+ let (_, (n, map), _, _, _) = ctx in
try n - (SMap.find name map) - 1
with Not_found
-> let get_related_names (n : db_ridx) name map =
@@ -189,11 +223,11 @@ let lctx_extend (ctx : lexp_context) (def: vname) (v: varbind) (t: lexp) =
let env_extend_rec (ctx: elab_context) (def: vname) (v: varbind) (t: lexp) =
let (loc, oname) = def in
- let (grm, (n, map), env, sl) = ctx in
+ let (grm, (n, map), env, sl, tcctx) = ctx in
let nmap = match oname with None -> map | Some name -> SMap.add name n map in
(grm, (n + 1, nmap),
lexp_ctx_cons env def v t,
- sl)
+ sl, tcctx)
let ectx_extend (ctx: elab_context) (def: vname) (v: varbind) (t: lexp) = env_extend_rec ctx def v t
@@ -207,28 +241,33 @@ let lctx_extend_rec (ctx : lexp_context) (defs: (vname * lexp * ltype) list) =
ctx
let ectx_extend_rec (ctx: elab_context) (defs: (vname * lexp * ltype) list) =
- let (grm, (n, senv), lctx, sl) = ctx in
+ let (grm, (n, senv), lctx, sl, tcctx) = ctx in
let senv', _ = List.fold_left
(fun (senv, i) ((_, oname), _, _) ->
(match oname with None -> senv
| Some name -> SMap.add name i senv),
i + 1)
(senv, n) defs in
- (grm, (n + List.length defs, senv'), lctx_extend_rec lctx defs, sl)
+ (grm, (n + List.length defs, senv'), lctx_extend_rec lctx defs, sl, tcctx)
let ectx_new_scope (ectx : elab_context) : elab_context =
- let (grm, senv, lctx, (scope, _, rmmap)) = ectx in
- (grm, senv, lctx, (scope + 1, Myers.length lctx, ref (!rmmap)))
+ let (grm, senv, lctx, (scope, _, rmmap), tcctx) = ectx in
+ (grm, senv, lctx, (scope + 1, Myers.length lctx, ref (!rmmap)), tcctx)
let ectx_get_scope (ectx : elab_context) : meta_scope =
- let (_, _, _, sl) = ectx in sl
+ let (_, _, _, sl, _) = ectx in sl
let ectx_get_grammar (ectx : elab_context) : Grammar.grammar =
- let (grm, _, _, _) = ectx in grm
+ let (grm, _, _, _, _) = ectx in grm
let env_lookup_by_index index (ctx: lexp_context): env_elem =
Myers.nth index ctx
+let env_add_typeclass (ectx : elab_context) (t : ltype) : elab_context =
+ let (grm, senv, lctx, sl, tcctx) = ectx in
+ let ntcctx = ((t, get_size ectx) :: tcctx) in
+ (grm, senv, lctx, sl, ntcctx)
+
(* Print context *)
let print_lexp_ctx_n (ctx : lexp_context) start =
let n = (M.length ctx) - 1 in
=====================================
src/elab.ml
=====================================
@@ -57,6 +57,7 @@ open Grammar
module BI = Builtin
module Unif = Unification
+module Inst = Instances
module OL = Opslexp
module EL = Elexp
@@ -257,6 +258,13 @@ let newMetavar (ctx : lexp_context) sl name t =
let meta = Unif.create_metavar ctx sl t in
mkMetavar (meta, S.identity, name)
+let newInstanceMetavar (ctx : elab_context) name t =
+ let lctx = ectx_to_lctx ctx in
+ let sl = ectx_to_scope_level ctx in
+ let meta = Unif.create_metavar lctx sl t in
+ Inst.add_instance_metavar meta ctx (fst name);
+ mkMetavar (meta, S.identity, name)
+
let newMetalevel (ctx : lexp_context) sl loc =
newMetavar ctx sl (loc, Some "ℓ") type_level
@@ -280,8 +288,8 @@ let sdform_define_operator (ctx : elab_context) loc sargs _ot : elab_context =
| Symbol (_, "") -> None
| Integer (_, n) -> Some n
| _ -> sexp_error (sexp_location s) "Expecting an integer or ()"; None in
- let (grm, a, b, c) = ctx in
- (SMap.add name (level l, level r) grm, a, b, c)
+ let (grm, a, b, c, d) = ctx in
+ (SMap.add name (level l, level r) grm, a, b, c, d)
| [o; _; _]
-> sexp_error (sexp_location o) "Expecting a string"; ctx
| _
@@ -466,11 +474,11 @@ let rec meta_to_var ids (e : lexp) =
-> let ncases
= SMap.map
(fun (l, fields, e)
- -> (l, fields, loop (o + List.length fields) e))
+ -> (l, fields, loop (o + List.length fields + 1) e))
cases in
mkCase (l, loop o e, loop o t, ncases,
match default with None -> None
- | Some (v, e) -> Some (v, loop (1 + o) e))
+ | Some (v, e) -> Some (v, loop (2 + o) e))
| Metavar (id, s, name)
-> if IMap.mem id ids then
mkVar (name, o + count - IMap.find id ids)
@@ -625,12 +633,83 @@ and get_implicit_arg ctx loc oname t =
and instantiate_implicit e t ctx =
let rec instantiate t args =
match OL.lexp_whnf t (ectx_to_lctx ctx) with
+ | Arrow ((Aerasable | Aimplicit) as ak, (_, v), t1, _, t2) when Inst.is_typeclass ctx t1
+ -> let arg = newInstanceMetavar ctx (lexp_location e, v) t1 in
+ instantiate (mkSusp t2 (S.substitute arg)) ((ak, arg)::args)
| Arrow ((Aerasable | Aimplicit) as ak, (_, v), t1, _, t2)
-> let arg = get_implicit_arg ctx (lexp_location e) v t1 in
instantiate (mkSusp t2 (S.substitute arg)) ((ak, arg)::args)
| _ -> (mkCall (e, List.rev args), t)
in instantiate t []
+and myers_filter_map_index (f : int -> 'a -> 'b option) (m : 'a M.myers)
+ : ('b M.myers)
+ = snd (M.fold_right
+ (fun x (i, l') ->
+ match (f i x) with
+ | Some y -> (i - 1, M.cons y l')
+ | None -> (i - 1, l'))
+ m (M.length m - 1, M.nil))
+
+and search_instance (ctx : elab_context) (loc : location) (t : ltype) : lexp option =
+ Log.log_debug ~loc ("Searching for t = `" ^ (lexp_string t) ^ "`");
+ let ctx = ectx_new_scope ctx in
+ let lctx = (ectx_to_lctx ctx) in
+ let sl = (ectx_to_scope_level ctx) in
+ let env_elem_match (i : int) (elem : DB.env_elem) : (int * DB.env_elem * lexp * ltype) option =
+ let ((_, namopt), _, t') = elem in
+ let var = mkVar ((loc,namopt), i) in
+ let t' = mkSusp t' (S.shift (i + 1)) in
+ let (e, t') = instantiate_implicit var t' ctx in
+ (* All candidates should have a type that is a typeclass *)
+ if not (Inst.is_typeclass ctx t') then None else
+ match Inst.check_typeclass_match t t' lctx sl with
+ | (Impossible | Possible) -> None
+ (* | Possible -> None *)
+ | (Match) -> Some (i, elem, e, t') in
+ let candidates =
+ myers_filter_map_index env_elem_match lctx in
+ Log.log_debug ("Candidates for instance of type `" ^ lexp_string t ^ "`:")
+ ~print_action:(fun () ->
+ M.iter (fun (i, ((_, so),_,t'),_, _) ->
+ lalign_print_int i 4;
+ lalign_print_string (match so with | Some s -> s | None -> "<none>") 10;
+ print_endline (lexp_string t')) candidates);
+ match M.safe_car candidates with
+ | None -> None
+ | Some (i, (vname, _, t'),e,t) ->
+ let t' = mkSusp t' (S.shift (i + 1)) in
+ Log.log_debug ~loc
+ ("Found candidate at index " ^ (string_of_int i) ^ ": `" ^
+ (lexp_string (Var (vname, i))) ^ " : " ^ (lexp_string t') ^ "`");
+ Some e
+
+and resolve_instances e =
+ let (_, (fv_map, _)) = OL.fv e in
+ U.IMap.iter (fun i (sl, t, cl, vn) ->
+ match Inst.instance_metavar_lookup i with
+ | Some (ctx, loc) ->
+ (match search_instance ctx loc t with
+ | Some e -> Unif.associate i e; resolve_instances e
+ | None ->
+ error ~loc ("No instance found for type `" ^ (lexp_string t) ^ "`")
+ )
+ | None -> ()
+ ) fv_map
+
+
+and resolve_instances_and_generalize ctx e =
+ resolve_instances e;
+ generalize ctx e
+
+and sdform_typeclass (ctx : elab_context) loc sargs _ot : elab_context =
+ match sargs with
+ | [se] ->
+ let (t, _) = infer se ctx in
+ Inst.add_typeclass ctx t
+ | _
+ -> sexp_error loc "typeclass expects 1 argument"; ctx
+
and infer_type pexp ectx var =
(* We could also use lexp_check with an argument of the form
* Sort (?s), but in most cases the metavar would be allocated
@@ -707,7 +786,8 @@ and check_inferred ctx e inferred_t t =
-> lexp_error (lexp_location e) e
("Type mismatch("
^ (match ck with | Unif.CKimpossible -> "impossible"
- | Unif.CKresidual -> "residue")
+ | Unif.CKresidual -> "residue"
+ | _ -> failwith "impossible" )
^ ")! Context expected:\n "
^ lexp_string t ^ "\nbut expression has type:\n "
^ lexp_string inferred_t ^ "\ncan't unify:\n "
@@ -738,16 +818,16 @@ and check_case rtype (loc, target, ppatterns) ctx =
let ltarget = ref tlxp in
let get_cs_as it' lctor =
+ let unify_ind expected actual =
+ match Unif.unify actual expected (ectx_to_lctx ctx) with
+ | (_::_)
+ -> lexp_error loc lctor
+ ("Expected pattern of type `" ^ lexp_string expected
+ ^ "` but got `" ^ lexp_string actual ^ "`")
+ | [] -> () in
match !it_cs_as with
| Some (it, cs, args)
- -> let _ = match Unif.unify it' it (ectx_to_lctx ctx) with
- | (_::_)
- -> lexp_error loc lctor
- ("Expected pattern of type `"
- ^ lexp_string it ^ "` but got `"
- ^ lexp_string it' ^ "`")
- | [] -> () in
- (cs, args)
+ -> unify_ind it it'; (cs, args)
| None
-> match OL.lexp_whnf it' (ectx_to_lctx ctx) with
| Inductive (_, _, fargs, constructors)
@@ -768,6 +848,7 @@ and check_case rtype (loc, target, ppatterns) ctx =
with | Call (f, args) -> (f, args)
| _ -> (e,[]) in
let (it, targs) = call_split tltp in
+ unify_ind it it';
let constructors = match OL.lexp_whnf it (ectx_to_lctx ctx) with
| Inductive (_, _, fargs, constructors)
-> assert (List.length fargs = List.length targs);
@@ -776,14 +857,42 @@ and check_case rtype (loc, target, ppatterns) ctx =
("Can't `case` on objects of this type: "
^ lexp_string tltp);
SMap.empty in
+ it_cs_as := Some (it, constructors, targs);
(constructors, targs) in
(* Read patterns one by one *)
let fold_fun (lbranches, dflt) (pat, pexp) =
+ let shift_to_extended_ctx nctx lexp =
+ mkSusp lexp (S.shift (M.length (ectx_to_lctx nctx)
+ - M.length (ectx_to_lctx ctx))) in
+
+ let ctx_extend_with_eq nctx head_lexp =
+ (* Add a proof of equality between the target and the branch
+ head to the context *)
+ let tlxp' = shift_to_extended_ctx nctx tlxp in
+ let tltp' = shift_to_extended_ctx nctx tltp in
+ let tkind = OL.get_type (ectx_to_lctx nctx) tltp' in
+ let tlevel = (match OL.lexp_whnf tkind (ectx_to_lctx nctx) with
+ | Sort (_, Stype l) -> l
+ | _ -> error "HMMM"; DB.level0) in
+ let head_lexp_type = OL.get_type (ectx_to_lctx nctx) head_lexp in
+ (match Unif.unify tltp' head_lexp_type (ectx_to_lctx nctx) with
+ | [] -> ()
+ | constraints -> Log.log_error "Unification failed for case Eq");
+ let eqty = mkCall (DB.type_eq,
+ [(Aerasable, tlevel); (* Typelevel *)
+ (Aerasable, tltp'); (* Inductive type *)
+ (Anormal, tlxp'); (* Target lexp *)
+ (Anormal, head_lexp)]) (* Lexp of the branch head *)
+ in ctx_extend nctx (loc, None) Variable eqty
+ in
+
let add_default v =
(if dflt != None then uniqueness_warn pat);
let nctx = ctx_extend ctx v Variable tltp in
+ let head_lexp = mkVar (v, 0) in
+ let nctx = ctx_extend_with_eq nctx head_lexp in
let rtype' = mkSusp rtype (S.shift (M.length (ectx_to_lctx nctx)
- M.length (ectx_to_lctx ctx))) in
let lexp = check pexp rtype' nctx in
@@ -864,6 +973,15 @@ and check_case rtype (loc, target, ppatterns) ctx =
make_nctx nctx (ssink var s) pargs cargs pe
((ak, var)::acc) in
let nctx, fargs = make_nctx ctx subst pargs cargs SMap.empty [] in
+ let head_lexp_ctor =
+ shift_to_extended_ctx nctx
+ (mkCall (lctor, List.map (fun (_, a) -> (Aerasable, a)) targs)) in
+ let head_lexp_args =
+ List.mapi (fun i (ak, vname) ->
+ (* This is not pretty :( *)
+ (ak, mkVar (vname, List.length fargs - i - 1))) fargs in
+ let head_lexp = mkCall (head_lexp_ctor, head_lexp_args) in
+ let nctx = ctx_extend_with_eq nctx head_lexp in
let rtype' = mkSusp rtype
(S.shift (M.length (ectx_to_lctx nctx)
- M.length (ectx_to_lctx ctx))) in
@@ -946,11 +1064,13 @@ and elab_call ctx (func, ltp) (sargs: sexp list) =
(* Don't instantiate after the last explicit arg: the rest is done,
* when needed in infer_and_check (via instantiate_implicit). *)
when not (sargs = [] && SMap.is_empty pending)
- -> let larg = get_implicit_arg
- ctx (match sargs with
- | [] -> loc
- | sarg::_ -> sexp_location sarg)
- v arg_type in
+ -> let larg = if Inst.is_typeclass ctx arg_type
+ then newInstanceMetavar ctx (loc, v) arg_type
+ else get_implicit_arg
+ ctx (match sargs with
+ | [] -> loc
+ | sarg::_ -> sexp_location sarg)
+ v arg_type in
handle_fun_args ((ak, larg) :: largs) sargs pending
(L.mkSusp ret_type (S.substitute larg))
| [], _
@@ -996,7 +1116,7 @@ and lexp_parse_inductive ctors ctx =
(fun (ak, n, t) aa
-> Arrow (ak, n, t, dummy_location, aa))
acc impossible in
- let g = generalize nctx altacc in
+ let g = resolve_instances_and_generalize nctx altacc in
let altacc' = g (fun _ne vname t l e
-> Arrow (Aerasable, vname, t, l, e))
altacc in
@@ -1110,9 +1230,9 @@ and lexp_check_decls (ectx : elab_context) (* External context. *)
(* FIXME: Generalize when/where possible, so things like `map` can be
defined without type annotations! *)
(* Preserve the new operators added to nctx. *)
- let ectx = let (_, a, b, c) = ectx in
- let (grm, _, _, _) = nctx in
- (grm, a, b, c) in
+ let ectx = let (_, a, b, c, _) = ectx in
+ let (grm, _, _, _, tcctx) = nctx in
+ (grm, a, b, c, tcctx) in
let (declmap, nctx)
= List.fold_right
(fun ((l, vname), pexp) (map, nctx) ->
@@ -1122,10 +1242,11 @@ and lexp_check_decls (ectx : elab_context) (* External context. *)
| (v', ForwardRef, t)
-> let adjusted_t = push_susp t (S.shift (i + 1)) in
let e = check pexp adjusted_t nctx in
- let (grm, ec, lc, sl) = nctx in
+ resolve_instances e;
+ let (grm, ec, lc, sl, tcctx) = nctx in
let d = (v', LetDef (i + 1, e), t) in
(IMap.add i ((l, Some vname), e, t) map,
- (grm, ec, Myers.set_nth i d lc, sl))
+ (grm, ec, Myers.set_nth i d lc, sl, tcctx))
| _ -> Log.internal_error "Defining same slot!")
defs (IMap.empty, nctx) in
let decls = List.rev (List.map (fun (_, d) -> d) (IMap.bindings declmap)) in
@@ -1161,7 +1282,7 @@ and infer_and_generalize_type (ctx : elab_context) se name =
| Arrow (ak, v, t1, l, t2) -> Arrow (ak, v, t1, l, strip_rettype t2)
| Sort _ | Metavar _ -> type0 (* Abritrary closed constant. *)
| _ -> t in
- let g = generalize nctx (strip_rettype t) in
+ let g = resolve_instances_and_generalize nctx (strip_rettype t) in
g (fun _ne name t l e
-> mkArrow (Aerasable, name, t, l, e))
t
@@ -1169,7 +1290,7 @@ and infer_and_generalize_type (ctx : elab_context) se name =
and infer_and_generalize_def (ctx : elab_context) se =
let nctx = ectx_new_scope ctx in
let (e,t) = infer se nctx in
- let g = generalize nctx e in
+ let g = resolve_instances_and_generalize nctx e in
let e' = g (fun ne vname t l e
-> mkLambda ((if ne then Aimplicit else Aerasable),
vname, t, e))
@@ -1301,6 +1422,10 @@ and lexp_decls_1
-> recur [] (sdform_define_operator nctx l args None)
pending_decls pending_defs
+ | Some (Node (Symbol (l, "typeclass"), args))
+ -> recur [] (sdform_typeclass nctx l args None)
+ pending_decls pending_defs
+
| Some (Node (Symbol ((l, _) as v), sargs))
-> (* expand macro and get the generated declarations *)
let sdecl' = lexp_decls_macro v sargs nctx in
@@ -1329,10 +1454,12 @@ and lexp_p_decls (sdecls : sexp list) (tokens : token list) (ctx : elab_context)
impl sdecls tokens ctx
and lexp_parse_all (p: sexp list) (ctx: elab_context) : lexp list =
+ Eval.set_getenv ctx;
let res = List.map (fun pe -> let e, _ = infer pe ctx in e) p in
(Log.stop_on_error (); res)
and lexp_parse_sexp (ctx: elab_context) (e : sexp) : lexp =
+ Eval.set_getenv ctx;
let e, _ = infer e ctx in (Log.stop_on_error (); e)
(* --------------------------------------------------------------------------
@@ -1657,10 +1784,21 @@ let rec sform_lambda kind ctx loc sargs ot =
-> (match olt1 with
| None -> ()
| Some lt1'
- -> if not (OL.conv_p (ectx_to_lctx ctx) lt1 lt1')
- then lexp_error (lexp_location lt1') lt1'
- ("Type mismatch! Context expected `"
- ^ lexp_string lt1 ^ "`"));
+ -> (match Unif.unify lt1' lt1 (ectx_to_lctx ctx) with
+ | ((ck, _ctx, t1, t2)::_)
+ -> lexp_error (lexp_location lt1') lt1'
+ ("Type mismatch("
+ ^ (match ck with | Unif.CKimpossible -> "impossible"
+ | Unif.CKresidual -> "residue"
+ | _ -> failwith "impossible")
+ ^ ")! Context expected:\n "
+ ^ lexp_string lt1 ^ "\nbut parameter has type:\n "
+ ^ lexp_string lt1' ^ "\ncan't unify:\n "
+ ^ lexp_string t1
+ ^ "\nwith:\n "
+ ^ lexp_string t2);
+ assert (not (OL.conv_p (ectx_to_lctx ctx) lt1' lt1))
+ | [] -> ()));
mklam lt1 (Some lt2)
| Arrow (ak2, v, lt1, _, lt2) when kind = Anormal
@@ -1824,6 +1962,22 @@ let sform_load usr_elctx loc sargs ot =
(tuple',Lazy)
+(**
+ Draft of a special form "instance" that gets refers to a variable
+ of the requested type in the context.
+ **)
+let sform_instance ctx loc sargs ot =
+ match sargs, ot with
+ | ([se; _], _) -> (* Dummy param to trigger the special form *)
+ let t = infer_type se ctx (loc, None) in
+ let mv = newInstanceMetavar ctx (loc, Some "instance") t in
+ (mv, Inferred t)
+ | ([_], Some t) -> (* Dummy param to trigger the special form *)
+ let mv = newInstanceMetavar ctx (loc, Some "instance") t in
+ (mv, Checked)
+ | _ -> (sexp_error loc "##instance expects a type argument if not checked";
+ sform_dummy_ret ctx loc)
+
(* Register special forms. *)
let register_special_forms () =
List.iter add_special_form
@@ -1853,6 +2007,7 @@ let register_special_forms () =
(* FIXME: These should be functions! *)
("decltype", sform_decltype);
("declexpr", sform_declexpr);
+ ("instance", sform_instance);
]
(* Default context with builtin types
=====================================
src/eval.ml
=====================================
@@ -744,6 +744,14 @@ let constructor_p name ectx =
| _ -> false
with Senv_Lookup_Fail _ -> false
+let inductive_p name ectx =
+ try let idx = senv_lookup name ectx in
+ match OL.lexp_whnf (mkVar ((dummy_location, Some name), idx))
+ (ectx_to_lctx ectx) with
+ | Inductive _ -> true
+ | _ -> false
+ with Senv_Lookup_Fail _ -> false
+
let erasable_p name nth ectx =
let is_erasable ctors = match (smap_find_opt name ctors) with
| (Some args) ->
@@ -821,10 +829,43 @@ let ctor_arg_pos name arg ectx =
| _ -> (-1)
with Senv_Lookup_Fail _ -> (-1)
+let ind_ctor_arg_pos indname ctorname arg ectx =
+ let rec find_opt xs n = match xs with
+ | [] -> None
+ | (_, (_, Some x), _)::xs -> if x = arg then Some n else find_opt xs (n + 1)
+ | _::xs -> find_opt xs (n + 1) in
+ try let idx = senv_lookup indname ectx in
+ match OL.lexp_whnf (mkVar ((dummy_location, Some indname), idx))
+ (ectx_to_lctx ectx) with
+ | Inductive (_, _, _, ctors) ->
+ (match smap_find_opt ctorname ctors with
+ | (Some args) ->
+ (match (find_opt args 0) with
+ | None -> (-1)
+ | Some n -> n)
+ | _ -> (-1))
+ | _ -> (-1)
+ with Senv_Lookup_Fail _ -> (-1)
+
+let count_ctor_args indname ctorname ectx =
+ try let idx = senv_lookup indname ectx in
+ match OL.lexp_whnf (mkVar ((dummy_location, Some indname), idx))
+ (ectx_to_lctx ectx) with
+ | Inductive (_,_,_,ctors) ->
+ (match smap_find_opt ctorname ctors with
+ | Some args -> List.length args
+ | None -> (-1))
+ | _ -> (-1)
+ with Senv_Lookup_Fail _ -> (-1)
+
let is_constructor loc depth args_val = match args_val with
| [Vstring name; Velabctx ectx] -> o2v_bool (constructor_p name ectx)
| _ -> error loc "Elab.isconstructor takes a String and an Elab_Context as arguments"
+let is_inductive loc depth args_val = match args_val with
+ | [Vstring name; Velabctx ectx] -> o2v_bool (inductive_p name ectx)
+ | _ -> error loc "Elab.isinductive takes a String and an Elab_Context as arguments"
+
let is_nth_erasable loc depth args_val = match args_val with
| [Vstring name; Vint nth_arg; Velabctx ectx] -> o2v_bool (erasable_p name nth_arg ectx)
| _ -> error loc "Elab.is-nth-erasable takes a String, an Int and an Elab_Context as arguments"
@@ -841,6 +882,14 @@ let arg_pos loc depth args_val = match args_val with
| [Vstring t; Vstring a; Velabctx ectx] -> Vint (ctor_arg_pos t a ectx)
| _ -> error loc "Elab.arg-pos takes two String and an Elab_Context as arguments"
+let ind_ctor_arg_pos loc depth args_val = match args_val with
+ | [Vstring ind; Vstring ctor; Vstring field; Velabctx ectx] -> Vint (ind_ctor_arg_pos ind ctor field ectx)
+ | _ -> error loc "Elab.ind-ctor-arg-pos takes three String and an Elab_Context as arguments"
+
+let count_ctor_args loc depth args_val = match args_val with
+ | [Vstring ind; Vstring ctor; Velabctx ectx] -> Vint (count_ctor_args ind ctor ectx)
+ | _ -> error loc "Elab.count-ctor-args takes two String and an Elab_Context as arguments"
+
let array_append loc depth args_val = match args_val with
| [v; Varray a] ->
Varray (Array.append (Array.map (fun v -> v) a) (Array.make 1 v))
@@ -996,10 +1045,13 @@ let register_builtin_functions () =
("Elab.debug-doc", debug_doc, 2);
("Elab.isbound" , is_bound, 2);
("Elab.isconstructor", is_constructor, 2);
+ ("Elab.isinductive", is_inductive, 2);
("Elab.is-nth-erasable", is_nth_erasable, 3);
("Elab.is-arg-erasable", is_arg_erasable, 3);
("Elab.nth-arg" , nth_arg, 3);
("Elab.arg-pos" , arg_pos, 3);
+ ("Elab.ind-ctor-arg-pos", ind_ctor_arg_pos, 4);
+ ("Elab.count-ctor-args", count_ctor_args, 3);
("Array.append" , array_append,2);
("Array.create" , array_create,2);
("Array.length" , array_length,1);
=====================================
src/instances.ml
=====================================
@@ -0,0 +1,52 @@
+module Unif = Unification
+module U = Util
+module DB = Debruijn
+module L = Lexp
+module S = Subst
+module OL = Opslexp
+
+(* FIXME Is it possible to have multiple references to the same
+ instance metavar? It would break the following code *)
+let instance_metavar_table = ref (U.IMap.empty : (DB.elab_context * U.location) U.IMap.t)
+let instance_metavar_lookup (id : L.meta_id) : (DB.elab_context * U.location) option
+ = U.IMap.find_opt id (!instance_metavar_table)
+let add_instance_metavar (id : L.meta_id) (ctx : DB.elab_context) (loc : U.location) : unit
+ = instance_metavar_table := U.IMap.add id (ctx, loc) !instance_metavar_table
+
+let env_is_typeclass (ectx : DB.elab_context) (t : L.ltype) : bool =
+ let (_, _, _, _, tcctx) = ectx in
+ let cl = DB.get_size ectx in
+ List.exists (fun (t', cl') ->
+ let i = cl - cl' in
+ let t' = L.mkSusp t' (S.shift i) in
+ OL.conv_p (DB.ectx_to_lctx ectx) t t'
+ (*(Unif.unify ~checking:(max_int (* FIXME *)) t t' (DB.ectx_to_lctx ectx)) = []*)
+ ) tcctx
+
+
+let get_head (lctx : DB.lexp_context) (t : L.ltype) : L.ltype =
+ match OL.lexp_whnf t lctx with
+ | L.Call (head, _) -> head
+ | head -> head
+
+
+let is_typeclass (ctx : DB.elab_context) (t : L.ltype) =
+ let lctx = DB.ectx_to_lctx ctx in
+ let head = get_head lctx t in
+ env_is_typeclass ctx head
+
+let add_typeclass (ctx : DB.elab_context) (t : L.ltype) : DB.elab_context =
+ let lctx = DB.ectx_to_lctx ctx in
+ let head = get_head lctx t in
+ DB.env_add_typeclass ctx head
+
+type match_res = Impossible | Possible | Match
+
+let check_typeclass_match t1 t2 lctx sl =
+ match Unif.unify ~checking:sl t1 t2 lctx with
+ | [] -> Match
+ | constraints when List.exists (function | (Unif.CKimpossible,_,_,_) -> true
+ | _ -> false)
+ constraints -> Impossible
+ | _ -> Possible
+
=====================================
src/inverse_subst.ml
=====================================
@@ -300,11 +300,12 @@ and apply_inv_subst (e : lexp) (s : subst) : lexp = match e with
-> let s' = L.fold_left
(fun s (_,ov) -> ssink ov s)
s cargs in
- (l, cargs, apply_inv_subst e s'))
+ let s'' = ssink (l, None) s' in
+ (l, cargs, apply_inv_subst e s''))
cases,
match default with
| None -> default
- | Some (v,e) -> Some (v, apply_inv_subst e (ssink v s)))
+ | Some (v,e) -> Some (v, apply_inv_subst e (ssink (l, None) (ssink v s))))
| Metavar (id, s', name)
-> match metavar_lookup id with
| MVal e -> apply_inv_subst (push_susp e s') s
=====================================
src/lexp.ml
=====================================
@@ -409,11 +409,11 @@ let rec push_susp e s = (* Push a suspension one level down. *)
-> let s' = L.fold_left
(fun s (_,ov) -> ssink ov s)
s cargs in
- (l, cargs, mkSusp e s'))
+ (l, cargs, mkSusp e (ssink (l, None) s')))
cases,
match default with
| None -> default
- | Some (v,e) -> Some (v, mkSusp e (ssink v s)))
+ | Some (v,e) -> Some (v, mkSusp e (ssink (l, None) (ssink v s))))
(* Susp should never appear around Var/Susp/Metavar because mkSusp
* pushes the subst into them eagerly. IOW if there's a Susp(Var..)
* or Susp(Metavar..) it's because some chunk of code should use mkSusp
@@ -475,11 +475,12 @@ let clean e =
-> let s' = L.fold_left
(fun s (_,ov) -> ssink ov s)
s cargs in
- (l, cargs, clean s' e))
+ let s'' = ssink (l, None) s' in
+ (l, cargs, clean s'' e))
cases,
match default with
| None -> default
- | Some (v,e) -> Some (v, clean (ssink v s) e))
+ | Some (v,e) -> Some (v, clean (ssink (l, None) (ssink v s)) e))
| Susp (e, s') -> clean (scompose s' s) e
| Var _ -> if S.identity_p s then e
else clean S.identity (mkSusp e s)
=====================================
src/log.ml
=====================================
@@ -133,11 +133,13 @@ let print_entry entry =
let log_entry (entry : log_entry) =
if (entry.level <= typer_log_config.level)
then (
- log_push entry;
- if (typer_log_config.print_at_log)
+ if (typer_log_config.print_at_log ||
+ entry.level >= Debug)
then
(print_entry entry;
flush stdout)
+ else
+ log_push entry
)
let count_msgs (lvlp : log_level -> bool) =
=====================================
src/myers.ml
=====================================
@@ -54,11 +54,21 @@ let car l =
| Mnil -> raise Not_found
| Mcons (x, _, _, _) -> x
+let safe_car l =
+ match l with
+ | Mnil -> None
+ | Mcons (x, _, _, _) -> Some x
+
let cdr l =
match l with
| Mnil -> Mnil
| Mcons (_, l, _, _) -> l
+let safe_cdr l =
+ match l with
+ | Mnil -> None
+ | Mcons (_, l, _, _) -> Some l
+
let case l n c =
match l with
| Mnil -> n ()
@@ -136,3 +146,6 @@ let rec fold_right f l i = match l with
let map f l = fold_right (fun x l' -> cons (f x) l') l nil
let iteri f l = fold_left (fun i x -> f i x; i + 1) 0 l
+
+let iter (f : 'a -> unit) (l : 'a myers) : unit
+ = fold_left (fun _ x -> f x; ()) () l
=====================================
src/opslexp.ml
=====================================
@@ -38,6 +38,22 @@ module S = Subst
(* module L = List *)
module DB = Debruijn
+type set_plexp = (lexp * lexp) list
+type sort_compose_result
+ = SortResult of ltype
+ | SortInvalid
+ | SortK1NotType
+ | SortK2NotType
+type mv_set = (scope_level * ltype * ctx_length * vname) IMap.t
+ (* Metavars that appear in non-erasable positions. *)
+ * unit IMap.t
+
+module LMap
+ (* Memoization table. FIXME: Ideally the keys should be "weak", but
+ * I haven't found any such functionality in OCaml's libs. *)
+ = Hashtbl.Make
+ (struct type t = lexp let hash = Hashtbl.hash let equal = (==) end)
+
let error_tc = Log.log_error ~section:"TC"
let warning_tc = Log.log_warning ~section:"TC"
@@ -132,7 +148,7 @@ let lexp_close lctx e =
* but only on *types*. If you must use it on code, be sure to use its
* return value as little as possible since WHNF will inherently introduce
* call-by-name behavior. *)
-let lexp_whnf e (ctx : DB.lexp_context) : lexp =
+let rec lexp_whnf e (ctx : DB.lexp_context) : lexp =
let rec lexp_whnf e (ctx : DB.lexp_context) : lexp =
match e with
| Var v -> (match lookup_value ctx v with
@@ -156,30 +172,45 @@ let lexp_whnf e (ctx : DB.lexp_context) : lexp =
| _ -> e) (* Keep `e`, assuming it's more readable! *)
| Case (l, e, rt, branches, default) ->
let e' = lexp_whnf e ctx in
- let reduce name aargs =
+ let get_refl e =
+ let etype = get_type ctx e in (* FIXME we should not need get_type here *)
+ let elevel = match lexp_whnf (get_type ctx etype) ctx with
+ | Sort (_, Stype l) -> l
+ | _ -> Log.internal_error "" in
+ mkCall (DB.eq_refl, [Aerasable, elevel; Aerasable, etype; Aerasable, e]) in
+ let reduce it name aargs =
+ let targs = match (lexp_whnf it ctx) with
+ | Inductive (_,_,fargs,_) -> fargs
+ | _ -> Log.log_error "Case on a non-inductive type in whnf!"; [] in
try
let (_, _, branch) = SMap.find name branches in
let (subst, _)
= List.fold_left
- (fun (s,d) (_, arg) ->
- (S.cons (L.mkSusp (lexp_whnf arg ctx) (S.shift d)) s,
- d + 1))
- (S.identity, 0)
+ (fun (s, targs) (_, arg) ->
+ match targs with
+ | [] -> (S.cons (lexp_whnf arg ctx) s, [])
+ | _targ::targs ->
+ (* Ignore the type arguments *)
+ (s, targs))
+ (S.identity, targs)
aargs in
+ (* Substitute case Eq variable by the proof (Eq.refl l t e') *)
+ let subst = S.cons (get_refl e') subst in
lexp_whnf (push_susp branch subst) ctx
with Not_found
-> match default
with | Some (v,default)
- -> lexp_whnf (push_susp default (S.substitute e')) ctx
+ -> let subst = S.cons (get_refl e') (S.substitute e') in
+ lexp_whnf (push_susp default subst) ctx
| _ -> Log.log_error ~section:"WHNF" ~loc:l
("Unhandled constructor " ^
name ^ "in case expression");
mkCase (l, e, rt, branches, default) in
(match e' with
- | Cons (_, (_, name)) -> reduce name []
+ | Cons (it, (_, name)) -> reduce it name []
| Call (f, aargs) ->
(match lexp_whnf f ctx with
- | Cons (_, (_, name)) -> reduce name aargs
+ | Cons (it, (_, name)) -> reduce it name aargs
| _ -> mkCase (l, e, rt, branches, default))
| _ -> mkCase (l, e, rt, branches, default))
| Metavar (idx, s, _)
@@ -198,9 +229,8 @@ let lexp_whnf e (ctx : DB.lexp_context) : lexp =
(** A very naive implementation of sets of pairs of lexps. *)
-type set_plexp = (lexp * lexp) list
-let set_empty : set_plexp = []
-let set_member_p (s : set_plexp) (e1 : lexp) (e2 : lexp) : bool
+and set_empty : set_plexp = []
+and set_member_p (s : set_plexp) (e1 : lexp) (e2 : lexp) : bool
= assert (e1 == Lexp.hc e1);
assert (e2 == Lexp.hc e2);
try let _ = List.find (fun (e1', e2')
@@ -208,14 +238,14 @@ let set_member_p (s : set_plexp) (e1 : lexp) (e2 : lexp) : bool
s
in true
with Not_found -> false
-let set_add (s : set_plexp) (e1 : lexp) (e2 : lexp) : set_plexp
+and set_add (s : set_plexp) (e1 : lexp) (e2 : lexp) : set_plexp
= (* assert (not (set_member_p s e1 e2)); *)
((e1, e2) :: s)
-let set_shift_n (s : set_plexp) (n : U.db_offset)
+and set_shift_n (s : set_plexp) (n : U.db_offset)
= List.map (let s = S.shift n in
fun (e1, e2) -> (Lexp.push_susp e1 s, Lexp.push_susp e2 s))
s
-let set_shift s : set_plexp = set_shift_n s 1
+and set_shift s : set_plexp = set_shift_n s 1
(********* Testing if two types are "convertible" aka "equivalent" *********)
@@ -225,7 +255,7 @@ let set_shift s : set_plexp = set_shift_n s 1
* `c` is the maximum "constant" level that occurs in `e`
* and `m` maps variable indices to the maxmimum depth at which they were
* found. *)
-let level_canon e =
+and level_canon e =
let add_var_depth v d ((c,m) as acc) =
let o = try IMap.find v m with Not_found -> -1 in
if o < d then (c, IMap.add v d m) else acc in
@@ -244,18 +274,21 @@ let level_canon e =
| _ -> (max_int, m)
in canon e 0 (0,IMap.empty)
-let level_leq (c1, m1) (c2, m2) =
+and level_leq (c1, m1) (c2, m2) =
c1 <= c2
&& c1 != max_int
&& IMap.for_all (fun i d -> try d <= IMap.find i m2 with Not_found -> false)
m1
(* Returns true if e₁ and e₂ are equal (upto alpha/beta/...). *)
-let rec conv_p' (ctx : DB.lexp_context) (vs : set_plexp) e1 e2 : bool =
+and conv_p' (ctx : DB.lexp_context) (vs : set_plexp) e1 e2 : bool =
let e1' = lexp_whnf e1 ctx in
let e2' = lexp_whnf e2 ctx in
+ Log.log_debug ("conv_p : e1' = `" ^ (lexp_string e1')
+ ^ "`; e2' = `" ^ (lexp_string e2') ^ "`");
e1' == e2' ||
let changed = not (e1 == e1' && e2 == e2') in
+ Log.log_debug ("changed : " ^ string_of_bool changed);
if changed && set_member_p vs e1' e2' then true else
let vs' = if changed then set_add vs e1' e2' else vs in
let conv_p = conv_p' ctx vs' in
@@ -319,19 +352,119 @@ let rec conv_p' (ctx : DB.lexp_context) (vs : set_plexp) e1 e2 : bool =
| _,_ -> false in
l1 == l2 && conv_args ctx vs' args1 args2
| (Cons (t1, (_, l1)), Cons (t2, (_, l2))) -> l1 = l2 && conv_p t1 t2
- (* I'm not sure to understand how to compare two Metavar *
- * Should I do a `lookup`? Or is it that simple: *)
- (*| (Metavar (id1,_,_), Metavar (id2,_,_)) -> id1 = id2*)
- (* FIXME: Various missing cases, such as Case. *)
- | (_, _) -> false
-
-let conv_p (ctx : DB.lexp_context) e1 e2
+ | (Case (_, te1, r1, cases1, def1), Case (_, te2, r2, cases2, def2))
+ -> Log.log_debug ("conv_p of case : e1' = `" ^ (lexp_string e1')
+ ^ "`; e2' = `" ^ (lexp_string e2') ^ "`");
+ eq e1' e2' ||
+ (Log.log_debug "subexpr"; conv_p te1 te2) &&
+ (Log.log_debug "return"; conv_p r1 r2) && (
+ Log.log_debug "branches";
+ (* Compare the branches *)
+ (* 1. Get the inductive for the field types *)
+ let call_split e = match e with
+ | Call (f, args) -> (f, args)
+ | _ -> (e,[]) in
+ (* We can arbitrarily use te1 since te1 and te2 are convertible *)
+ let etype = lexp_whnf (get_type ctx te1) ctx in
+ let it, aargs = call_split etype in
+ (* 2. Build the substitution for the inductive arguments *)
+ let fargs, ctors =
+ (match lexp_whnf it ctx with
+ | Inductive (_, _, fargs, constructors)
+ -> fargs, constructors
+ | _ -> Log.log_fatal ("Case of non-inductive in conv_p")) in
+ let fargs_subst = List.fold_left2 (fun s _farg (_, aarg) -> S.cons aarg s)
+ S.identity fargs aargs in
+ (* 3. Compare the branches *)
+ (* The map module doesn't have a function to compare two
+ maps with the key (which is needed to get the field
+ types from the inductive. Instead, we work with the
+ lists of associations. *)
+ (try
+ List.for_all2 (fun (l1, (_, fields1, e1)) (l2, (_, fields2, e2)) ->
+ l1 = l2 &&
+ let fieldtypes = SMap.find l1 ctors in
+ let rec mkctx ctx args s i vdefs1 vdefs2 fieldtypes =
+ match vdefs1, vdefs2, fieldtypes with
+ | [], [], [] -> Some (ctx, List.rev args, s)
+ | (ak1, vdef1)::vdefs1, (ak2, vdef2)::vdefs2,
+ (ak', vdef', ftype)::fieldtypes
+ -> if ak1 = ak2 && ak2 = ak' then
+ (* FIXME Should we compare the variable names ? *)
+ mkctx
+ (DB.lexp_ctx_cons ctx vdef1 Variable (mkSusp ftype s))
+ ((ak1, (mkVar (vdef1, i)))::args)
+ (ssink vdef1 s)
+ (i - 1)
+ vdefs1 vdefs2 fieldtypes
+ else None
+ | _,_,_ -> None in
+ match mkctx ctx [] fargs_subst (List.length fields1)
+ fields1 fields2 fieldtypes with
+ | None -> false
+ | Some (nctx, args, _subst) ->
+ (* TODO build head lexp the eq type *)
+ let offset = (List.length fields1) in
+ let subst = S.shift offset in
+ Log.log_debug "hlxp time";
+ let tlxp = mkSusp te1 subst in
+ Log.log_debug ("tlxp : `" ^ (lexp_string tlxp) ^ "`");
+ let tltp = mkSusp etype subst in
+ Log.log_debug ("etype : `" ^ (lexp_string etype) ^ "`");
+ Log.log_debug ("subst : `" ^ (subst_string subst) ^ "`");
+ Log.log_debug ("tltp : `" ^ (lexp_string tltp) ^ "`");
+ let tlev = (match lexp_whnf (get_type nctx tltp) nctx with
+ | Sort (_, Stype l) -> l
+ | _ -> Log.log_error "HMMM"; DB.level0) in
+ let ctor = mkSusp (mkCall (mkCons (it, (DB.dloc, l1)), aargs)) subst in
+ Log.log_debug ("ctor : `" ^ (lexp_string ctor) ^ "`");
+ let hlxp = mkCall (ctor, args) in
+ Log.log_debug ("hlxp : `" ^ (lexp_string hlxp) ^ "`");
+ let eqty = mkCall (DB.type_eq,
+ [(Aerasable, tlev); (* Typelevel *)
+ (Aerasable, tltp); (* Inductive type *)
+ (Anormal, tlxp); (* Target lexp *)
+ (Anormal, hlxp)]) in (* Lexp of the branch head *)
+ let nctx = DB.lexp_ctx_cons nctx (DB.dloc, None) Variable eqty in
+ conv_p' nctx (set_shift_n vs' (offset + 1)) e1 e2
+ ) (SMap.bindings cases1) (SMap.bindings cases2)
+ with
+ | Invalid_argument _ -> false (* If the lists have different length *)
+ )
+ && (match (def1, def2) with
+ | (Some (v1, e1), Some (v2, e2)) ->
+ (* FIXME should we compare the variable names ? *)
+ Log.log_debug "default";
+ let nctx = DB.lctx_extend ctx v1 Variable etype in
+ let subst = S.shift 1 in
+ let tlxp = mkSusp e1 subst in
+ let tltp = mkSusp etype subst in
+ let tlev = (match lexp_whnf (get_type nctx tltp) nctx with
+ | Sort (_, Stype l) -> l
+ | _ -> Log.log_error "HMMM"; DB.level0) in
+ let hlxp = mkVar ((DB.dloc, None), 0) in
+ let eqty = mkCall (DB.type_eq,
+ [(Aerasable, tlev); (* Typelevel *)
+ (Aerasable, tltp); (* Inductive type *)
+ (Anormal, tlxp); (* Target lexp *)
+ (Anormal, hlxp)]) in (* Lexp of the branch head *)
+ let nctx = DB.lexp_ctx_cons nctx (DB.dloc, None) Variable eqty in
+ conv_p' nctx (set_shift_n vs' 2) e1 e2
+ | None, None -> true
+ | _, _ -> false))
+ (* I'm not sure to understand how to compare two Metavar *
+ * Should I do a `lookup`? Or is it that simple: *)
+ (*| (Metavar (id1,_,_), Metavar (id2,_,_)) -> id1 = id2*)
+ (* FIXME: Various missing cases, such as Case. *)
+ | (_, _) -> false
+
+and conv_p (ctx : DB.lexp_context) e1 e2
= if e1 == e2 then true
else conv_p' ctx set_empty e1 e2
(********* Testing if a lexp is properly typed *********)
-let rec mkSLlub ctx e1 e2 =
+and mkSLlub ctx e1 e2 =
match (lexp_whnf e1 ctx, lexp_whnf e2 ctx) with
| (SortLevel SLz, _) -> e2
| (_, SortLevel SLz) -> e1
@@ -344,13 +477,7 @@ let rec mkSLlub ctx e1 e2 =
else if level_leq ce2 ce1 then e1
else mkSortLevel (mkSLlub' (e1, e2)) (* FIXME: Could be more canonical *)
-type sort_compose_result
- = SortResult of ltype
- | SortInvalid
- | SortK1NotType
- | SortK2NotType
-
-let sort_compose ctx1 ctx2 l ak k1 k2 =
+and sort_compose ctx1 ctx2 l ak k1 k2 =
(* BEWARE! Technically `k2` can refer to `v`, but this should only happen
* if `v` is a TypeLevel. *)
match (lexp_whnf k1 ctx1, lexp_whnf k2 ctx2) with
@@ -388,11 +515,11 @@ let sort_compose ctx1 ctx2 l ak k1 k2 =
| (Sort (_, _), _) -> SortK2NotType
| (_, _) -> SortK1NotType
-let dbset_push ak erased =
+and dbset_push ak erased =
let nerased = DB.set_sink 1 erased in
if ak = P.Aerasable then DB.set_set 0 nerased else nerased
-let nerased_let defs erased =
+and nerased_let defs erased =
(* Let bindings are not erasable, with the important exception of
* let-bindings of the form `x = y` where `y` is an erasable var.
* This exception is designed so that macros like `case` which need to
@@ -418,7 +545,7 @@ let nerased_let defs erased =
erased es
(* "check ctx e" should return τ when "Δ ⊢ e : τ" *)
-let rec check'' erased ctx e =
+and check'' erased ctx e =
let check = check'' in
let assert_type ctx e t t' =
if conv_p ctx t t' then ()
@@ -610,24 +737,38 @@ let rec check'' erased ctx e =
SMap.iter
(fun name (l, vdefs, branch)
-> let fieldtypes = SMap.find name constructors in
- let rec mkctx erased ctx s vdefs fieldtypes =
+ let rec mkctx erased ctx s hlxp vdefs fieldtypes =
match vdefs, fieldtypes with
- | [], [] -> (erased, ctx)
+ | [], [] -> (erased, ctx, hlxp)
(* FIXME: If ak is Aerasable, make sure the var only
* appears in type annotations. *)
| (ak, vdef)::vdefs, (ak', vdef', ftype)::fieldtypes
-> mkctx (dbset_push ak erased)
(DB.lexp_ctx_cons ctx vdef Variable (mkSusp ftype s))
- (S.cons (mkVar (vdef, 0))
- (S.mkShift s 1))
+ (ssink vdef s)
+ (mkCall (mkSusp hlxp (S.shift 1), [(ak, mkVar (vdef, 0))]))
vdefs fieldtypes
| _,_ -> (error_tc ~loc:l
"Wrong number of args to constructor!";
- (erased, ctx)) in
- let (nerased, nctx) = mkctx erased ctx s vdefs fieldtypes in
+ (erased, ctx, hlxp)) in
+ let hctor = mkCall (mkCons (it, (l, name)), aargs) in
+ let (nerased, nctx, hlxp) =
+ mkctx erased ctx s hctor vdefs fieldtypes in
+ (* Create Eq type between target and lexp matching the
+ branch head, and add it (erasable) to the context *)
+ let subst = S.shift (List.length vdefs) in
+ let tlxp = mkSusp e subst in
+ let tltp = mkSusp etype subst in
+ let eqty = mkCall (DB.type_eq,
+ [(Aerasable, DB.type0); (* Typelevel *) (* FIXME The real typelevel *)
+ (Aerasable, tltp); (* Inductive type *)
+ (Anormal, tlxp); (* Target lexp *)
+ (Anormal, hlxp)]) in (* Lexp of the branch head *)
+ let nerased = dbset_push Aerasable nerased in (* The eq proof is erasable *)
+ let nctx = DB.lexp_ctx_cons nctx (l, None) Variable eqty in
assert_type nctx branch
(check nerased nctx branch)
- (mkSusp ret (S.shift (List.length fieldtypes))))
+ (mkSusp ret (S.shift ((List.length fieldtypes) + 1))))
branches;
let diff = SMap.cardinal constructors - SMap.cardinal branches in
(match default with
@@ -635,8 +776,21 @@ let rec check'' erased ctx e =
-> if diff <= 0 then
warning_tc ~loc:l "Redundant default clause";
let nctx = (DB.lctx_extend ctx v (LetDef (0, e)) etype) in
- assert_type nctx d (check (DB.set_sink 1 erased) nctx d)
- (mkSusp ret (S.shift 1))
+ let nerased = DB.set_sink 1 erased in
+ let subst = S.shift 1 in
+ (* FIXME DRY this code *)
+ let tlxp = mkSusp e subst in
+ let tltp = mkSusp etype subst in
+ let hlxp = mkVar ((l, None), 0) in
+ let eqty = mkCall (DB.type_eq,
+ [(Aerasable, DB.type0); (* Typelevel *) (* FIXME The real typelevel *)
+ (Aerasable, tltp); (* Inductive type *)
+ (Anormal, tlxp); (* Target lexp *)
+ (Anormal, hlxp)]) in (* Lexp of the branch head *)
+ let nerased = dbset_push Aerasable nerased in (* The eq proof is erasable *)
+ let nctx = DB.lexp_ctx_cons nctx (l, None) Variable eqty in
+ assert_type nctx d (check nerased nctx d)
+ (mkSusp ret (S.shift 2))
| None
-> if diff > 0 then
error_tc ~loc:l ("Non-exhaustive match: "
@@ -682,24 +836,21 @@ let rec check'' erased ctx e =
check erased ctx e
| MVar (_, t, _) -> push_susp t s)
-let check' ctx e =
+and check' ctx e =
let res = check'' DB.set_empty ctx e in
(Log.stop_on_error (); res)
-let check = check'
+and check ctx e = check' ctx e
(** Compute the set of free (meta)variables. **)
-let rec list_union l1 l2 = match l1 with
+and list_union l1 l2 = match l1 with
| [] -> l2
| (x::l1) -> list_union l1 (if List.mem x l2 then l2 else (x::l2))
-type mv_set = (scope_level * ltype * ctx_length * vname) IMap.t
- (* Metavars that appear in non-erasable positions. *)
- * unit IMap.t
-let mv_set_empty : mv_set = (IMap.empty, IMap.empty)
-let mv_set_add (ms, nes) id x : mv_set = (IMap.add id x ms, IMap.add id () nes)
-let mv_set_union ((ms1, nes1) : mv_set) ((ms2, nes2) : mv_set) : mv_set
+and mv_set_empty : mv_set = (IMap.empty, IMap.empty)
+and mv_set_add (ms, nes) id x : mv_set = (IMap.add id x ms, IMap.add id () nes)
+and mv_set_union ((ms1, nes1) : mv_set) ((ms2, nes2) : mv_set) : mv_set
= (IMap.merge (fun _m oss1 oss2
-> match (oss1, oss2) with
| (None, _) -> oss2
@@ -715,23 +866,19 @@ let mv_set_union ((ms1, nes1) : mv_set) ((ms2, nes2) : mv_set) : mv_set
Some ss1)
ms1 ms2,
IMap.merge (fun _m _o1 _o2 -> Some ()) nes1 nes2)
-let mv_set_erase (ms, _nes) = (ms, IMap.empty)
+and mv_set_erase (ms, _nes) = (ms, IMap.empty)
-module LMap
- (* Memoization table. FIXME: Ideally the keys should be "weak", but
- * I haven't found any such functionality in OCaml's libs. *)
- = Hashtbl.Make
- (struct type t = lexp let hash = Hashtbl.hash let equal = (==) end)
-let fv_memo = LMap.create 1000
+and fv_memo = LMap.create 1000
+and fv_flush () = LMap.clear fv_memo
-let fv_empty = (DB.set_empty, mv_set_empty)
-let fv_union (fv1, mv1) (fv2, mv2)
+and fv_empty = (DB.set_empty, mv_set_empty)
+and fv_union (fv1, mv1) (fv2, mv2)
= (DB.set_union fv1 fv2, mv_set_union mv1 mv2)
-let fv_sink n (fvs, mvs) = (DB.set_sink n fvs, mvs)
-let fv_hoist n (fvs, mvs) = (DB.set_hoist n fvs, mvs)
-let fv_erase (fvs, mvs) = (fvs, mv_set_erase mvs)
+and fv_sink n (fvs, mvs) = (DB.set_sink n fvs, mvs)
+and fv_hoist n (fvs, mvs) = (DB.set_hoist n fvs, mvs)
+and fv_erase (fvs, mvs) = (fvs, mv_set_erase mvs)
-let rec fv (e : lexp) : (DB.set * mv_set) =
+and fv (e : lexp) : (DB.set * mv_set) =
let fv' e = match e with
| Imm _ -> fv_empty
| SortLevel SLz -> fv_empty
@@ -784,9 +931,9 @@ let rec fv (e : lexp) : (DB.set * mv_set) =
-> let s = fv_union (fv e) (fv_erase (fv t)) in
let s = match def with
| None -> s
- | Some (_, e) -> fv_union s (fv_hoist 1 (fv e)) in
+ | Some (_, e) -> fv_union s (fv_hoist 2 (fv e)) in
SMap.fold (fun _ (_, fields, e) s
- -> fv_union s (fv_hoist (List.length fields) (fv e)))
+ -> fv_union s (fv_hoist (List.length fields + 1) (fv e)))
cases s
| Metavar (id, s, name)
-> (match metavar_lookup id with
@@ -806,7 +953,7 @@ let rec fv (e : lexp) : (DB.set * mv_set) =
(** Finding the type of a expression. **)
(* This should never signal any warning/error. *)
-let rec get_type ctx e =
+and get_type ctx e =
match e with
| Imm (Float (_, _)) -> DB.type_float
| Imm (Integer (_, _)) -> DB.type_int
@@ -933,7 +1080,7 @@ let rec erase_type (lxp: L.lexp): E.elexp =
| L.Case(l, target, _, cases, default) ->
E.Case(l, (erase_type target), (clean_map cases),
- (clean_maybe default))
+ (clean_default default))
| L.Susp(l, s) -> erase_type (L.push_susp l s)
@@ -962,10 +1109,12 @@ and filter_arg_list lst =
and clean_decls decls =
List.map (fun (v, lxp, _) -> (v, (erase_type lxp))) decls
-and clean_maybe lxp =
- match lxp with
- | Some (v, lxp) -> Some (v, erase_type lxp)
- | None -> None
+and clean_default lxp =
+ match lxp with
+ | Some (v, lxp) ->
+ Some (v,
+ erase_type (L.push_susp lxp (S.substitute DB.type0)))
+ | None -> None
and clean_map cases =
let clean_arg_list lst =
@@ -979,7 +1128,8 @@ and clean_map cases =
clean_arg_list lst [] in
SMap.map (fun (l, args, expr)
- -> (l, (clean_arg_list args), (erase_type expr)))
+ -> (l, (clean_arg_list args),
+ erase_type (L.push_susp expr (S.substitute DB.type0))))
cases
(** Turning a set of declarations into an object. **)
=====================================
src/unification.ml
=====================================
@@ -46,6 +46,7 @@ let create_metavar (ctx : DB.lexp_context) (sl : scope_level) (t : ltype)
type constraint_kind =
| CKimpossible (* Unification is simply impossible. *)
| CKresidual (* We failed to find a unifier. *)
+ | CKassoc (* Couldn't associate because of checking mode *)
(* FIXME: Each constraint should additionally come with a description of how
it relates to its "top-level" or some other info which might let us
fix the problem (e.g. by introducing coercions). *)
@@ -54,8 +55,9 @@ type constraints = (constraint_kind * DB.lexp_context * lexp * lexp) list
type return_type = constraints
(** Alias for VMap.add*)
-let associate (id: meta_id) (lxp: lexp) (subst: meta_subst) : meta_subst
- = U.IMap.add id (MVal lxp) subst
+let associate (id: meta_id) (lxp: lexp) : unit
+ = metavar_table := U.IMap.add id (MVal lxp) (!metavar_table);
+ OL.fv_flush ()
let occurs_in (id: meta_id) (e : lexp) : bool = match metavar_lookup id with
| MVal _ -> Log.internal_error
@@ -174,13 +176,15 @@ let rec s_offset s = match s with
The metavar unifier is the end rule, it can't call unify with its parameter (changing their order)
*)
-let rec unify (e1: lexp) (e2: lexp)
+let rec unify ?checking
+ (e1: lexp) (e2: lexp)
(ctx : DB.lexp_context)
: return_type =
- unify' e1 e2 ctx OL.set_empty
+ unify' e1 e2 ctx OL.set_empty checking
and unify' (e1: lexp) (e2: lexp)
(ctx : DB.lexp_context) (vs : OL.set_plexp)
+ (c : scope_level option) (* checking mode scope level *)
: return_type =
if e1 == e2 then [] else
let e1' = OL.lexp_whnf e1 ctx in
@@ -190,20 +194,26 @@ and unify' (e1: lexp) (e2: lexp)
if changed && OL.set_member_p vs e1' e2' then [] else
let vs' = if changed then OL.set_add vs e1' e2' else vs in
match (e1', e2') with
- | ((Imm _, Imm _) | (Cons _, Cons _) | (Builtin _, Builtin _)
- | (Var _, Var _))
+ | ((Imm _, Imm _) | (Cons _, Cons _) | (Builtin _, Builtin _))
-> if OL.conv_p ctx e1' e2' then [] else [(CKimpossible, ctx, e1, e2)]
- | (l, (Metavar (idx, s, _) as r)) -> unify_metavar ctx idx s r l
- | ((Metavar (idx, s, _) as l), r) -> unify_metavar ctx idx s l r
- | (l, (Call _ as r)) -> unify_call r l ctx vs'
- (* | (l, (Case _ as r)) -> unify_case r l subst *)
- | (Arrow _ as l, r) -> unify_arrow l r ctx vs'
- | (Lambda _ as l, r) -> unify_lambda l r ctx vs'
- | (Call _ as l, r) -> unify_call l r ctx vs'
- (* | (Case _ as l, r) -> unify_case l r subst *)
- (* | (Inductive _ as l, r) -> unify_induct l r subst *)
- | (Sort _ as l, r) -> unify_sort l r ctx vs'
- | (SortLevel _ as l, r) -> unify_sortlvl l r ctx vs'
+ | (l, (Metavar (idx, s, _) as r)) -> unify_metavar c ctx idx s r l
+ | ((Metavar (idx, s, _) as l), r) -> unify_metavar c ctx idx s l r
+ | (l, (Call _ as r)) -> unify_call c r l ctx vs'
+ | ((Call _ as l), r) -> unify_call c l r ctx vs'
+ | (l, (Var _ as r)) -> unify_var r l ctx vs'
+ | ((Var _ as l), r) -> unify_var l r ctx vs'
+ | (l, (Arrow _ as r)) -> unify_arrow c r l ctx vs'
+ | ((Arrow _ as l), r) -> unify_arrow c l r ctx vs'
+ | (l, (Lambda _ as r)) -> unify_lambda c r l ctx vs'
+ | ((Lambda _ as l), r) -> unify_lambda c l r ctx vs'
+ (* | (l, (Case _ as r)) -> unify_case r l subst *)
+ (* | ((Case _ as l), r) -> unify_case l r subst *)
+ (* | (l, (Inductive _ as r)) -> unify_induct r l subst *)
+ (* | ((Inductive _ as l), r) -> unify_induct l r subst *)
+ | (l, (Sort _ as r)) -> unify_sort c r l ctx vs'
+ | ((Sort _ as l), r) -> unify_sort c l r ctx vs'
+ | (l, (SortLevel _ as r)) -> unify_sortlvl c r l ctx vs'
+ | ((SortLevel _ as l), r) -> unify_sortlvl c l r ctx vs'
| (Inductive (_loc1, label1, args1, consts1),
Inductive (_loc2, label2, args2, consts2))
-> (* print_string ("Unifying inductives "
@@ -211,7 +221,7 @@ and unify' (e1: lexp) (e2: lexp)
* ^ " and "
* ^ snd label2
* ^ "\n"); *)
- unify_inductive ctx vs' args1 args2 consts1 consts2 e1 e2
+ unify_inductive c ctx vs' args1 args2 consts1 consts2 e1 e2
| _ -> (if OL.conv_p ctx e1' e2' then []
else ((* print_string "Unification failure on default\n"; *)
[(CKresidual, ctx, e1, e2)]))
@@ -222,87 +232,77 @@ and unify' (e1: lexp) (e2: lexp)
- (Arrow, Arrow) -> if var_kind = var_kind
then unify ltype & lexp (Arrow (var_kind, _, ltype, lexp))
else None
- - (Arrow, Var) -> Constraint
- (_, _) -> None
*)
-and unify_arrow (arrow: lexp) (lxp: lexp) ctx vs
+and unify_arrow (checking : scope_level option) (arrow: lexp) (lxp: lexp) ctx vs
: return_type =
match (arrow, lxp) with
| (Arrow (var_kind1, v1, ltype1, _, lexp1),
Arrow (var_kind2, _, ltype2, _, lexp2))
-> if var_kind1 = var_kind2
- then (unify' ltype1 ltype2 ctx vs)
+ then (unify' ltype1 ltype2 ctx vs checking)
@(unify' lexp1 (srename v1 lexp2)
(DB.lexp_ctx_cons ctx v1 Variable ltype1)
- (OL.set_shift vs))
- else [(CKimpossible, ctx, arrow, lxp)]
- | (Arrow _, Imm _) -> [(CKimpossible, ctx, arrow, lxp)]
- | (Arrow _, Var _) -> ([(CKresidual, ctx, arrow, lxp)])
- | (Arrow _, _) -> unify' lxp arrow ctx vs
+ (OL.set_shift vs) checking)
+ else [(CKimpossible, ctx, arrow, lxp)]
| (_, _) -> [(CKimpossible, ctx, arrow, lxp)]
(** Unify a Lambda and a lexp if possible
- - Lamda , Lambda -> if var_kind = var_kind
+ - Lambda , Lambda -> if var_kind = var_kind
then UNIFY ltype & lxp else ERROR
- - Lambda , Var -> CONSTRAINT
- - Lambda , Call -> Constraint
- - Lambda , Let -> Constraint
- - Lambda , lexp -> unify lexp lambda subst
+ - Lambda , _ -> Impossible
*)
-and unify_lambda (lambda: lexp) (lxp: lexp) ctx vs : return_type =
+and unify_lambda (checking : scope_level option) (lambda: lexp) (lxp: lexp) ctx vs : return_type =
match (lambda, lxp) with
| (Lambda (var_kind1, v1, ltype1, lexp1),
Lambda (var_kind2, _, ltype2, lexp2))
-> if var_kind1 = var_kind2
- then (unify' ltype1 ltype2 ctx vs)
+ then (unify' ltype1 ltype2 ctx vs checking)
@(unify' lexp1 lexp2
(DB.lexp_ctx_cons ctx v1 Variable ltype1)
- (OL.set_shift vs))
+ (OL.set_shift vs) checking)
else [(CKimpossible, ctx, lambda, lxp)]
- | ((Lambda _, Var _)
- | (Lambda _, Let _)
- | (Lambda _, Call _)) -> [(CKresidual, ctx, lambda, lxp)]
- | (Lambda _, Arrow _)
- | (Lambda _, Imm _) -> [(CKimpossible, ctx, lambda, lxp)]
- | (Lambda _, _) -> unify' lxp lambda ctx vs
- | (_, _) -> [(CKimpossible, ctx, lambda, lxp)]
+ | (_, _) -> [(CKimpossible, ctx, lambda, lxp)]
(** Unify a Metavar and a lexp if possible
- - lexp , {metavar <-> none} -> UNIFY
- - lexp , {metavar <-> lexp} -> UNFIFY lexp subst[metavar]
- - metavar , metavar -> if Metavar = Metavar then OK else ERROR
- - metavar , lexp -> OK
+ - metavar , metavar -> if Metavar = Metavar then intersect
+ - metavar , metavar -> inverse subst (both sides)
+ - metavar , lexp -> inverse subst
*)
-and unify_metavar ctx idx s1 (lxp1: lexp) (lxp2: lexp)
+and unify_metavar (checking : scope_level option) ctx idx s1 (lxp1: lexp) (lxp2: lexp)
: return_type =
let unif idx s lxp =
- let t = match metavar_lookup idx with
+ let t, sl = match metavar_lookup idx with
| MVal _ -> Log.internal_error
"`lexp_whnf` returned an instantiated metavar!!"
- | MVar (_, t, _) -> push_susp t s in
+ | MVar (_, t, sl) -> push_susp t s, sl in
match Inverse_subst.apply_inv_subst lxp s with
| exception Inverse_subst.Not_invertible
- -> log_info ?loc:None ("Unification of metavar failed:\n "
- ^ "?[" ^ subst_string s ^ "]"
- ^ "\nAgainst:\n "
- ^ lexp_string lxp ^ "\n");
+ -> log_info ~loc:(lexp_location lxp)
+ ("Unification of metavar failed:\n "
+ ^ "?[" ^ subst_string s ^ "]"
+ ^ "\nAgainst:\n "
+ ^ lexp_string lxp ^ "\n");
[(CKresidual, ctx, lxp1, lxp2)]
| lxp' when occurs_in idx lxp' -> [(CKimpossible, ctx, lxp1, lxp2)]
| lxp'
- -> metavar_table := associate idx lxp' (!metavar_table);
- match unify t (OL.get_type ctx lxp) ctx with
- | [] as r -> r
- (* FIXME: Let's ignore the error for now. *)
- | _
- -> log_info ?loc:None
- ("Unification of metavar type failed:\n "
- ^ lexp_string t ^ " != "
- ^ lexp_string (OL.get_type ctx lxp)
- ^ "\n" ^ "for " ^ lexp_string lxp ^ "\n");
- [(CKresidual, ctx, lxp1, lxp2)] in
+ -> match checking with
+ | Some l when l >= sl -> [(CKassoc, ctx, lxp1, lxp2)]
+ | _ -> (
+ associate idx lxp';
+ match unify t (OL.get_type ctx lxp) ctx with
+ | [] as r -> r
+ (* FIXME: Let's ignore the error for now. *)
+ | _
+ -> log_info ?loc:None
+ ("Unification of metavar type failed:\n "
+ ^ lexp_string t ^ " != "
+ ^ lexp_string (OL.get_type ctx lxp)
+ ^ "\n" ^ "for " ^ lexp_string lxp ^ "\n");
+ [(CKresidual, ctx, lxp1, lxp2)]) in
match lxp2 with
| Metavar (idx2, s2, name)
- -> if idx = idx2 then
+ -> if idx = idx2 && checking == None then
match common_subset ctx s1 s2 with
| S.Identity 0 -> [] (* Optimization! *)
(* ¡ s1 != s2 !
@@ -353,7 +353,7 @@ and unify_metavar ctx idx s1 (lxp1: lexp) (lxp2: lexp)
* ^ "\n =\n "
* ^ subst_string (scompose s s2)
* ^ "\n"); *)
- metavar_table := associate idx lexp (!metavar_table);
+ associate idx lexp;
assert (OL.conv_p ctx lxp1 lxp2);
[]
else
@@ -364,18 +364,28 @@ and unify_metavar ctx idx s1 (lxp1: lexp) (lxp2: lexp)
| _ -> unif idx2 s2 lxp1)
| _ -> unif idx s1 lxp2
+(** Unify a Var (var) and a lexp (lxp)
+ - Var , Var -> IF same var THEN ok ELSE constraint
+ - Var , lexp -> Constraint
+*)
+and unify_var (var: lexp) (lxp: lexp) ctx vs
+ : return_type =
+ match (var, lxp) with
+ | (Var _, Var _) when OL.conv_p ctx var lxp -> []
+ | (_, _) -> [(CKresidual, ctx, var, lxp)]
+
(** Unify a Call (call) and a lexp (lxp)
- Call , Call -> UNIFY
- Call , lexp -> CONSTRAINT
*)
-and unify_call (call: lexp) (lxp: lexp) ctx vs
+and unify_call (checking : scope_level option) (call: lexp) (lxp: lexp) ctx vs
: return_type =
match (call, lxp) with
| (Call (lxp_left, lxp_list1), Call (lxp_right, lxp_list2))
when OL.conv_p ctx lxp_left lxp_right
-> List.fold_left (fun op ((ak1, e1), (ak2, e2))
-> if ak1 == ak2 then
- (unify' e1 e2 ctx vs)@op
+ (unify' e1 e2 ctx vs checking)@op
else [(CKimpossible, ctx, call, lxp)])
[]
(List.combine lxp_list1 lxp_list2)
@@ -438,31 +448,29 @@ and unify_call (call: lexp) (lxp: lexp) ctx vs
- SortLevel, SortLevel -> if SortLevel ~= SortLevel then OK else ERROR
- SortLevel, _ -> ERROR
*)
-and unify_sortlvl (sortlvl: lexp) (lxp: lexp) ctx vs : return_type =
+and unify_sortlvl (checking : scope_level option) (sortlvl: lexp) (lxp: lexp) ctx vs : return_type =
match sortlvl, lxp with
| (SortLevel s, SortLevel s2) -> (match s, s2 with
| SLz, SLz -> []
- | SLsucc l1, SLsucc l2 -> unify' l1 l2 ctx vs
+ | SLsucc l1, SLsucc l2 -> unify' l1 l2 ctx vs checking
| SLlub (l11, l12), SLlub (l21, l22)
-> (* FIXME: This SLlub representation needs to be
* more "canonicalized" otherwise it's too restrictive! *)
- (unify' l11 l21 ctx vs)@(unify' l12 l22 ctx vs)
+ (unify' l11 l21 ctx vs checking)@(unify' l12 l22 ctx vs checking)
| _, _ -> [(CKimpossible, ctx, sortlvl, lxp)])
| _, _ -> [(CKresidual, ctx, sortlvl, lxp)]
(** Unify a Sort and a lexp
- Sort, Sort -> if Sort ~= Sort then OK else ERROR
- - Sort, Var -> Constraint
- Sort, lexp -> ERROR
*)
-and unify_sort (sort_: lexp) (lxp: lexp) ctx vs : return_type =
+and unify_sort (checking : scope_level option) (sort_: lexp) (lxp: lexp) ctx vs : return_type =
match sort_, lxp with
| (Sort (_, srt), Sort (_, srt2)) -> (match srt, srt2 with
- | Stype lxp1, Stype lxp2 -> unify' lxp1 lxp2 ctx vs
+ | Stype lxp1, Stype lxp2 -> unify' lxp1 lxp2 ctx vs checking
| StypeOmega, StypeOmega -> []
| StypeLevel, StypeLevel -> []
| _, _ -> [(CKimpossible, ctx, sort_, lxp)])
- | Sort _, Var _ -> [(CKresidual, ctx, sort_, lxp)]
| _, _ -> [(CKimpossible, ctx, sort_, lxp)]
(************************ Helper function ************************************)
@@ -513,7 +521,7 @@ and is_same arglist arglist2 =
* | None -> test e subst)
* ) None lst *)
-and unify_inductive ctx vs args1 args2 consts1 consts2 e1 e2 =
+and unify_inductive (checking : scope_level option) ctx vs args1 args2 consts1 consts2 e1 e2 =
let unif_formals ctx vs args1 args2
= if not (List.length args1 == List.length args2) then
(ctx, vs, [(CKimpossible, ctx, e1, e2)])
@@ -522,7 +530,7 @@ and unify_inductive ctx vs args1 args2 consts1 consts2 e1 e2 =
-> (DB.lexp_ctx_cons ctx v1 Variable t1,
OL.set_shift vs,
if not (ak1 == ak2) then [(CKimpossible, ctx, e1, e2)]
- else (unify' t1 t2 ctx vs) @ residue))
+ else (unify' t1 t2 ctx vs checking) @ residue))
(ctx, vs, [])
(List.combine args1 args2) in
let (ctx, vs, residue) = unif_formals ctx vs args1 args2 in
=====================================
tests/elab_test.ml
=====================================
@@ -51,8 +51,24 @@ let generate_tests (name: string)
(test input_gen fmt tester)
(* let input = "y = lambda x -> x + 1;" *)
-let input = "id = lambda (α : Type) ≡> lambda (x : α) -> x;
-res = id 3;"
+let inputs =
+ [("identity", {|
+id = lambda (α : Type) ≡> lambda (x : α) -> x;
+res = id 3;
+ |});
+ ("whnf of case", {|
+Box = (typecons (Box (l : TypeLevel) (t : Type_ l)) (box t));
+box = (datacons Box box);
+unbox b = ##case_ (b | box inside => inside);
+alwaysbool b = ##case_ (b | box _ => Bool);
+
+example1 : unbox (box (lambda x -> Bool)) 1;
+example1 = true;
+
+example2 : alwaysbool (box Int);
+example2 = true;
+ |});
+ ]
let generate_lexp_from_str str =
List.hd ((fun (lst, _) ->
@@ -63,9 +79,22 @@ let generate_lexp_from_str str =
let _ = generate_tests
"TYPECHECK"
- (fun () -> [generate_lexp_from_str input])
- (fun x -> List.map lexp_string x)
- (fun x -> (x, true))
+ (fun () -> inputs)
+ (fun x -> x)
+ (fun (name, input) ->
+ let result =
+ try
+ let ectx = Elab.default_ectx in
+ let pres = Prelexer.prelex_string input in
+ let sxps = Lexer.lex Grammar.default_stt pres in
+ let _lxps, _ectx = Elab.lexp_p_decls [] sxps ectx in
+ Log.stop_on_error();
+ true
+ with
+ | Log.Stop_Compilation _ -> (Log.print_and_clear_log (); false)
+ | Log.Internal_error _ -> (Log.print_and_clear_log (); false) in
+ (name, result)
+ )
let lctx = Elab.default_ectx
(* let _ = (add_test "TYPECHEK_LEXP" "lexp_print" (fun () ->
=====================================
tests/unify_test.ml
=====================================
@@ -199,6 +199,7 @@ let test_input (lxp1: lexp) (lxp2: lexp): unif_res =
else (Unification, res, lxp1, lxp2)
| (CKresidual, _, _, _)::_ -> (Constraint, res, lxp1, lxp2)
| (CKimpossible, _, _, _)::_ -> (Nothing, res, lxp1, lxp2)
+ | _ -> failwith "impossible"
let check (lxp1: lexp) (lxp2: lexp) (res: result): bool =
let r, _, _, _ = test_input lxp1 lxp2
View it on GitLab: https://gitlab.com/monnier/typer/-/compare/333bc9e96ea618b68ea943bc8701108a…
--
View it on GitLab: https://gitlab.com/monnier/typer/-/compare/333bc9e96ea618b68ea943bc8701108a…
You're receiving this email because of your account on gitlab.com.
1
0
[Git][monnier/typer][master] 2 commits: Add hash in Lexp's type (hash-consing).
by Alice de Berny 24 Aoû '20
by Alice de Berny 24 Aoû '20
24 Aoû '20
Alice de Berny pushed to branch master at Stefan / Typer
Commits:
28d16874 by irradiee at 2020-08-14T05:59:20-04:00
Add hash in Lexp's type (hash-consing).
Lexp: type lexp is now a pair int * lexp' (interchangeable),
profiling: add compilation with ocamlc & ocamlopt,
collisions: add %cl command to get stats of hash-consing,
Lexp tests: add tests and getters for some Lexp
- - - - -
68f25184 by irradiee at 2020-08-24T13:11:01-04:00
Add hash in Lexp's type (hash-consing).
Lexp: type lexp is now a pair int * lexp' (interchangeable),
profiling: add compilation with ocamlc & ocamlopt,
collisions: add %cl command to get stats of hash-consing,
Lexp tests: add tests and getters for some Lexp
- - - - -
13 changed files:
- GNUmakefile
- src/REPL.ml
- src/builtin.ml
- src/debruijn.ml
- src/elab.ml
- src/eval.ml
- src/inverse_subst.ml
- src/lexp.ml
- src/opslexp.ml
- src/sexp.ml
- src/unification.ml
- src/util.ml
- tests/unify_test.ml
Changes:
=====================================
GNUmakefile
=====================================
@@ -4,9 +4,13 @@ OCAMLBUILD=ocamlbuild
BUILDDIR := _build
+OCAMLCP := ocamlcp
+OCAMLOPT := ocamlopt
+OCAMLDEP := ocamldep
+
SRC_FILES := $(wildcard ./src/*.ml)
-CPL_FILES := $(wildcard ./$(BUILDDIR)/src/*.cmo)
TEST_FILES := $(wildcard ./tests/*_test.ml)
+DEPSORT_FILES := $(shell ocamldep -sort -I src $(SRC_NO_DEBUG))
OBFLAGS = -tag debug -tag profile -lib str -build-dir $(BUILDDIR) -pkg zarith
# OBFLAGS := -I $(SRCDIR) -build-dir $(BUILDDIR) -pkg str
@@ -108,3 +112,30 @@ run/typer-file:
run/test-file:
@./$(BUILDDIR)/test
+
+# Compile into bytecode using ocamlc in profiling mode.
+# Generate a ocamlprof.dump file.
+profiling-cp:
+ # ============================
+ # profiling bytecode
+ # ============================
+ ocamlfind $(OCAMLCP) -o profiling -linkpkg -package zarith \
+ -I src str.cma -P f $(DEPSORT_FILES)
+
+# Compile into native code using ocamlopt in profiling mode.
+# Generate a gmon.out file.
+profiling-optp:
+ # ============================
+ # profiling native code
+ # ============================
+ ocamlfind $(OCAMLOPTP) -o profiling -linkpkg -package zarith \
+ -I src str.cmxa -P f $(DEPSORT_FILES)
+
+# Clean profiling
+# FIXME: We prefer generate files in the "./$(BUILDDIR)/" folder but how ?
+# No -build-dir option found for ocamlc and ocamlopt.
+clean-profiling:
+ -rm -rf profiling
+ -rm -rf src/*.cm[iox] src/*.o
+ -rm -rf ocamlprof.dump
+ -rm -rf gmon.out
=====================================
src/REPL.ml
=====================================
@@ -232,6 +232,7 @@ let rec repl i clxp rctx =
| "%help" | "%h" -> (print_string help_msg; repl clxp rctx)
| "%calltrace" | "%ct" -> (print_eval_trace None; repl clxp rctx)
| "%typertrace" | "%tt" -> (print_typer_trace None; repl clxp rctx)
+ | "%lcollisions" | "%cl" -> (get_stats_hashtbl (WHC.stats hc_table))
(* command with arguments *)
| _ when (ipt.[0] = '%' && ipt.[1] != ' ') -> (
=====================================
src/builtin.ml
=====================================
@@ -57,7 +57,7 @@ open Util
open Sexp (* Integer/Float *)
open Pexp (* arg_kind *)
-module L = Lexp
+
module OL = Opslexp
open Lexp
=====================================
src/debruijn.ml
=====================================
@@ -35,8 +35,10 @@
module Str = Str
open Util
+
+
open Lexp
-module L = Lexp
+
module M = Myers
open Fmt
@@ -300,7 +302,7 @@ let print_lexp_ctx_n (ctx : lexp_context) start =
(* Only print user defined variables *)
let print_lexp_ctx (ctx : lexp_context) =
- print_lexp_ctx_n ctx !L.builtin_size
+ print_lexp_ctx_n ctx !builtin_size
(* Dump the whole context *)
let dump_lexp_ctx (ctx : lexp_context) =
=====================================
src/elab.ml
=====================================
@@ -121,7 +121,7 @@ let sform_default_ectx = ref empty_elab_context
* to errors in the user's code). *)
let elab_check_sort (ctx : elab_context) lsort var ltp =
- match (try OL.lexp_whnf lsort (ectx_to_lctx ctx)
+ match (try OL.lexp'_whnf lsort (ectx_to_lctx ctx)
with e ->
info ~print_action:(fun _ -> lexp_print lsort; print_newline ())
~loc:(lexp_location lsort)
@@ -323,7 +323,7 @@ let rec meta_to_var ids (e : lexp) =
* into something like
*
* Γ ⊢ λ x₁…xₙ ≡> e[x₁…xₙ/m₁…mₙ] : τ₁…τₙ ≡> τ
- *
+ *
* The above substitution is not the usual capture-avoiding substitution
* since it replaces metavars with vars rather than vars with terms.
* It's more like *instanciation* of those metavars.
@@ -402,7 +402,7 @@ let rec meta_to_var ids (e : lexp) =
* (case (B) above), so don't let it refer to the new vars. *)
S.Identity (n + count)
else
- Identity n
+ S.Identity n
| S.Cons (e, s', n)
-> let o' = o - n in
if o' < 0 then
@@ -414,7 +414,8 @@ let rec meta_to_var ids (e : lexp) =
(* `o` is the binding depth at which we are relative to the "root"
* of the expression (i.e. where the new vars will be inserted). *)
- and loop o e = match e with
+ and loop o e =
+ match lexp_lexp' e with
| Imm _ -> e
| SortLevel SLz -> e
| SortLevel (SLsucc e) -> mkSortLevel (mkSLsucc (loop o e))
@@ -576,7 +577,7 @@ and infer (p : sexp) (ctx : elab_context): lexp * ltype =
and elab_special_form ctx f args ot =
let loc = lexp_location f in
- match OL.lexp_whnf f (ectx_to_lctx ctx) with
+ match (OL.lexp'_whnf f (ectx_to_lctx ctx)) with
| Builtin ((_, name), _, _) ->
(* Special form. *)
(get_special_form name) ctx loc args ot
@@ -624,7 +625,7 @@ and get_implicit_arg ctx loc oname t =
(* Build the list of implicit arguments to instantiate. *)
and instantiate_implicit e t ctx =
let rec instantiate t args =
- match OL.lexp_whnf t (ectx_to_lctx ctx) with
+ match OL.lexp'_whnf t (ectx_to_lctx ctx) with
| Arrow ((Aerasable | Aimplicit) as ak, (_, v), t1, _, t2)
-> let arg = get_implicit_arg ctx (lexp_location e) v t1 in
instantiate (mkSusp t2 (S.substitute arg)) ((ak, arg)::args)
@@ -636,7 +637,7 @@ and infer_type pexp ectx var =
* Sort (?s), but in most cases the metavar would be allocated
* unnecessarily. *)
let t, s = infer pexp ectx in
- (match OL.lexp_whnf s (ectx_to_lctx ectx) with
+ (match OL.lexp'_whnf s (ectx_to_lctx ectx) with
| Sort (_, _) -> () (* All clear! *)
(* FIXME: We could automatically coerce Type levels to Sorts, so we
* could write `(a : TypeLevel) -> a -> a` instead of
@@ -698,7 +699,8 @@ and check (p : sexp) (t : ltype) (ctx : elab_context): lexp =
* we use is to instantiate implicit arguments when needed, but we could/should
* do lots of other things. *)
and check_inferred ctx e inferred_t t =
- let (e, inferred_t) = match OL.lexp_whnf t (ectx_to_lctx ctx) with
+ let (e, inferred_t) =
+ match OL.lexp'_whnf t (ectx_to_lctx ctx) with
| Arrow ((Aerasable | Aimplicit), _, _, _, _)
-> (e, inferred_t)
| _ -> instantiate_implicit e inferred_t ctx in
@@ -749,7 +751,7 @@ and check_case rtype (loc, target, ppatterns) ctx =
| [] -> () in
(cs, args)
| None
- -> match OL.lexp_whnf it' (ectx_to_lctx ctx) with
+ -> match OL.lexp'_whnf it' (ectx_to_lctx ctx) with
| Inductive (_, _, fargs, constructors)
-> let (s, targs) = List.fold_left
(fun (s, targs) (ak, name, t)
@@ -764,11 +766,13 @@ and check_case rtype (loc, target, ppatterns) ctx =
ltarget := check_inferred ctx tlxp tltp (mkCall (it', args));
it_cs_as := Some (it', cs, args);
(cs, args)
- | _ -> let call_split e = match (OL.lexp_whnf e (ectx_to_lctx ctx))
- with | Call (f, args) -> (f, args)
+ | _ -> let call_split e =
+ match OL.lexp'_whnf e (ectx_to_lctx ctx) with
+ | Call (f, args) -> (f, args)
| _ -> (e,[]) in
let (it, targs) = call_split tltp in
- let constructors = match OL.lexp_whnf it (ectx_to_lctx ctx) with
+ let constructors =
+ match OL.lexp'_whnf it (ectx_to_lctx ctx) with
| Inductive (_, _, fargs, constructors)
-> assert (List.length fargs = List.length targs);
constructors
@@ -792,15 +796,17 @@ and check_case rtype (loc, target, ppatterns) ctx =
let add_branch pctor pargs =
let loc = sexp_location pctor in
let lctor, ct = infer pctor ctx in
- let rec inst_args ctx e = match OL.lexp_whnf e (ectx_to_lctx ctx) with
+ let rec inst_args ctx e =
+ let lxp = OL.lexp_whnf e (ectx_to_lctx ctx) in
+ match lexp_lexp' lxp with
| Lambda (Aerasable, v, t, body)
-> let arg = newMetavar (ectx_to_lctx ctx) (ectx_to_scope_level ctx)
v t in
let nctx = ctx_extend ctx v Variable t in
let body = inst_args nctx body in
mkSusp body (S.substitute arg)
- | e -> e in
- match nosusp (inst_args ctx lctor) with
+ | e -> lxp in
+ match lexp_lexp' (nosusp (inst_args ctx lctor)) with
| Cons (it', (_, cons_name))
-> let _ = check_uniqueness pat cons_name lbranches in
let (constructors, targs) = get_cs_as it' lctor in
@@ -912,7 +918,7 @@ and elab_call ctx (func, ltp) (sargs: sexp list) =
let rec handle_fun_args largs sargs pending ltp =
let ltp' = OL.lexp_whnf ltp (ectx_to_lctx ctx) in
- match sargs, ltp' with
+ match sargs, lexp_lexp' ltp' with
| _, Arrow (ak, (_, Some aname), arg_type, _, ret_type)
when SMap.mem aname pending
-> let sarg = SMap.find aname pending in
@@ -967,7 +973,7 @@ and elab_call ctx (func, ltp) (sargs: sexp list) =
largs, ltp
| sarg :: sargs, _
- -> let (arg_type, ret_type) = match ltp' with
+ -> let (arg_type, ret_type) = match lexp_lexp' ltp' with
| Arrow (ak, _, arg_type, _, ret_type)
-> assert (ak = Anormal); (arg_type, ret_type)
| _ -> unify_with_arrow ctx (sexp_location sarg)
@@ -994,17 +1000,18 @@ and lexp_parse_inductive ctors ctx =
* things like `fv` and `meta_to_var`. *)
let altacc = List.fold_right
(fun (ak, n, t) aa
- -> Arrow (ak, n, t, dummy_location, aa))
+ -> mkArrow (ak, n, t, dummy_location, aa))
acc impossible in
let g = generalize nctx altacc in
let altacc' = g (fun _ne vname t l e
- -> Arrow (Aerasable, vname, t, l, e))
+ -> mkArrow (Aerasable, vname, t, l, e))
altacc in
if altacc' == altacc
then acc (* No generalization! *)
else
(* Convert the Lexp back into a list of fields. *)
- let rec loop e = match e with
+ let rec loop e =
+ match lexp_lexp' e with
| Arrow (ak, n, t, _, e) -> (ak, n, t)::(loop e)
| _ -> assert (e = impossible); [] in
loop altacc'
@@ -1157,8 +1164,10 @@ and infer_and_generalize_type (ctx : elab_context) se name =
*
* But we don't bother trying to catch all cases currently.
*)
- let rec strip_rettype t = match t with
- | Arrow (ak, v, t1, l, t2) -> Arrow (ak, v, t1, l, strip_rettype t2)
+ let rec strip_rettype t =
+ match lexp_lexp' t with
+ | Arrow (ak, v, t1, l, t2)
+ -> mkArrow (ak, v, t1, l, strip_rettype t2)
| Sort _ | Metavar _ -> type0 (* Abritrary closed constant. *)
| _ -> t in
let g = generalize nctx (strip_rettype t) in
@@ -1354,10 +1363,12 @@ and sform_new_attribute ctx loc sargs ot =
and sform_add_attribute ctx loc (sargs : sexp list) ot =
let n = get_size ctx in
let table, var, attr = match List.map (lexp_parse_sexp ctx) sargs with
- | [table; Var((_, Some name), idx); attr] -> table, (n - idx, name), attr
+ | [table; e; attr] when is_var e
+ -> table, (n - (get_var_db_index (get_var e)), U.get_vname_name (get_var_vname (get_var e))), attr
| _ -> fatal ~loc "add-attribute expects 3 arguments (table; var; attr)" in
- let map, attr_type = match OL.lexp_whnf table (ectx_to_lctx ctx) with
+ let map, attr_type =
+ match OL.lexp'_whnf table (ectx_to_lctx ctx) with
| Builtin (_, attr_type, Some map) -> map, attr_type
| _ -> fatal ~loc "add-attribute expects a table as first argument" in
@@ -1367,13 +1378,17 @@ and sform_add_attribute ctx loc (sargs : sexp list) ot =
(mkBuiltin ((loc, "add-attribute"), attr_type, Some table),
Lazy)
-and get_attribute ctx loc largs =
- let ctx_n = get_size ctx in
- let table, var = match largs with
- | [table; Var((_, Some name), idx)] -> table, (ctx_n - idx, name)
- | _ -> fatal ~loc "get-attribute expects 2 arguments (table; var)" in
- let map = match OL.lexp_whnf table (ectx_to_lctx ctx) with
+ and get_attribute ctx loc largs =
+ let ctx_n = get_size ctx in
+ let table, var = match largs with
+ | [table; e] when is_var e
+ -> table, (ctx_n - get_var_db_index (get_var e), U.get_vname_name (get_var_vname (get_var e)))
+ | _ -> fatal ~loc "get-attribute expects 2 arguments (table; var)" in
+
+
+ let map =
+ match OL.lexp'_whnf table (ectx_to_lctx ctx) with
| Builtin (_, attr_type, Some map) -> map
| _ -> fatal ~loc "get-attribute expects a table as first argument" in
@@ -1388,33 +1403,39 @@ and sform_get_attribute ctx loc (sargs : sexp list) ot =
and sform_has_attribute ctx loc (sargs : sexp list) ot =
let n = get_size ctx in
let table, var = match List.map (lexp_parse_sexp ctx) sargs with
- | [table; Var((_, Some name), idx)] -> table, (n - idx, name)
+ | [table; e] when is_var e
+ -> table, (n - get_var_db_index (get_var e), U.get_vname_name (get_var_vname (get_var e)))
| _ -> fatal ~loc "get-attribute expects 2 arguments (table; var)" in
- let map, attr_type = match OL.lexp_whnf table (ectx_to_lctx ctx) with
+
+ let map, attr_type =
+ let lp = OL.lexp_whnf table (ectx_to_lctx ctx) in
+ match lexp_lexp' lp with
| Builtin (_, attr_type, Some map) -> map, attr_type
- | lxp -> lexp_fatal loc lxp
+ | lxp -> lexp_fatal loc table
"get-attribute expects a table as first argument" in
(BI.o2l_bool ctx (AttributeMap.mem var map), Lazy)
-and sform_declexpr ctx loc sargs ot =
- match List.map (lexp_parse_sexp ctx) sargs with
- | [Var((_, vn), vi)]
- -> (match DB.env_lookup_expr ctx ((loc, vn), vi) with
- | Some lxp -> (lxp, Lazy)
- | None -> error ~loc "no expr available";
- sform_dummy_ret ctx loc)
- | _ -> error ~loc "declexpr expects one argument";
- sform_dummy_ret ctx loc
+ and sform_declexpr ctx loc sargs ot =
+ match List.map (lexp_parse_sexp ctx) sargs with
+ | [e] when is_var e
+ -> (match DB.env_lookup_expr ctx ((loc, U.get_vname_name_option (get_var_vname (get_var e))), get_var_db_index (get_var e)) with
+ | Some lxp -> (lxp, Lazy)
+ | None -> error ~loc "no expr available";
+ sform_dummy_ret ctx loc)
+ | _ -> error ~loc "declexpr expects one argument";
+ sform_dummy_ret ctx loc
+
+
+ let sform_decltype ctx loc sargs ot =
+ match List.map (lexp_parse_sexp ctx) sargs with
+ | [e] when is_var e
+ -> (DB.env_lookup_type ctx ((loc, U.get_vname_name_option (get_var_vname (get_var e))), get_var_db_index (get_var e)), Lazy)
+ | _ -> error ~loc "decltype expects one argument";
+ sform_dummy_ret ctx loc
-let sform_decltype ctx loc sargs ot =
- match List.map (lexp_parse_sexp ctx) sargs with
- | [Var((_, vn), vi)]
- -> (DB.env_lookup_type ctx ((loc, vn), vi), Lazy)
- | _ -> error ~loc "decltype expects one argument";
- sform_dummy_ret ctx loc
let builtin_value_types : ltype option SMap.t ref = ref SMap.empty
@@ -1597,7 +1618,8 @@ let sform_identifier ctx loc sargs ot =
-> Inverse_subst.apply_inv_subst t subst in
let mv = newMetavar octx sl (loc, Some name) t in
(if not (name = "") then
- let idx = match mv with
+ let idx =
+ match lexp_lexp' mv with
| Metavar (idx, _, _) -> idx
| _ -> fatal ~loc "newMetavar returned a non-Metavar" in
rmmap := SMap.add name idx (!rmmap));
@@ -1652,7 +1674,8 @@ let rec sform_lambda kind ctx loc sargs ot =
None
(* Read var type from the provided type *)
| Some t
- -> match OL.lexp_whnf t (ectx_to_lctx ctx) with
+ -> let lp = OL.lexp_whnf t (ectx_to_lctx ctx) in
+ match lexp_lexp' lp with
| Arrow (ak2, _, lt1, _, lt2) when ak2 = kind
-> (match olt1 with
| None -> ()
@@ -1680,7 +1703,7 @@ let rec sform_lambda kind ctx loc sargs ot =
| _ -> alt)
| lt
- -> let (lt1, lt2) = unify_with_arrow ctx loc lt kind arg olt1
+ -> let (lt1, lt2) = unify_with_arrow ctx loc lp kind arg olt1
in mklam lt1 (Some lt2))
| _ -> sexp_error loc ("##lambda_"^(match kind with Anormal -> "->"
@@ -1956,4 +1979,3 @@ let eval_decl_str str lctx rctx =
let elxps = (List.map OL.clean_decls lxps) in
(EV.eval_decls_toplevel elxps rctx), lctx
with Log.Stop_Compilation s -> (prev_rctx, prev_lctx)
-
=====================================
src/eval.ml
=====================================
@@ -484,7 +484,7 @@ and eval_call loc unef i f args =
(* We may call a Vlexp e.g. for "x = Map Int String".
* FIXME: The arg will sometimes be a Vlexp but not always, so this is
* really just broken! *)
- -> Vtype (L.mkCall (e, [(Anormal, Var (vdummy, -1))]))
+ -> Vtype (L.mkCall (e, [(Anormal, mkVar (vdummy, -1))]))
| _ -> value_fatal loc f "Trying to call a non-function!"
and eval_case ctx i loc target pat dflt =
@@ -738,10 +738,9 @@ let constructor_p name ectx =
(* Use `lexp_whnf` so that `name` can be indirectly
* defined as a constructor
* (e.g. as in `let foo = cons in case foo x xs | ...` *)
- match OL.lexp_whnf (mkVar ((dummy_location, Some name), idx))
- (ectx_to_lctx ectx) with
- | Cons _ -> true (* It's indeed a constructor! *)
- | _ -> false
+ match OL.lexp'_whnf (mkVar ((dummy_location, Some name), idx)) (ectx_to_lctx ectx) with
+ | Cons _ -> true (* It's indeed a constructor! *)
+ | _ -> false
with Senv_Lookup_Fail _ -> false
let erasable_p name nth ectx =
@@ -753,32 +752,33 @@ let erasable_p name nth ectx =
else false
| _ -> false in
try let idx = senv_lookup name ectx in
- match OL.lexp_whnf (mkVar ((dummy_location, Some name), idx))
- (ectx_to_lctx ectx) with
- | Cons (Var v, _) -> ( match (env_lookup_expr ectx v) with
- | Some (Inductive (_, _, _, ctors)) ->
- is_erasable ctors
- | _ -> false )
+ match OL.lexp'_whnf (mkVar ((dummy_location, Some name), idx)) (ectx_to_lctx ectx) with
+ | Cons (e, _) when is_var e
+ -> (match (env_lookup_expr ectx (get_var e)) with
+ | Some i when is_inductive i
+ -> is_erasable (get_inductive_ctor (get_inductive i))
+ | _ -> false)
| _ -> false
with Senv_Lookup_Fail _ -> false
let erasable_p2 t name ectx =
- let is_erasable ctors = match (smap_find_opt t ctors) with
- | Some args ->
- (List.exists
- (fun (k, oname, _)
- -> match oname with
- | (_, Some n) -> (n = name && k = Aerasable)
- | _ -> false)
- args)
- | _ -> false in
+ let is_erasable ctors =
+ match (smap_find_opt t ctors) with
+ | Some args
+ -> (List.exists
+ (fun (k, oname, _)
+ -> match oname with
+ | (_, Some n) -> (n = name && k = Aerasable)
+ | _ -> false)
+ args)
+ | _ -> false in
try let idx = senv_lookup t ectx in
- match OL.lexp_whnf (mkVar ((dummy_location, Some t), idx))
- (ectx_to_lctx ectx) with
- | Cons (Var v, _) -> ( match (env_lookup_expr ectx v) with
- | Some (Inductive (_, _, _, ctors)) ->
- is_erasable ctors
- | _ -> false )
+ match OL.lexp'_whnf (mkVar ((dummy_location, Some t), idx)) (ectx_to_lctx ectx) with
+ | Cons (e, _) when is_var e
+ -> (match (env_lookup_expr ectx (get_var e)) with
+ | Some i when is_inductive i
+ -> is_erasable (get_inductive_ctor (get_inductive i))
+ | _ -> false)
| _ -> false
with Senv_Lookup_Fail _ -> false
@@ -791,12 +791,12 @@ let nth_ctor_arg name nth ectx =
| exception (Failure _) -> "_" )
| _ -> "_" in
try let idx = senv_lookup name ectx in
- match OL.lexp_whnf (mkVar ((dummy_location, Some name), idx))
- (ectx_to_lctx ectx) with
- | Cons (Var v, _) -> ( match (env_lookup_expr ectx v) with
- | Some (Inductive (_, _, _, ctors)) ->
- find_nth ctors
- | _ -> "_" )
+ match OL.lexp'_whnf (mkVar ((dummy_location, Some name), idx)) (ectx_to_lctx ectx) with
+ | Cons (e, _) when is_var e
+ -> (match (env_lookup_expr ectx (get_var e)) with
+ | Some i when is_inductive i
+ -> find_nth (get_inductive_ctor (get_inductive i))
+ | _ -> "_")
| _ -> "_"
with Senv_Lookup_Fail _ -> "_"
@@ -812,12 +812,12 @@ let ctor_arg_pos name arg ectx =
| Some n -> n )
| _ -> (-1) in
try let idx = senv_lookup name ectx in
- match OL.lexp_whnf (mkVar ((dummy_location, Some name), idx))
- (ectx_to_lctx ectx) with
- | Cons (Var v, _) -> ( match (env_lookup_expr ectx v) with
- | Some (Inductive (_, _, _, ctors)) ->
- find_arg ctors
- | _ -> (-1) )
+ match OL.lexp'_whnf (mkVar ((dummy_location, Some name), idx)) (ectx_to_lctx ectx) with
+ | Cons (e, _) when is_var e
+ -> (match (env_lookup_expr ectx (get_var e)) with
+ | Some i when is_inductive i
+ -> find_arg (get_inductive_ctor (get_inductive i))
+ | _ -> (-1))
| _ -> (-1)
with Senv_Lookup_Fail _ -> (-1)
=====================================
src/inverse_subst.ml
=====================================
@@ -56,11 +56,11 @@ type substIR = ((int * int) list * int * int)
(** Transform a substitution to a more linear substitution
* makes the inversion easier
* Example of result : ((new_idx, old_position)::..., shift)*)
-let transfo (s: Lexp.subst) : substIR option =
- let rec transfo (s: Lexp.subst) (off_acc: int) (idx: int) (imp_cnt : int)
+let transfo (s: subst) : substIR option =
+ let rec transfo (s: subst) (off_acc: int) (idx: int) (imp_cnt : int)
: substIR option =
let indexOf (v: lexp): int = (* Helper : return the index of a variabble *)
- match v with
+ match lexp_lexp' v with
| Var (_, v) -> v
| _ -> assert false
in
@@ -68,15 +68,16 @@ let transfo (s: Lexp.subst) : substIR option =
indexOf (mkSusp var (S.shift offset)) (* Helper : shift the index of a var *)
in
match s with
- | S.Cons (Var _ as v, s, o) ->
- let off_acc = off_acc + o in
+ | S.Cons (e, s, o) when is_var e
+ -> let off_acc = off_acc + o in
(match transfo s off_acc (idx + 1) imp_cnt with
| Some (tail, off, imp)
- -> let newVar = shiftVar v off_acc
+ -> let newVar = shiftVar e off_acc
in if newVar >= off then None (* Error *)
- else Some (((shiftVar v off_acc), idx)::tail, off, imp)
+ else Some (((shiftVar e off_acc), idx)::tail, off, imp)
| None -> None)
- | S.Cons (Imm (Sexp.Symbol (_, "")), s, o)
+ | S.Cons (e, s, o)
+ when pred_imm e (fun s -> Sexp.pred_symbol s (fun n -> n = ""))
-> transfo s (o + off_acc) (idx + 1) (imp_cnt + 1)
| S.Identity o -> Some ([], (o + off_acc), imp_cnt)
| _ -> None (* Error *)
@@ -93,7 +94,7 @@ let rec sizeOf (s: (int * int) list): int = List.length s
let counter = ref 0
let mkVar (idx: int) : lexp =
counter := !counter + 1;
- Lexp.mkVar ((U.dummy_location, None), idx)
+ mkVar ((U.dummy_location, None), idx)
(** Fill the gap between e_i in the list of couple (e_i, i) by adding
dummy variables.
@@ -104,18 +105,18 @@ let mkVar (idx: int) : lexp =
@param size size of the list to return
@param acc recursion accumulator
*)
-let fill (l: (int * int) list) (nbVar: int) (shift: int): Lexp.subst option =
- let rec genDummyVar (beg_: int) (end_: int) (l: Lexp.subst): Lexp.subst = (* Create the filler variables *)
+let fill (l: (int * int) list) (nbVar: int) (shift: int): subst option =
+ let rec genDummyVar (beg_: int) (end_: int) (l: subst): subst = (* Create the filler variables *)
if beg_ < end_
then S.cons impossible (genDummyVar (beg_ + 1) end_ l)
else l
in
- let fill_before (l: (int * int) list) (s: Lexp.subst) (nbVar: int): Lexp.subst option = (* Fill if the first var is not 0 *)
+ let fill_before (l: (int * int) list) (s: subst) (nbVar: int): subst option = (* Fill if the first var is not 0 *)
match l with
| [] -> Some (genDummyVar 0 nbVar s)
| (i1, v1)::_ when i1 > 0 -> Some (genDummyVar 0 i1 s)
| _ -> Some s
- in let rec fill_after (l: (int * int) list) (nbVar: int) (shift: int): Lexp.subst option = (* Fill gaps *)
+ in let rec fill_after (l: (int * int) list) (nbVar: int) (shift: int): subst option = (* Fill gaps *)
match l with
| (idx1, val1)::(idx2, val2)::tail when (idx1 = idx2) -> None
@@ -145,7 +146,8 @@ let fill (l: (int * int) list) (nbVar: int) (shift: int): Lexp.subst option =
let is_identity s =
let rec is_identity s acc =
match s with
- | S.Cons(Var(_, idx), s1, 0) when idx = acc -> is_identity s1 (acc + 1)
+ | S.Cons(e, s1, 0) when pred_var e (fun e -> get_var_db_index e = acc)
+ -> is_identity s1 (acc + 1)
| S.Identity o -> acc = o
| _ -> S.identity_p s
in is_identity s 0
@@ -154,7 +156,7 @@ let is_identity s =
<code>s:S.subst, l:lexp, s':S.subst</code> where <code>l[s][s'] = l</code> and <code> inverse s = s' </code>
*)
-let inverse (s: Lexp.subst) : Lexp.subst option =
+let inverse (s: subst) : subst option =
let sort = List.sort (fun (ei1, _) (ei2, _) -> compare ei1 ei2)
in match transfo s with
| None -> None
@@ -182,7 +184,8 @@ let inverse (s: Lexp.subst) : Lexp.subst option =
* with non-variables, in which case the "inverse" is ambiguous. *)
let rec invertible (s: subst) : bool = match s with
| S.Identity _ -> true
- | S.Cons (e, s, _) -> (match e with Var _ -> true | _ -> e = impossible)
+ | S.Cons (e, s, _)
+ -> (match lexp_lexp' e with Var _ -> true | _ -> e = impossible)
&& invertible s
exception Not_invertible
@@ -193,13 +196,13 @@ let rec lookup_inv_subst (i : db_index) (s : subst) : db_index
= match s with
| (S.Identity o | S.Cons (_, _, o)) when i < o -> raise Not_invertible
| S.Identity o -> i - o
- | S.Cons (Var (_, i'), s, o) when i' = i - o
- -> (try let i'' = lookup_inv_subst i' s in
+ | S.Cons (e, s, o) when pred_var e (fun e -> get_var_db_index e = i - o)
+ -> (try let i'' = lookup_inv_subst (get_var_db_index (get_var e)) s in
assert (i'' != 0);
raise Ambiguous
with Not_invertible -> 0)
| S.Cons (e, s, o)
- -> assert (match e with Var _ -> true | _ -> e = impossible);
+ -> assert (match lexp_lexp' e with Var _ -> true | _ -> e = impossible);
1 + lookup_inv_subst (i - o) s
(* When going under a binder, we have the rule
@@ -248,7 +251,8 @@ let rec compose_inv_subst (s' : subst) (s : subst) = match s' with
* The function presumes that `invertible s` was true.
* This can be used like mkSusp/push_susp, but it's not lazy.
* This is because it can signal errors Not_invertible or Ambiguous. *)
-and apply_inv_subst (e : lexp) (s : subst) : lexp = match e with
+and apply_inv_subst (e : lexp) (s : subst) : lexp =
+ match lexp_lexp' e with
| Imm _ -> e
| SortLevel (SLz) -> e
| SortLevel (SLsucc e) -> mkSortLevel (mkSLsucc (apply_inv_subst e s))
=====================================
src/lexp.ml
=====================================
@@ -60,7 +60,9 @@ module AttributeMap = Map.Make (struct type t = attribute_key let compare = comp
type ltype = lexp
and subst = lexp S.subst
- and lexp =
+(* Here we want a pair of `Lexp` and its hash value to avoid re-hashing "sub-Lexp". *)
+ and lexp = lexp' * int
+ and lexp' =
| Imm of sexp (* Used for strings, ... *)
| SortLevel of sort_level
| Sort of U.location * sort
@@ -157,7 +159,6 @@ type metavar_info =
type meta_subst = metavar_info U.IMap.t
let dummy_scope_level = 0
-let impossible = Imm Sexp.dummy_epsilon
let builtin_size = ref 0
@@ -169,22 +170,140 @@ let metavar_lookup (id : meta_id) : metavar_info
(********************** Hash-consing **********************)
-(* let hc_table : (lexp, lexp) Hashtbl.t = Hashtbl.create 1000
- * let hc (e : lexp) : lexp =
- * try Hashtbl.find hc_table e
- * with Not_found -> Hashtbl.add hc_table e e; e *)
+(** Hash-consing test **
+* with: Hashtbl.hash / lexp'_hash
+* median bucket length: 7 / 7
+* biggest bucket length: 205 / 36
+* found/new lexp entries: - / 2 *)
+
+let lexp_lexp' (e, h) = e
+let lexp_hash (e, h) = h
+
+(* Hash `Lexp` using combine_hash (lxor) with hash of "sub-lexp". *)
+let lexp'_hash (lp : lexp') =
+ match lp with
+ | Imm s -> U.combine_hash 1 (Hashtbl.hash s)
+ | SortLevel l
+ -> U.combine_hash 2
+ (match l with
+ | SLz -> Hashtbl.hash l
+ | SLsucc lp -> lexp_hash lp
+ | SLlub (lp1, lp2)
+ -> U.combine_hash (lexp_hash lp1) (lexp_hash lp2))
+ | Sort (l, s)
+ -> U.combine_hash 3 (U.combine_hash (Hashtbl.hash l)
+ (match s with
+ | Stype lp -> lexp_hash lp
+ | StypeOmega -> Hashtbl.hash s
+ | StypeLevel -> Hashtbl.hash s))
+ | Builtin (v, t, m)
+ -> U.combine_hash 4 (U.combine_hash
+ (U.combine_hash (Hashtbl.hash v) (lexp_hash t))
+ (match m with
+ | Some m -> Hashtbl.hash m
+ | None -> 404))
+ | Var v -> U.combine_hash 5 (Hashtbl.hash v)
+ | Let (l, ds, e)
+ -> U.combine_hash 6 (U.combine_hash (Hashtbl.hash l)
+ (U.combine_hash (U.combine_hashes
+ (List.map (fun e -> let (n, lp, lt) = e in
+ (U.combine_hash (Hashtbl.hash n)
+ (U.combine_hash (lexp_hash lp) (lexp_hash lt))))
+ ds))
+ (lexp_hash e)))
+ | Arrow (k, v, t1, l, t2)
+ -> U.combine_hash 7 (U.combine_hash
+ (U.combine_hash (Hashtbl.hash k) (Hashtbl.hash v))
+ (U.combine_hash (lexp_hash t1)
+ (U.combine_hash (Hashtbl.hash l) (lexp_hash t2))))
+ | Lambda (k, v, t, e)
+ -> U.combine_hash 8 (U.combine_hash
+ (U.combine_hash (Hashtbl.hash k) (Hashtbl.hash v))
+ (U.combine_hash (lexp_hash t) (lexp_hash e)))
+ | Inductive (l, n, a, cs)
+ -> U.combine_hash 9 (U.combine_hash
+ (U.combine_hash (Hashtbl.hash l) (Hashtbl.hash n))
+ (U.combine_hash (U.combine_hashes
+ (List.map (fun e -> let (ak, n, lt) = e in
+ (U.combine_hash (Hashtbl.hash ak)
+ (U.combine_hash (Hashtbl.hash n) (lexp_hash lt))))
+ a))
+ (Hashtbl.hash cs)))
+ | Cons (t, n) -> U.combine_hash 10 (U.combine_hash (lexp_hash t) (Hashtbl.hash n))
+ | Case (l, e, rt, bs, d)
+ -> U.combine_hash 11 (U.combine_hash
+ (U.combine_hash (Hashtbl.hash l) (lexp_hash e))
+ (U.combine_hash (lexp_hash rt) (U.combine_hash
+ (Hashtbl.hash bs)
+ (match d with
+ | Some (n, lp) -> U.combine_hash (Hashtbl.hash n) (lexp_hash lp)
+ | _ -> 0))))
+ | Metavar (id, s, v)
+ -> U.combine_hash 12 (U.combine_hash id
+ (U.combine_hash (Hashtbl.hash s) (Hashtbl.hash v)))
+ | Call (e, args)
+ -> U.combine_hash 13 (U.combine_hash (lexp_hash e)
+ (U.combine_hashes (List.map (fun e -> let (ak, lp) = e in
+ (U.combine_hash (Hashtbl.hash ak) (lexp_hash lp)))
+ args)))
+ | Susp (lp, subst)
+ -> U.combine_hash 14 (U.combine_hash (lexp_hash lp) (Hashtbl.hash subst))
+
+(* Equality function for hash table
+ * using physical equality for "sub-lexp" and compare for `subst`. *)
+let hc_eq e1 e2 =
+ match (lexp_lexp' e1, lexp_lexp' e2) with
+ | (Imm (Integer (_, i1)), Imm (Integer (_, i2))) -> i1 = i2
+ | (Imm (Float (_, x1)), Imm (Float (_, x2))) -> x1 = x2
+ | (Imm (String (_, s1)), Imm (String (_, s2))) -> s1 = s2
+ | (Imm s1, Imm s2) -> s1 = s2
+ | (SortLevel SLz, SortLevel SLz) -> true
+ | (SortLevel (SLsucc e1), SortLevel (SLsucc e2)) -> e1 == e2
+ | (SortLevel (SLlub (e11, e21)), SortLevel (SLlub (e12, e22)))
+ -> e11 == e12 && e21 == e22
+ | (Sort (_, StypeOmega), Sort (_, StypeOmega)) -> true
+ | (Sort (_, StypeLevel), Sort (_, StypeLevel)) -> true
+ | (Sort (_, Stype e1), Sort (_, Stype e2)) -> e1 == e2
+ | (Builtin ((_, name1), _, _), Builtin ((_, name2), _, _)) -> name1 = name2
+ | (Var (_, i1), Var (_, i2)) -> i1 = i2
+ | (Susp (e1, s1), Susp (e2, s2)) -> e1 == e2 && compare s1 s2 = 0
+ | (Let (_, defs1, e1), Let (_, defs2, e2))
+ -> e1 == e2 && List.for_all2
+ (fun (_, e1, t1) (_, e2, t2) -> t1 == t2 && e1 == e2) defs1 defs2
+ | (Arrow (ak1, _, t11, _, t21), Arrow (ak2, _, t12, _, t22))
+ -> ak1 = ak2 && t11 == t12 && t21 == t22
+ | (Lambda (ak1, _, t1, e1), Lambda (ak2, _, t2, e2))
+ -> ak1 = ak2 && t1 == t2 && e1 == e2
+ | (Call (e1, as1), Call (e2, as2))
+ -> e1 == e2 && List.for_all2
+ (fun (ak1, e1) (ak2, e2) -> ak1 = ak2 && e1 == e2) as1 as2
+ | (Inductive (_, l1, as1, ctor1), Inductive (_, l2, as2, ctor2))
+ -> l1 = l2 && List.for_all2
+ (fun (ak1, _, e1) (ak2, _, e2) -> ak1 = ak2 && e1 == e2) as1 as2
+ && SMap.equal (List.for_all2
+ (fun (ak1, _, e1) (ak2, _, e2) -> ak1 = ak2 && e1 == e2)) ctor1 ctor2
+ | (Cons (t1, (_, l1)), Cons (t2, (_, l2))) -> t1 == t2 && l1 = l2
+ | (Case (_, e1, r1, ctor1, def1), Case (_, e2, r2, ctor2, def2))
+ -> e1 == e2 && r1 == r2 && SMap.equal
+ (fun (_, fields1, e1) (_, fields2, e2)
+ -> e1 == e2 && List.for_all2
+ (fun (ak1, _) (ak2, _) -> ak1 = ak2) fields1 fields2) ctor1 ctor2
+ && (match (def1, def2) with
+ | (Some (_, e1), Some (_, e2)) -> e1 == e2
+ | _ -> def1 = def2)
+ | (Metavar (i1, s1, _), Metavar (i2, s2, _))
+ -> i1 = i2 && compare s1 s2 = 0
+ | _ -> false
module WHC = Weak.Make (struct type t = lexp
- (* Using (=) instead of `compare` results
- * in an *enormous* slowdown. Apparently
- * `compare` checks == before recursing
- * but (=) doesn't? *)
- let equal x y = (compare x y = 0)
- let hash = Hashtbl.hash
- end)
+ let equal x y = hc_eq x y
+ let hash = lexp_hash
+ end)
+
let hc_table : WHC.t = WHC.create 1000
-let hc : lexp -> lexp = WHC.merge hc_table
+let hc (l : lexp') : lexp =
+ WHC.merge hc_table (l, lexp'_hash l)
let mkImm s = hc (Imm s)
let mkSortLevel l = hc (SortLevel l)
@@ -198,14 +317,16 @@ let mkInductive (l, n, a, cs) = hc (Inductive (l, n, a, cs))
let mkCons (t, n) = hc (Cons (t, n))
let mkCase (l, e, rt, bs, d) = hc (Case (l, e, rt, bs, d))
let mkMetavar (n, s, v) = hc (Metavar (n, s, v))
-let mkCall (f, es)
- = match f, es with
- | Call (f', es'), _ -> hc (Call (f', es' @ es))
- | _, [] -> f
- | _ -> hc (Call (f, es))
-
-and lexp_head e =
- match e with
+let mkCall (f, es) =
+ match lexp_lexp' f, es with
+ | Call (f', es'), _ -> hc (Call (f', es' @ es))
+ | _, [] -> f
+ | _ -> hc (Call (f, es))
+
+let impossible = mkImm Sexp.dummy_epsilon
+
+let lexp_head e =
+ match lexp_lexp' e with
| Imm s -> if e = impossible then "impossible" else "Imm" ^ sexp_string s
| Var _ -> "Var"
| Let _ -> "let"
@@ -222,7 +343,8 @@ and lexp_head e =
| Sort _ -> "Sort"
| SortLevel _ -> "SortLevel"
-let mkSLlub' (e1, e2) = match (e1, e2) with
+let mkSLlub' (e1, e2) =
+ match (lexp_lexp' e1, lexp_lexp' e2) with
(* FIXME: This first case should be handled by calling `mkSLlub` instead! *)
| (SortLevel SLz, SortLevel l) | (SortLevel l, SortLevel SLz) -> l
| (SortLevel SLz, _) | (_, SortLevel SLz)
@@ -235,11 +357,54 @@ let mkSLlub' (e1, e2) = match (e1, e2) with
| _ -> Log.log_fatal ~section:"internal"
("SLlub of non-level: " ^ lexp_head e1 ^ " ∪ " ^ lexp_head e2)
-let mkSLsucc e = match e with
- | SortLevel _ | Var _ | Metavar _ | Susp _
- -> SLsucc e
- | _ -> Log.log_fatal ~section:"internal" "SLsucc of non-level "
-
+let mkSLsucc e =
+ match lexp_lexp' e with
+ | SortLevel _ | Var _ | Metavar _ | Susp _
+ -> SLsucc e
+ | _ -> Log.log_fatal ~section:"internal" "SLsucc of non-level "
+
+(********************** Lexp tests ************************)
+
+let pred_imm l pred =
+ match lexp_lexp' l with
+ | Imm s -> pred s
+ | _ -> false
+
+let is_imm l = pred_imm l (fun e -> true)
+
+let pred_var l pred =
+ match lexp_lexp' l with
+ | Var v -> pred v
+ | _ -> false
+
+let is_var l = pred_var l (fun e -> true)
+
+let get_var l =
+ match lexp_lexp' l with
+ | Var v -> v
+ | _ -> Log.log_fatal ~section:"internal" "Lexp is not Var "
+
+let get_var_db_index v =
+ let (n, idx) = v in idx
+
+let get_var_vname v =
+ let (n, idx) = v in n
+
+let pred_inductive l pred =
+ match lexp_lexp' l with
+ | Inductive (l, n, a, cs) -> pred (l, n, a, cs)
+ | _ -> false
+
+let get_inductive l =
+match lexp_lexp' l with
+ | Inductive (l, n, a, cs) -> (l, n, a, cs)
+ | _ -> Log.log_fatal ~section:"internal" "Lexp is not Inductive "
+
+let get_inductive_ctor i =
+ let (l, n, a, cs) = i in cs
+
+let is_inductive l = pred_inductive l (fun e -> true)
+
(********* Helper functions to use the Subst operations *********)
(* This basically "ties the knot" between Subst and Lexp.
* Maybe it would be cleaner to just move subst.ml into lexp.ml
@@ -276,7 +441,7 @@ let rec mkSusp e s =
(* We apply the substitution eagerly to some terms.
* There's no deep technical reason for that:
* it just seemed like a good idea to do it eagerly when it's easy. *)
- match e with
+ match lexp_lexp' e with
| Imm _ -> e
| Builtin _ -> e
| Susp (e, s') -> mkSusp_memo e (scompose s' s)
@@ -338,7 +503,7 @@ let _ = assert (S.identity_p (scompose (S.shift 5) (sunshift 5)))
let rec lexp_location e =
- match e with
+ match lexp_lexp' e with
| Sort (l,_) -> l
| SortLevel (SLsucc e) -> lexp_location e
| SortLevel (SLlub (e, _)) -> lexp_location e
@@ -365,10 +530,10 @@ let maybename n = match n with None -> "<anon>" | Some v -> v
let sname (l,n) = (l, maybename n)
let rec push_susp e s = (* Push a suspension one level down. *)
- match e with
+ match lexp_lexp' e with
| Imm _ -> e
| SortLevel (SLz) -> e
- | SortLevel (SLsucc e') -> mkSortLevel (mkSLsucc (mkSusp e' s))
+ | SortLevel (SLsucc e'') -> mkSortLevel (mkSLsucc (mkSusp e'' s))
| SortLevel (SLlub (e1, e2))
-> mkSortLevel (mkSLlub' (mkSusp e1 s, mkSusp e2 s))
| Sort (l, Stype e) -> mkSort (l, Stype (mkSusp e s))
@@ -424,14 +589,15 @@ let rec push_susp e s = (* Push a suspension one level down. *)
| (Var _ | Metavar _) -> nosusp (mkSusp e s)
and nosusp e = (* Return `e` with no outermost `Susp`. *)
- match e with
+ match lexp_lexp' e with
| Susp(e, s) -> push_susp e s
| _ -> e
(* Get rid of `Susp`ensions and instantiated `Metavar`s. *)
let clean e =
- let rec clean s e = match e with
+ let rec clean s e =
+ match lexp_lexp' e with
| Imm _ -> e
| SortLevel (SLz) -> e
| SortLevel (SLsucc e) -> mkSortLevel (mkSLsucc (clean s e))
@@ -468,7 +634,7 @@ let clean e =
L.rev ncase)
cases in
mkInductive (l, label, nargs, ncases)
- | Cons (it, name) -> Cons (clean s it, name)
+ | Cons (it, name) -> mkCons (clean s it, name)
| Case (l, e, ret, cases, default)
-> mkCase (l, clean s e, clean s ret,
SMap.map (fun (l, cargs, e)
@@ -495,8 +661,8 @@ let stypecons = Symbol (U.dummy_location, "##typecons")
(* ugly printing (sexp_print (pexp_unparse (lexp_unparse e))) *)
let rec lexp_unparse lxp =
- match lxp with
- | Susp _ as e -> lexp_unparse (nosusp e)
+ match lexp_lexp' lxp with
+ | Susp _ -> lexp_unparse (nosusp lxp)
| Imm (sexp) -> sexp
| Builtin ((l,name), _, _) -> Symbol (l, "##" ^ name)
(* FIXME: Add a Sexp syntax for debindex references. *)
@@ -626,7 +792,7 @@ and subst_string s = match s with
-> "(↑"^ string_of_int o ^ " " ^ subst_string (S.cons l s) ^ ")"
and lexp_name e =
- match e with
+ match lexp_lexp' e with
| Imm _ -> lexp_string e
| Var _ -> lexp_string e
| _ -> lexp_head e
@@ -716,7 +882,7 @@ let get_binary_op_name name =
let rec get_precedence expr ctx =
let lkp name = SMap.find name (pp_grammar ctx) in
- match expr with
+ match lexp_lexp' expr with
| Lambda _ -> lkp "lambda"
| Case _ -> lkp "case"
| Let _ -> lkp "let"
@@ -784,14 +950,15 @@ and lexp_str ctx (exp : lexp) : string =
let kindp_str k = match k with
| Anormal -> ":" | Aimplicit -> "::" | Aerasable -> ":::" in
- let get_name fname = match fname with
+ let get_name fname =
+ match lexp_lexp' fname with
| Builtin ((_, name), _, _) -> name, 0
| Var((_, Some name), idx) -> name, idx
| Lambda _ -> "__", 0
| Cons _ -> "__", 0
| _ -> "__", -1 in
- match exp with
+ match lexp_lexp' exp with
| Imm(value) -> (match value with
| String (_, s) -> tval ("\"" ^ s ^ "\"")
| Integer(_, s) -> tval (string_of_int s)
@@ -902,9 +1069,6 @@ and lexp_str ctx (exp : lexp) : string =
| Builtin ((_, name), _, _) -> "##" ^ name
- | Sort (_, Stype (SortLevel SLz)) -> "##Type"
- | Sort (_, Stype (SortLevel (SLsucc (SortLevel SLz)))) -> "##Type1"
- | Sort (_, Stype l) -> "(##Type_ " ^ lexp_string l ^ ")"
| Sort (_, StypeLevel) -> "##TypeLevel.Sort"
| Sort (_, StypeOmega) -> "##Type_ω"
@@ -913,6 +1077,14 @@ and lexp_str ctx (exp : lexp) : string =
| SortLevel (SLlub (e1, e2))
-> "(##TypeLevel.∪ " ^ lexp_string e1 ^ " " ^ lexp_string e2 ^ ")"
+ | Sort (_, Stype l)
+ -> match lexp_lexp' l with
+ | SortLevel SLz -> "##Type"
+ | SortLevel (SLsucc lp)
+ when (match lexp_lexp' lp with SortLevel SLz -> true | _ -> false)
+ -> "##Type1"
+ | _ -> "(##Type_ " ^ lexp_string l ^ ")"
+
and lexp_str_ctor ctx ctors =
let pretty = pp_pretty ctx in
@@ -947,11 +1119,8 @@ and lexp_str_decls ctx decls =
let rec eq e1 e2 =
e1 == e2 ||
- match (e1, e2) with
- | (Imm (Integer (_, i1)), Imm (Integer (_, i2))) -> i1 = i2
- | (Imm (Float (_, x1)), Imm (Float (_, x2))) -> x1 = x2
- | (Imm (String (_, s1)), Imm (String (_, s2))) -> s1 = s2
- | (Imm s1, Imm s2) -> s1 = s2
+ match (lexp_lexp' e1, lexp_lexp' e2) with
+ | (Imm s1, Imm s2) -> sexp_equal s1 s2
| (SortLevel SLz, SortLevel SLz) -> true
| (SortLevel (SLsucc e1), SortLevel (SLsucc e2)) -> eq e1 e2
| (SortLevel (SLlub (e11, e21)), SortLevel (SLlub (e12, e22)))
@@ -961,37 +1130,31 @@ let rec eq e1 e2 =
| (Sort (_, Stype e1), Sort (_, Stype e2)) -> eq e1 e2
| (Builtin ((_, name1), _, _), Builtin ((_, name2), _, _)) -> name1 = name2
| (Var (_, i1), Var (_, i2)) -> i1 = i2
- | (Susp (e1, s1), e2) -> eq (push_susp e1 s1) e2
- | (e1, Susp (e2, s2)) -> eq e1 (push_susp e2 s2)
+ | (Susp (e1, s1), _) -> eq (push_susp e1 s1) e2
+ | (_, Susp (e2, s2)) -> eq e1 (push_susp e2 s2)
| (Let (_, defs1, e1), Let (_, defs2, e2))
- -> eq e1 e2 && List.for_all2 (fun (_, e1, t1) (_, e2, t2)
- -> eq t1 t2 && eq e1 e2)
- defs1 defs2
+ -> eq e1 e2 && List.for_all2
+ (fun (_, e1, t1) (_, e2, t2) -> eq t1 t2 && eq e1 e2) defs1 defs2
| (Arrow (ak1, _, t11, _, t21), Arrow (ak2, _, t12, _, t22))
-> ak1 = ak2 && eq t11 t12 && eq t21 t22
| (Lambda (ak1, _, t1, e1), Lambda (ak2, _, t2, e2))
-> ak1 = ak2 && eq t1 t2 && eq e1 e2
| (Call (e1, as1), Call (e2, as2))
- -> eq e1 e2 && List.for_all2 (fun (ak1, e1) (ak2, e2) -> ak1 = ak2 && eq e1 e2)
- as1 as2
- | (Inductive (_, l1, as1, cases1), Inductive (_, l2, as2, cases2))
- -> l1 = l2
- && List.for_all2 (fun (ak1, _, e1) (ak2, _, e2) -> ak1 = ak2 && eq e1 e2)
- as1 as2
- && SMap.equal (List.for_all2 (fun (ak1, _, e1) (ak2, _, e2)
- -> ak1 = ak2 && eq e1 e2))
- cases1 cases2
+ -> eq e1 e2 && List.for_all2
+ (fun (ak1, e1) (ak2, e2) -> ak1 = ak2 && eq e1 e2) as1 as2
+ | (Inductive (_, l1, as1, ctor1), Inductive (_, l2, as2, ctor2))
+ -> l1 = l2 && List.for_all2
+ (fun (ak1, _, e1) (ak2, _, e2) -> ak1 = ak2 && eq e1 e2) as1 as2
+ && SMap.equal (List.for_all2
+ (fun (ak1, _, e1) (ak2, _, e2) -> ak1 = ak2 && eq e1 e2)) ctor1 ctor2
| (Cons (t1, (_, l1)), Cons (t2, (_, l2))) -> eq t1 t2 && l1 = l2
- | (Case (_, e1, r1, cases1, def1), Case (_, e2, r2, cases2, def2))
- -> eq e1 e2 && eq r1 r2
- && SMap.equal (fun (_, fields1, e1) (_, fields2, e2)
- -> eq e1 e2 && List.for_all2 (fun (ak1, _) (ak2, _)
- -> ak1 = ak2)
- fields1 fields2)
- cases1 cases2
+ | (Case (_, e1, r1, ctor1, def1), Case (_, e2, r2, ctor2, def2))
+ -> eq e1 e2 && eq r1 r2 && SMap.equal
+ (fun (_, fields1, e1) (_, fields2, e2) -> eq e1 e2 && List.for_all2
+ (fun (ak1, _) (ak2, _) -> ak1 = ak2) fields1 fields2) ctor1 ctor2
&& (match (def1, def2) with
- | (Some (_, e1), Some (_, e2)) -> eq e1 e2
- | _ -> def1 = def2)
+ | (Some (_, e1), Some (_, e2)) -> eq e1 e2
+ | _ -> def1 = def2)
| (Metavar (i1, s1, _), Metavar (i2, s2, _))
-> if i1 == i2 then subst_eq s1 s2 else
(match (metavar_lookup i1, metavar_lookup i2) with
@@ -1024,4 +1187,3 @@ and subst_eq s1 s2 =
eq e1 (mkSusp e2 (S.shift o))
&& subst_eq s1 (S.mkShift s2 o)
| _ -> false
-
=====================================
src/opslexp.ml
=====================================
@@ -132,78 +132,82 @@ let lexp_close lctx e =
* but only on *types*. If you must use it on code, be sure to use its
* return value as little as possible since WHNF will inherently introduce
* call-by-name behavior. *)
-let lexp_whnf e (ctx : DB.lexp_context) : lexp =
- let rec lexp_whnf e (ctx : DB.lexp_context) : lexp =
- match e with
+
+let lexp_whnf_aux e (ctx : DB.lexp_context) : lexp =
+let rec lexp_whnf_aux e (ctx : DB.lexp_context) : lexp =
+ match lexp_lexp' e with
| Var v -> (match lookup_value ctx v with
| None -> e
(* We can do this blindly even for recursive definitions!
* IOW the risk of inf-looping should only show up when doing
* things like full normalization (e.g. lexp_conv_p). *)
- | Some e' -> lexp_whnf e' ctx)
- | Susp (e, s) -> lexp_whnf (push_susp e s) ctx
- | Call (e, []) -> lexp_whnf e ctx
+ | Some e' -> lexp_whnf_aux e' ctx)
+ | Susp (e, s) -> lexp_whnf_aux (push_susp e s) ctx
+ | Call (e, []) -> lexp_whnf_aux e ctx
| Call (f, (((_, arg)::args) as xs)) ->
- (match lexp_whnf f ctx with
+ (match lexp_lexp' (lexp_whnf_aux f ctx) with
| Lambda (_, _, _, body) ->
(* Here we apply whnf to the arg eagerly to kind of stay closer
* to the idea of call-by-value, although in this context
* we can't really make sure we always reduce the arg to a value. *)
- lexp_whnf (mkCall (push_susp body (S.substitute (lexp_whnf arg ctx)),
+ lexp_whnf_aux (mkCall (push_susp body (S.substitute (lexp_whnf_aux arg ctx)),
args))
ctx
| Call (f', xs1) -> mkCall (f', List.append xs1 xs)
| _ -> e) (* Keep `e`, assuming it's more readable! *)
| Case (l, e, rt, branches, default) ->
- let e' = lexp_whnf e ctx in
+ let e' = lexp_whnf_aux e ctx in
let reduce name aargs =
try
let (_, _, branch) = SMap.find name branches in
let (subst, _)
= List.fold_left
(fun (s,d) (_, arg) ->
- (S.cons (L.mkSusp (lexp_whnf arg ctx) (S.shift d)) s,
+ (S.cons (L.mkSusp (lexp_whnf_aux arg ctx) (S.shift d)) s,
d + 1))
(S.identity, 0)
aargs in
- lexp_whnf (push_susp branch subst) ctx
+ lexp_whnf_aux (push_susp branch subst) ctx
with Not_found
-> match default
with | Some (v,default)
- -> lexp_whnf (push_susp default (S.substitute e')) ctx
+ -> lexp_whnf_aux (push_susp default (S.substitute e')) ctx
| _ -> Log.log_error ~section:"WHNF" ~loc:l
("Unhandled constructor " ^
name ^ "in case expression");
mkCase (l, e, rt, branches, default) in
- (match e' with
+ (match lexp_lexp' e' with
| Cons (_, (_, name)) -> reduce name []
| Call (f, aargs) ->
- (match lexp_whnf f ctx with
+ (match lexp_lexp' (lexp_whnf_aux f ctx) with
| Cons (_, (_, name)) -> reduce name aargs
| _ -> mkCase (l, e, rt, branches, default))
| _ -> mkCase (l, e, rt, branches, default))
| Metavar (idx, s, _)
-> (match metavar_lookup idx with
- | MVal e -> lexp_whnf (push_susp e s) ctx
+ | MVal e -> lexp_whnf_aux (push_susp e s) ctx
| _ -> e)
(* FIXME: I'd really prefer to use "native" recursive substitutions, using
* ideally a trick similar to the db_offsets in lexp_context! *)
| Let (l, defs, body)
- -> lexp_whnf (push_susp body (lexp_defs_subst l S.identity defs)) ctx
+ -> lexp_whnf_aux (push_susp body (lexp_defs_subst l S.identity defs)) ctx
- | e -> e
+ | elem -> e
- in lexp_whnf e ctx
+ in lexp_whnf_aux e ctx
+let lexp'_whnf e (ctx : DB.lexp_context) : lexp' =
+ lexp_lexp' (lexp_whnf_aux e ctx)
+
+let lexp_whnf e (ctx : DB.lexp_context) : lexp =
+ lexp_whnf_aux e ctx
(** A very naive implementation of sets of pairs of lexps. *)
type set_plexp = (lexp * lexp) list
let set_empty : set_plexp = []
let set_member_p (s : set_plexp) (e1 : lexp) (e2 : lexp) : bool
- = assert (e1 == Lexp.hc e1);
- assert (e2 == Lexp.hc e2);
- try let _ = List.find (fun (e1', e2')
+ = try let _ = List.find (fun (e1', e2')
-> L.eq e1 e1' && L.eq e2 e2')
s
in true
@@ -230,7 +234,8 @@ let level_canon e =
let o = try IMap.find v m with Not_found -> -1 in
if o < d then (c, IMap.add v d m) else acc in
- let rec canon e d ((c,m) as acc) = match e with
+ let rec canon e d ((c,m) as acc) =
+ match lexp_lexp' e with
| SortLevel SLz -> if c < d then (d, m) else acc
| SortLevel (SLsucc e) -> canon e (d + 1) acc
| SortLevel (SLlub (e1, e2)) -> canon e1 d (canon e2 d acc)
@@ -259,7 +264,7 @@ let rec conv_p' (ctx : DB.lexp_context) (vs : set_plexp) e1 e2 : bool =
if changed && set_member_p vs e1' e2' then true else
let vs' = if changed then set_add vs e1' e2' else vs in
let conv_p = conv_p' ctx vs' in
- match (e1', e2') with
+ match (lexp_lexp' e1', lexp_lexp' e2') with
| (Imm (Integer (_, i1)), Imm (Integer (_, i2))) -> i1 = i2
| (Imm (Float (_, i1)), Imm (Float (_, i2))) -> i1 = i2
| (Imm (String (_, i1)), Imm (String (_, i2))) -> i1 = i2
@@ -332,14 +337,16 @@ let conv_p (ctx : DB.lexp_context) e1 e2
(********* Testing if a lexp is properly typed *********)
let rec mkSLlub ctx e1 e2 =
- match (lexp_whnf e1 ctx, lexp_whnf e2 ctx) with
+ let lwhnf1 = lexp_whnf e1 ctx in
+ let lwhnf2 = lexp_whnf e2 ctx in
+ match (lexp_lexp' lwhnf1, lexp_lexp' lwhnf2) with
| (SortLevel SLz, _) -> e2
| (_, SortLevel SLz) -> e1
| (SortLevel (SLsucc e1), SortLevel (SLsucc e2))
-> mkSortLevel (SLsucc (mkSLlub ctx e1 e2))
| (e1', e2')
- -> let ce1 = level_canon e1' in
- let ce2 = level_canon e2' in
+ -> let ce1 = level_canon lwhnf1 in
+ let ce2 = level_canon lwhnf2 in
if level_leq ce1 ce2 then e2
else if level_leq ce2 ce1 then e1
else mkSortLevel (mkSLlub' (e1, e2)) (* FIXME: Could be more canonical *)
@@ -353,7 +360,9 @@ type sort_compose_result
let sort_compose ctx1 ctx2 l ak k1 k2 =
(* BEWARE! Technically `k2` can refer to `v`, but this should only happen
* if `v` is a TypeLevel. *)
- match (lexp_whnf k1 ctx1, lexp_whnf k2 ctx2) with
+ let lwhnf1 = lexp'_whnf k1 ctx1 in
+ let lwhnf2 = lexp'_whnf k2 ctx2 in
+ match (lwhnf1, lwhnf2) with
| (Sort (_, s1), Sort (_, s2))
-> (match s1, s2 with
| (Stype l1, Stype l2)
@@ -408,7 +417,7 @@ let nerased_let defs erased =
* will be non-erasable, so in `let x = z; y = x ...`
* where `z` is erasable, `x` will be found
* to be erasable, but not `y`. *)
- match e with Var (_, idx) -> DB.set_mem idx nerased
+ match lexp_lexp' e with Var (_, idx) -> DB.set_mem idx nerased
| _ -> false)
defs in
if not (List.mem true es) then nerased else
@@ -430,14 +439,13 @@ let rec check'' erased ctx e =
(* Log.internal_error "Type mismatch" *)) in
let check_type erased ctx t =
let s = check erased ctx t in
- (match lexp_whnf s ctx with
- | Sort _ -> ()
- | _ -> error_tc ~loc:(lexp_location t)
- ("Not a proper type: " ^ lexp_string t));
- (* FIXME: return the `sort` rather than the surrounding `lexp`! *)
- s in
-
- match e with
+ (match lexp'_whnf s ctx with
+ | Sort _ -> ()
+ | _ -> error_tc ~loc:(lexp_location t)
+ ("Not a proper type: " ^ lexp_string t));
+ (* FIXME: return the `sort` rather than the surrounding `lexp`! *)
+ s in
+ match lexp_lexp' e with
| Imm (Float (_, _)) -> DB.type_float
| Imm (Integer (_, _)) -> DB.type_int
| Imm (String (_, _)) -> DB.type_string
@@ -528,7 +536,7 @@ let rec check'' erased ctx e =
(fun ft (ak,arg)
-> let at = check (if ak = P.Aerasable then DB.set_empty else erased)
ctx arg in
- match lexp_whnf ft ctx with
+ match lexp'_whnf ft ctx with
| Arrow (ak', v, t1, l, t2)
-> if not (ak == ak') then
(error_tc ~loc:(lexp_location arg)
@@ -551,8 +559,8 @@ let rec check'' erased ctx e =
let (level, _, _, _) =
List.fold_left
(fun (level, ictx, erased, n) (ak, v, t) ->
- ((match lexp_whnf (check_type erased ictx t)
- ictx with
+ ((let lwhnf = lexp_whnf (check_type erased ictx t) ictx in
+ match lexp_lexp' lwhnf with
| Sort (_, Stype _)
when ak == P.Aerasable && impredicative_erase
-> level
@@ -570,7 +578,7 @@ let rec check'' erased ctx e =
("Field type "
^ lexp_string t
^ " is not a Type! ("
- ^ lexp_string tt ^")");
+ ^ lexp_string lwhnf ^")");
level),
DB.lctx_extend ictx v Variable t,
DB.set_sink 1 erased,
@@ -590,12 +598,13 @@ let rec check'' erased ctx e =
tct
| Case (l, e, ret, branches, default)
(* FIXME: Check that the return type isn't TypeLevel. *)
- -> let call_split e = match e with
+ -> let call_split e =
+ match lexp_lexp' e with
| Call (f, args) -> (f, args)
| _ -> (e,[]) in
let etype = lexp_whnf (check erased ctx e) ctx in
let it, aargs = call_split etype in
- (match lexp_whnf it ctx, aargs with
+ (match lexp'_whnf it ctx, aargs with
| Inductive (_, _, fargs, constructors), aargs ->
let rec mksubst s fargs aargs =
match fargs, aargs with
@@ -644,8 +653,8 @@ let rec check'' erased ctx e =
| _,_ -> error_tc ~loc:l "Case on a non-inductive type!");
ret
| Cons (t, (l, name))
- -> (match lexp_whnf t ctx with
- | Inductive (l, _, fargs, constructors)
+ -> (match lexp'_whnf t ctx with
+ | Inductive (l, _, fargs, constructors)
-> (try
let fieldtypes = SMap.find name constructors in
let rec indtype fargs start_index =
@@ -732,7 +741,8 @@ let fv_hoist n (fvs, mvs) = (DB.set_hoist n fvs, mvs)
let fv_erase (fvs, mvs) = (fvs, mv_set_erase mvs)
let rec fv (e : lexp) : (DB.set * mv_set) =
- let fv' e = match e with
+ let fv' e =
+ match lexp_lexp' e with
| Imm _ -> fv_empty
| SortLevel SLz -> fv_empty
| SortLevel (SLsucc e) -> fv e
@@ -807,7 +817,7 @@ let rec fv (e : lexp) : (DB.set * mv_set) =
(* This should never signal any warning/error. *)
let rec get_type ctx e =
- match e with
+ match lexp_lexp' e with
| Imm (Float (_, _)) -> DB.type_float
| Imm (Integer (_, _)) -> DB.type_int
| Imm (String (_, _)) -> DB.type_string
@@ -838,7 +848,7 @@ let rec get_type ctx e =
-> let ft = get_type ctx f in
List.fold_left
(fun ft (ak,arg)
- -> match lexp_whnf ft ctx with
+ -> match lexp'_whnf ft ctx with
| Arrow (ak', v, t1, l, t2)
-> mkSusp t2 (S.substitute arg)
| _ -> ft)
@@ -854,7 +864,7 @@ let rec get_type ctx e =
let (level, _, _) =
List.fold_left
(fun (level, ictx, n) (ak, v, t) ->
- ((match lexp_whnf (get_type ictx t) ictx with
+ ((match lexp'_whnf (get_type ictx t) ictx with
| Sort (_, Stype _)
when ak == P.Aerasable && impredicative_erase
-> level
@@ -878,7 +888,7 @@ let rec get_type ctx e =
tct
| Case (l, e, ret, branches, default) -> ret
| Cons (t, (l, name))
- -> (match lexp_whnf t ctx with
+ -> (match lexp'_whnf t ctx with
| Inductive (l, _, fargs, constructors)
-> (try
let fieldtypes = SMap.find name constructors in
@@ -911,9 +921,8 @@ let rec get_type ctx e =
(*********** Type erasure, before evaluation. *****************)
-let rec erase_type (lxp: L.lexp): E.elexp =
-
- match lxp with
+let rec erase_type (lxp: lexp): E.elexp =
+ match lexp_lexp' lxp with
| L.Imm(s) -> E.Imm(s)
| L.Builtin(v, _, _) -> E.Builtin(v)
| L.Var(v) -> E.Var(v)
@@ -943,7 +952,7 @@ let rec erase_type (lxp: L.lexp): E.elexp =
| L.Sort _ -> E.Type lxp
(* Still useful to some extent. *)
| L.Inductive(l, label, _, _) -> E.Type lxp
- | Metavar (idx, s, _)
+ | L.Metavar (idx, s, _)
-> (match metavar_lookup idx with
| MVal e -> erase_type (push_susp e s)
| MVar (_, t, _)
@@ -1004,7 +1013,8 @@ let ctx2tup ctx nctx =
let offset = List.length types in
let types = List.rev types in
(*Log.debug_msg ("Building tuple of size " ^ string_of_int offset ^ "\n");*)
- Call (Cons (Inductive (loc, type_label, [],
+
+ mkCall (mkCons (mkInductive (loc, type_label, [],
SMap.add cons_name
(List.map (fun (oname, t)
-> (P.Aimplicit, oname,
@@ -1024,10 +1034,10 @@ let ctx2tup ctx nctx =
-> (P.Aimplicit, mkVar (oname, offset - i - 1)))
types)
| (DB.CVlet (name, LetDef (_, e), t, _) :: blocs)
- -> Let (loc, [(name, mkSusp e (S.shift 1), t)],
+ -> mkLet (loc, [(name, mkSusp e (S.shift 1), t)],
mk_lets_and_tup blocs ((name, t) :: types))
| (DB.CVfix (defs, _) :: blocs)
- -> Let (loc, defs,
+ -> mkLet (loc, defs,
mk_lets_and_tup blocs (List.append
(List.rev
(List.map (fun (oname, _, t)
=====================================
src/sexp.ml
=====================================
@@ -45,6 +45,15 @@ type token = sexp
let epsilon l = Symbol (l, "")
let dummy_epsilon = epsilon dummy_location
+(********************** Sexp tests **********************)
+
+let pred_symbol s pred =
+ match s with
+ | Symbol (_, n) -> pred n
+ | _ -> false
+
+let is_symbol e = pred_symbol e (fun e -> true)
+
(**************** Hash-consing symbols *********************)
module SHash = Hashtbl.Make (struct type t = string
=====================================
src/unification.ml
=====================================
@@ -61,7 +61,8 @@ let occurs_in (id: meta_id) (e : lexp) : bool = match metavar_lookup id with
| MVal _ -> Log.internal_error
"Checking occurrence of an instantiated metavar!!"
| MVar (sl, _, _)
- -> let rec oi e = match e with
+ -> let rec oi e =
+ match lexp_lexp' e with
| Imm _ -> false
| SortLevel SLz -> false
| SortLevel (SLsucc e) -> oi e
@@ -189,21 +190,21 @@ and unify' (e1: lexp) (e2: lexp)
let changed = true (* not (e1 == e1' && e2 == e2') *) in
if changed && OL.set_member_p vs e1' e2' then [] else
let vs' = if changed then OL.set_add vs e1' e2' else vs in
- match (e1', e2') with
+ match (lexp_lexp' e1', lexp_lexp' e2') with
| ((Imm _, Imm _) | (Cons _, Cons _) | (Builtin _, Builtin _)
| (Var _, Var _))
-> if OL.conv_p ctx e1' e2' then [] else [(CKimpossible, ctx, e1, e2)]
- | (l, (Metavar (idx, s, _) as r)) -> unify_metavar ctx idx s r l
- | ((Metavar (idx, s, _) as l), r) -> unify_metavar ctx idx s l r
- | (l, (Call _ as r)) -> unify_call r l ctx vs'
+ | (_, Metavar (idx, s, _)) -> unify_metavar ctx idx s e2' e1'
+ | (Metavar (idx, s, _), _) -> unify_metavar ctx idx s e1' e2'
+ | (_, Call _) -> unify_call e2' e1' ctx vs'
(* | (l, (Case _ as r)) -> unify_case r l subst *)
- | (Arrow _ as l, r) -> unify_arrow l r ctx vs'
- | (Lambda _ as l, r) -> unify_lambda l r ctx vs'
- | (Call _ as l, r) -> unify_call l r ctx vs'
+ | (Arrow _ , _) -> unify_arrow e1' e2' ctx vs'
+ | (Lambda _, _) -> unify_lambda e1' e2' ctx vs'
+ | (Call _, _) -> unify_call e1' e2' ctx vs'
(* | (Case _ as l, r) -> unify_case l r subst *)
(* | (Inductive _ as l, r) -> unify_induct l r subst *)
- | (Sort _ as l, r) -> unify_sort l r ctx vs'
- | (SortLevel _ as l, r) -> unify_sortlvl l r ctx vs'
+ | (Sort _, _) -> unify_sort e1' e2' ctx vs'
+ | (SortLevel _, _) -> unify_sortlvl e1' e2' ctx vs'
| (Inductive (_loc1, label1, args1, consts1),
Inductive (_loc2, label2, args2, consts2))
-> (* print_string ("Unifying inductives "
@@ -227,7 +228,7 @@ and unify' (e1: lexp) (e2: lexp)
*)
and unify_arrow (arrow: lexp) (lxp: lexp) ctx vs
: return_type =
- match (arrow, lxp) with
+ match (lexp_lexp' arrow, lexp_lexp' lxp) with
| (Arrow (var_kind1, v1, ltype1, _, lexp1),
Arrow (var_kind2, _, ltype2, _, lexp2))
-> if var_kind1 = var_kind2
@@ -250,7 +251,7 @@ and unify_arrow (arrow: lexp) (lxp: lexp) ctx vs
- Lambda , lexp -> unify lexp lambda subst
*)
and unify_lambda (lambda: lexp) (lxp: lexp) ctx vs : return_type =
- match (lambda, lxp) with
+ match (lexp_lexp' lambda, lexp_lexp' lxp) with
| (Lambda (var_kind1, v1, ltype1, lexp1),
Lambda (var_kind2, _, ltype2, lexp2))
-> if var_kind1 = var_kind2
@@ -300,7 +301,7 @@ and unify_metavar ctx idx s1 (lxp1: lexp) (lxp2: lexp)
^ lexp_string (OL.get_type ctx lxp)
^ "\n" ^ "for " ^ lexp_string lxp ^ "\n");
[(CKresidual, ctx, lxp1, lxp2)] in
- match lxp2 with
+ match lexp_lexp' lxp2 with
| Metavar (idx2, s2, name)
-> if idx = idx2 then
match common_subset ctx s1 s2 with
@@ -370,7 +371,7 @@ and unify_metavar ctx idx s1 (lxp1: lexp) (lxp2: lexp)
*)
and unify_call (call: lexp) (lxp: lexp) ctx vs
: return_type =
- match (call, lxp) with
+ match (lexp_lexp' call, lexp_lexp' lxp) with
| (Call (lxp_left, lxp_list1), Call (lxp_right, lxp_list2))
when OL.conv_p ctx lxp_left lxp_right
-> List.fold_left (fun op ((ak1, e1), (ak2, e2))
@@ -439,7 +440,7 @@ and unify_call (call: lexp) (lxp: lexp) ctx vs
- SortLevel, _ -> ERROR
*)
and unify_sortlvl (sortlvl: lexp) (lxp: lexp) ctx vs : return_type =
- match sortlvl, lxp with
+ match lexp_lexp' sortlvl, lexp_lexp' lxp with
| (SortLevel s, SortLevel s2) -> (match s, s2 with
| SLz, SLz -> []
| SLsucc l1, SLsucc l2 -> unify' l1 l2 ctx vs
@@ -456,7 +457,7 @@ and unify_sortlvl (sortlvl: lexp) (lxp: lexp) ctx vs : return_type =
- Sort, lexp -> ERROR
*)
and unify_sort (sort_: lexp) (lxp: lexp) ctx vs : return_type =
- match sort_, lxp with
+ match lexp_lexp' sort_, lexp_lexp' lxp with
| (Sort (_, srt), Sort (_, srt2)) -> (match srt, srt2 with
| Stype lxp1, Stype lxp2 -> unify' lxp1 lxp2 ctx vs
| StypeOmega, StypeOmega -> []
=====================================
src/util.ml
=====================================
@@ -45,6 +45,15 @@ type vref = vname * db_index
type bottom = | B_o_t_t_o_m_ of bottom
+let get_vname_name_option vname =
+ let (loc, name) = vname in name
+
+let get_vname_name vname =
+ let (loc, name) = vname in
+ match name with
+ | Some n -> n
+ | _ -> "" (* FIXME: Replace with dummy_name ? *)
+
(* print debug info *)
let loc_string loc =
"Ln " ^ (Fmt.ralign_int loc.line 3) ^ ", cl " ^ (Fmt.ralign_int loc.column 3)
@@ -116,3 +125,22 @@ let option_map (fn : 'a -> 'b) (opt : 'a option) : 'b option =
match opt with
| None -> None
| Some x -> Some (fn x)
+
+(* It seemed good to use the prime number 31.
+ * FIXME: Pick another one ? *)
+let combine_hash e1 e2 = (e1 * 31) lxor e2
+
+let rec combine_hashes li =
+ match li with
+ | [] -> 31
+ | e :: l -> combine_hash (e * 31) (combine_hashes l)
+
+let get_stats_hashtbl stats =
+ let (tl, ne, sumb, smallb, medianb, bigb) = stats in
+ Printf.printf "\n\ttable length: %i\n
+ number of entries: %i\n
+ sum of bucket lengths: %i\n
+ smallest bucket length: %i\n
+ median bucket length: %i\n
+ biggest bucket length: %i\n"
+ tl ne sumb smallb medianb bigb
=====================================
tests/unify_test.ml
=====================================
@@ -125,14 +125,14 @@ let input_type_t = generate_ltype_from_str str_type2
let generate_testable (_: lexp list) : ((lexp * lexp * result) list) =
- ( Lambda ((Anormal),
+ ( mkLambda ((Anormal),
(Util.dummy_location, Some "L1"),
- Var((Util.dummy_location, Some "z"), 3),
- Imm (Integer (Util.dummy_location, 3))),
- Lambda ((Anormal),
+ mkVar((Util.dummy_location, Some "z"), 3),
+ mkImm (Integer (Util.dummy_location, 3))),
+ mkLambda ((Anormal),
(Util.dummy_location, Some "L2"),
- Var((Util.dummy_location, Some "z"), 4),
- Imm (Integer (Util.dummy_location, 3))), Nothing )
+ mkVar((Util.dummy_location, Some "z"), 4),
+ mkImm (Integer (Util.dummy_location, 3))), Nothing )
::(input_induct , input_induct , Equivalent) (* 2 *)
::(input_int_4 , input_int_4 , Equivalent) (* 3 *)
@@ -183,8 +183,8 @@ let generate_testable (_: lexp list) : ((lexp * lexp * result) list) =
::(input_type , input_type_t , Equivalent) (* 44 *)
- ::(Metavar (0, S.identity, (Util.dummy_location, Some "M")),
- Var ((Util.dummy_location, Some "x"), 3), Unification) (* 45 *)
+ ::(mkMetavar (0, S.identity, (Util.dummy_location, Some "M")),
+ mkVar ((Util.dummy_location, Some "x"), 3), Unification) (* 45 *)
::[]
View it on GitLab: https://gitlab.com/monnier/typer/-/compare/f0b33b284588b1cc628f0b482bb00afe…
--
View it on GitLab: https://gitlab.com/monnier/typer/-/compare/f0b33b284588b1cc628f0b482bb00afe…
You're receiving this email because of your account on gitlab.com.
1
0
[Git][monnier/typer][master] 2 commits: Apply the instantiated metavariable substs when displaying lexps
by Jean-Alexandre Barszcz 21 Aoû '20
by Jean-Alexandre Barszcz 21 Aoû '20
21 Aoû '20
Jean-Alexandre Barszcz pushed to branch master at Stefan / Typer
Commits:
ac4cc3a5 by Jean-Alexandre Barszcz at 2020-08-20T15:01:14-04:00
Apply the instantiated metavariable substs when displaying lexps
- - - - -
f0b33b28 by Jean-Alexandre Barszcz at 2020-08-20T15:01:36-04:00
Replace instantiated metavars when checking syntactic equality
- - - - -
1 changed file:
- src/lexp.ml
Changes:
=====================================
src/lexp.ml
=====================================
@@ -805,7 +805,7 @@ and lexp_str ctx (exp : lexp) : string =
| Metavar (idx, subst, (loc, name))
(* print metavar result if any *)
-> (match metavar_lookup idx with
- | MVal e -> lexp_str ctx e
+ | MVal e -> lexp_str ctx (push_susp e subst)
| _ -> "?" ^ maybename name ^ (subst_string subst) ^ (index idx))
| Let (_, decls, body) ->
@@ -993,7 +993,19 @@ let rec eq e1 e2 =
| (Some (_, e1), Some (_, e2)) -> eq e1 e2
| _ -> def1 = def2)
| (Metavar (i1, s1, _), Metavar (i2, s2, _))
- -> i1 = i2 && subst_eq s1 s2
+ -> if i1 == i2 then subst_eq s1 s2 else
+ (match (metavar_lookup i1, metavar_lookup i2) with
+ | (MVal l, _) -> eq (push_susp l s1) e2
+ | (_, MVal l) -> eq e1 (push_susp l s2)
+ | _ -> false)
+ | (Metavar (i1, s1, _), _)
+ -> (match metavar_lookup i1 with
+ | MVal l -> eq (push_susp l s1) e2
+ | _ -> false)
+ | (_, Metavar (i2, s2, _))
+ -> (match metavar_lookup i2 with
+ | MVal l -> eq e1 (push_susp l s2)
+ | _ -> false)
| _ -> false
and subst_eq s1 s2 =
View it on GitLab: https://gitlab.com/monnier/typer/-/compare/2e00884b0d84ec33ca9cacc643ca9ecd…
--
View it on GitLab: https://gitlab.com/monnier/typer/-/compare/2e00884b0d84ec33ca9cacc643ca9ecd…
You're receiving this email because of your account on gitlab.com.
1
0
[Git][monnier/typer][ja-barszcz] 26 commits: Apply the instantiated metavariable substs when displaying lexps
by Jean-Alexandre Barszcz 21 Aoû '20
by Jean-Alexandre Barszcz 21 Aoû '20
21 Aoû '20
Jean-Alexandre Barszcz pushed to branch ja-barszcz at Stefan / Typer
Commits:
ac4cc3a5 by Jean-Alexandre Barszcz at 2020-08-20T15:01:14-04:00
Apply the instantiated metavariable substs when displaying lexps
- - - - -
f0b33b28 by Jean-Alexandre Barszcz at 2020-08-20T15:01:36-04:00
Replace instantiated metavars when checking syntactic equality
- - - - -
dc78ba24 by Jean-Alexandre Barszcz at 2020-08-21T18:04:30-04:00
Test WHNF of case
- - - - -
28fd1c84 by Jean-Alexandre Barszcz at 2020-08-21T18:04:56-04:00
Fix `lexp_whnf` for Case
A substitution built with `cons`es happens all at once, in the sense
that the terms in such a list are substituted independently, and thus
should not be shifted one relative to another.
This commit removes such a shift that was made by mistake in the
computation of the WHNF of a `Case` redex. The shift caused debruijn
indexing errors in the body of branches with multiple fields.
- - - - -
ae72b840 by Jean-Alexandre Barszcz at 2020-08-21T18:05:32-04:00
[WIP] Make unification symmetric
- - - - -
2d50e3b8 by Jean-Alexandre Barszcz at 2020-08-21T18:05:32-04:00
[WIP] Handle variables earlier during unification
- - - - -
490090a5 by Jean-Alexandre Barszcz at 2020-08-21T18:05:32-04:00
[WIP] experiments with Decidable and proofs
- - - - -
85ed613c by Jean-Alexandre Barszcz at 2020-08-21T18:05:32-04:00
[WIP] unify instead of conv_p in sform_lambda
- - - - -
81b757c3 by Jean-Alexandre Barszcz at 2020-08-21T18:05:32-04:00
[WIP] proof of Decidable (a < b)
- - - - -
e357e46a by Jean-Alexandre Barszcz at 2020-08-21T18:05:32-04:00
[WIP] First draft of an instance search algorithm
- - - - -
033b3837 by Jean-Alexandre Barszcz at 2020-08-21T18:05:32-04:00
WIP WIP WIP
- - - - -
f19d4d84 by Jean-Alexandre Barszcz at 2020-08-21T18:05:32-04:00
WIP WIP getting there
- - - - -
f394fb30 by Jean-Alexandre Barszcz at 2020-08-21T18:05:32-04:00
[WIP] Add a set of typeclasses to the elab context
- - - - -
2ef581db by Jean-Alexandre Barszcz at 2020-08-21T18:05:32-04:00
[WIP] Add a syntax for records
- - - - -
d0ec2a80 by Jean-Alexandre Barszcz at 2020-08-21T18:05:32-04:00
[WIP] Extend the Decidable sample with conjunction (dep on records)
- - - - -
33d9c63c by Jean-Alexandre Barszcz at 2020-08-21T18:05:32-04:00
Resolve instances in the REPL (since exprs. are not generalized)
- - - - -
d0678ad7 by Jean-Alexandre Barszcz at 2020-08-21T18:05:32-04:00
Resolve instances for recursive definitions
- - - - -
b54e3e6a by Jean-Alexandre Barszcz at 2020-08-21T18:05:32-04:00
[WIP] Do the set_getenv
IIRC these were missing to correctly handle the elab context for macro
expansion and Elab_... primitives. Perhaps it would be simpler to call
set_getenv once before macro expansion rather than everywhere where
the context can change. Needs some experimentation and tests.
- - - - -
86624799 by Jean-Alexandre Barszcz at 2020-08-21T18:05:32-04:00
Num class example
- - - - -
27b776e3 by Jean-Alexandre Barszcz at 2020-08-21T18:05:32-04:00
Num class (with records)
- - - - -
ec0bb7e6 by Jean-Alexandre Barszcz at 2020-08-21T18:05:32-04:00
Allow non-inductives to be typeclasses (Eq for instance)
- - - - -
016b580a by Jean-Alexandre Barszcz at 2020-08-21T18:05:32-04:00
Move the Eq builtin to debruijn.ml to make it available for elab.
- - - - -
56b2ecb8 by Jean-Alexandre Barszcz at 2020-08-21T18:05:32-04:00
Make Eq.refl available to the ocaml code
* src/debruijn.ml : Add a definition of the lexp for Eq.refl
* src/builtin.ml : Register the constant Eq.refl
* btl/builtins.typer (Eq_refl) : Use the builtin variable ##Eq.refl
instead of registering the builtin with the `Built-in` form. This
ensures that we have the right variable and type, and might help to
keep things in sync between the ocaml and typer code.
- - - - -
9e5aa5d1 by Jean-Alexandre Barszcz at 2020-08-21T18:05:32-04:00
[WIP] Add Eq to case
- - - - -
7e8b3db1 by Jean-Alexandre Barszcz at 2020-08-21T18:05:32-04:00
[WIP] Adding Eq to Case: mutual rec for (whnf & get_type) + conv_p of case?
- - - - -
333bc9e9 by Jean-Alexandre Barszcz at 2020-08-21T18:05:32-04:00
Algebra classes sample with proof of associativity of +
- - - - -
21 changed files:
- btl/builtins.typer
- btl/pervasive.typer
- + btl/records.typer
- + samples/alg_classes.typer
- + samples/decidable.typer
- + samples/num_class.typer
- + samples/num_class_recs.typer
- src/REPL.ml
- src/builtin.ml
- src/debruijn.ml
- src/elab.ml
- src/eval.ml
- + src/instances.ml
- src/inverse_subst.ml
- src/lexp.ml
- src/log.ml
- src/myers.ml
- src/opslexp.ml
- src/unification.ml
- tests/elab_test.ml
- tests/unify_test.ml
Changes:
=====================================
btl/builtins.typer
=====================================
@@ -48,7 +48,7 @@ Void = typecons Void;
%% Eq : (l : TypeLevel) ≡> (t : Type_ l) ≡> t -> t -> Type_ l
%% Eq' : (l : TypeLevel) ≡> Type_ l -> Type_ l -> Type_ l
Eq_refl : ((x : ?t) ≡> Eq x x);
-Eq_refl = Built-in "Eq.refl";
+Eq_refl = ##Eq\.refl;
Eq_cast : (x : ?) ≡> (y : ?)
≡> (p : Eq x y)
@@ -363,6 +363,12 @@ Elab_isbound = Built-in "Elab.isbound" : String -> Elab_Context -> Bool;
Elab_isconstructor = Built-in "Elab.isconstructor"
: String -> Elab_Context -> Bool;
+%%
+%% Check if a symbol is an inductive in a particular context
+%%
+Elab_isinductive = Built-in "Elab.isinductive"
+ : String -> Elab_Context -> Bool;
+
%%
%% Check if the n'th field of a constructor is erasable
%% If the constructor isn't defined it will always return false
@@ -389,6 +395,20 @@ Elab_nth-arg' = Built-in "Elab.nth-arg" : String -> Int -> Elab_Context -> Strin
%%
Elab_arg-pos' = Built-in "Elab.arg-pos" : String -> String -> Elab_Context -> Int;
+%%
+%% Get the position of a field in a constructor
+%% It return -1 in case the field isn't defined
+%% see pervasive.typer for a more convenient function
+%%
+Elab_ind-ctor-arg-pos' = Built-in "Elab.ind-ctor-arg-pos" : String -> String -> String -> Elab_Context -> Int;
+
+%%
+%% Get the number of fields in a constructor
+%% It return -1 in case the field isn't defined
+%% see pervasive.typer for a more convenient function
+%%
+Elab_count-ctor-args' = Built-in "Elab.count-ctor-args" : String -> String -> Elab_Context -> Int;
+
%%
%% Get the docstring associated with a symbol
%%
=====================================
btl/pervasive.typer
=====================================
@@ -394,7 +394,7 @@ BoolMod = (##datacons
Pair = typecons (Pair (a : Type) (b : Type)) (pair (fst : a) (snd : b));
pair = datacons Pair pair;
-__\.__ =
+dot-impl =
let mksel o f =
let constructor = Sexp_node (Sexp_symbol "##datacons")
(cons (Sexp_symbol "?")
@@ -411,14 +411,15 @@ __\.__ =
(cons (Sexp_node (Sexp_symbol "_|_")
(cons o (cons branch nil)))
nil)
- in macro (lambda args
- -> IO_return
- case args
- | cons o tail
- => (case tail
- | cons f _ => mksel o f
- | nil => Sexp_error)
- | nil => Sexp_error);
+ in (lambda args ->
+ IO_return case args
+ | cons o tail
+ => (case tail
+ | cons f _ => mksel o f
+ | nil => Sexp_error)
+ | nil => Sexp_error);
+
+__\.__ = macro dot-impl;
%% Triplet (tuple with 3 values)
type Triplet (a : Type) (b : Type) (c : Type)
@@ -458,7 +459,8 @@ Not prop = prop -> False;
%% We don't use the `type` macro here because it would make these `true`
%% and `false` constructors override `Bool`'s, and we currently don't
%% want that.
-Decidable = typecons (Decidable (prop : Type_ ?ℓ))
+%% FIXME generalize typecons formal arguments
+Decidable = typecons (Decidable (ℓ ::: TypeLevel) (prop : Type_ ℓ))
(true (p ::: prop)) (false (p ::: Not prop));
%% Testing generalization in inductive type constructors.
@@ -547,6 +549,32 @@ in case (Int_eq r (-1))
| true => (none)
| false => (some r);
+%%
+%% If `Elab_ind-ctor-arg-pos'` returns (-1) it means:
+%% A- The constructor isn't defined, or
+%% B- The constructor has no argument named like this
+%%
+%% So in those case this function returns `none`
+%%
+Elab_ind-ctor-arg-pos a b c d = let
+ r = Elab_ind-ctor-arg-pos' a b c d;
+in case (Int_eq r (-1))
+ | true => (none)
+ | false => (some r);
+
+%%
+%% If `Elab_count-ctor-args'` returns (-1) it means:
+%% A- The constructor isn't defined, or
+%% B- The constructor has no argument named like this
+%%
+%% So in those case this function returns `none`
+%%
+Elab_count-ctor-args a b c = let
+ r = Elab_count-ctor-args' a b c;
+in case (Int_eq r (-1))
+ | true => (none)
+ | false => (some r);
+
%%%%
%%%% Common library
%%%%
@@ -634,6 +662,15 @@ plain-let_in_ = let lib = load "btl/plain-let.typer" in lib.plain-let-macro;
%%
_|_ = let lib = load "btl/polyfun.typer" in lib._|_;
+%%
+%% records : a simple datatype when there is only one case
+%%
+define-operator "#" 200 ();
+records = load "btl/records.typer";
+record = records.record;
+__\.__ = records.__\.__;
+_# = records._#;
+
%%%% Unit tests function for doing file
%% It's hard to do a primitive which execute test file
=====================================
btl/records.typer
=====================================
@@ -0,0 +1,82 @@
+record-impl : List Sexp -> IO Sexp;
+record-impl args =
+ let
+ %% Get a name (symbol) from a sexp
+ %% - (name t) -> name
+ %% - name -> name
+ get-name : Sexp -> Sexp;
+ get-name sxp =
+ case Sexp_wrap sxp
+ | node op _ => get-name op
+ | symbol _ => sxp
+ | _ => Sexp_error;
+
+ %% head is (Sexp_node type-name (arg list))
+ name-args = List_head Sexp_error args;
+ fields = List_tail args;
+
+ type-name = get-name name-args;
+
+ %% Create the inductive type definition.
+ inductive = Sexp_node (Sexp_symbol "typecons")
+ (cons name-args
+ (cons (Sexp_node (Sexp_symbol "rec") fields)
+ nil));
+
+ decl = make-decl type-name inductive;
+
+ in IO_return decl;
+
+record = macro record-impl;
+
+record-get-impl : List Sexp -> IO Sexp;
+record-get-impl args =
+ let
+ get tc f idx nargs ectx =
+ let arg_pats : Sexp -> Int -> Int -> List Sexp;
+ arg_pats s i n =
+ if (Int_eq n 0) then nil
+ else (if (Int_eq i 0)
+ then (cons s (arg_pats s (i - 1) (n - 1)))
+ else (cons (Sexp_symbol "_") (arg_pats s (i - 1) (n - 1))));
+
+ pat = (Sexp_node (quote (datacons (uquote (Sexp_symbol tc)) rec))
+ (arg_pats (Sexp_symbol "v") idx nargs));
+
+ branch = (quote ((uquote pat) => v));
+ in
+ (quote (lambda rec -> (##case_ (_|_ rec (uquote branch)))));
+
+ try-rec-get : List Sexp -> Elab_Context -> Option Sexp;
+ try-rec-get arg ectx =
+ case args
+ | (cons tc (cons f nil)) =>
+ (case (Sexp_wrap tc, Sexp_wrap f)
+ | (symbol tcstr, symbol fstr) =>
+ (case (Elab_count-ctor-args tcstr "rec" ectx,
+ Elab_ind-ctor-arg-pos tcstr "rec" fstr ectx)
+ | (some nargs, some idx) => some (get tcstr fstr idx nargs ectx)
+ | _ => none)
+ | _ => none)
+ | _ => none;
+ in
+ do {
+ ectx <- Elab_getenv ();
+ case try-rec-get args ectx
+ | some sxp => IO_return sxp
+ | _ => dot-impl args; %% Fallback on default dot implementation
+ };
+
+__\.__ = macro record-get-impl;
+
+record-make-impl : List Sexp -> IO Sexp;
+record-make-impl args =
+ IO_return case args
+ | (cons tc nil) => (quote (datacons (uquote tc) rec))
+ | _ => Sexp_error;
+
+_# = macro record-make-impl; %% I was going for a syntax close to
+ %% Erlang's, but the # doesn't separate
+ %% tokens ... Meh.
+
+record (Pair (a : Type) (b : Type)) (fst : a) (snd : a);
=====================================
samples/alg_classes.typer
=====================================
@@ -0,0 +1,84 @@
+case_ = ##case_; %% To ease debugging
+
+type Magma (α : Type)
+ | mkMagma (op : α -> α -> α);
+
+typeclass Magma;
+
+magma_op =
+ lambda magma_inst =>
+ case magma_inst
+ | mkMagma op => op;
+
+Associativity (op : ?α -> ?α -> ?α) =
+ (x : ?α) -> (y : ?α) -> (z : ?α) -> Eq (op (op x y) z) (op x (op y z));
+
+type Semigroup (α : Type)
+ | mkSemigroup (magma : Magma α) (assoc ::: Associativity magma_op);
+
+typeclass Semigroup;
+
+semigroup_magma =
+ lambda semigroup_inst =>
+ case semigroup_inst
+ | mkSemigroup magma => magma;
+
+IsLeftIdentity (id : ?α) (op : ?α -> ?α -> ?α) =
+ (x : ?α) -> Eq (op id x) x;
+
+IsRightIdentity (id : ?α) (op : ?α -> ?α -> ?α) =
+ (x : ?α) -> Eq (op x id) x;
+
+IsIdentity (id : ?α) (op : ?α -> ?α -> ?α) =
+ (Pair (IsLeftIdentity id op) (IsRightIdentity id op));
+
+type Monoid (α : Type)
+ | mkMonoid (semigroup : Semigroup α)
+ (identity : α)
+ (isIdent ::: IsIdentity identity magma_op);
+
+typeclass Monoid;
+
+type Nat
+ | Zero
+ | Succ Nat;
+
+plus : Nat -> Nat -> Nat;
+plus x y =
+ case x
+ | Zero => y
+ | Succ x' => Succ (plus x' y);
+
+natAdditiveMagma =
+ mkMagma plus;
+
+Eq_cong : % not sure about levels here
+ (t : (Type_ ?ℓ)) ≡> (r : (Type_ ?ℓ)) ≡>
+ (x : t) ≡> (y : t) ≡> (p : (Eq x y)) ≡>
+ (f : (t -> r)) -> (Eq (f x) (f y));
+Eq_cong f =
+ Eq_cast (p := p) (f := lambda xy -> Eq (f x) (f xy)) Eq_refl;
+
+natPlusAssoc : Associativity plus;
+natPlusAssoc x y z =
+ let
+ typeclass Eq
+ in
+ case x
+ | Zero => Eq_cast
+ (x := Zero)
+ (y := x)
+ (p := Eq_comm (instance ()))
+ (f := (lambda (Zx : Nat) -> Eq (plus (plus Zx y) z) (plus Zx (plus y z))))
+ Eq_refl
+ | Succ x' =>
+ Eq_cast
+ (x := Succ x')
+ (y := x)
+ (p := Eq_comm (instance ()))
+ (f := (lambda (sx'x : Nat) -> Eq (plus (plus sx'x y) z) (plus sx'x (plus y z))))
+ (Eq_cong (p := natPlusAssoc x' y z) Succ);
+
+natAdditiveSemigroup : Semigroup Nat;
+natAdditiveSemigroup =
+ mkSemigroup natAdditiveMagma (assoc := natPlusAssoc);
=====================================
samples/decidable.typer
=====================================
@@ -0,0 +1,168 @@
+False = Void;
+True = Unit;
+
+% FIXME improved "case" fails with no branches
+exfalso : False -> ?a;
+exfalso f = ##case_ f;
+
+%type Decidable (prop : Type)
+% | yes (p ::: prop)
+% | no (p ::: Not prop);
+yes = datacons Decidable true;
+no = datacons Decidable false;
+
+typeclass Decidable;
+
+Eq_trans :
+ (x : ?t) => (y : ?t) => (a : ?t) ->
+ (ax : Eq a x) => (ay : Eq a y) => Eq x y;
+Eq_trans a =
+ lambda (ax : Eq a x) (ay : Eq a y) =>
+ Eq_cast (f := lambda ax -> Eq ax y) ay;
+
+Eq_cong : % not sure about levels here
+ (t : (Type_ ?ℓ)) ≡> (r : (Type_ ?ℓ)) ≡>
+ (x : t) ≡> (y : t) ≡> (p : (Eq x y)) ≡>
+ (f : (t -> r)) -> (Eq (f x) (f y));
+Eq_cong f =
+ Eq_cast (p := p) (f := lambda xy -> Eq (f x) (f xy)) Eq_refl;
+
+discriminate_nocheck =
+ macro (lambda args ->
+ case args
+ | cons x (cons y nil) =>
+ do {
+ sd <- gensym ();
+ sp <- gensym ();
+ IO_return
+ (quote ((lambda (uquote sp) ->
+ (Eq_cast (p := (uquote sp))
+ (f := (lambda (uquote sd) ->
+ (case uquote sd
+ | (uquote x) => True
+ | _ => False)))
+ ())) : Not (Eq (uquote x) (uquote y))))
+ }
+ | _ => IO_return Sexp_error);
+
+discriminate =
+ macro (lambda args ->
+ case args
+ | cons x (cons y nil) =>
+ (case (Sexp_wrap x, Sexp_wrap y)
+ | (symbol sx, symbol sy) => % FIXME get the constructor even when its a call
+ do {
+ env <- Elab_getenv ();
+ if (and (Elab_isconstructor sx env)
+ (and (Elab_isconstructor sy env)
+ (not (Sexp_eq x y))))
+ then
+ Macro_expand discriminate_nocheck args
+ else (IO_return Sexp_error)
+ }
+ | _ => IO_return Sexp_error)
+ | _ => IO_return Sexp_error);
+
+test : (Not (Eq true false));
+test = discriminate true false;
+
+absurd =
+ lambda (p : ?prop) ->
+ lambda (contra : (Not ?prop)) ->
+ contra p;
+
+% We can't (usefully) have a `Decidable Bool` because it's
+% impossible to have a `Not Bool`. Instead, we can decide boolean
+% equality:
+
+decideBoolEq : (a : Bool) => (b : Bool) => Decidable (Eq a b);
+decideBoolEq =
+ lambda (a : Bool) (b : Bool) =>
+ case (a, b)
+ | (false, false) => yes (p := Eq_trans false)
+ | (false, true) => no (p := lambda (p : Eq a b) ->
+ absurd (Eq_trans (ax := Eq_trans a) b) (discriminate false true))
+ | (true, false) => no (p := lambda (p : Eq a b) ->
+ absurd (Eq_trans (ax := Eq_trans a) b) (discriminate true false))
+ | (true, true) => yes (p := Eq_trans true);
+
+type Nat
+ | zero
+ | succ Nat;
+
+type even (a : Nat)
+ | eZ (p ::: Eq a zero)
+ | eSS (p :: even ?a) (pss ::: Eq a (succ (succ ?a)));
+
+decideEven : (a : Nat) => Decidable (even a);
+decideEven =
+ lambda (a : Nat) =>
+ case a
+ | zero => yes (p := eZ)
+ | succ zero => no (p :=
+ lambda (p : even a) ->
+ case p
+ | eZ => absurd (Eq_trans a) (discriminate_nocheck zero (succ zero))
+ | eSS => absurd (Eq_trans a) (discriminate_nocheck (succ (succ ?)) (succ zero)))
+ | succ (succ a') =>
+ case (decideEven : Decidable (even a'))
+ | yes => yes (p := eSS)
+ | no => no (p :=
+ lambda (p : even a) ->
+ case p
+ | eZ => absurd (Eq_trans a) (discriminate_nocheck zero (succ (succ ?)))
+ | eSS => absurd (? : even a') (? : Not (even a')));
+
+type _<_ (a : Nat) (b : Nat)
+ | ltZ (pa ::: Eq a zero) (pb ::: Eq b (succ ?b))
+ | ltS (p :: (?a < ?b)) (pa ::: Eq a (succ ?a)) (pb ::: Eq b (succ ?b));
+
+decideLT : (a : Nat) => (b : Nat) => Decidable (a < b);
+decideLT =
+ lambda a b =>
+ case b
+ | zero => no (p :=
+ lambda (p : (a < b)) ->
+ case p
+ | ltZ => absurd (Eq_trans b) (discriminate_nocheck zero (succ ?))
+ | ltS => absurd (Eq_trans b) (discriminate_nocheck zero (succ ?)))
+ | succ b' =>
+ case a
+ | zero => yes (p := ltZ)
+ | succ a' =>
+ case (decideLT : (Decidable (a' < b')))
+ | yes => yes (p := ltS)
+ | no => no (p :=
+ lambda (p : (a < b)) ->
+ case p
+ | ltZ => absurd (Eq_trans a) (discriminate_nocheck zero (succ ?))
+ | ltS => absurd (? : (a' < b')) (? : Not (a' < b')));
+
+define-operator "∧" 111 130;
+
+record ((a : Type) ∧ (b : Type)) (fst : a) (snd : b);
+
+decideAnd : (P : Type) ≡> (Q : Type) ≡>
+ (Decidable P) => (Decidable Q) => (Decidable (P ∧ Q));
+decideAnd =
+ lambda P Q ≡>
+ lambda (decP : Decidable P) (decQ : Decidable Q) =>
+ case (decP, decQ)
+ | (yes (p := pP), yes (p := pQ)) => yes (p := _∧_ # pP pQ)
+ | (no (p := nP), _) =>
+ no (p := (lambda (proofs : P ∧ Q) -> absurd (_∧_.fst proofs) nP))
+ | (_, no (p := nQ)) =>
+ no (p := (lambda (proofs : P ∧ Q) -> absurd (_∧_.snd proofs) nQ));
+
+if_then_else_
+ = macro (lambda args ->
+ let e1 = List_nth 0 args Sexp_error;
+ e2 = List_nth 1 args Sexp_error;
+ e3 = List_nth 2 args Sexp_error;
+ in IO_return (quote (case (instance () : (Decidable (uquote e1)))
+ | yes => uquote e2
+ | no => uquote e3)));
+
+test2 : Bool;
+test2 = if ((even (succ zero)) ∧ (zero < zero)) then false else true;
+
=====================================
samples/num_class.typer
=====================================
@@ -0,0 +1,39 @@
+type Num (α : Type)
+ | mkNum (Num_+ : α -> α -> α)
+ (Num_- : α -> α -> α)
+ (Num_* : α -> α -> α)
+ (Num_/ : α -> α -> α);
+
+typeclass Num;
+
+_+_ = lambda numInst => case numInst | mkNum _+_ _ _ _ => _+_;
+_-_ = lambda numInst => case numInst | mkNum _ _-_ _ _ => _-_;
+_*_ = lambda numInst => case numInst | mkNum _ _ _*_ _ => _*_;
+_/_ = lambda numInst => case numInst | mkNum _ _ _ _/_ => _/_;
+
+IntNum : Num Int;
+IntNum =
+ mkNum (Num_+ := Int_+) (Num_- := Int_-) (Num_* := Int_*) (Num_/ := Int_/);
+
+IntegerNum : Num Integer;
+IntegerNum =
+ mkNum (Num_+ := Integer_+) (Num_- := Integer_-)
+ (Num_* := Integer_*) (Num_/ := Integer_/);
+
+FloatNum : Num Float;
+FloatNum =
+ mkNum (Num_+ := Float_+) (Num_- := Float_-)
+ (Num_* := Float_*) (Num_/ := Float_/);
+
+type FromInt (α : Type)
+ | mkFromInt (FromInt_fromInt : Int -> α);
+
+typeclass FromInt;
+
+fromInt = lambda fromIntInst => case fromIntInst | mkFromInt fromInt => fromInt;
+
+IntFromInt : FromInt Int;
+IntFromInt = mkFromInt (lambda x -> x);
+
+IntegerFromInt : FromInt Integer;
+IntegerFromInt = mkFromInt Int->Integer;
=====================================
samples/num_class_recs.typer
=====================================
@@ -0,0 +1,33 @@
+record (Num (α : Type))
+ (_+_ : α -> α -> α)
+ (_-_ : α -> α -> α)
+ (_*_ : α -> α -> α)
+ (_/_ : α -> α -> α);
+
+typeclass Num;
+
+_+_ = lambda numInst => Num._+_ numInst;
+_-_ = lambda numInst => Num._-_ numInst;
+_*_ = lambda numInst => Num._*_ numInst;
+_/_ = lambda numInst => Num._/_ numInst;
+
+IntNum : Num Int;
+IntNum = Num # Int_+ Int_- Int_* Int_/;
+
+IntegerNum : Num Integer;
+IntegerNum = Num # Integer_+ Integer_- Integer_* Integer_/;
+
+FloatNum : Num Float;
+FloatNum = Num # Float_+ Float_- Float_* Float_/;
+
+record (FromInt (α : Type)) (fromInt : Int -> α);
+
+typeclass FromInt;
+
+fromInt = lambda fromIntInst => FromInt.fromInt fromIntInst;
+
+IntFromInt : FromInt Int;
+IntFromInt = FromInt # (lambda x -> x);
+
+IntegerFromInt : FromInt Integer;
+IntegerFromInt = FromInt # Int->Integer;
=====================================
src/REPL.ml
=====================================
@@ -139,6 +139,7 @@ let ilexp_parse pexps lctx: ((ldecl list list * lexpr list) * elab_context) =
unparsed tokens directly instead *)
let ldecls, lctx = Elab.lexp_p_decls pdecls [] lctx in
let lexprs = Elab.lexp_parse_all pexprs lctx in
+ List.iter Elab.resolve_instances lexprs;
List.iter (fun lxp -> ignore (OL.check (ectx_to_lctx lctx) lxp))
lexprs;
(ldecls, lexprs), lctx
=====================================
src/builtin.ml
=====================================
@@ -99,19 +99,6 @@ let dloc = DB.dloc
let op_binary t = mkArrow (Anormal, (dloc, None), t, dloc,
mkArrow (Anormal, (dloc, None), t, dloc, t))
-let type_eq =
- let lv = (dloc, Some "l") in
- let tv = (dloc, Some "t") in
- mkArrow (Aerasable, lv,
- DB.type_level, dloc,
- mkArrow (Aerasable, tv,
- mkSort (dloc, Stype (mkVar (lv, 0))), dloc,
- mkArrow (Anormal, (dloc, None),
- mkVar (tv, 0), dloc,
- mkArrow (Anormal, (dloc, None),
- mkVar (tv, 1), dloc,
- mkSort (dloc, Stype (mkVar (lv, 3)))))))
-
let o2l_bool ctx b = get_predef (if b then "true" else "false") ctx
(* Typer list as seen during runtime. *)
@@ -161,7 +148,9 @@ let register_builtin_csts () =
add_builtin_cst "Integer" DB.type_integer;
add_builtin_cst "Float" DB.type_float;
add_builtin_cst "String" DB.type_string;
- add_builtin_cst "Elab_Context" DB.type_elabctx
+ add_builtin_cst "Elab_Context" DB.type_elabctx;
+ add_builtin_cst "Eq" DB.type_eq;
+ add_builtin_cst "Eq.refl" DB.eq_refl
let register_builtin_types () =
let _ = new_builtin_type "Sexp" DB.type0 in
@@ -175,7 +164,6 @@ let register_builtin_types () =
"Array" (mkArrow (Anormal, (dloc, None),
DB.type0, dloc, DB.type0)) in
let _ = new_builtin_type "FileHandle" DB.type0 in
- let _ = new_builtin_type "Eq" type_eq in
()
let _ = register_builtin_csts ();
=====================================
src/debruijn.ml
=====================================
@@ -94,6 +94,37 @@ let type_integer = mkBuiltin ((dloc, "Integer"), type0, None)
let type_float = mkBuiltin ((dloc, "Float"), type0, None)
let type_string = mkBuiltin ((dloc, "String"), type0, None)
let type_elabctx = mkBuiltin ((dloc, "Elab_Context"), type0, None)
+let type_eq_type =
+ let lv = (dloc, Some "l") in
+ let tv = (dloc, Some "t") in
+ mkArrow (Aerasable, lv,
+ type_level, dloc,
+ mkArrow (Aerasable, tv,
+ mkSort (dloc, Stype (mkVar (lv, 0))), dloc,
+ mkArrow (Anormal, (dloc, None),
+ mkVar (tv, 0), dloc,
+ mkArrow (Anormal, (dloc, None),
+ mkVar (tv, 1), dloc,
+ mkSort (dloc, Stype (mkVar (lv, 3)))))))
+let type_eq = mkBuiltin ((dloc, "Eq"), type_eq_type, None)
+let eq_refl =
+ let lv = (dloc, Some "l") in
+ let tv = (dloc, Some "t") in
+ let xv = (dloc, Some "x") in
+ mkBuiltin ((dloc, "Eq.refl"),
+ mkArrow (Aerasable, lv,
+ type_level, dloc,
+ mkArrow (Aerasable, tv,
+ mkSort (dloc, Stype (mkVar (lv, 0))), dloc,
+ mkArrow (Aerasable, xv,
+ mkVar (tv, 0), dloc,
+ mkCall (type_eq,
+ [Aerasable, mkVar (lv, 2);
+ Aerasable, mkVar (tv, 1);
+ Anormal, mkVar (xv, 0);
+ Anormal, mkVar (xv, 0)])))),
+ None)
+
(* easier to debug with type annotations *)
type env_elem = (vname * varbind * ltype)
@@ -112,26 +143,29 @@ type meta_scope
* lctx_length (* Length of ctx when the scope is added. *)
* (meta_id SMap.t ref) (* Metavars already known in this scope. *)
+type typeclass_ctx
+ = (ltype * lctx_length) list (* FIXME make it a set of lexps ? *)
+
(* This is the *elaboration context* (i.e. a context that holds
* a lexp context plus some side info. *)
type elab_context
- = Grammar.grammar * senv_type * lexp_context * meta_scope
+ = Grammar.grammar * senv_type * lexp_context * meta_scope * typeclass_ctx
let get_size (ctx : elab_context)
- = let (_, (n, _), lctx, _) = ctx in
+ = let (_, (n, _), lctx, _, _) = ctx in
assert (n = M.length lctx); n
let ectx_to_grm (ectx : elab_context) : Grammar.grammar =
- let (grm,_, _, _) = ectx in grm
+ let (grm,_, _, _, _) = ectx in grm
(* Extract the lexp context from the context used during elaboration. *)
let ectx_to_lctx (ectx : elab_context) : lexp_context =
- let (_,_, lctx, _) = ectx in lctx
+ let (_,_, lctx, _, _) = ectx in lctx
-let ectx_to_scope_level ((_, _, _, (sl, _, _)) : elab_context) : scope_level
+let ectx_to_scope_level ((_, _, _, (sl, _, _), _) : elab_context) : scope_level
= sl
-let ectx_local_scope_size ((_, (n, _), _, (_, slen, _)) as ectx) : int
+let ectx_local_scope_size ((_, (n, _), _, (_, slen, _), _) as ectx) : int
= get_size ectx - slen
(* Public methods: DO USE
@@ -142,7 +176,7 @@ let empty_lctx = M.nil
let empty_elab_context : elab_context
= (Grammar.default_grammar, empty_senv, empty_lctx,
- (0, 0, ref SMap.empty))
+ (0, 0, ref SMap.empty), [])
(* senv_lookup caller were using Not_found exception *)
exception Senv_Lookup_Fail of (string list)
@@ -150,7 +184,7 @@ let senv_lookup_fail relateds = raise (Senv_Lookup_Fail relateds)
(* Return its current DeBruijn index. *)
let senv_lookup (name: string) (ctx: elab_context): int =
- let (_, (n, map), _, _) = ctx in
+ let (_, (n, map), _, _, _) = ctx in
try n - (SMap.find name map) - 1
with Not_found
-> let get_related_names (n : db_ridx) name map =
@@ -189,11 +223,11 @@ let lctx_extend (ctx : lexp_context) (def: vname) (v: varbind) (t: lexp) =
let env_extend_rec (ctx: elab_context) (def: vname) (v: varbind) (t: lexp) =
let (loc, oname) = def in
- let (grm, (n, map), env, sl) = ctx in
+ let (grm, (n, map), env, sl, tcctx) = ctx in
let nmap = match oname with None -> map | Some name -> SMap.add name n map in
(grm, (n + 1, nmap),
lexp_ctx_cons env def v t,
- sl)
+ sl, tcctx)
let ectx_extend (ctx: elab_context) (def: vname) (v: varbind) (t: lexp) = env_extend_rec ctx def v t
@@ -207,28 +241,33 @@ let lctx_extend_rec (ctx : lexp_context) (defs: (vname * lexp * ltype) list) =
ctx
let ectx_extend_rec (ctx: elab_context) (defs: (vname * lexp * ltype) list) =
- let (grm, (n, senv), lctx, sl) = ctx in
+ let (grm, (n, senv), lctx, sl, tcctx) = ctx in
let senv', _ = List.fold_left
(fun (senv, i) ((_, oname), _, _) ->
(match oname with None -> senv
| Some name -> SMap.add name i senv),
i + 1)
(senv, n) defs in
- (grm, (n + List.length defs, senv'), lctx_extend_rec lctx defs, sl)
+ (grm, (n + List.length defs, senv'), lctx_extend_rec lctx defs, sl, tcctx)
let ectx_new_scope (ectx : elab_context) : elab_context =
- let (grm, senv, lctx, (scope, _, rmmap)) = ectx in
- (grm, senv, lctx, (scope + 1, Myers.length lctx, ref (!rmmap)))
+ let (grm, senv, lctx, (scope, _, rmmap), tcctx) = ectx in
+ (grm, senv, lctx, (scope + 1, Myers.length lctx, ref (!rmmap)), tcctx)
let ectx_get_scope (ectx : elab_context) : meta_scope =
- let (_, _, _, sl) = ectx in sl
+ let (_, _, _, sl, _) = ectx in sl
let ectx_get_grammar (ectx : elab_context) : Grammar.grammar =
- let (grm, _, _, _) = ectx in grm
+ let (grm, _, _, _, _) = ectx in grm
let env_lookup_by_index index (ctx: lexp_context): env_elem =
Myers.nth index ctx
+let env_add_typeclass (ectx : elab_context) (t : ltype) : elab_context =
+ let (grm, senv, lctx, sl, tcctx) = ectx in
+ let ntcctx = ((t, get_size ectx) :: tcctx) in
+ (grm, senv, lctx, sl, ntcctx)
+
(* Print context *)
let print_lexp_ctx_n (ctx : lexp_context) start =
let n = (M.length ctx) - 1 in
=====================================
src/elab.ml
=====================================
@@ -57,6 +57,7 @@ open Grammar
module BI = Builtin
module Unif = Unification
+module Inst = Instances
module OL = Opslexp
module EL = Elexp
@@ -257,6 +258,13 @@ let newMetavar (ctx : lexp_context) sl name t =
let meta = Unif.create_metavar ctx sl t in
mkMetavar (meta, S.identity, name)
+let newInstanceMetavar (ctx : elab_context) name t =
+ let lctx = ectx_to_lctx ctx in
+ let sl = ectx_to_scope_level ctx in
+ let meta = Unif.create_metavar lctx sl t in
+ Inst.add_instance_metavar meta ctx (fst name);
+ mkMetavar (meta, S.identity, name)
+
let newMetalevel (ctx : lexp_context) sl loc =
newMetavar ctx sl (loc, Some "ℓ") type_level
@@ -280,8 +288,8 @@ let sdform_define_operator (ctx : elab_context) loc sargs _ot : elab_context =
| Symbol (_, "") -> None
| Integer (_, n) -> Some n
| _ -> sexp_error (sexp_location s) "Expecting an integer or ()"; None in
- let (grm, a, b, c) = ctx in
- (SMap.add name (level l, level r) grm, a, b, c)
+ let (grm, a, b, c, d) = ctx in
+ (SMap.add name (level l, level r) grm, a, b, c, d)
| [o; _; _]
-> sexp_error (sexp_location o) "Expecting a string"; ctx
| _
@@ -466,11 +474,11 @@ let rec meta_to_var ids (e : lexp) =
-> let ncases
= SMap.map
(fun (l, fields, e)
- -> (l, fields, loop (o + List.length fields) e))
+ -> (l, fields, loop (o + List.length fields + 1) e))
cases in
mkCase (l, loop o e, loop o t, ncases,
match default with None -> None
- | Some (v, e) -> Some (v, loop (1 + o) e))
+ | Some (v, e) -> Some (v, loop (2 + o) e))
| Metavar (id, s, name)
-> if IMap.mem id ids then
mkVar (name, o + count - IMap.find id ids)
@@ -625,12 +633,83 @@ and get_implicit_arg ctx loc oname t =
and instantiate_implicit e t ctx =
let rec instantiate t args =
match OL.lexp_whnf t (ectx_to_lctx ctx) with
+ | Arrow ((Aerasable | Aimplicit) as ak, (_, v), t1, _, t2) when Inst.is_typeclass ctx t1
+ -> let arg = newInstanceMetavar ctx (lexp_location e, v) t1 in
+ instantiate (mkSusp t2 (S.substitute arg)) ((ak, arg)::args)
| Arrow ((Aerasable | Aimplicit) as ak, (_, v), t1, _, t2)
-> let arg = get_implicit_arg ctx (lexp_location e) v t1 in
instantiate (mkSusp t2 (S.substitute arg)) ((ak, arg)::args)
| _ -> (mkCall (e, List.rev args), t)
in instantiate t []
+and myers_filter_map_index (f : int -> 'a -> 'b option) (m : 'a M.myers)
+ : ('b M.myers)
+ = snd (M.fold_right
+ (fun x (i, l') ->
+ match (f i x) with
+ | Some y -> (i - 1, M.cons y l')
+ | None -> (i - 1, l'))
+ m (M.length m - 1, M.nil))
+
+and search_instance (ctx : elab_context) (loc : location) (t : ltype) : lexp option =
+ Log.log_debug ~loc ("Searching for t = `" ^ (lexp_string t) ^ "`");
+ let ctx = ectx_new_scope ctx in
+ let lctx = (ectx_to_lctx ctx) in
+ let sl = (ectx_to_scope_level ctx) in
+ let env_elem_match (i : int) (elem : DB.env_elem) : (int * DB.env_elem * lexp * ltype) option =
+ let ((_, namopt), _, t') = elem in
+ let var = mkVar ((loc,namopt), i) in
+ let t' = mkSusp t' (S.shift (i + 1)) in
+ let (e, t') = instantiate_implicit var t' ctx in
+ (* All candidates should have a type that is a typeclass *)
+ if not (Inst.is_typeclass ctx t') then None else
+ match Inst.check_typeclass_match t t' lctx sl with
+ | (Impossible | Possible) -> None
+ (* | Possible -> None *)
+ | (Match) -> Some (i, elem, e, t') in
+ let candidates =
+ myers_filter_map_index env_elem_match lctx in
+ Log.log_debug ("Candidates for instance of type `" ^ lexp_string t ^ "`:")
+ ~print_action:(fun () ->
+ M.iter (fun (i, ((_, so),_,t'),_, _) ->
+ lalign_print_int i 4;
+ lalign_print_string (match so with | Some s -> s | None -> "<none>") 10;
+ print_endline (lexp_string t')) candidates);
+ match M.safe_car candidates with
+ | None -> None
+ | Some (i, (vname, _, t'),e,t) ->
+ let t' = mkSusp t' (S.shift (i + 1)) in
+ Log.log_debug ~loc
+ ("Found candidate at index " ^ (string_of_int i) ^ ": `" ^
+ (lexp_string (Var (vname, i))) ^ " : " ^ (lexp_string t') ^ "`");
+ Some e
+
+and resolve_instances e =
+ let (_, (fv_map, _)) = OL.fv e in
+ U.IMap.iter (fun i (sl, t, cl, vn) ->
+ match Inst.instance_metavar_lookup i with
+ | Some (ctx, loc) ->
+ (match search_instance ctx loc t with
+ | Some e -> Unif.associate i e; resolve_instances e
+ | None ->
+ error ~loc ("No instance found for type `" ^ (lexp_string t) ^ "`")
+ )
+ | None -> ()
+ ) fv_map
+
+
+and resolve_instances_and_generalize ctx e =
+ resolve_instances e;
+ generalize ctx e
+
+and sdform_typeclass (ctx : elab_context) loc sargs _ot : elab_context =
+ match sargs with
+ | [se] ->
+ let (t, _) = infer se ctx in
+ Inst.add_typeclass ctx t
+ | _
+ -> sexp_error loc "typeclass expects 1 argument"; ctx
+
and infer_type pexp ectx var =
(* We could also use lexp_check with an argument of the form
* Sort (?s), but in most cases the metavar would be allocated
@@ -707,7 +786,8 @@ and check_inferred ctx e inferred_t t =
-> lexp_error (lexp_location e) e
("Type mismatch("
^ (match ck with | Unif.CKimpossible -> "impossible"
- | Unif.CKresidual -> "residue")
+ | Unif.CKresidual -> "residue"
+ | _ -> failwith "impossible" )
^ ")! Context expected:\n "
^ lexp_string t ^ "\nbut expression has type:\n "
^ lexp_string inferred_t ^ "\ncan't unify:\n "
@@ -738,16 +818,16 @@ and check_case rtype (loc, target, ppatterns) ctx =
let ltarget = ref tlxp in
let get_cs_as it' lctor =
+ let unify_ind expected actual =
+ match Unif.unify actual expected (ectx_to_lctx ctx) with
+ | (_::_)
+ -> lexp_error loc lctor
+ ("Expected pattern of type `" ^ lexp_string expected
+ ^ "` but got `" ^ lexp_string actual ^ "`")
+ | [] -> () in
match !it_cs_as with
| Some (it, cs, args)
- -> let _ = match Unif.unify it' it (ectx_to_lctx ctx) with
- | (_::_)
- -> lexp_error loc lctor
- ("Expected pattern of type `"
- ^ lexp_string it ^ "` but got `"
- ^ lexp_string it' ^ "`")
- | [] -> () in
- (cs, args)
+ -> unify_ind it it'; (cs, args)
| None
-> match OL.lexp_whnf it' (ectx_to_lctx ctx) with
| Inductive (_, _, fargs, constructors)
@@ -768,6 +848,7 @@ and check_case rtype (loc, target, ppatterns) ctx =
with | Call (f, args) -> (f, args)
| _ -> (e,[]) in
let (it, targs) = call_split tltp in
+ unify_ind it it';
let constructors = match OL.lexp_whnf it (ectx_to_lctx ctx) with
| Inductive (_, _, fargs, constructors)
-> assert (List.length fargs = List.length targs);
@@ -776,14 +857,42 @@ and check_case rtype (loc, target, ppatterns) ctx =
("Can't `case` on objects of this type: "
^ lexp_string tltp);
SMap.empty in
+ it_cs_as := Some (it, constructors, targs);
(constructors, targs) in
(* Read patterns one by one *)
let fold_fun (lbranches, dflt) (pat, pexp) =
+ let shift_to_extended_ctx nctx lexp =
+ mkSusp lexp (S.shift (M.length (ectx_to_lctx nctx)
+ - M.length (ectx_to_lctx ctx))) in
+
+ let ctx_extend_with_eq nctx head_lexp =
+ (* Add a proof of equality between the target and the branch
+ head to the context *)
+ let tlxp' = shift_to_extended_ctx nctx tlxp in
+ let tltp' = shift_to_extended_ctx nctx tltp in
+ let tkind = OL.get_type (ectx_to_lctx nctx) tltp' in
+ let tlevel = (match OL.lexp_whnf tkind (ectx_to_lctx nctx) with
+ | Sort (_, Stype l) -> l
+ | _ -> error "HMMM"; DB.level0) in
+ let head_lexp_type = OL.get_type (ectx_to_lctx nctx) head_lexp in
+ (match Unif.unify tltp' head_lexp_type (ectx_to_lctx nctx) with
+ | [] -> ()
+ | constraints -> Log.log_error "Unification failed for case Eq");
+ let eqty = mkCall (DB.type_eq,
+ [(Aerasable, tlevel); (* Typelevel *)
+ (Aerasable, tltp'); (* Inductive type *)
+ (Anormal, tlxp'); (* Target lexp *)
+ (Anormal, head_lexp)]) (* Lexp of the branch head *)
+ in ctx_extend nctx (loc, None) Variable eqty
+ in
+
let add_default v =
(if dflt != None then uniqueness_warn pat);
let nctx = ctx_extend ctx v Variable tltp in
+ let head_lexp = mkVar (v, 0) in
+ let nctx = ctx_extend_with_eq nctx head_lexp in
let rtype' = mkSusp rtype (S.shift (M.length (ectx_to_lctx nctx)
- M.length (ectx_to_lctx ctx))) in
let lexp = check pexp rtype' nctx in
@@ -864,6 +973,15 @@ and check_case rtype (loc, target, ppatterns) ctx =
make_nctx nctx (ssink var s) pargs cargs pe
((ak, var)::acc) in
let nctx, fargs = make_nctx ctx subst pargs cargs SMap.empty [] in
+ let head_lexp_ctor =
+ shift_to_extended_ctx nctx
+ (mkCall (lctor, List.map (fun (_, a) -> (Aerasable, a)) targs)) in
+ let head_lexp_args =
+ List.mapi (fun i (ak, vname) ->
+ (* This is not pretty :( *)
+ (ak, mkVar (vname, List.length fargs - i - 1))) fargs in
+ let head_lexp = mkCall (head_lexp_ctor, head_lexp_args) in
+ let nctx = ctx_extend_with_eq nctx head_lexp in
let rtype' = mkSusp rtype
(S.shift (M.length (ectx_to_lctx nctx)
- M.length (ectx_to_lctx ctx))) in
@@ -946,11 +1064,13 @@ and elab_call ctx (func, ltp) (sargs: sexp list) =
(* Don't instantiate after the last explicit arg: the rest is done,
* when needed in infer_and_check (via instantiate_implicit). *)
when not (sargs = [] && SMap.is_empty pending)
- -> let larg = get_implicit_arg
- ctx (match sargs with
- | [] -> loc
- | sarg::_ -> sexp_location sarg)
- v arg_type in
+ -> let larg = if Inst.is_typeclass ctx arg_type
+ then newInstanceMetavar ctx (loc, v) arg_type
+ else get_implicit_arg
+ ctx (match sargs with
+ | [] -> loc
+ | sarg::_ -> sexp_location sarg)
+ v arg_type in
handle_fun_args ((ak, larg) :: largs) sargs pending
(L.mkSusp ret_type (S.substitute larg))
| [], _
@@ -996,7 +1116,7 @@ and lexp_parse_inductive ctors ctx =
(fun (ak, n, t) aa
-> Arrow (ak, n, t, dummy_location, aa))
acc impossible in
- let g = generalize nctx altacc in
+ let g = resolve_instances_and_generalize nctx altacc in
let altacc' = g (fun _ne vname t l e
-> Arrow (Aerasable, vname, t, l, e))
altacc in
@@ -1110,9 +1230,9 @@ and lexp_check_decls (ectx : elab_context) (* External context. *)
(* FIXME: Generalize when/where possible, so things like `map` can be
defined without type annotations! *)
(* Preserve the new operators added to nctx. *)
- let ectx = let (_, a, b, c) = ectx in
- let (grm, _, _, _) = nctx in
- (grm, a, b, c) in
+ let ectx = let (_, a, b, c, _) = ectx in
+ let (grm, _, _, _, tcctx) = nctx in
+ (grm, a, b, c, tcctx) in
let (declmap, nctx)
= List.fold_right
(fun ((l, vname), pexp) (map, nctx) ->
@@ -1122,10 +1242,11 @@ and lexp_check_decls (ectx : elab_context) (* External context. *)
| (v', ForwardRef, t)
-> let adjusted_t = push_susp t (S.shift (i + 1)) in
let e = check pexp adjusted_t nctx in
- let (grm, ec, lc, sl) = nctx in
+ resolve_instances e;
+ let (grm, ec, lc, sl, tcctx) = nctx in
let d = (v', LetDef (i + 1, e), t) in
(IMap.add i ((l, Some vname), e, t) map,
- (grm, ec, Myers.set_nth i d lc, sl))
+ (grm, ec, Myers.set_nth i d lc, sl, tcctx))
| _ -> Log.internal_error "Defining same slot!")
defs (IMap.empty, nctx) in
let decls = List.rev (List.map (fun (_, d) -> d) (IMap.bindings declmap)) in
@@ -1161,7 +1282,7 @@ and infer_and_generalize_type (ctx : elab_context) se name =
| Arrow (ak, v, t1, l, t2) -> Arrow (ak, v, t1, l, strip_rettype t2)
| Sort _ | Metavar _ -> type0 (* Abritrary closed constant. *)
| _ -> t in
- let g = generalize nctx (strip_rettype t) in
+ let g = resolve_instances_and_generalize nctx (strip_rettype t) in
g (fun _ne name t l e
-> mkArrow (Aerasable, name, t, l, e))
t
@@ -1169,7 +1290,7 @@ and infer_and_generalize_type (ctx : elab_context) se name =
and infer_and_generalize_def (ctx : elab_context) se =
let nctx = ectx_new_scope ctx in
let (e,t) = infer se nctx in
- let g = generalize nctx e in
+ let g = resolve_instances_and_generalize nctx e in
let e' = g (fun ne vname t l e
-> mkLambda ((if ne then Aimplicit else Aerasable),
vname, t, e))
@@ -1301,6 +1422,10 @@ and lexp_decls_1
-> recur [] (sdform_define_operator nctx l args None)
pending_decls pending_defs
+ | Some (Node (Symbol (l, "typeclass"), args))
+ -> recur [] (sdform_typeclass nctx l args None)
+ pending_decls pending_defs
+
| Some (Node (Symbol ((l, _) as v), sargs))
-> (* expand macro and get the generated declarations *)
let sdecl' = lexp_decls_macro v sargs nctx in
@@ -1329,10 +1454,12 @@ and lexp_p_decls (sdecls : sexp list) (tokens : token list) (ctx : elab_context)
impl sdecls tokens ctx
and lexp_parse_all (p: sexp list) (ctx: elab_context) : lexp list =
+ Eval.set_getenv ctx;
let res = List.map (fun pe -> let e, _ = infer pe ctx in e) p in
(Log.stop_on_error (); res)
and lexp_parse_sexp (ctx: elab_context) (e : sexp) : lexp =
+ Eval.set_getenv ctx;
let e, _ = infer e ctx in (Log.stop_on_error (); e)
(* --------------------------------------------------------------------------
@@ -1657,10 +1784,21 @@ let rec sform_lambda kind ctx loc sargs ot =
-> (match olt1 with
| None -> ()
| Some lt1'
- -> if not (OL.conv_p (ectx_to_lctx ctx) lt1 lt1')
- then lexp_error (lexp_location lt1') lt1'
- ("Type mismatch! Context expected `"
- ^ lexp_string lt1 ^ "`"));
+ -> (match Unif.unify lt1' lt1 (ectx_to_lctx ctx) with
+ | ((ck, _ctx, t1, t2)::_)
+ -> lexp_error (lexp_location lt1') lt1'
+ ("Type mismatch("
+ ^ (match ck with | Unif.CKimpossible -> "impossible"
+ | Unif.CKresidual -> "residue"
+ | _ -> failwith "impossible")
+ ^ ")! Context expected:\n "
+ ^ lexp_string lt1 ^ "\nbut parameter has type:\n "
+ ^ lexp_string lt1' ^ "\ncan't unify:\n "
+ ^ lexp_string t1
+ ^ "\nwith:\n "
+ ^ lexp_string t2);
+ assert (not (OL.conv_p (ectx_to_lctx ctx) lt1' lt1))
+ | [] -> ()));
mklam lt1 (Some lt2)
| Arrow (ak2, v, lt1, _, lt2) when kind = Anormal
@@ -1824,6 +1962,22 @@ let sform_load usr_elctx loc sargs ot =
(tuple',Lazy)
+(**
+ Draft of a special form "instance" that gets refers to a variable
+ of the requested type in the context.
+ **)
+let sform_instance ctx loc sargs ot =
+ match sargs, ot with
+ | ([se; _], _) -> (* Dummy param to trigger the special form *)
+ let t = infer_type se ctx (loc, None) in
+ let mv = newInstanceMetavar ctx (loc, Some "instance") t in
+ (mv, Inferred t)
+ | ([_], Some t) -> (* Dummy param to trigger the special form *)
+ let mv = newInstanceMetavar ctx (loc, Some "instance") t in
+ (mv, Checked)
+ | _ -> (sexp_error loc "##instance expects a type argument if not checked";
+ sform_dummy_ret ctx loc)
+
(* Register special forms. *)
let register_special_forms () =
List.iter add_special_form
@@ -1853,6 +2007,7 @@ let register_special_forms () =
(* FIXME: These should be functions! *)
("decltype", sform_decltype);
("declexpr", sform_declexpr);
+ ("instance", sform_instance);
]
(* Default context with builtin types
=====================================
src/eval.ml
=====================================
@@ -744,6 +744,14 @@ let constructor_p name ectx =
| _ -> false
with Senv_Lookup_Fail _ -> false
+let inductive_p name ectx =
+ try let idx = senv_lookup name ectx in
+ match OL.lexp_whnf (mkVar ((dummy_location, Some name), idx))
+ (ectx_to_lctx ectx) with
+ | Inductive _ -> true
+ | _ -> false
+ with Senv_Lookup_Fail _ -> false
+
let erasable_p name nth ectx =
let is_erasable ctors = match (smap_find_opt name ctors) with
| (Some args) ->
@@ -821,10 +829,43 @@ let ctor_arg_pos name arg ectx =
| _ -> (-1)
with Senv_Lookup_Fail _ -> (-1)
+let ind_ctor_arg_pos indname ctorname arg ectx =
+ let rec find_opt xs n = match xs with
+ | [] -> None
+ | (_, (_, Some x), _)::xs -> if x = arg then Some n else find_opt xs (n + 1)
+ | _::xs -> find_opt xs (n + 1) in
+ try let idx = senv_lookup indname ectx in
+ match OL.lexp_whnf (mkVar ((dummy_location, Some indname), idx))
+ (ectx_to_lctx ectx) with
+ | Inductive (_, _, _, ctors) ->
+ (match smap_find_opt ctorname ctors with
+ | (Some args) ->
+ (match (find_opt args 0) with
+ | None -> (-1)
+ | Some n -> n)
+ | _ -> (-1))
+ | _ -> (-1)
+ with Senv_Lookup_Fail _ -> (-1)
+
+let count_ctor_args indname ctorname ectx =
+ try let idx = senv_lookup indname ectx in
+ match OL.lexp_whnf (mkVar ((dummy_location, Some indname), idx))
+ (ectx_to_lctx ectx) with
+ | Inductive (_,_,_,ctors) ->
+ (match smap_find_opt ctorname ctors with
+ | Some args -> List.length args
+ | None -> (-1))
+ | _ -> (-1)
+ with Senv_Lookup_Fail _ -> (-1)
+
let is_constructor loc depth args_val = match args_val with
| [Vstring name; Velabctx ectx] -> o2v_bool (constructor_p name ectx)
| _ -> error loc "Elab.isconstructor takes a String and an Elab_Context as arguments"
+let is_inductive loc depth args_val = match args_val with
+ | [Vstring name; Velabctx ectx] -> o2v_bool (inductive_p name ectx)
+ | _ -> error loc "Elab.isinductive takes a String and an Elab_Context as arguments"
+
let is_nth_erasable loc depth args_val = match args_val with
| [Vstring name; Vint nth_arg; Velabctx ectx] -> o2v_bool (erasable_p name nth_arg ectx)
| _ -> error loc "Elab.is-nth-erasable takes a String, an Int and an Elab_Context as arguments"
@@ -841,6 +882,14 @@ let arg_pos loc depth args_val = match args_val with
| [Vstring t; Vstring a; Velabctx ectx] -> Vint (ctor_arg_pos t a ectx)
| _ -> error loc "Elab.arg-pos takes two String and an Elab_Context as arguments"
+let ind_ctor_arg_pos loc depth args_val = match args_val with
+ | [Vstring ind; Vstring ctor; Vstring field; Velabctx ectx] -> Vint (ind_ctor_arg_pos ind ctor field ectx)
+ | _ -> error loc "Elab.ind-ctor-arg-pos takes three String and an Elab_Context as arguments"
+
+let count_ctor_args loc depth args_val = match args_val with
+ | [Vstring ind; Vstring ctor; Velabctx ectx] -> Vint (count_ctor_args ind ctor ectx)
+ | _ -> error loc "Elab.count-ctor-args takes two String and an Elab_Context as arguments"
+
let array_append loc depth args_val = match args_val with
| [v; Varray a] ->
Varray (Array.append (Array.map (fun v -> v) a) (Array.make 1 v))
@@ -996,10 +1045,13 @@ let register_builtin_functions () =
("Elab.debug-doc", debug_doc, 2);
("Elab.isbound" , is_bound, 2);
("Elab.isconstructor", is_constructor, 2);
+ ("Elab.isinductive", is_inductive, 2);
("Elab.is-nth-erasable", is_nth_erasable, 3);
("Elab.is-arg-erasable", is_arg_erasable, 3);
("Elab.nth-arg" , nth_arg, 3);
("Elab.arg-pos" , arg_pos, 3);
+ ("Elab.ind-ctor-arg-pos", ind_ctor_arg_pos, 4);
+ ("Elab.count-ctor-args", count_ctor_args, 3);
("Array.append" , array_append,2);
("Array.create" , array_create,2);
("Array.length" , array_length,1);
=====================================
src/instances.ml
=====================================
@@ -0,0 +1,52 @@
+module Unif = Unification
+module U = Util
+module DB = Debruijn
+module L = Lexp
+module S = Subst
+module OL = Opslexp
+
+(* FIXME Is it possible to have multiple references to the same
+ instance metavar? It would break the following code *)
+let instance_metavar_table = ref (U.IMap.empty : (DB.elab_context * U.location) U.IMap.t)
+let instance_metavar_lookup (id : L.meta_id) : (DB.elab_context * U.location) option
+ = U.IMap.find_opt id (!instance_metavar_table)
+let add_instance_metavar (id : L.meta_id) (ctx : DB.elab_context) (loc : U.location) : unit
+ = instance_metavar_table := U.IMap.add id (ctx, loc) !instance_metavar_table
+
+let env_is_typeclass (ectx : DB.elab_context) (t : L.ltype) : bool =
+ let (_, _, _, _, tcctx) = ectx in
+ let cl = DB.get_size ectx in
+ List.exists (fun (t', cl') ->
+ let i = cl - cl' in
+ let t' = L.mkSusp t' (S.shift i) in
+ OL.conv_p (DB.ectx_to_lctx ectx) t t'
+ (*(Unif.unify ~checking:(max_int (* FIXME *)) t t' (DB.ectx_to_lctx ectx)) = []*)
+ ) tcctx
+
+
+let get_head (lctx : DB.lexp_context) (t : L.ltype) : L.ltype =
+ match OL.lexp_whnf t lctx with
+ | L.Call (head, _) -> head
+ | head -> head
+
+
+let is_typeclass (ctx : DB.elab_context) (t : L.ltype) =
+ let lctx = DB.ectx_to_lctx ctx in
+ let head = get_head lctx t in
+ env_is_typeclass ctx head
+
+let add_typeclass (ctx : DB.elab_context) (t : L.ltype) : DB.elab_context =
+ let lctx = DB.ectx_to_lctx ctx in
+ let head = get_head lctx t in
+ DB.env_add_typeclass ctx head
+
+type match_res = Impossible | Possible | Match
+
+let check_typeclass_match t1 t2 lctx sl =
+ match Unif.unify ~checking:sl t1 t2 lctx with
+ | [] -> Match
+ | constraints when List.exists (function | (Unif.CKimpossible,_,_,_) -> true
+ | _ -> false)
+ constraints -> Impossible
+ | _ -> Possible
+
=====================================
src/inverse_subst.ml
=====================================
@@ -300,11 +300,12 @@ and apply_inv_subst (e : lexp) (s : subst) : lexp = match e with
-> let s' = L.fold_left
(fun s (_,ov) -> ssink ov s)
s cargs in
- (l, cargs, apply_inv_subst e s'))
+ let s'' = ssink (l, None) s' in
+ (l, cargs, apply_inv_subst e s''))
cases,
match default with
| None -> default
- | Some (v,e) -> Some (v, apply_inv_subst e (ssink v s)))
+ | Some (v,e) -> Some (v, apply_inv_subst e (ssink (l, None) (ssink v s))))
| Metavar (id, s', name)
-> match metavar_lookup id with
| MVal e -> apply_inv_subst (push_susp e s') s
=====================================
src/lexp.ml
=====================================
@@ -409,11 +409,11 @@ let rec push_susp e s = (* Push a suspension one level down. *)
-> let s' = L.fold_left
(fun s (_,ov) -> ssink ov s)
s cargs in
- (l, cargs, mkSusp e s'))
+ (l, cargs, mkSusp e (ssink (l, None) s')))
cases,
match default with
| None -> default
- | Some (v,e) -> Some (v, mkSusp e (ssink v s)))
+ | Some (v,e) -> Some (v, mkSusp e (ssink (l, None) (ssink v s))))
(* Susp should never appear around Var/Susp/Metavar because mkSusp
* pushes the subst into them eagerly. IOW if there's a Susp(Var..)
* or Susp(Metavar..) it's because some chunk of code should use mkSusp
@@ -475,11 +475,12 @@ let clean e =
-> let s' = L.fold_left
(fun s (_,ov) -> ssink ov s)
s cargs in
- (l, cargs, clean s' e))
+ let s'' = ssink (l, None) s' in
+ (l, cargs, clean s'' e))
cases,
match default with
| None -> default
- | Some (v,e) -> Some (v, clean (ssink v s) e))
+ | Some (v,e) -> Some (v, clean (ssink (l, None) (ssink v s)) e))
| Susp (e, s') -> clean (scompose s' s) e
| Var _ -> if S.identity_p s then e
else clean S.identity (mkSusp e s)
@@ -805,7 +806,7 @@ and lexp_str ctx (exp : lexp) : string =
| Metavar (idx, subst, (loc, name))
(* print metavar result if any *)
-> (match metavar_lookup idx with
- | MVal e -> lexp_str ctx e
+ | MVal e -> lexp_str ctx (push_susp e subst)
| _ -> "?" ^ maybename name ^ (subst_string subst) ^ (index idx))
| Let (_, decls, body) ->
@@ -993,7 +994,19 @@ let rec eq e1 e2 =
| (Some (_, e1), Some (_, e2)) -> eq e1 e2
| _ -> def1 = def2)
| (Metavar (i1, s1, _), Metavar (i2, s2, _))
- -> i1 = i2 && subst_eq s1 s2
+ -> if i1 == i2 then subst_eq s1 s2 else
+ (match (metavar_lookup i1, metavar_lookup i2) with
+ | (MVal l, _) -> eq (push_susp l s1) e2
+ | (_, MVal l) -> eq e1 (push_susp l s2)
+ | _ -> false)
+ | (Metavar (i1, s1, _), _)
+ -> (match metavar_lookup i1 with
+ | MVal l -> eq (push_susp l s1) e2
+ | _ -> false)
+ | (_, Metavar (i2, s2, _))
+ -> (match metavar_lookup i2 with
+ | MVal l -> eq e1 (push_susp l s2)
+ | _ -> false)
| _ -> false
and subst_eq s1 s2 =
=====================================
src/log.ml
=====================================
@@ -133,11 +133,13 @@ let print_entry entry =
let log_entry (entry : log_entry) =
if (entry.level <= typer_log_config.level)
then (
- log_push entry;
- if (typer_log_config.print_at_log)
+ if (typer_log_config.print_at_log ||
+ entry.level >= Debug)
then
(print_entry entry;
flush stdout)
+ else
+ log_push entry
)
let count_msgs (lvlp : log_level -> bool) =
=====================================
src/myers.ml
=====================================
@@ -54,11 +54,21 @@ let car l =
| Mnil -> raise Not_found
| Mcons (x, _, _, _) -> x
+let safe_car l =
+ match l with
+ | Mnil -> None
+ | Mcons (x, _, _, _) -> Some x
+
let cdr l =
match l with
| Mnil -> Mnil
| Mcons (_, l, _, _) -> l
+let safe_cdr l =
+ match l with
+ | Mnil -> None
+ | Mcons (_, l, _, _) -> Some l
+
let case l n c =
match l with
| Mnil -> n ()
@@ -136,3 +146,6 @@ let rec fold_right f l i = match l with
let map f l = fold_right (fun x l' -> cons (f x) l') l nil
let iteri f l = fold_left (fun i x -> f i x; i + 1) 0 l
+
+let iter (f : 'a -> unit) (l : 'a myers) : unit
+ = fold_left (fun _ x -> f x; ()) () l
=====================================
src/opslexp.ml
=====================================
@@ -38,6 +38,22 @@ module S = Subst
(* module L = List *)
module DB = Debruijn
+type set_plexp = (lexp * lexp) list
+type sort_compose_result
+ = SortResult of ltype
+ | SortInvalid
+ | SortK1NotType
+ | SortK2NotType
+type mv_set = (scope_level * ltype * ctx_length * vname) IMap.t
+ (* Metavars that appear in non-erasable positions. *)
+ * unit IMap.t
+
+module LMap
+ (* Memoization table. FIXME: Ideally the keys should be "weak", but
+ * I haven't found any such functionality in OCaml's libs. *)
+ = Hashtbl.Make
+ (struct type t = lexp let hash = Hashtbl.hash let equal = (==) end)
+
let error_tc = Log.log_error ~section:"TC"
let warning_tc = Log.log_warning ~section:"TC"
@@ -132,7 +148,7 @@ let lexp_close lctx e =
* but only on *types*. If you must use it on code, be sure to use its
* return value as little as possible since WHNF will inherently introduce
* call-by-name behavior. *)
-let lexp_whnf e (ctx : DB.lexp_context) : lexp =
+let rec lexp_whnf e (ctx : DB.lexp_context) : lexp =
let rec lexp_whnf e (ctx : DB.lexp_context) : lexp =
match e with
| Var v -> (match lookup_value ctx v with
@@ -156,21 +172,28 @@ let lexp_whnf e (ctx : DB.lexp_context) : lexp =
| _ -> e) (* Keep `e`, assuming it's more readable! *)
| Case (l, e, rt, branches, default) ->
let e' = lexp_whnf e ctx in
+ let get_refl e =
+ let etype = get_type ctx e in (* FIXME we should not need get_type here *)
+ let elevel = match lexp_whnf (get_type ctx etype) ctx with
+ | Sort (_, Stype l) -> l
+ | _ -> Log.internal_error "" in
+ mkCall (DB.eq_refl, [Aerasable, elevel; Aerasable, etype; Aerasable, e]) in
let reduce name aargs =
try
let (_, _, branch) = SMap.find name branches in
- let (subst, _)
+ let subst
= List.fold_left
- (fun (s,d) (_, arg) ->
- (S.cons (L.mkSusp (lexp_whnf arg ctx) (S.shift d)) s,
- d + 1))
- (S.identity, 0)
+ (fun (s) (_, arg) -> S.cons (lexp_whnf arg ctx) s)
+ S.identity
aargs in
+ (* Substitute case Eq variable by the proof (Eq.refl l t e') *)
+ let subst = S.cons (get_refl e') subst in
lexp_whnf (push_susp branch subst) ctx
with Not_found
-> match default
with | Some (v,default)
- -> lexp_whnf (push_susp default (S.substitute e')) ctx
+ -> let subst = S.cons (get_refl e') (S.substitute e') in
+ lexp_whnf (push_susp default subst) ctx
| _ -> Log.log_error ~section:"WHNF" ~loc:l
("Unhandled constructor " ^
name ^ "in case expression");
@@ -198,9 +221,8 @@ let lexp_whnf e (ctx : DB.lexp_context) : lexp =
(** A very naive implementation of sets of pairs of lexps. *)
-type set_plexp = (lexp * lexp) list
-let set_empty : set_plexp = []
-let set_member_p (s : set_plexp) (e1 : lexp) (e2 : lexp) : bool
+and set_empty : set_plexp = []
+and set_member_p (s : set_plexp) (e1 : lexp) (e2 : lexp) : bool
= assert (e1 == Lexp.hc e1);
assert (e2 == Lexp.hc e2);
try let _ = List.find (fun (e1', e2')
@@ -208,14 +230,14 @@ let set_member_p (s : set_plexp) (e1 : lexp) (e2 : lexp) : bool
s
in true
with Not_found -> false
-let set_add (s : set_plexp) (e1 : lexp) (e2 : lexp) : set_plexp
+and set_add (s : set_plexp) (e1 : lexp) (e2 : lexp) : set_plexp
= (* assert (not (set_member_p s e1 e2)); *)
((e1, e2) :: s)
-let set_shift_n (s : set_plexp) (n : U.db_offset)
+and set_shift_n (s : set_plexp) (n : U.db_offset)
= List.map (let s = S.shift n in
fun (e1, e2) -> (Lexp.push_susp e1 s, Lexp.push_susp e2 s))
s
-let set_shift s : set_plexp = set_shift_n s 1
+and set_shift s : set_plexp = set_shift_n s 1
(********* Testing if two types are "convertible" aka "equivalent" *********)
@@ -225,7 +247,7 @@ let set_shift s : set_plexp = set_shift_n s 1
* `c` is the maximum "constant" level that occurs in `e`
* and `m` maps variable indices to the maxmimum depth at which they were
* found. *)
-let level_canon e =
+and level_canon e =
let add_var_depth v d ((c,m) as acc) =
let o = try IMap.find v m with Not_found -> -1 in
if o < d then (c, IMap.add v d m) else acc in
@@ -244,18 +266,21 @@ let level_canon e =
| _ -> (max_int, m)
in canon e 0 (0,IMap.empty)
-let level_leq (c1, m1) (c2, m2) =
+and level_leq (c1, m1) (c2, m2) =
c1 <= c2
&& c1 != max_int
&& IMap.for_all (fun i d -> try d <= IMap.find i m2 with Not_found -> false)
m1
(* Returns true if e₁ and e₂ are equal (upto alpha/beta/...). *)
-let rec conv_p' (ctx : DB.lexp_context) (vs : set_plexp) e1 e2 : bool =
+and conv_p' (ctx : DB.lexp_context) (vs : set_plexp) e1 e2 : bool =
let e1' = lexp_whnf e1 ctx in
let e2' = lexp_whnf e2 ctx in
+ Log.log_debug ("conv_p : e1' = `" ^ (lexp_string e1')
+ ^ "`; e2' = `" ^ (lexp_string e2') ^ "`");
e1' == e2' ||
let changed = not (e1 == e1' && e2 == e2') in
+ Log.log_debug ("changed : " ^ string_of_bool changed);
if changed && set_member_p vs e1' e2' then true else
let vs' = if changed then set_add vs e1' e2' else vs in
let conv_p = conv_p' ctx vs' in
@@ -319,19 +344,119 @@ let rec conv_p' (ctx : DB.lexp_context) (vs : set_plexp) e1 e2 : bool =
| _,_ -> false in
l1 == l2 && conv_args ctx vs' args1 args2
| (Cons (t1, (_, l1)), Cons (t2, (_, l2))) -> l1 = l2 && conv_p t1 t2
- (* I'm not sure to understand how to compare two Metavar *
- * Should I do a `lookup`? Or is it that simple: *)
- (*| (Metavar (id1,_,_), Metavar (id2,_,_)) -> id1 = id2*)
- (* FIXME: Various missing cases, such as Case. *)
- | (_, _) -> false
-
-let conv_p (ctx : DB.lexp_context) e1 e2
+ | (Case (_, te1, r1, cases1, def1), Case (_, te2, r2, cases2, def2))
+ -> Log.log_debug ("conv_p of case : e1' = `" ^ (lexp_string e1')
+ ^ "`; e2' = `" ^ (lexp_string e2') ^ "`");
+ eq e1' e2' ||
+ (Log.log_debug "subexpr"; conv_p te1 te2) &&
+ (Log.log_debug "return"; conv_p r1 r2) && (
+ Log.log_debug "branches";
+ (* Compare the branches *)
+ (* 1. Get the inductive for the field types *)
+ let call_split e = match e with
+ | Call (f, args) -> (f, args)
+ | _ -> (e,[]) in
+ (* We can arbitrarily use te1 since te1 and te2 are convertible *)
+ let etype = lexp_whnf (get_type ctx te1) ctx in
+ let it, aargs = call_split etype in
+ (* 2. Build the substitution for the inductive arguments *)
+ let fargs, ctors =
+ (match lexp_whnf it ctx with
+ | Inductive (_, _, fargs, constructors)
+ -> fargs, constructors
+ | _ -> Log.log_fatal ("Case of non-inductive in conv_p")) in
+ let fargs_subst = List.fold_left2 (fun s _farg (_, aarg) -> S.cons aarg s)
+ S.identity fargs aargs in
+ (* 3. Compare the branches *)
+ (* The map module doesn't have a function to compare two
+ maps with the key (which is needed to get the field
+ types from the inductive. Instead, we work with the
+ lists of associations. *)
+ (try
+ List.for_all2 (fun (l1, (_, fields1, e1)) (l2, (_, fields2, e2)) ->
+ l1 = l2 &&
+ let fieldtypes = SMap.find l1 ctors in
+ let rec mkctx ctx args s i vdefs1 vdefs2 fieldtypes =
+ match vdefs1, vdefs2, fieldtypes with
+ | [], [], [] -> Some (ctx, List.rev args, s)
+ | (ak1, vdef1)::vdefs1, (ak2, vdef2)::vdefs2,
+ (ak', vdef', ftype)::fieldtypes
+ -> if ak1 = ak2 && ak2 = ak' then
+ (* FIXME Should we compare the variable names ? *)
+ mkctx
+ (DB.lexp_ctx_cons ctx vdef1 Variable (mkSusp ftype s))
+ ((ak1, (mkVar (vdef1, i)))::args)
+ (ssink vdef1 s)
+ (i - 1)
+ vdefs1 vdefs2 fieldtypes
+ else None
+ | _,_,_ -> None in
+ match mkctx ctx [] fargs_subst (List.length fields1)
+ fields1 fields2 fieldtypes with
+ | None -> false
+ | Some (nctx, args, _subst) ->
+ (* TODO build head lexp the eq type *)
+ let offset = (List.length fields1) in
+ let subst = S.shift offset in
+ Log.log_debug "hlxp time";
+ let tlxp = mkSusp te1 subst in
+ Log.log_debug ("tlxp : `" ^ (lexp_string tlxp) ^ "`");
+ let tltp = mkSusp etype subst in
+ Log.log_debug ("etype : `" ^ (lexp_string etype) ^ "`");
+ Log.log_debug ("subst : `" ^ (subst_string subst) ^ "`");
+ Log.log_debug ("tltp : `" ^ (lexp_string tltp) ^ "`");
+ let tlev = (match lexp_whnf (get_type nctx tltp) nctx with
+ | Sort (_, Stype l) -> l
+ | _ -> Log.log_error "HMMM"; DB.level0) in
+ let ctor = mkSusp (mkCall (mkCons (it, (DB.dloc, l1)), aargs)) subst in
+ Log.log_debug ("ctor : `" ^ (lexp_string ctor) ^ "`");
+ let hlxp = mkCall (ctor, args) in
+ Log.log_debug ("hlxp : `" ^ (lexp_string hlxp) ^ "`");
+ let eqty = mkCall (DB.type_eq,
+ [(Aerasable, tlev); (* Typelevel *)
+ (Aerasable, tltp); (* Inductive type *)
+ (Anormal, tlxp); (* Target lexp *)
+ (Anormal, hlxp)]) in (* Lexp of the branch head *)
+ let nctx = DB.lexp_ctx_cons nctx (DB.dloc, None) Variable eqty in
+ conv_p' nctx (set_shift_n vs' (offset + 1)) e1 e2
+ ) (SMap.bindings cases1) (SMap.bindings cases2)
+ with
+ | Invalid_argument _ -> false (* If the lists have different length *)
+ )
+ && (match (def1, def2) with
+ | (Some (v1, e1), Some (v2, e2)) ->
+ (* FIXME should we compare the variable names ? *)
+ Log.log_debug "default";
+ let nctx = DB.lctx_extend ctx v1 Variable etype in
+ let subst = S.shift 1 in
+ let tlxp = mkSusp e1 subst in
+ let tltp = mkSusp etype subst in
+ let tlev = (match lexp_whnf (get_type nctx tltp) nctx with
+ | Sort (_, Stype l) -> l
+ | _ -> Log.log_error "HMMM"; DB.level0) in
+ let hlxp = mkVar ((DB.dloc, None), 0) in
+ let eqty = mkCall (DB.type_eq,
+ [(Aerasable, tlev); (* Typelevel *)
+ (Aerasable, tltp); (* Inductive type *)
+ (Anormal, tlxp); (* Target lexp *)
+ (Anormal, hlxp)]) in (* Lexp of the branch head *)
+ let nctx = DB.lexp_ctx_cons nctx (DB.dloc, None) Variable eqty in
+ conv_p' nctx (set_shift_n vs' 2) e1 e2
+ | None, None -> true
+ | _, _ -> false))
+ (* I'm not sure to understand how to compare two Metavar *
+ * Should I do a `lookup`? Or is it that simple: *)
+ (*| (Metavar (id1,_,_), Metavar (id2,_,_)) -> id1 = id2*)
+ (* FIXME: Various missing cases, such as Case. *)
+ | (_, _) -> false
+
+and conv_p (ctx : DB.lexp_context) e1 e2
= if e1 == e2 then true
else conv_p' ctx set_empty e1 e2
(********* Testing if a lexp is properly typed *********)
-let rec mkSLlub ctx e1 e2 =
+and mkSLlub ctx e1 e2 =
match (lexp_whnf e1 ctx, lexp_whnf e2 ctx) with
| (SortLevel SLz, _) -> e2
| (_, SortLevel SLz) -> e1
@@ -344,13 +469,7 @@ let rec mkSLlub ctx e1 e2 =
else if level_leq ce2 ce1 then e1
else mkSortLevel (mkSLlub' (e1, e2)) (* FIXME: Could be more canonical *)
-type sort_compose_result
- = SortResult of ltype
- | SortInvalid
- | SortK1NotType
- | SortK2NotType
-
-let sort_compose ctx1 ctx2 l ak k1 k2 =
+and sort_compose ctx1 ctx2 l ak k1 k2 =
(* BEWARE! Technically `k2` can refer to `v`, but this should only happen
* if `v` is a TypeLevel. *)
match (lexp_whnf k1 ctx1, lexp_whnf k2 ctx2) with
@@ -388,11 +507,11 @@ let sort_compose ctx1 ctx2 l ak k1 k2 =
| (Sort (_, _), _) -> SortK2NotType
| (_, _) -> SortK1NotType
-let dbset_push ak erased =
+and dbset_push ak erased =
let nerased = DB.set_sink 1 erased in
if ak = P.Aerasable then DB.set_set 0 nerased else nerased
-let nerased_let defs erased =
+and nerased_let defs erased =
(* Let bindings are not erasable, with the important exception of
* let-bindings of the form `x = y` where `y` is an erasable var.
* This exception is designed so that macros like `case` which need to
@@ -418,7 +537,7 @@ let nerased_let defs erased =
erased es
(* "check ctx e" should return τ when "Δ ⊢ e : τ" *)
-let rec check'' erased ctx e =
+and check'' erased ctx e =
let check = check'' in
let assert_type ctx e t t' =
if conv_p ctx t t' then ()
@@ -610,24 +729,38 @@ let rec check'' erased ctx e =
SMap.iter
(fun name (l, vdefs, branch)
-> let fieldtypes = SMap.find name constructors in
- let rec mkctx erased ctx s vdefs fieldtypes =
+ let rec mkctx erased ctx s hlxp vdefs fieldtypes =
match vdefs, fieldtypes with
- | [], [] -> (erased, ctx)
+ | [], [] -> (erased, ctx, hlxp)
(* FIXME: If ak is Aerasable, make sure the var only
* appears in type annotations. *)
| (ak, vdef)::vdefs, (ak', vdef', ftype)::fieldtypes
-> mkctx (dbset_push ak erased)
(DB.lexp_ctx_cons ctx vdef Variable (mkSusp ftype s))
- (S.cons (mkVar (vdef, 0))
- (S.mkShift s 1))
+ (ssink vdef s)
+ (mkCall (mkSusp hlxp (S.shift 1), [(ak, mkVar (vdef, 0))]))
vdefs fieldtypes
| _,_ -> (error_tc ~loc:l
"Wrong number of args to constructor!";
- (erased, ctx)) in
- let (nerased, nctx) = mkctx erased ctx s vdefs fieldtypes in
+ (erased, ctx, hlxp)) in
+ let hctor = mkCall (mkCons (it, (l, name)), aargs) in
+ let (nerased, nctx, hlxp) =
+ mkctx erased ctx s hctor vdefs fieldtypes in
+ (* Create Eq type between target and lexp matching the
+ branch head, and add it (erasable) to the context *)
+ let subst = S.shift (List.length vdefs) in
+ let tlxp = mkSusp e subst in
+ let tltp = mkSusp etype subst in
+ let eqty = mkCall (DB.type_eq,
+ [(Aerasable, DB.type0); (* Typelevel *) (* FIXME The real typelevel *)
+ (Aerasable, tltp); (* Inductive type *)
+ (Anormal, tlxp); (* Target lexp *)
+ (Anormal, hlxp)]) in (* Lexp of the branch head *)
+ let nerased = dbset_push Aerasable nerased in (* The eq proof is erasable *)
+ let nctx = DB.lexp_ctx_cons nctx (l, None) Variable eqty in
assert_type nctx branch
(check nerased nctx branch)
- (mkSusp ret (S.shift (List.length fieldtypes))))
+ (mkSusp ret (S.shift ((List.length fieldtypes) + 1))))
branches;
let diff = SMap.cardinal constructors - SMap.cardinal branches in
(match default with
@@ -635,8 +768,21 @@ let rec check'' erased ctx e =
-> if diff <= 0 then
warning_tc ~loc:l "Redundant default clause";
let nctx = (DB.lctx_extend ctx v (LetDef (0, e)) etype) in
- assert_type nctx d (check (DB.set_sink 1 erased) nctx d)
- (mkSusp ret (S.shift 1))
+ let nerased = DB.set_sink 1 erased in
+ let subst = S.shift 1 in
+ (* FIXME DRY this code *)
+ let tlxp = mkSusp e subst in
+ let tltp = mkSusp etype subst in
+ let hlxp = mkVar ((l, None), 0) in
+ let eqty = mkCall (DB.type_eq,
+ [(Aerasable, DB.type0); (* Typelevel *) (* FIXME The real typelevel *)
+ (Aerasable, tltp); (* Inductive type *)
+ (Anormal, tlxp); (* Target lexp *)
+ (Anormal, hlxp)]) in (* Lexp of the branch head *)
+ let nerased = dbset_push Aerasable nerased in (* The eq proof is erasable *)
+ let nctx = DB.lexp_ctx_cons nctx (l, None) Variable eqty in
+ assert_type nctx d (check nerased nctx d)
+ (mkSusp ret (S.shift 2))
| None
-> if diff > 0 then
error_tc ~loc:l ("Non-exhaustive match: "
@@ -682,24 +828,21 @@ let rec check'' erased ctx e =
check erased ctx e
| MVar (_, t, _) -> push_susp t s)
-let check' ctx e =
+and check' ctx e =
let res = check'' DB.set_empty ctx e in
(Log.stop_on_error (); res)
-let check = check'
+and check ctx e = check' ctx e
(** Compute the set of free (meta)variables. **)
-let rec list_union l1 l2 = match l1 with
+and list_union l1 l2 = match l1 with
| [] -> l2
| (x::l1) -> list_union l1 (if List.mem x l2 then l2 else (x::l2))
-type mv_set = (scope_level * ltype * ctx_length * vname) IMap.t
- (* Metavars that appear in non-erasable positions. *)
- * unit IMap.t
-let mv_set_empty : mv_set = (IMap.empty, IMap.empty)
-let mv_set_add (ms, nes) id x : mv_set = (IMap.add id x ms, IMap.add id () nes)
-let mv_set_union ((ms1, nes1) : mv_set) ((ms2, nes2) : mv_set) : mv_set
+and mv_set_empty : mv_set = (IMap.empty, IMap.empty)
+and mv_set_add (ms, nes) id x : mv_set = (IMap.add id x ms, IMap.add id () nes)
+and mv_set_union ((ms1, nes1) : mv_set) ((ms2, nes2) : mv_set) : mv_set
= (IMap.merge (fun _m oss1 oss2
-> match (oss1, oss2) with
| (None, _) -> oss2
@@ -715,23 +858,19 @@ let mv_set_union ((ms1, nes1) : mv_set) ((ms2, nes2) : mv_set) : mv_set
Some ss1)
ms1 ms2,
IMap.merge (fun _m _o1 _o2 -> Some ()) nes1 nes2)
-let mv_set_erase (ms, _nes) = (ms, IMap.empty)
+and mv_set_erase (ms, _nes) = (ms, IMap.empty)
-module LMap
- (* Memoization table. FIXME: Ideally the keys should be "weak", but
- * I haven't found any such functionality in OCaml's libs. *)
- = Hashtbl.Make
- (struct type t = lexp let hash = Hashtbl.hash let equal = (==) end)
-let fv_memo = LMap.create 1000
+and fv_memo = LMap.create 1000
+and fv_flush () = LMap.clear fv_memo
-let fv_empty = (DB.set_empty, mv_set_empty)
-let fv_union (fv1, mv1) (fv2, mv2)
+and fv_empty = (DB.set_empty, mv_set_empty)
+and fv_union (fv1, mv1) (fv2, mv2)
= (DB.set_union fv1 fv2, mv_set_union mv1 mv2)
-let fv_sink n (fvs, mvs) = (DB.set_sink n fvs, mvs)
-let fv_hoist n (fvs, mvs) = (DB.set_hoist n fvs, mvs)
-let fv_erase (fvs, mvs) = (fvs, mv_set_erase mvs)
+and fv_sink n (fvs, mvs) = (DB.set_sink n fvs, mvs)
+and fv_hoist n (fvs, mvs) = (DB.set_hoist n fvs, mvs)
+and fv_erase (fvs, mvs) = (fvs, mv_set_erase mvs)
-let rec fv (e : lexp) : (DB.set * mv_set) =
+and fv (e : lexp) : (DB.set * mv_set) =
let fv' e = match e with
| Imm _ -> fv_empty
| SortLevel SLz -> fv_empty
@@ -784,9 +923,9 @@ let rec fv (e : lexp) : (DB.set * mv_set) =
-> let s = fv_union (fv e) (fv_erase (fv t)) in
let s = match def with
| None -> s
- | Some (_, e) -> fv_union s (fv_hoist 1 (fv e)) in
+ | Some (_, e) -> fv_union s (fv_hoist 2 (fv e)) in
SMap.fold (fun _ (_, fields, e) s
- -> fv_union s (fv_hoist (List.length fields) (fv e)))
+ -> fv_union s (fv_hoist (List.length fields + 1) (fv e)))
cases s
| Metavar (id, s, name)
-> (match metavar_lookup id with
@@ -806,7 +945,7 @@ let rec fv (e : lexp) : (DB.set * mv_set) =
(** Finding the type of a expression. **)
(* This should never signal any warning/error. *)
-let rec get_type ctx e =
+and get_type ctx e =
match e with
| Imm (Float (_, _)) -> DB.type_float
| Imm (Integer (_, _)) -> DB.type_int
@@ -933,7 +1072,7 @@ let rec erase_type (lxp: L.lexp): E.elexp =
| L.Case(l, target, _, cases, default) ->
E.Case(l, (erase_type target), (clean_map cases),
- (clean_maybe default))
+ (clean_default default))
| L.Susp(l, s) -> erase_type (L.push_susp l s)
@@ -962,10 +1101,12 @@ and filter_arg_list lst =
and clean_decls decls =
List.map (fun (v, lxp, _) -> (v, (erase_type lxp))) decls
-and clean_maybe lxp =
- match lxp with
- | Some (v, lxp) -> Some (v, erase_type lxp)
- | None -> None
+and clean_default lxp =
+ match lxp with
+ | Some (v, lxp) ->
+ Some (v,
+ erase_type (L.push_susp lxp (S.substitute DB.type0)))
+ | None -> None
and clean_map cases =
let clean_arg_list lst =
@@ -979,7 +1120,8 @@ and clean_map cases =
clean_arg_list lst [] in
SMap.map (fun (l, args, expr)
- -> (l, (clean_arg_list args), (erase_type expr)))
+ -> (l, (clean_arg_list args),
+ erase_type (L.push_susp expr (S.substitute DB.type0))))
cases
(** Turning a set of declarations into an object. **)
=====================================
src/unification.ml
=====================================
@@ -46,6 +46,7 @@ let create_metavar (ctx : DB.lexp_context) (sl : scope_level) (t : ltype)
type constraint_kind =
| CKimpossible (* Unification is simply impossible. *)
| CKresidual (* We failed to find a unifier. *)
+ | CKassoc (* Couldn't associate because of checking mode *)
(* FIXME: Each constraint should additionally come with a description of how
it relates to its "top-level" or some other info which might let us
fix the problem (e.g. by introducing coercions). *)
@@ -54,8 +55,9 @@ type constraints = (constraint_kind * DB.lexp_context * lexp * lexp) list
type return_type = constraints
(** Alias for VMap.add*)
-let associate (id: meta_id) (lxp: lexp) (subst: meta_subst) : meta_subst
- = U.IMap.add id (MVal lxp) subst
+let associate (id: meta_id) (lxp: lexp) : unit
+ = metavar_table := U.IMap.add id (MVal lxp) (!metavar_table);
+ OL.fv_flush ()
let occurs_in (id: meta_id) (e : lexp) : bool = match metavar_lookup id with
| MVal _ -> Log.internal_error
@@ -174,13 +176,15 @@ let rec s_offset s = match s with
The metavar unifier is the end rule, it can't call unify with its parameter (changing their order)
*)
-let rec unify (e1: lexp) (e2: lexp)
+let rec unify ?checking
+ (e1: lexp) (e2: lexp)
(ctx : DB.lexp_context)
: return_type =
- unify' e1 e2 ctx OL.set_empty
+ unify' e1 e2 ctx OL.set_empty checking
and unify' (e1: lexp) (e2: lexp)
(ctx : DB.lexp_context) (vs : OL.set_plexp)
+ (c : scope_level option) (* checking mode scope level *)
: return_type =
if e1 == e2 then [] else
let e1' = OL.lexp_whnf e1 ctx in
@@ -190,20 +194,26 @@ and unify' (e1: lexp) (e2: lexp)
if changed && OL.set_member_p vs e1' e2' then [] else
let vs' = if changed then OL.set_add vs e1' e2' else vs in
match (e1', e2') with
- | ((Imm _, Imm _) | (Cons _, Cons _) | (Builtin _, Builtin _)
- | (Var _, Var _))
+ | ((Imm _, Imm _) | (Cons _, Cons _) | (Builtin _, Builtin _))
-> if OL.conv_p ctx e1' e2' then [] else [(CKimpossible, ctx, e1, e2)]
- | (l, (Metavar (idx, s, _) as r)) -> unify_metavar ctx idx s r l
- | ((Metavar (idx, s, _) as l), r) -> unify_metavar ctx idx s l r
- | (l, (Call _ as r)) -> unify_call r l ctx vs'
- (* | (l, (Case _ as r)) -> unify_case r l subst *)
- | (Arrow _ as l, r) -> unify_arrow l r ctx vs'
- | (Lambda _ as l, r) -> unify_lambda l r ctx vs'
- | (Call _ as l, r) -> unify_call l r ctx vs'
- (* | (Case _ as l, r) -> unify_case l r subst *)
- (* | (Inductive _ as l, r) -> unify_induct l r subst *)
- | (Sort _ as l, r) -> unify_sort l r ctx vs'
- | (SortLevel _ as l, r) -> unify_sortlvl l r ctx vs'
+ | (l, (Metavar (idx, s, _) as r)) -> unify_metavar c ctx idx s r l
+ | ((Metavar (idx, s, _) as l), r) -> unify_metavar c ctx idx s l r
+ | (l, (Call _ as r)) -> unify_call c r l ctx vs'
+ | ((Call _ as l), r) -> unify_call c l r ctx vs'
+ | (l, (Var _ as r)) -> unify_var r l ctx vs'
+ | ((Var _ as l), r) -> unify_var l r ctx vs'
+ | (l, (Arrow _ as r)) -> unify_arrow c r l ctx vs'
+ | ((Arrow _ as l), r) -> unify_arrow c l r ctx vs'
+ | (l, (Lambda _ as r)) -> unify_lambda c r l ctx vs'
+ | ((Lambda _ as l), r) -> unify_lambda c l r ctx vs'
+ (* | (l, (Case _ as r)) -> unify_case r l subst *)
+ (* | ((Case _ as l), r) -> unify_case l r subst *)
+ (* | (l, (Inductive _ as r)) -> unify_induct r l subst *)
+ (* | ((Inductive _ as l), r) -> unify_induct l r subst *)
+ | (l, (Sort _ as r)) -> unify_sort c r l ctx vs'
+ | ((Sort _ as l), r) -> unify_sort c l r ctx vs'
+ | (l, (SortLevel _ as r)) -> unify_sortlvl c r l ctx vs'
+ | ((SortLevel _ as l), r) -> unify_sortlvl c l r ctx vs'
| (Inductive (_loc1, label1, args1, consts1),
Inductive (_loc2, label2, args2, consts2))
-> (* print_string ("Unifying inductives "
@@ -211,7 +221,7 @@ and unify' (e1: lexp) (e2: lexp)
* ^ " and "
* ^ snd label2
* ^ "\n"); *)
- unify_inductive ctx vs' args1 args2 consts1 consts2 e1 e2
+ unify_inductive c ctx vs' args1 args2 consts1 consts2 e1 e2
| _ -> (if OL.conv_p ctx e1' e2' then []
else ((* print_string "Unification failure on default\n"; *)
[(CKresidual, ctx, e1, e2)]))
@@ -222,87 +232,77 @@ and unify' (e1: lexp) (e2: lexp)
- (Arrow, Arrow) -> if var_kind = var_kind
then unify ltype & lexp (Arrow (var_kind, _, ltype, lexp))
else None
- - (Arrow, Var) -> Constraint
- (_, _) -> None
*)
-and unify_arrow (arrow: lexp) (lxp: lexp) ctx vs
+and unify_arrow (checking : scope_level option) (arrow: lexp) (lxp: lexp) ctx vs
: return_type =
match (arrow, lxp) with
| (Arrow (var_kind1, v1, ltype1, _, lexp1),
Arrow (var_kind2, _, ltype2, _, lexp2))
-> if var_kind1 = var_kind2
- then (unify' ltype1 ltype2 ctx vs)
+ then (unify' ltype1 ltype2 ctx vs checking)
@(unify' lexp1 (srename v1 lexp2)
(DB.lexp_ctx_cons ctx v1 Variable ltype1)
- (OL.set_shift vs))
- else [(CKimpossible, ctx, arrow, lxp)]
- | (Arrow _, Imm _) -> [(CKimpossible, ctx, arrow, lxp)]
- | (Arrow _, Var _) -> ([(CKresidual, ctx, arrow, lxp)])
- | (Arrow _, _) -> unify' lxp arrow ctx vs
+ (OL.set_shift vs) checking)
+ else [(CKimpossible, ctx, arrow, lxp)]
| (_, _) -> [(CKimpossible, ctx, arrow, lxp)]
(** Unify a Lambda and a lexp if possible
- - Lamda , Lambda -> if var_kind = var_kind
+ - Lambda , Lambda -> if var_kind = var_kind
then UNIFY ltype & lxp else ERROR
- - Lambda , Var -> CONSTRAINT
- - Lambda , Call -> Constraint
- - Lambda , Let -> Constraint
- - Lambda , lexp -> unify lexp lambda subst
+ - Lambda , _ -> Impossible
*)
-and unify_lambda (lambda: lexp) (lxp: lexp) ctx vs : return_type =
+and unify_lambda (checking : scope_level option) (lambda: lexp) (lxp: lexp) ctx vs : return_type =
match (lambda, lxp) with
| (Lambda (var_kind1, v1, ltype1, lexp1),
Lambda (var_kind2, _, ltype2, lexp2))
-> if var_kind1 = var_kind2
- then (unify' ltype1 ltype2 ctx vs)
+ then (unify' ltype1 ltype2 ctx vs checking)
@(unify' lexp1 lexp2
(DB.lexp_ctx_cons ctx v1 Variable ltype1)
- (OL.set_shift vs))
+ (OL.set_shift vs) checking)
else [(CKimpossible, ctx, lambda, lxp)]
- | ((Lambda _, Var _)
- | (Lambda _, Let _)
- | (Lambda _, Call _)) -> [(CKresidual, ctx, lambda, lxp)]
- | (Lambda _, Arrow _)
- | (Lambda _, Imm _) -> [(CKimpossible, ctx, lambda, lxp)]
- | (Lambda _, _) -> unify' lxp lambda ctx vs
- | (_, _) -> [(CKimpossible, ctx, lambda, lxp)]
+ | (_, _) -> [(CKimpossible, ctx, lambda, lxp)]
(** Unify a Metavar and a lexp if possible
- - lexp , {metavar <-> none} -> UNIFY
- - lexp , {metavar <-> lexp} -> UNFIFY lexp subst[metavar]
- - metavar , metavar -> if Metavar = Metavar then OK else ERROR
- - metavar , lexp -> OK
+ - metavar , metavar -> if Metavar = Metavar then intersect
+ - metavar , metavar -> inverse subst (both sides)
+ - metavar , lexp -> inverse subst
*)
-and unify_metavar ctx idx s1 (lxp1: lexp) (lxp2: lexp)
+and unify_metavar (checking : scope_level option) ctx idx s1 (lxp1: lexp) (lxp2: lexp)
: return_type =
let unif idx s lxp =
- let t = match metavar_lookup idx with
+ let t, sl = match metavar_lookup idx with
| MVal _ -> Log.internal_error
"`lexp_whnf` returned an instantiated metavar!!"
- | MVar (_, t, _) -> push_susp t s in
+ | MVar (_, t, sl) -> push_susp t s, sl in
match Inverse_subst.apply_inv_subst lxp s with
| exception Inverse_subst.Not_invertible
- -> log_info ?loc:None ("Unification of metavar failed:\n "
- ^ "?[" ^ subst_string s ^ "]"
- ^ "\nAgainst:\n "
- ^ lexp_string lxp ^ "\n");
+ -> log_info ~loc:(lexp_location lxp)
+ ("Unification of metavar failed:\n "
+ ^ "?[" ^ subst_string s ^ "]"
+ ^ "\nAgainst:\n "
+ ^ lexp_string lxp ^ "\n");
[(CKresidual, ctx, lxp1, lxp2)]
| lxp' when occurs_in idx lxp' -> [(CKimpossible, ctx, lxp1, lxp2)]
| lxp'
- -> metavar_table := associate idx lxp' (!metavar_table);
- match unify t (OL.get_type ctx lxp) ctx with
- | [] as r -> r
- (* FIXME: Let's ignore the error for now. *)
- | _
- -> log_info ?loc:None
- ("Unification of metavar type failed:\n "
- ^ lexp_string t ^ " != "
- ^ lexp_string (OL.get_type ctx lxp)
- ^ "\n" ^ "for " ^ lexp_string lxp ^ "\n");
- [(CKresidual, ctx, lxp1, lxp2)] in
+ -> match checking with
+ | Some l when l >= sl -> [(CKassoc, ctx, lxp1, lxp2)]
+ | _ -> (
+ associate idx lxp';
+ match unify t (OL.get_type ctx lxp) ctx with
+ | [] as r -> r
+ (* FIXME: Let's ignore the error for now. *)
+ | _
+ -> log_info ?loc:None
+ ("Unification of metavar type failed:\n "
+ ^ lexp_string t ^ " != "
+ ^ lexp_string (OL.get_type ctx lxp)
+ ^ "\n" ^ "for " ^ lexp_string lxp ^ "\n");
+ [(CKresidual, ctx, lxp1, lxp2)]) in
match lxp2 with
| Metavar (idx2, s2, name)
- -> if idx = idx2 then
+ -> if idx = idx2 && checking == None then
match common_subset ctx s1 s2 with
| S.Identity 0 -> [] (* Optimization! *)
(* ¡ s1 != s2 !
@@ -353,7 +353,7 @@ and unify_metavar ctx idx s1 (lxp1: lexp) (lxp2: lexp)
* ^ "\n =\n "
* ^ subst_string (scompose s s2)
* ^ "\n"); *)
- metavar_table := associate idx lexp (!metavar_table);
+ associate idx lexp;
assert (OL.conv_p ctx lxp1 lxp2);
[]
else
@@ -364,18 +364,28 @@ and unify_metavar ctx idx s1 (lxp1: lexp) (lxp2: lexp)
| _ -> unif idx2 s2 lxp1)
| _ -> unif idx s1 lxp2
+(** Unify a Var (var) and a lexp (lxp)
+ - Var , Var -> IF same var THEN ok ELSE constraint
+ - Var , lexp -> Constraint
+*)
+and unify_var (var: lexp) (lxp: lexp) ctx vs
+ : return_type =
+ match (var, lxp) with
+ | (Var _, Var _) when OL.conv_p ctx var lxp -> []
+ | (_, _) -> [(CKresidual, ctx, var, lxp)]
+
(** Unify a Call (call) and a lexp (lxp)
- Call , Call -> UNIFY
- Call , lexp -> CONSTRAINT
*)
-and unify_call (call: lexp) (lxp: lexp) ctx vs
+and unify_call (checking : scope_level option) (call: lexp) (lxp: lexp) ctx vs
: return_type =
match (call, lxp) with
| (Call (lxp_left, lxp_list1), Call (lxp_right, lxp_list2))
when OL.conv_p ctx lxp_left lxp_right
-> List.fold_left (fun op ((ak1, e1), (ak2, e2))
-> if ak1 == ak2 then
- (unify' e1 e2 ctx vs)@op
+ (unify' e1 e2 ctx vs checking)@op
else [(CKimpossible, ctx, call, lxp)])
[]
(List.combine lxp_list1 lxp_list2)
@@ -438,31 +448,29 @@ and unify_call (call: lexp) (lxp: lexp) ctx vs
- SortLevel, SortLevel -> if SortLevel ~= SortLevel then OK else ERROR
- SortLevel, _ -> ERROR
*)
-and unify_sortlvl (sortlvl: lexp) (lxp: lexp) ctx vs : return_type =
+and unify_sortlvl (checking : scope_level option) (sortlvl: lexp) (lxp: lexp) ctx vs : return_type =
match sortlvl, lxp with
| (SortLevel s, SortLevel s2) -> (match s, s2 with
| SLz, SLz -> []
- | SLsucc l1, SLsucc l2 -> unify' l1 l2 ctx vs
+ | SLsucc l1, SLsucc l2 -> unify' l1 l2 ctx vs checking
| SLlub (l11, l12), SLlub (l21, l22)
-> (* FIXME: This SLlub representation needs to be
* more "canonicalized" otherwise it's too restrictive! *)
- (unify' l11 l21 ctx vs)@(unify' l12 l22 ctx vs)
+ (unify' l11 l21 ctx vs checking)@(unify' l12 l22 ctx vs checking)
| _, _ -> [(CKimpossible, ctx, sortlvl, lxp)])
| _, _ -> [(CKresidual, ctx, sortlvl, lxp)]
(** Unify a Sort and a lexp
- Sort, Sort -> if Sort ~= Sort then OK else ERROR
- - Sort, Var -> Constraint
- Sort, lexp -> ERROR
*)
-and unify_sort (sort_: lexp) (lxp: lexp) ctx vs : return_type =
+and unify_sort (checking : scope_level option) (sort_: lexp) (lxp: lexp) ctx vs : return_type =
match sort_, lxp with
| (Sort (_, srt), Sort (_, srt2)) -> (match srt, srt2 with
- | Stype lxp1, Stype lxp2 -> unify' lxp1 lxp2 ctx vs
+ | Stype lxp1, Stype lxp2 -> unify' lxp1 lxp2 ctx vs checking
| StypeOmega, StypeOmega -> []
| StypeLevel, StypeLevel -> []
| _, _ -> [(CKimpossible, ctx, sort_, lxp)])
- | Sort _, Var _ -> [(CKresidual, ctx, sort_, lxp)]
| _, _ -> [(CKimpossible, ctx, sort_, lxp)]
(************************ Helper function ************************************)
@@ -513,7 +521,7 @@ and is_same arglist arglist2 =
* | None -> test e subst)
* ) None lst *)
-and unify_inductive ctx vs args1 args2 consts1 consts2 e1 e2 =
+and unify_inductive (checking : scope_level option) ctx vs args1 args2 consts1 consts2 e1 e2 =
let unif_formals ctx vs args1 args2
= if not (List.length args1 == List.length args2) then
(ctx, vs, [(CKimpossible, ctx, e1, e2)])
@@ -522,7 +530,7 @@ and unify_inductive ctx vs args1 args2 consts1 consts2 e1 e2 =
-> (DB.lexp_ctx_cons ctx v1 Variable t1,
OL.set_shift vs,
if not (ak1 == ak2) then [(CKimpossible, ctx, e1, e2)]
- else (unify' t1 t2 ctx vs) @ residue))
+ else (unify' t1 t2 ctx vs checking) @ residue))
(ctx, vs, [])
(List.combine args1 args2) in
let (ctx, vs, residue) = unif_formals ctx vs args1 args2 in
=====================================
tests/elab_test.ml
=====================================
@@ -51,8 +51,21 @@ let generate_tests (name: string)
(test input_gen fmt tester)
(* let input = "y = lambda x -> x + 1;" *)
-let input = "id = lambda (α : Type) ≡> lambda (x : α) -> x;
-res = id 3;"
+let inputs =
+ [("identity", {|
+id = lambda (α : Type) ≡> lambda (x : α) -> x;
+res = id 3;
+ |});
+ ("whnf of case", {|
+Box = (typecons (Box (l : TypeLevel) (t : Type_ l)) (box t));
+box = (datacons Box box);
+unbox b = ##case_ (b | box inside => inside);
+
+%% unbox twice to compute something in a branch
+example : unbox (unbox (box (box Bool)));
+example = true;
+ |});
+ ]
let generate_lexp_from_str str =
List.hd ((fun (lst, _) ->
@@ -63,9 +76,22 @@ let generate_lexp_from_str str =
let _ = generate_tests
"TYPECHECK"
- (fun () -> [generate_lexp_from_str input])
- (fun x -> List.map lexp_string x)
- (fun x -> (x, true))
+ (fun () -> inputs)
+ (fun x -> x)
+ (fun (name, input) ->
+ let result =
+ try
+ let ectx = Elab.default_ectx in
+ let pres = Prelexer.prelex_string input in
+ let sxps = Lexer.lex Grammar.default_stt pres in
+ let _lxps, _ectx = Elab.lexp_p_decls [] sxps ectx in
+ Log.stop_on_error();
+ true
+ with
+ | Log.Stop_Compilation _ -> (Log.print_and_clear_log (); false)
+ | Log.Internal_error _ -> (Log.print_and_clear_log (); false) in
+ (name, result)
+ )
let lctx = Elab.default_ectx
(* let _ = (add_test "TYPECHEK_LEXP" "lexp_print" (fun () ->
=====================================
tests/unify_test.ml
=====================================
@@ -199,6 +199,7 @@ let test_input (lxp1: lexp) (lxp2: lexp): unif_res =
else (Unification, res, lxp1, lxp2)
| (CKresidual, _, _, _)::_ -> (Constraint, res, lxp1, lxp2)
| (CKimpossible, _, _, _)::_ -> (Nothing, res, lxp1, lxp2)
+ | _ -> failwith "impossible"
let check (lxp1: lexp) (lxp2: lexp) (res: result): bool =
let r, _, _, _ = test_input lxp1 lxp2
View it on GitLab: https://gitlab.com/monnier/typer/-/compare/e68491a11f17e63d891831b8c6cbe037…
--
View it on GitLab: https://gitlab.com/monnier/typer/-/compare/e68491a11f17e63d891831b8c6cbe037…
You're receiving this email because of your account on gitlab.com.
1
0
[Git][monnier/typer][ja-barszcz] 25 commits: Apply the instanciated metavariable substs when displaying lexps
by Jean-Alexandre Barszcz 20 Aoû '20
by Jean-Alexandre Barszcz 20 Aoû '20
20 Aoû '20
Jean-Alexandre Barszcz pushed to branch ja-barszcz at Stefan / Typer
Commits:
278423a1 by Jean-Alexandre Barszcz at 2020-08-20T14:20:35-04:00
Apply the instanciated metavariable substs when displaying lexps
- - - - -
1770ced6 by Jean-Alexandre Barszcz at 2020-08-20T14:37:48-04:00
Replace instantiated metavars when checking syntactic equality
- - - - -
a8bdf2b4 by Jean-Alexandre Barszcz at 2020-08-20T14:39:20-04:00
[WIP] Make unification symmetric
- - - - -
405f6925 by Jean-Alexandre Barszcz at 2020-08-20T14:39:20-04:00
[WIP] Handle variables earlier during unification
- - - - -
40d5961b by Jean-Alexandre Barszcz at 2020-08-20T14:39:20-04:00
[WIP] experiments with Decidable and proofs
- - - - -
7481b309 by Jean-Alexandre Barszcz at 2020-08-20T14:39:20-04:00
[WIP] unify instead of conv_p in sform_lambda
- - - - -
cad463b7 by Jean-Alexandre Barszcz at 2020-08-20T14:39:20-04:00
[WIP] proof of Decidable (a < b)
- - - - -
cef036d4 by Jean-Alexandre Barszcz at 2020-08-20T14:39:20-04:00
[WIP] First draft of an instance search algorithm
- - - - -
c1a49f21 by Jean-Alexandre Barszcz at 2020-08-20T14:39:20-04:00
WIP WIP WIP
- - - - -
4a835061 by Jean-Alexandre Barszcz at 2020-08-20T14:39:20-04:00
WIP WIP getting there
- - - - -
c15acaf2 by Jean-Alexandre Barszcz at 2020-08-20T14:39:20-04:00
[WIP] Add a set of typeclasses to the elab context
- - - - -
e94b31ac by Jean-Alexandre Barszcz at 2020-08-20T14:39:20-04:00
[WIP] Add a syntax for records
- - - - -
0430966d by Jean-Alexandre Barszcz at 2020-08-20T14:39:20-04:00
[WIP] Extend the Decidable sample with conjunction (dep on records)
- - - - -
cb75ce9a by Jean-Alexandre Barszcz at 2020-08-20T14:39:20-04:00
Resolve instances in the REPL (since exprs. are not generalized)
- - - - -
e25097c0 by Jean-Alexandre Barszcz at 2020-08-20T14:39:20-04:00
Resolve instances for recursive definitions
- - - - -
71c459d5 by Jean-Alexandre Barszcz at 2020-08-20T14:39:20-04:00
[WIP] Do the set_getenv
IIRC these were missing to correctly handle the elab context for macro
expansion and Elab_... primitives. Perhaps it would be simpler to call
set_getenv once before macro expansion rather than everywhere where
the context can change. Needs some experimentation and tests.
- - - - -
62ffe0bb by Jean-Alexandre Barszcz at 2020-08-20T14:39:20-04:00
Num class example
- - - - -
855c9dba by Jean-Alexandre Barszcz at 2020-08-20T14:39:20-04:00
Num class (with records)
- - - - -
e794d500 by Jean-Alexandre Barszcz at 2020-08-20T14:39:20-04:00
Allow non-inductives to be typeclasses (Eq for instance)
- - - - -
efd0be65 by Jean-Alexandre Barszcz at 2020-08-20T14:39:20-04:00
Move the Eq builtin to debruijn.ml to make it available for elab.
- - - - -
277c643f by Jean-Alexandre Barszcz at 2020-08-20T14:39:20-04:00
Make Eq.refl available to the ocaml code
* src/debruijn.ml : Add a definition of the lexp for Eq.refl
* src/builtin.ml : Register the constant Eq.refl
* btl/builtins.typer (Eq_refl) : Use the builtin variable ##Eq.refl
instead of registering the builtin with the `Built-in` form. This
ensures that we have the right variable and type, and might help to
keep things in sync between the ocaml and typer code.
- - - - -
1bddfa4b by Jean-Alexandre Barszcz at 2020-08-20T14:39:20-04:00
[WIP] Add Eq to case
- - - - -
8d64941d by Jean-Alexandre Barszcz at 2020-08-20T14:39:20-04:00
[WIP] Adding Eq to Case: mutual rec for (whnf & get_type) + conv_p of case?
- - - - -
e1ecbe47 by Jean-Alexandre Barszcz at 2020-08-20T14:39:20-04:00
[WIP] Fix whnf of case??
TODO test and explain the problem
- - - - -
e68491a1 by Jean-Alexandre Barszcz at 2020-08-20T14:39:20-04:00
Algebra classes sample with proof of associativity of +
- - - - -
20 changed files:
- btl/builtins.typer
- btl/pervasive.typer
- + btl/records.typer
- + samples/alg_classes.typer
- + samples/decidable.typer
- + samples/num_class.typer
- + samples/num_class_recs.typer
- src/REPL.ml
- src/builtin.ml
- src/debruijn.ml
- src/elab.ml
- src/eval.ml
- + src/instances.ml
- src/inverse_subst.ml
- src/lexp.ml
- src/log.ml
- src/myers.ml
- src/opslexp.ml
- src/unification.ml
- tests/unify_test.ml
Changes:
=====================================
btl/builtins.typer
=====================================
@@ -48,7 +48,7 @@ Void = typecons Void;
%% Eq : (l : TypeLevel) ≡> (t : Type_ l) ≡> t -> t -> Type_ l
%% Eq' : (l : TypeLevel) ≡> Type_ l -> Type_ l -> Type_ l
Eq_refl : ((x : ?t) ≡> Eq x x);
-Eq_refl = Built-in "Eq.refl";
+Eq_refl = ##Eq\.refl;
Eq_cast : (x : ?) ≡> (y : ?)
≡> (p : Eq x y)
@@ -363,6 +363,12 @@ Elab_isbound = Built-in "Elab.isbound" : String -> Elab_Context -> Bool;
Elab_isconstructor = Built-in "Elab.isconstructor"
: String -> Elab_Context -> Bool;
+%%
+%% Check if a symbol is an inductive in a particular context
+%%
+Elab_isinductive = Built-in "Elab.isinductive"
+ : String -> Elab_Context -> Bool;
+
%%
%% Check if the n'th field of a constructor is erasable
%% If the constructor isn't defined it will always return false
@@ -389,6 +395,20 @@ Elab_nth-arg' = Built-in "Elab.nth-arg" : String -> Int -> Elab_Context -> Strin
%%
Elab_arg-pos' = Built-in "Elab.arg-pos" : String -> String -> Elab_Context -> Int;
+%%
+%% Get the position of a field in a constructor
+%% It return -1 in case the field isn't defined
+%% see pervasive.typer for a more convenient function
+%%
+Elab_ind-ctor-arg-pos' = Built-in "Elab.ind-ctor-arg-pos" : String -> String -> String -> Elab_Context -> Int;
+
+%%
+%% Get the number of fields in a constructor
+%% It return -1 in case the field isn't defined
+%% see pervasive.typer for a more convenient function
+%%
+Elab_count-ctor-args' = Built-in "Elab.count-ctor-args" : String -> String -> Elab_Context -> Int;
+
%%
%% Get the docstring associated with a symbol
%%
=====================================
btl/pervasive.typer
=====================================
@@ -394,7 +394,7 @@ BoolMod = (##datacons
Pair = typecons (Pair (a : Type) (b : Type)) (pair (fst : a) (snd : b));
pair = datacons Pair pair;
-__\.__ =
+dot-impl =
let mksel o f =
let constructor = Sexp_node (Sexp_symbol "##datacons")
(cons (Sexp_symbol "?")
@@ -411,14 +411,15 @@ __\.__ =
(cons (Sexp_node (Sexp_symbol "_|_")
(cons o (cons branch nil)))
nil)
- in macro (lambda args
- -> IO_return
- case args
- | cons o tail
- => (case tail
- | cons f _ => mksel o f
- | nil => Sexp_error)
- | nil => Sexp_error);
+ in (lambda args ->
+ IO_return case args
+ | cons o tail
+ => (case tail
+ | cons f _ => mksel o f
+ | nil => Sexp_error)
+ | nil => Sexp_error);
+
+__\.__ = macro dot-impl;
%% Triplet (tuple with 3 values)
type Triplet (a : Type) (b : Type) (c : Type)
@@ -458,7 +459,8 @@ Not prop = prop -> False;
%% We don't use the `type` macro here because it would make these `true`
%% and `false` constructors override `Bool`'s, and we currently don't
%% want that.
-Decidable = typecons (Decidable (prop : Type_ ?ℓ))
+%% FIXME generalize typecons formal arguments
+Decidable = typecons (Decidable (ℓ ::: TypeLevel) (prop : Type_ ℓ))
(true (p ::: prop)) (false (p ::: Not prop));
%% Testing generalization in inductive type constructors.
@@ -547,6 +549,32 @@ in case (Int_eq r (-1))
| true => (none)
| false => (some r);
+%%
+%% If `Elab_ind-ctor-arg-pos'` returns (-1) it means:
+%% A- The constructor isn't defined, or
+%% B- The constructor has no argument named like this
+%%
+%% So in those case this function returns `none`
+%%
+Elab_ind-ctor-arg-pos a b c d = let
+ r = Elab_ind-ctor-arg-pos' a b c d;
+in case (Int_eq r (-1))
+ | true => (none)
+ | false => (some r);
+
+%%
+%% If `Elab_count-ctor-args'` returns (-1) it means:
+%% A- The constructor isn't defined, or
+%% B- The constructor has no argument named like this
+%%
+%% So in those case this function returns `none`
+%%
+Elab_count-ctor-args a b c = let
+ r = Elab_count-ctor-args' a b c;
+in case (Int_eq r (-1))
+ | true => (none)
+ | false => (some r);
+
%%%%
%%%% Common library
%%%%
@@ -634,6 +662,15 @@ plain-let_in_ = let lib = load "btl/plain-let.typer" in lib.plain-let-macro;
%%
_|_ = let lib = load "btl/polyfun.typer" in lib._|_;
+%%
+%% records : a simple datatype when there is only one case
+%%
+define-operator "#" 200 ();
+records = load "btl/records.typer";
+record = records.record;
+__\.__ = records.__\.__;
+_# = records._#;
+
%%%% Unit tests function for doing file
%% It's hard to do a primitive which execute test file
=====================================
btl/records.typer
=====================================
@@ -0,0 +1,82 @@
+record-impl : List Sexp -> IO Sexp;
+record-impl args =
+ let
+ %% Get a name (symbol) from a sexp
+ %% - (name t) -> name
+ %% - name -> name
+ get-name : Sexp -> Sexp;
+ get-name sxp =
+ case Sexp_wrap sxp
+ | node op _ => get-name op
+ | symbol _ => sxp
+ | _ => Sexp_error;
+
+ %% head is (Sexp_node type-name (arg list))
+ name-args = List_head Sexp_error args;
+ fields = List_tail args;
+
+ type-name = get-name name-args;
+
+ %% Create the inductive type definition.
+ inductive = Sexp_node (Sexp_symbol "typecons")
+ (cons name-args
+ (cons (Sexp_node (Sexp_symbol "rec") fields)
+ nil));
+
+ decl = make-decl type-name inductive;
+
+ in IO_return decl;
+
+record = macro record-impl;
+
+record-get-impl : List Sexp -> IO Sexp;
+record-get-impl args =
+ let
+ get tc f idx nargs ectx =
+ let arg_pats : Sexp -> Int -> Int -> List Sexp;
+ arg_pats s i n =
+ if (Int_eq n 0) then nil
+ else (if (Int_eq i 0)
+ then (cons s (arg_pats s (i - 1) (n - 1)))
+ else (cons (Sexp_symbol "_") (arg_pats s (i - 1) (n - 1))));
+
+ pat = (Sexp_node (quote (datacons (uquote (Sexp_symbol tc)) rec))
+ (arg_pats (Sexp_symbol "v") idx nargs));
+
+ branch = (quote ((uquote pat) => v));
+ in
+ (quote (lambda rec -> (##case_ (_|_ rec (uquote branch)))));
+
+ try-rec-get : List Sexp -> Elab_Context -> Option Sexp;
+ try-rec-get arg ectx =
+ case args
+ | (cons tc (cons f nil)) =>
+ (case (Sexp_wrap tc, Sexp_wrap f)
+ | (symbol tcstr, symbol fstr) =>
+ (case (Elab_count-ctor-args tcstr "rec" ectx,
+ Elab_ind-ctor-arg-pos tcstr "rec" fstr ectx)
+ | (some nargs, some idx) => some (get tcstr fstr idx nargs ectx)
+ | _ => none)
+ | _ => none)
+ | _ => none;
+ in
+ do {
+ ectx <- Elab_getenv ();
+ case try-rec-get args ectx
+ | some sxp => IO_return sxp
+ | _ => dot-impl args; %% Fallback on default dot implementation
+ };
+
+__\.__ = macro record-get-impl;
+
+record-make-impl : List Sexp -> IO Sexp;
+record-make-impl args =
+ IO_return case args
+ | (cons tc nil) => (quote (datacons (uquote tc) rec))
+ | _ => Sexp_error;
+
+_# = macro record-make-impl; %% I was going for a syntax close to
+ %% Erlang's, but the # doesn't separate
+ %% tokens ... Meh.
+
+record (Pair (a : Type) (b : Type)) (fst : a) (snd : a);
=====================================
samples/alg_classes.typer
=====================================
@@ -0,0 +1,84 @@
+case_ = ##case_; %% To ease debugging
+
+type Magma (α : Type)
+ | mkMagma (op : α -> α -> α);
+
+typeclass Magma;
+
+magma_op =
+ lambda magma_inst =>
+ case magma_inst
+ | mkMagma op => op;
+
+Associativity (op : ?α -> ?α -> ?α) =
+ (x : ?α) -> (y : ?α) -> (z : ?α) -> Eq (op (op x y) z) (op x (op y z));
+
+type Semigroup (α : Type)
+ | mkSemigroup (magma : Magma α) (assoc ::: Associativity magma_op);
+
+typeclass Semigroup;
+
+semigroup_magma =
+ lambda semigroup_inst =>
+ case semigroup_inst
+ | mkSemigroup magma => magma;
+
+IsLeftIdentity (id : ?α) (op : ?α -> ?α -> ?α) =
+ (x : ?α) -> Eq (op id x) x;
+
+IsRightIdentity (id : ?α) (op : ?α -> ?α -> ?α) =
+ (x : ?α) -> Eq (op x id) x;
+
+IsIdentity (id : ?α) (op : ?α -> ?α -> ?α) =
+ (Pair (IsLeftIdentity id op) (IsRightIdentity id op));
+
+type Monoid (α : Type)
+ | mkMonoid (semigroup : Semigroup α)
+ (identity : α)
+ (isIdent ::: IsIdentity identity magma_op);
+
+typeclass Monoid;
+
+type Nat
+ | Zero
+ | Succ Nat;
+
+plus : Nat -> Nat -> Nat;
+plus x y =
+ case x
+ | Zero => y
+ | Succ x' => Succ (plus x' y);
+
+natAdditiveMagma =
+ mkMagma plus;
+
+Eq_cong : % not sure about levels here
+ (t : (Type_ ?ℓ)) ≡> (r : (Type_ ?ℓ)) ≡>
+ (x : t) ≡> (y : t) ≡> (p : (Eq x y)) ≡>
+ (f : (t -> r)) -> (Eq (f x) (f y));
+Eq_cong f =
+ Eq_cast (p := p) (f := lambda xy -> Eq (f x) (f xy)) Eq_refl;
+
+natPlusAssoc : Associativity plus;
+natPlusAssoc x y z =
+ let
+ typeclass Eq
+ in
+ case x
+ | Zero => Eq_cast
+ (x := Zero)
+ (y := x)
+ (p := Eq_comm (instance ()))
+ (f := (lambda (Zx : Nat) -> Eq (plus (plus Zx y) z) (plus Zx (plus y z))))
+ Eq_refl
+ | Succ x' =>
+ Eq_cast
+ (x := Succ x')
+ (y := x)
+ (p := Eq_comm (instance ()))
+ (f := (lambda (sx'x : Nat) -> Eq (plus (plus sx'x y) z) (plus sx'x (plus y z))))
+ (Eq_cong (p := natPlusAssoc x' y z) Succ);
+
+natAdditiveSemigroup : Semigroup Nat;
+natAdditiveSemigroup =
+ mkSemigroup natAdditiveMagma (assoc := natPlusAssoc);
=====================================
samples/decidable.typer
=====================================
@@ -0,0 +1,168 @@
+False = Void;
+True = Unit;
+
+% FIXME improved "case" fails with no branches
+exfalso : False -> ?a;
+exfalso f = ##case_ f;
+
+%type Decidable (prop : Type)
+% | yes (p ::: prop)
+% | no (p ::: Not prop);
+yes = datacons Decidable true;
+no = datacons Decidable false;
+
+typeclass Decidable;
+
+Eq_trans :
+ (x : ?t) => (y : ?t) => (a : ?t) ->
+ (ax : Eq a x) => (ay : Eq a y) => Eq x y;
+Eq_trans a =
+ lambda (ax : Eq a x) (ay : Eq a y) =>
+ Eq_cast (f := lambda ax -> Eq ax y) ay;
+
+Eq_cong : % not sure about levels here
+ (t : (Type_ ?ℓ)) ≡> (r : (Type_ ?ℓ)) ≡>
+ (x : t) ≡> (y : t) ≡> (p : (Eq x y)) ≡>
+ (f : (t -> r)) -> (Eq (f x) (f y));
+Eq_cong f =
+ Eq_cast (p := p) (f := lambda xy -> Eq (f x) (f xy)) Eq_refl;
+
+discriminate_nocheck =
+ macro (lambda args ->
+ case args
+ | cons x (cons y nil) =>
+ do {
+ sd <- gensym ();
+ sp <- gensym ();
+ IO_return
+ (quote ((lambda (uquote sp) ->
+ (Eq_cast (p := (uquote sp))
+ (f := (lambda (uquote sd) ->
+ (case uquote sd
+ | (uquote x) => True
+ | _ => False)))
+ ())) : Not (Eq (uquote x) (uquote y))))
+ }
+ | _ => IO_return Sexp_error);
+
+discriminate =
+ macro (lambda args ->
+ case args
+ | cons x (cons y nil) =>
+ (case (Sexp_wrap x, Sexp_wrap y)
+ | (symbol sx, symbol sy) => % FIXME get the constructor even when its a call
+ do {
+ env <- Elab_getenv ();
+ if (and (Elab_isconstructor sx env)
+ (and (Elab_isconstructor sy env)
+ (not (Sexp_eq x y))))
+ then
+ Macro_expand discriminate_nocheck args
+ else (IO_return Sexp_error)
+ }
+ | _ => IO_return Sexp_error)
+ | _ => IO_return Sexp_error);
+
+test : (Not (Eq true false));
+test = discriminate true false;
+
+absurd =
+ lambda (p : ?prop) ->
+ lambda (contra : (Not ?prop)) ->
+ contra p;
+
+% We can't (usefully) have a `Decidable Bool` because it's
+% impossible to have a `Not Bool`. Instead, we can decide boolean
+% equality:
+
+decideBoolEq : (a : Bool) => (b : Bool) => Decidable (Eq a b);
+decideBoolEq =
+ lambda (a : Bool) (b : Bool) =>
+ case (a, b)
+ | (false, false) => yes (p := Eq_trans false)
+ | (false, true) => no (p := lambda (p : Eq a b) ->
+ absurd (Eq_trans (ax := Eq_trans a) b) (discriminate false true))
+ | (true, false) => no (p := lambda (p : Eq a b) ->
+ absurd (Eq_trans (ax := Eq_trans a) b) (discriminate true false))
+ | (true, true) => yes (p := Eq_trans true);
+
+type Nat
+ | zero
+ | succ Nat;
+
+type even (a : Nat)
+ | eZ (p ::: Eq a zero)
+ | eSS (p :: even ?a) (pss ::: Eq a (succ (succ ?a)));
+
+decideEven : (a : Nat) => Decidable (even a);
+decideEven =
+ lambda (a : Nat) =>
+ case a
+ | zero => yes (p := eZ)
+ | succ zero => no (p :=
+ lambda (p : even a) ->
+ case p
+ | eZ => absurd (Eq_trans a) (discriminate_nocheck zero (succ zero))
+ | eSS => absurd (Eq_trans a) (discriminate_nocheck (succ (succ ?)) (succ zero)))
+ | succ (succ a') =>
+ case (decideEven : Decidable (even a'))
+ | yes => yes (p := eSS)
+ | no => no (p :=
+ lambda (p : even a) ->
+ case p
+ | eZ => absurd (Eq_trans a) (discriminate_nocheck zero (succ (succ ?)))
+ | eSS => absurd (? : even a') (? : Not (even a')));
+
+type _<_ (a : Nat) (b : Nat)
+ | ltZ (pa ::: Eq a zero) (pb ::: Eq b (succ ?b))
+ | ltS (p :: (?a < ?b)) (pa ::: Eq a (succ ?a)) (pb ::: Eq b (succ ?b));
+
+decideLT : (a : Nat) => (b : Nat) => Decidable (a < b);
+decideLT =
+ lambda a b =>
+ case b
+ | zero => no (p :=
+ lambda (p : (a < b)) ->
+ case p
+ | ltZ => absurd (Eq_trans b) (discriminate_nocheck zero (succ ?))
+ | ltS => absurd (Eq_trans b) (discriminate_nocheck zero (succ ?)))
+ | succ b' =>
+ case a
+ | zero => yes (p := ltZ)
+ | succ a' =>
+ case (decideLT : (Decidable (a' < b')))
+ | yes => yes (p := ltS)
+ | no => no (p :=
+ lambda (p : (a < b)) ->
+ case p
+ | ltZ => absurd (Eq_trans a) (discriminate_nocheck zero (succ ?))
+ | ltS => absurd (? : (a' < b')) (? : Not (a' < b')));
+
+define-operator "∧" 111 130;
+
+record ((a : Type) ∧ (b : Type)) (fst : a) (snd : b);
+
+decideAnd : (P : Type) ≡> (Q : Type) ≡>
+ (Decidable P) => (Decidable Q) => (Decidable (P ∧ Q));
+decideAnd =
+ lambda P Q ≡>
+ lambda (decP : Decidable P) (decQ : Decidable Q) =>
+ case (decP, decQ)
+ | (yes (p := pP), yes (p := pQ)) => yes (p := _∧_ # pP pQ)
+ | (no (p := nP), _) =>
+ no (p := (lambda (proofs : P ∧ Q) -> absurd (_∧_.fst proofs) nP))
+ | (_, no (p := nQ)) =>
+ no (p := (lambda (proofs : P ∧ Q) -> absurd (_∧_.snd proofs) nQ));
+
+if_then_else_
+ = macro (lambda args ->
+ let e1 = List_nth 0 args Sexp_error;
+ e2 = List_nth 1 args Sexp_error;
+ e3 = List_nth 2 args Sexp_error;
+ in IO_return (quote (case (instance () : (Decidable (uquote e1)))
+ | yes => uquote e2
+ | no => uquote e3)));
+
+test2 : Bool;
+test2 = if ((even (succ zero)) ∧ (zero < zero)) then false else true;
+
=====================================
samples/num_class.typer
=====================================
@@ -0,0 +1,39 @@
+type Num (α : Type)
+ | mkNum (Num_+ : α -> α -> α)
+ (Num_- : α -> α -> α)
+ (Num_* : α -> α -> α)
+ (Num_/ : α -> α -> α);
+
+typeclass Num;
+
+_+_ = lambda numInst => case numInst | mkNum _+_ _ _ _ => _+_;
+_-_ = lambda numInst => case numInst | mkNum _ _-_ _ _ => _-_;
+_*_ = lambda numInst => case numInst | mkNum _ _ _*_ _ => _*_;
+_/_ = lambda numInst => case numInst | mkNum _ _ _ _/_ => _/_;
+
+IntNum : Num Int;
+IntNum =
+ mkNum (Num_+ := Int_+) (Num_- := Int_-) (Num_* := Int_*) (Num_/ := Int_/);
+
+IntegerNum : Num Integer;
+IntegerNum =
+ mkNum (Num_+ := Integer_+) (Num_- := Integer_-)
+ (Num_* := Integer_*) (Num_/ := Integer_/);
+
+FloatNum : Num Float;
+FloatNum =
+ mkNum (Num_+ := Float_+) (Num_- := Float_-)
+ (Num_* := Float_*) (Num_/ := Float_/);
+
+type FromInt (α : Type)
+ | mkFromInt (FromInt_fromInt : Int -> α);
+
+typeclass FromInt;
+
+fromInt = lambda fromIntInst => case fromIntInst | mkFromInt fromInt => fromInt;
+
+IntFromInt : FromInt Int;
+IntFromInt = mkFromInt (lambda x -> x);
+
+IntegerFromInt : FromInt Integer;
+IntegerFromInt = mkFromInt Int->Integer;
=====================================
samples/num_class_recs.typer
=====================================
@@ -0,0 +1,33 @@
+record (Num (α : Type))
+ (_+_ : α -> α -> α)
+ (_-_ : α -> α -> α)
+ (_*_ : α -> α -> α)
+ (_/_ : α -> α -> α);
+
+typeclass Num;
+
+_+_ = lambda numInst => Num._+_ numInst;
+_-_ = lambda numInst => Num._-_ numInst;
+_*_ = lambda numInst => Num._*_ numInst;
+_/_ = lambda numInst => Num._/_ numInst;
+
+IntNum : Num Int;
+IntNum = Num # Int_+ Int_- Int_* Int_/;
+
+IntegerNum : Num Integer;
+IntegerNum = Num # Integer_+ Integer_- Integer_* Integer_/;
+
+FloatNum : Num Float;
+FloatNum = Num # Float_+ Float_- Float_* Float_/;
+
+record (FromInt (α : Type)) (fromInt : Int -> α);
+
+typeclass FromInt;
+
+fromInt = lambda fromIntInst => FromInt.fromInt fromIntInst;
+
+IntFromInt : FromInt Int;
+IntFromInt = FromInt # (lambda x -> x);
+
+IntegerFromInt : FromInt Integer;
+IntegerFromInt = FromInt # Int->Integer;
=====================================
src/REPL.ml
=====================================
@@ -139,6 +139,7 @@ let ilexp_parse pexps lctx: ((ldecl list list * lexpr list) * elab_context) =
unparsed tokens directly instead *)
let ldecls, lctx = Elab.lexp_p_decls pdecls [] lctx in
let lexprs = Elab.lexp_parse_all pexprs lctx in
+ List.iter Elab.resolve_instances lexprs;
List.iter (fun lxp -> ignore (OL.check (ectx_to_lctx lctx) lxp))
lexprs;
(ldecls, lexprs), lctx
=====================================
src/builtin.ml
=====================================
@@ -99,19 +99,6 @@ let dloc = DB.dloc
let op_binary t = mkArrow (Anormal, (dloc, None), t, dloc,
mkArrow (Anormal, (dloc, None), t, dloc, t))
-let type_eq =
- let lv = (dloc, Some "l") in
- let tv = (dloc, Some "t") in
- mkArrow (Aerasable, lv,
- DB.type_level, dloc,
- mkArrow (Aerasable, tv,
- mkSort (dloc, Stype (mkVar (lv, 0))), dloc,
- mkArrow (Anormal, (dloc, None),
- mkVar (tv, 0), dloc,
- mkArrow (Anormal, (dloc, None),
- mkVar (tv, 1), dloc,
- mkSort (dloc, Stype (mkVar (lv, 3)))))))
-
let o2l_bool ctx b = get_predef (if b then "true" else "false") ctx
(* Typer list as seen during runtime. *)
@@ -161,7 +148,9 @@ let register_builtin_csts () =
add_builtin_cst "Integer" DB.type_integer;
add_builtin_cst "Float" DB.type_float;
add_builtin_cst "String" DB.type_string;
- add_builtin_cst "Elab_Context" DB.type_elabctx
+ add_builtin_cst "Elab_Context" DB.type_elabctx;
+ add_builtin_cst "Eq" DB.type_eq;
+ add_builtin_cst "Eq.refl" DB.eq_refl
let register_builtin_types () =
let _ = new_builtin_type "Sexp" DB.type0 in
@@ -175,7 +164,6 @@ let register_builtin_types () =
"Array" (mkArrow (Anormal, (dloc, None),
DB.type0, dloc, DB.type0)) in
let _ = new_builtin_type "FileHandle" DB.type0 in
- let _ = new_builtin_type "Eq" type_eq in
()
let _ = register_builtin_csts ();
=====================================
src/debruijn.ml
=====================================
@@ -94,6 +94,37 @@ let type_integer = mkBuiltin ((dloc, "Integer"), type0, None)
let type_float = mkBuiltin ((dloc, "Float"), type0, None)
let type_string = mkBuiltin ((dloc, "String"), type0, None)
let type_elabctx = mkBuiltin ((dloc, "Elab_Context"), type0, None)
+let type_eq_type =
+ let lv = (dloc, Some "l") in
+ let tv = (dloc, Some "t") in
+ mkArrow (Aerasable, lv,
+ type_level, dloc,
+ mkArrow (Aerasable, tv,
+ mkSort (dloc, Stype (mkVar (lv, 0))), dloc,
+ mkArrow (Anormal, (dloc, None),
+ mkVar (tv, 0), dloc,
+ mkArrow (Anormal, (dloc, None),
+ mkVar (tv, 1), dloc,
+ mkSort (dloc, Stype (mkVar (lv, 3)))))))
+let type_eq = mkBuiltin ((dloc, "Eq"), type_eq_type, None)
+let eq_refl =
+ let lv = (dloc, Some "l") in
+ let tv = (dloc, Some "t") in
+ let xv = (dloc, Some "x") in
+ mkBuiltin ((dloc, "Eq.refl"),
+ mkArrow (Aerasable, lv,
+ type_level, dloc,
+ mkArrow (Aerasable, tv,
+ mkSort (dloc, Stype (mkVar (lv, 0))), dloc,
+ mkArrow (Aerasable, xv,
+ mkVar (tv, 0), dloc,
+ mkCall (type_eq,
+ [Aerasable, mkVar (lv, 2);
+ Aerasable, mkVar (tv, 1);
+ Anormal, mkVar (xv, 0);
+ Anormal, mkVar (xv, 0)])))),
+ None)
+
(* easier to debug with type annotations *)
type env_elem = (vname * varbind * ltype)
@@ -112,26 +143,29 @@ type meta_scope
* lctx_length (* Length of ctx when the scope is added. *)
* (meta_id SMap.t ref) (* Metavars already known in this scope. *)
+type typeclass_ctx
+ = (ltype * lctx_length) list (* FIXME make it a set of lexps ? *)
+
(* This is the *elaboration context* (i.e. a context that holds
* a lexp context plus some side info. *)
type elab_context
- = Grammar.grammar * senv_type * lexp_context * meta_scope
+ = Grammar.grammar * senv_type * lexp_context * meta_scope * typeclass_ctx
let get_size (ctx : elab_context)
- = let (_, (n, _), lctx, _) = ctx in
+ = let (_, (n, _), lctx, _, _) = ctx in
assert (n = M.length lctx); n
let ectx_to_grm (ectx : elab_context) : Grammar.grammar =
- let (grm,_, _, _) = ectx in grm
+ let (grm,_, _, _, _) = ectx in grm
(* Extract the lexp context from the context used during elaboration. *)
let ectx_to_lctx (ectx : elab_context) : lexp_context =
- let (_,_, lctx, _) = ectx in lctx
+ let (_,_, lctx, _, _) = ectx in lctx
-let ectx_to_scope_level ((_, _, _, (sl, _, _)) : elab_context) : scope_level
+let ectx_to_scope_level ((_, _, _, (sl, _, _), _) : elab_context) : scope_level
= sl
-let ectx_local_scope_size ((_, (n, _), _, (_, slen, _)) as ectx) : int
+let ectx_local_scope_size ((_, (n, _), _, (_, slen, _), _) as ectx) : int
= get_size ectx - slen
(* Public methods: DO USE
@@ -142,7 +176,7 @@ let empty_lctx = M.nil
let empty_elab_context : elab_context
= (Grammar.default_grammar, empty_senv, empty_lctx,
- (0, 0, ref SMap.empty))
+ (0, 0, ref SMap.empty), [])
(* senv_lookup caller were using Not_found exception *)
exception Senv_Lookup_Fail of (string list)
@@ -150,7 +184,7 @@ let senv_lookup_fail relateds = raise (Senv_Lookup_Fail relateds)
(* Return its current DeBruijn index. *)
let senv_lookup (name: string) (ctx: elab_context): int =
- let (_, (n, map), _, _) = ctx in
+ let (_, (n, map), _, _, _) = ctx in
try n - (SMap.find name map) - 1
with Not_found
-> let get_related_names (n : db_ridx) name map =
@@ -189,11 +223,11 @@ let lctx_extend (ctx : lexp_context) (def: vname) (v: varbind) (t: lexp) =
let env_extend_rec (ctx: elab_context) (def: vname) (v: varbind) (t: lexp) =
let (loc, oname) = def in
- let (grm, (n, map), env, sl) = ctx in
+ let (grm, (n, map), env, sl, tcctx) = ctx in
let nmap = match oname with None -> map | Some name -> SMap.add name n map in
(grm, (n + 1, nmap),
lexp_ctx_cons env def v t,
- sl)
+ sl, tcctx)
let ectx_extend (ctx: elab_context) (def: vname) (v: varbind) (t: lexp) = env_extend_rec ctx def v t
@@ -207,28 +241,33 @@ let lctx_extend_rec (ctx : lexp_context) (defs: (vname * lexp * ltype) list) =
ctx
let ectx_extend_rec (ctx: elab_context) (defs: (vname * lexp * ltype) list) =
- let (grm, (n, senv), lctx, sl) = ctx in
+ let (grm, (n, senv), lctx, sl, tcctx) = ctx in
let senv', _ = List.fold_left
(fun (senv, i) ((_, oname), _, _) ->
(match oname with None -> senv
| Some name -> SMap.add name i senv),
i + 1)
(senv, n) defs in
- (grm, (n + List.length defs, senv'), lctx_extend_rec lctx defs, sl)
+ (grm, (n + List.length defs, senv'), lctx_extend_rec lctx defs, sl, tcctx)
let ectx_new_scope (ectx : elab_context) : elab_context =
- let (grm, senv, lctx, (scope, _, rmmap)) = ectx in
- (grm, senv, lctx, (scope + 1, Myers.length lctx, ref (!rmmap)))
+ let (grm, senv, lctx, (scope, _, rmmap), tcctx) = ectx in
+ (grm, senv, lctx, (scope + 1, Myers.length lctx, ref (!rmmap)), tcctx)
let ectx_get_scope (ectx : elab_context) : meta_scope =
- let (_, _, _, sl) = ectx in sl
+ let (_, _, _, sl, _) = ectx in sl
let ectx_get_grammar (ectx : elab_context) : Grammar.grammar =
- let (grm, _, _, _) = ectx in grm
+ let (grm, _, _, _, _) = ectx in grm
let env_lookup_by_index index (ctx: lexp_context): env_elem =
Myers.nth index ctx
+let env_add_typeclass (ectx : elab_context) (t : ltype) : elab_context =
+ let (grm, senv, lctx, sl, tcctx) = ectx in
+ let ntcctx = ((t, get_size ectx) :: tcctx) in
+ (grm, senv, lctx, sl, ntcctx)
+
(* Print context *)
let print_lexp_ctx_n (ctx : lexp_context) start =
let n = (M.length ctx) - 1 in
=====================================
src/elab.ml
=====================================
@@ -57,6 +57,7 @@ open Grammar
module BI = Builtin
module Unif = Unification
+module Inst = Instances
module OL = Opslexp
module EL = Elexp
@@ -257,6 +258,13 @@ let newMetavar (ctx : lexp_context) sl name t =
let meta = Unif.create_metavar ctx sl t in
mkMetavar (meta, S.identity, name)
+let newInstanceMetavar (ctx : elab_context) name t =
+ let lctx = ectx_to_lctx ctx in
+ let sl = ectx_to_scope_level ctx in
+ let meta = Unif.create_metavar lctx sl t in
+ Inst.add_instance_metavar meta ctx (fst name);
+ mkMetavar (meta, S.identity, name)
+
let newMetalevel (ctx : lexp_context) sl loc =
newMetavar ctx sl (loc, Some "ℓ") type_level
@@ -280,8 +288,8 @@ let sdform_define_operator (ctx : elab_context) loc sargs _ot : elab_context =
| Symbol (_, "") -> None
| Integer (_, n) -> Some n
| _ -> sexp_error (sexp_location s) "Expecting an integer or ()"; None in
- let (grm, a, b, c) = ctx in
- (SMap.add name (level l, level r) grm, a, b, c)
+ let (grm, a, b, c, d) = ctx in
+ (SMap.add name (level l, level r) grm, a, b, c, d)
| [o; _; _]
-> sexp_error (sexp_location o) "Expecting a string"; ctx
| _
@@ -466,11 +474,11 @@ let rec meta_to_var ids (e : lexp) =
-> let ncases
= SMap.map
(fun (l, fields, e)
- -> (l, fields, loop (o + List.length fields) e))
+ -> (l, fields, loop (o + List.length fields + 1) e))
cases in
mkCase (l, loop o e, loop o t, ncases,
match default with None -> None
- | Some (v, e) -> Some (v, loop (1 + o) e))
+ | Some (v, e) -> Some (v, loop (2 + o) e))
| Metavar (id, s, name)
-> if IMap.mem id ids then
mkVar (name, o + count - IMap.find id ids)
@@ -625,12 +633,83 @@ and get_implicit_arg ctx loc oname t =
and instantiate_implicit e t ctx =
let rec instantiate t args =
match OL.lexp_whnf t (ectx_to_lctx ctx) with
+ | Arrow ((Aerasable | Aimplicit) as ak, (_, v), t1, _, t2) when Inst.is_typeclass ctx t1
+ -> let arg = newInstanceMetavar ctx (lexp_location e, v) t1 in
+ instantiate (mkSusp t2 (S.substitute arg)) ((ak, arg)::args)
| Arrow ((Aerasable | Aimplicit) as ak, (_, v), t1, _, t2)
-> let arg = get_implicit_arg ctx (lexp_location e) v t1 in
instantiate (mkSusp t2 (S.substitute arg)) ((ak, arg)::args)
| _ -> (mkCall (e, List.rev args), t)
in instantiate t []
+and myers_filter_map_index (f : int -> 'a -> 'b option) (m : 'a M.myers)
+ : ('b M.myers)
+ = snd (M.fold_right
+ (fun x (i, l') ->
+ match (f i x) with
+ | Some y -> (i - 1, M.cons y l')
+ | None -> (i - 1, l'))
+ m (M.length m - 1, M.nil))
+
+and search_instance (ctx : elab_context) (loc : location) (t : ltype) : lexp option =
+ Log.log_debug ~loc ("Searching for t = `" ^ (lexp_string t) ^ "`");
+ let ctx = ectx_new_scope ctx in
+ let lctx = (ectx_to_lctx ctx) in
+ let sl = (ectx_to_scope_level ctx) in
+ let env_elem_match (i : int) (elem : DB.env_elem) : (int * DB.env_elem * lexp * ltype) option =
+ let ((_, namopt), _, t') = elem in
+ let var = mkVar ((loc,namopt), i) in
+ let t' = mkSusp t' (S.shift (i + 1)) in
+ let (e, t') = instantiate_implicit var t' ctx in
+ (* All candidates should have a type that is a typeclass *)
+ if not (Inst.is_typeclass ctx t') then None else
+ match Inst.check_typeclass_match t t' lctx sl with
+ | (Impossible | Possible) -> None
+ (* | Possible -> None *)
+ | (Match) -> Some (i, elem, e, t') in
+ let candidates =
+ myers_filter_map_index env_elem_match lctx in
+ Log.log_debug ("Candidates for instance of type `" ^ lexp_string t ^ "`:")
+ ~print_action:(fun () ->
+ M.iter (fun (i, ((_, so),_,t'),_, _) ->
+ lalign_print_int i 4;
+ lalign_print_string (match so with | Some s -> s | None -> "<none>") 10;
+ print_endline (lexp_string t')) candidates);
+ match M.safe_car candidates with
+ | None -> None
+ | Some (i, (vname, _, t'),e,t) ->
+ let t' = mkSusp t' (S.shift (i + 1)) in
+ Log.log_debug ~loc
+ ("Found candidate at index " ^ (string_of_int i) ^ ": `" ^
+ (lexp_string (Var (vname, i))) ^ " : " ^ (lexp_string t') ^ "`");
+ Some e
+
+and resolve_instances e =
+ let (_, (fv_map, _)) = OL.fv e in
+ U.IMap.iter (fun i (sl, t, cl, vn) ->
+ match Inst.instance_metavar_lookup i with
+ | Some (ctx, loc) ->
+ (match search_instance ctx loc t with
+ | Some e -> Unif.associate i e; resolve_instances e
+ | None ->
+ error ~loc ("No instance found for type `" ^ (lexp_string t) ^ "`")
+ )
+ | None -> ()
+ ) fv_map
+
+
+and resolve_instances_and_generalize ctx e =
+ resolve_instances e;
+ generalize ctx e
+
+and sdform_typeclass (ctx : elab_context) loc sargs _ot : elab_context =
+ match sargs with
+ | [se] ->
+ let (t, _) = infer se ctx in
+ Inst.add_typeclass ctx t
+ | _
+ -> sexp_error loc "typeclass expects 1 argument"; ctx
+
and infer_type pexp ectx var =
(* We could also use lexp_check with an argument of the form
* Sort (?s), but in most cases the metavar would be allocated
@@ -707,7 +786,8 @@ and check_inferred ctx e inferred_t t =
-> lexp_error (lexp_location e) e
("Type mismatch("
^ (match ck with | Unif.CKimpossible -> "impossible"
- | Unif.CKresidual -> "residue")
+ | Unif.CKresidual -> "residue"
+ | _ -> failwith "impossible" )
^ ")! Context expected:\n "
^ lexp_string t ^ "\nbut expression has type:\n "
^ lexp_string inferred_t ^ "\ncan't unify:\n "
@@ -738,16 +818,16 @@ and check_case rtype (loc, target, ppatterns) ctx =
let ltarget = ref tlxp in
let get_cs_as it' lctor =
+ let unify_ind expected actual =
+ match Unif.unify actual expected (ectx_to_lctx ctx) with
+ | (_::_)
+ -> lexp_error loc lctor
+ ("Expected pattern of type `" ^ lexp_string expected
+ ^ "` but got `" ^ lexp_string actual ^ "`")
+ | [] -> () in
match !it_cs_as with
| Some (it, cs, args)
- -> let _ = match Unif.unify it' it (ectx_to_lctx ctx) with
- | (_::_)
- -> lexp_error loc lctor
- ("Expected pattern of type `"
- ^ lexp_string it ^ "` but got `"
- ^ lexp_string it' ^ "`")
- | [] -> () in
- (cs, args)
+ -> unify_ind it it'; (cs, args)
| None
-> match OL.lexp_whnf it' (ectx_to_lctx ctx) with
| Inductive (_, _, fargs, constructors)
@@ -768,6 +848,7 @@ and check_case rtype (loc, target, ppatterns) ctx =
with | Call (f, args) -> (f, args)
| _ -> (e,[]) in
let (it, targs) = call_split tltp in
+ unify_ind it it';
let constructors = match OL.lexp_whnf it (ectx_to_lctx ctx) with
| Inductive (_, _, fargs, constructors)
-> assert (List.length fargs = List.length targs);
@@ -776,14 +857,42 @@ and check_case rtype (loc, target, ppatterns) ctx =
("Can't `case` on objects of this type: "
^ lexp_string tltp);
SMap.empty in
+ it_cs_as := Some (it, constructors, targs);
(constructors, targs) in
(* Read patterns one by one *)
let fold_fun (lbranches, dflt) (pat, pexp) =
+ let shift_to_extended_ctx nctx lexp =
+ mkSusp lexp (S.shift (M.length (ectx_to_lctx nctx)
+ - M.length (ectx_to_lctx ctx))) in
+
+ let ctx_extend_with_eq nctx head_lexp =
+ (* Add a proof of equality between the target and the branch
+ head to the context *)
+ let tlxp' = shift_to_extended_ctx nctx tlxp in
+ let tltp' = shift_to_extended_ctx nctx tltp in
+ let tkind = OL.get_type (ectx_to_lctx nctx) tltp' in
+ let tlevel = (match OL.lexp_whnf tkind (ectx_to_lctx nctx) with
+ | Sort (_, Stype l) -> l
+ | _ -> error "HMMM"; DB.level0) in
+ let head_lexp_type = OL.get_type (ectx_to_lctx nctx) head_lexp in
+ (match Unif.unify tltp' head_lexp_type (ectx_to_lctx nctx) with
+ | [] -> ()
+ | constraints -> Log.log_error "Unification failed for case Eq");
+ let eqty = mkCall (DB.type_eq,
+ [(Aerasable, tlevel); (* Typelevel *)
+ (Aerasable, tltp'); (* Inductive type *)
+ (Anormal, tlxp'); (* Target lexp *)
+ (Anormal, head_lexp)]) (* Lexp of the branch head *)
+ in ctx_extend nctx (loc, None) Variable eqty
+ in
+
let add_default v =
(if dflt != None then uniqueness_warn pat);
let nctx = ctx_extend ctx v Variable tltp in
+ let head_lexp = mkVar (v, 0) in
+ let nctx = ctx_extend_with_eq nctx head_lexp in
let rtype' = mkSusp rtype (S.shift (M.length (ectx_to_lctx nctx)
- M.length (ectx_to_lctx ctx))) in
let lexp = check pexp rtype' nctx in
@@ -864,6 +973,15 @@ and check_case rtype (loc, target, ppatterns) ctx =
make_nctx nctx (ssink var s) pargs cargs pe
((ak, var)::acc) in
let nctx, fargs = make_nctx ctx subst pargs cargs SMap.empty [] in
+ let head_lexp_ctor =
+ shift_to_extended_ctx nctx
+ (mkCall (lctor, List.map (fun (_, a) -> (Aerasable, a)) targs)) in
+ let head_lexp_args =
+ List.mapi (fun i (ak, vname) ->
+ (* This is not pretty :( *)
+ (ak, mkVar (vname, List.length fargs - i - 1))) fargs in
+ let head_lexp = mkCall (head_lexp_ctor, head_lexp_args) in
+ let nctx = ctx_extend_with_eq nctx head_lexp in
let rtype' = mkSusp rtype
(S.shift (M.length (ectx_to_lctx nctx)
- M.length (ectx_to_lctx ctx))) in
@@ -946,11 +1064,13 @@ and elab_call ctx (func, ltp) (sargs: sexp list) =
(* Don't instantiate after the last explicit arg: the rest is done,
* when needed in infer_and_check (via instantiate_implicit). *)
when not (sargs = [] && SMap.is_empty pending)
- -> let larg = get_implicit_arg
- ctx (match sargs with
- | [] -> loc
- | sarg::_ -> sexp_location sarg)
- v arg_type in
+ -> let larg = if Inst.is_typeclass ctx arg_type
+ then newInstanceMetavar ctx (loc, v) arg_type
+ else get_implicit_arg
+ ctx (match sargs with
+ | [] -> loc
+ | sarg::_ -> sexp_location sarg)
+ v arg_type in
handle_fun_args ((ak, larg) :: largs) sargs pending
(L.mkSusp ret_type (S.substitute larg))
| [], _
@@ -996,7 +1116,7 @@ and lexp_parse_inductive ctors ctx =
(fun (ak, n, t) aa
-> Arrow (ak, n, t, dummy_location, aa))
acc impossible in
- let g = generalize nctx altacc in
+ let g = resolve_instances_and_generalize nctx altacc in
let altacc' = g (fun _ne vname t l e
-> Arrow (Aerasable, vname, t, l, e))
altacc in
@@ -1110,9 +1230,9 @@ and lexp_check_decls (ectx : elab_context) (* External context. *)
(* FIXME: Generalize when/where possible, so things like `map` can be
defined without type annotations! *)
(* Preserve the new operators added to nctx. *)
- let ectx = let (_, a, b, c) = ectx in
- let (grm, _, _, _) = nctx in
- (grm, a, b, c) in
+ let ectx = let (_, a, b, c, _) = ectx in
+ let (grm, _, _, _, tcctx) = nctx in
+ (grm, a, b, c, tcctx) in
let (declmap, nctx)
= List.fold_right
(fun ((l, vname), pexp) (map, nctx) ->
@@ -1122,10 +1242,11 @@ and lexp_check_decls (ectx : elab_context) (* External context. *)
| (v', ForwardRef, t)
-> let adjusted_t = push_susp t (S.shift (i + 1)) in
let e = check pexp adjusted_t nctx in
- let (grm, ec, lc, sl) = nctx in
+ resolve_instances e;
+ let (grm, ec, lc, sl, tcctx) = nctx in
let d = (v', LetDef (i + 1, e), t) in
(IMap.add i ((l, Some vname), e, t) map,
- (grm, ec, Myers.set_nth i d lc, sl))
+ (grm, ec, Myers.set_nth i d lc, sl, tcctx))
| _ -> Log.internal_error "Defining same slot!")
defs (IMap.empty, nctx) in
let decls = List.rev (List.map (fun (_, d) -> d) (IMap.bindings declmap)) in
@@ -1161,7 +1282,7 @@ and infer_and_generalize_type (ctx : elab_context) se name =
| Arrow (ak, v, t1, l, t2) -> Arrow (ak, v, t1, l, strip_rettype t2)
| Sort _ | Metavar _ -> type0 (* Abritrary closed constant. *)
| _ -> t in
- let g = generalize nctx (strip_rettype t) in
+ let g = resolve_instances_and_generalize nctx (strip_rettype t) in
g (fun _ne name t l e
-> mkArrow (Aerasable, name, t, l, e))
t
@@ -1169,7 +1290,7 @@ and infer_and_generalize_type (ctx : elab_context) se name =
and infer_and_generalize_def (ctx : elab_context) se =
let nctx = ectx_new_scope ctx in
let (e,t) = infer se nctx in
- let g = generalize nctx e in
+ let g = resolve_instances_and_generalize nctx e in
let e' = g (fun ne vname t l e
-> mkLambda ((if ne then Aimplicit else Aerasable),
vname, t, e))
@@ -1301,6 +1422,10 @@ and lexp_decls_1
-> recur [] (sdform_define_operator nctx l args None)
pending_decls pending_defs
+ | Some (Node (Symbol (l, "typeclass"), args))
+ -> recur [] (sdform_typeclass nctx l args None)
+ pending_decls pending_defs
+
| Some (Node (Symbol ((l, _) as v), sargs))
-> (* expand macro and get the generated declarations *)
let sdecl' = lexp_decls_macro v sargs nctx in
@@ -1329,10 +1454,12 @@ and lexp_p_decls (sdecls : sexp list) (tokens : token list) (ctx : elab_context)
impl sdecls tokens ctx
and lexp_parse_all (p: sexp list) (ctx: elab_context) : lexp list =
+ Eval.set_getenv ctx;
let res = List.map (fun pe -> let e, _ = infer pe ctx in e) p in
(Log.stop_on_error (); res)
and lexp_parse_sexp (ctx: elab_context) (e : sexp) : lexp =
+ Eval.set_getenv ctx;
let e, _ = infer e ctx in (Log.stop_on_error (); e)
(* --------------------------------------------------------------------------
@@ -1657,10 +1784,21 @@ let rec sform_lambda kind ctx loc sargs ot =
-> (match olt1 with
| None -> ()
| Some lt1'
- -> if not (OL.conv_p (ectx_to_lctx ctx) lt1 lt1')
- then lexp_error (lexp_location lt1') lt1'
- ("Type mismatch! Context expected `"
- ^ lexp_string lt1 ^ "`"));
+ -> (match Unif.unify lt1' lt1 (ectx_to_lctx ctx) with
+ | ((ck, _ctx, t1, t2)::_)
+ -> lexp_error (lexp_location lt1') lt1'
+ ("Type mismatch("
+ ^ (match ck with | Unif.CKimpossible -> "impossible"
+ | Unif.CKresidual -> "residue"
+ | _ -> failwith "impossible")
+ ^ ")! Context expected:\n "
+ ^ lexp_string lt1 ^ "\nbut parameter has type:\n "
+ ^ lexp_string lt1' ^ "\ncan't unify:\n "
+ ^ lexp_string t1
+ ^ "\nwith:\n "
+ ^ lexp_string t2);
+ assert (not (OL.conv_p (ectx_to_lctx ctx) lt1' lt1))
+ | [] -> ()));
mklam lt1 (Some lt2)
| Arrow (ak2, v, lt1, _, lt2) when kind = Anormal
@@ -1824,6 +1962,22 @@ let sform_load usr_elctx loc sargs ot =
(tuple',Lazy)
+(**
+ Draft of a special form "instance" that gets refers to a variable
+ of the requested type in the context.
+ **)
+let sform_instance ctx loc sargs ot =
+ match sargs, ot with
+ | ([se; _], _) -> (* Dummy param to trigger the special form *)
+ let t = infer_type se ctx (loc, None) in
+ let mv = newInstanceMetavar ctx (loc, Some "instance") t in
+ (mv, Inferred t)
+ | ([_], Some t) -> (* Dummy param to trigger the special form *)
+ let mv = newInstanceMetavar ctx (loc, Some "instance") t in
+ (mv, Checked)
+ | _ -> (sexp_error loc "##instance expects a type argument if not checked";
+ sform_dummy_ret ctx loc)
+
(* Register special forms. *)
let register_special_forms () =
List.iter add_special_form
@@ -1853,6 +2007,7 @@ let register_special_forms () =
(* FIXME: These should be functions! *)
("decltype", sform_decltype);
("declexpr", sform_declexpr);
+ ("instance", sform_instance);
]
(* Default context with builtin types
=====================================
src/eval.ml
=====================================
@@ -744,6 +744,14 @@ let constructor_p name ectx =
| _ -> false
with Senv_Lookup_Fail _ -> false
+let inductive_p name ectx =
+ try let idx = senv_lookup name ectx in
+ match OL.lexp_whnf (mkVar ((dummy_location, Some name), idx))
+ (ectx_to_lctx ectx) with
+ | Inductive _ -> true
+ | _ -> false
+ with Senv_Lookup_Fail _ -> false
+
let erasable_p name nth ectx =
let is_erasable ctors = match (smap_find_opt name ctors) with
| (Some args) ->
@@ -821,10 +829,43 @@ let ctor_arg_pos name arg ectx =
| _ -> (-1)
with Senv_Lookup_Fail _ -> (-1)
+let ind_ctor_arg_pos indname ctorname arg ectx =
+ let rec find_opt xs n = match xs with
+ | [] -> None
+ | (_, (_, Some x), _)::xs -> if x = arg then Some n else find_opt xs (n + 1)
+ | _::xs -> find_opt xs (n + 1) in
+ try let idx = senv_lookup indname ectx in
+ match OL.lexp_whnf (mkVar ((dummy_location, Some indname), idx))
+ (ectx_to_lctx ectx) with
+ | Inductive (_, _, _, ctors) ->
+ (match smap_find_opt ctorname ctors with
+ | (Some args) ->
+ (match (find_opt args 0) with
+ | None -> (-1)
+ | Some n -> n)
+ | _ -> (-1))
+ | _ -> (-1)
+ with Senv_Lookup_Fail _ -> (-1)
+
+let count_ctor_args indname ctorname ectx =
+ try let idx = senv_lookup indname ectx in
+ match OL.lexp_whnf (mkVar ((dummy_location, Some indname), idx))
+ (ectx_to_lctx ectx) with
+ | Inductive (_,_,_,ctors) ->
+ (match smap_find_opt ctorname ctors with
+ | Some args -> List.length args
+ | None -> (-1))
+ | _ -> (-1)
+ with Senv_Lookup_Fail _ -> (-1)
+
let is_constructor loc depth args_val = match args_val with
| [Vstring name; Velabctx ectx] -> o2v_bool (constructor_p name ectx)
| _ -> error loc "Elab.isconstructor takes a String and an Elab_Context as arguments"
+let is_inductive loc depth args_val = match args_val with
+ | [Vstring name; Velabctx ectx] -> o2v_bool (inductive_p name ectx)
+ | _ -> error loc "Elab.isinductive takes a String and an Elab_Context as arguments"
+
let is_nth_erasable loc depth args_val = match args_val with
| [Vstring name; Vint nth_arg; Velabctx ectx] -> o2v_bool (erasable_p name nth_arg ectx)
| _ -> error loc "Elab.is-nth-erasable takes a String, an Int and an Elab_Context as arguments"
@@ -841,6 +882,14 @@ let arg_pos loc depth args_val = match args_val with
| [Vstring t; Vstring a; Velabctx ectx] -> Vint (ctor_arg_pos t a ectx)
| _ -> error loc "Elab.arg-pos takes two String and an Elab_Context as arguments"
+let ind_ctor_arg_pos loc depth args_val = match args_val with
+ | [Vstring ind; Vstring ctor; Vstring field; Velabctx ectx] -> Vint (ind_ctor_arg_pos ind ctor field ectx)
+ | _ -> error loc "Elab.ind-ctor-arg-pos takes three String and an Elab_Context as arguments"
+
+let count_ctor_args loc depth args_val = match args_val with
+ | [Vstring ind; Vstring ctor; Velabctx ectx] -> Vint (count_ctor_args ind ctor ectx)
+ | _ -> error loc "Elab.count-ctor-args takes two String and an Elab_Context as arguments"
+
let array_append loc depth args_val = match args_val with
| [v; Varray a] ->
Varray (Array.append (Array.map (fun v -> v) a) (Array.make 1 v))
@@ -996,10 +1045,13 @@ let register_builtin_functions () =
("Elab.debug-doc", debug_doc, 2);
("Elab.isbound" , is_bound, 2);
("Elab.isconstructor", is_constructor, 2);
+ ("Elab.isinductive", is_inductive, 2);
("Elab.is-nth-erasable", is_nth_erasable, 3);
("Elab.is-arg-erasable", is_arg_erasable, 3);
("Elab.nth-arg" , nth_arg, 3);
("Elab.arg-pos" , arg_pos, 3);
+ ("Elab.ind-ctor-arg-pos", ind_ctor_arg_pos, 4);
+ ("Elab.count-ctor-args", count_ctor_args, 3);
("Array.append" , array_append,2);
("Array.create" , array_create,2);
("Array.length" , array_length,1);
=====================================
src/instances.ml
=====================================
@@ -0,0 +1,52 @@
+module Unif = Unification
+module U = Util
+module DB = Debruijn
+module L = Lexp
+module S = Subst
+module OL = Opslexp
+
+(* FIXME Is it possible to have multiple references to the same
+ instance metavar? It would break the following code *)
+let instance_metavar_table = ref (U.IMap.empty : (DB.elab_context * U.location) U.IMap.t)
+let instance_metavar_lookup (id : L.meta_id) : (DB.elab_context * U.location) option
+ = U.IMap.find_opt id (!instance_metavar_table)
+let add_instance_metavar (id : L.meta_id) (ctx : DB.elab_context) (loc : U.location) : unit
+ = instance_metavar_table := U.IMap.add id (ctx, loc) !instance_metavar_table
+
+let env_is_typeclass (ectx : DB.elab_context) (t : L.ltype) : bool =
+ let (_, _, _, _, tcctx) = ectx in
+ let cl = DB.get_size ectx in
+ List.exists (fun (t', cl') ->
+ let i = cl - cl' in
+ let t' = L.mkSusp t' (S.shift i) in
+ OL.conv_p (DB.ectx_to_lctx ectx) t t'
+ (*(Unif.unify ~checking:(max_int (* FIXME *)) t t' (DB.ectx_to_lctx ectx)) = []*)
+ ) tcctx
+
+
+let get_head (lctx : DB.lexp_context) (t : L.ltype) : L.ltype =
+ match OL.lexp_whnf t lctx with
+ | L.Call (head, _) -> head
+ | head -> head
+
+
+let is_typeclass (ctx : DB.elab_context) (t : L.ltype) =
+ let lctx = DB.ectx_to_lctx ctx in
+ let head = get_head lctx t in
+ env_is_typeclass ctx head
+
+let add_typeclass (ctx : DB.elab_context) (t : L.ltype) : DB.elab_context =
+ let lctx = DB.ectx_to_lctx ctx in
+ let head = get_head lctx t in
+ DB.env_add_typeclass ctx head
+
+type match_res = Impossible | Possible | Match
+
+let check_typeclass_match t1 t2 lctx sl =
+ match Unif.unify ~checking:sl t1 t2 lctx with
+ | [] -> Match
+ | constraints when List.exists (function | (Unif.CKimpossible,_,_,_) -> true
+ | _ -> false)
+ constraints -> Impossible
+ | _ -> Possible
+
=====================================
src/inverse_subst.ml
=====================================
@@ -300,11 +300,12 @@ and apply_inv_subst (e : lexp) (s : subst) : lexp = match e with
-> let s' = L.fold_left
(fun s (_,ov) -> ssink ov s)
s cargs in
- (l, cargs, apply_inv_subst e s'))
+ let s'' = ssink (l, None) s' in
+ (l, cargs, apply_inv_subst e s''))
cases,
match default with
| None -> default
- | Some (v,e) -> Some (v, apply_inv_subst e (ssink v s)))
+ | Some (v,e) -> Some (v, apply_inv_subst e (ssink (l, None) (ssink v s))))
| Metavar (id, s', name)
-> match metavar_lookup id with
| MVal e -> apply_inv_subst (push_susp e s') s
=====================================
src/lexp.ml
=====================================
@@ -409,11 +409,11 @@ let rec push_susp e s = (* Push a suspension one level down. *)
-> let s' = L.fold_left
(fun s (_,ov) -> ssink ov s)
s cargs in
- (l, cargs, mkSusp e s'))
+ (l, cargs, mkSusp e (ssink (l, None) s')))
cases,
match default with
| None -> default
- | Some (v,e) -> Some (v, mkSusp e (ssink v s)))
+ | Some (v,e) -> Some (v, mkSusp e (ssink (l, None) (ssink v s))))
(* Susp should never appear around Var/Susp/Metavar because mkSusp
* pushes the subst into them eagerly. IOW if there's a Susp(Var..)
* or Susp(Metavar..) it's because some chunk of code should use mkSusp
@@ -475,11 +475,12 @@ let clean e =
-> let s' = L.fold_left
(fun s (_,ov) -> ssink ov s)
s cargs in
- (l, cargs, clean s' e))
+ let s'' = ssink (l, None) s' in
+ (l, cargs, clean s'' e))
cases,
match default with
| None -> default
- | Some (v,e) -> Some (v, clean (ssink v s) e))
+ | Some (v,e) -> Some (v, clean (ssink (l, None) (ssink v s)) e))
| Susp (e, s') -> clean (scompose s' s) e
| Var _ -> if S.identity_p s then e
else clean S.identity (mkSusp e s)
@@ -805,7 +806,7 @@ and lexp_str ctx (exp : lexp) : string =
| Metavar (idx, subst, (loc, name))
(* print metavar result if any *)
-> (match metavar_lookup idx with
- | MVal e -> lexp_str ctx e
+ | MVal e -> lexp_str ctx (push_susp e subst)
| _ -> "?" ^ maybename name ^ (subst_string subst) ^ (index idx))
| Let (_, decls, body) ->
@@ -993,7 +994,19 @@ let rec eq e1 e2 =
| (Some (_, e1), Some (_, e2)) -> eq e1 e2
| _ -> def1 = def2)
| (Metavar (i1, s1, _), Metavar (i2, s2, _))
- -> i1 = i2 && subst_eq s1 s2
+ -> if i1 == i2 then subst_eq s1 s2 else
+ (match (metavar_lookup i1, metavar_lookup i2) with
+ | (MVal l, _) -> eq (push_susp l s1) e2
+ | (_, MVal l) -> eq e1 (push_susp l s2)
+ | _ -> false)
+ | (Metavar (i1, s1, _), _)
+ -> (match metavar_lookup i1 with
+ | MVal l -> eq (push_susp l s1) e2
+ | _ -> false)
+ | (_, Metavar (i2, s2, _))
+ -> (match metavar_lookup i2 with
+ | MVal l -> eq e1 (push_susp l s2)
+ | _ -> false)
| _ -> false
and subst_eq s1 s2 =
=====================================
src/log.ml
=====================================
@@ -133,11 +133,13 @@ let print_entry entry =
let log_entry (entry : log_entry) =
if (entry.level <= typer_log_config.level)
then (
- log_push entry;
- if (typer_log_config.print_at_log)
+ if (typer_log_config.print_at_log ||
+ entry.level >= Debug)
then
(print_entry entry;
flush stdout)
+ else
+ log_push entry
)
let count_msgs (lvlp : log_level -> bool) =
=====================================
src/myers.ml
=====================================
@@ -54,11 +54,21 @@ let car l =
| Mnil -> raise Not_found
| Mcons (x, _, _, _) -> x
+let safe_car l =
+ match l with
+ | Mnil -> None
+ | Mcons (x, _, _, _) -> Some x
+
let cdr l =
match l with
| Mnil -> Mnil
| Mcons (_, l, _, _) -> l
+let safe_cdr l =
+ match l with
+ | Mnil -> None
+ | Mcons (_, l, _, _) -> Some l
+
let case l n c =
match l with
| Mnil -> n ()
@@ -136,3 +146,6 @@ let rec fold_right f l i = match l with
let map f l = fold_right (fun x l' -> cons (f x) l') l nil
let iteri f l = fold_left (fun i x -> f i x; i + 1) 0 l
+
+let iter (f : 'a -> unit) (l : 'a myers) : unit
+ = fold_left (fun _ x -> f x; ()) () l
=====================================
src/opslexp.ml
=====================================
@@ -38,6 +38,22 @@ module S = Subst
(* module L = List *)
module DB = Debruijn
+type set_plexp = (lexp * lexp) list
+type sort_compose_result
+ = SortResult of ltype
+ | SortInvalid
+ | SortK1NotType
+ | SortK2NotType
+type mv_set = (scope_level * ltype * ctx_length * vname) IMap.t
+ (* Metavars that appear in non-erasable positions. *)
+ * unit IMap.t
+
+module LMap
+ (* Memoization table. FIXME: Ideally the keys should be "weak", but
+ * I haven't found any such functionality in OCaml's libs. *)
+ = Hashtbl.Make
+ (struct type t = lexp let hash = Hashtbl.hash let equal = (==) end)
+
let error_tc = Log.log_error ~section:"TC"
let warning_tc = Log.log_warning ~section:"TC"
@@ -132,7 +148,7 @@ let lexp_close lctx e =
* but only on *types*. If you must use it on code, be sure to use its
* return value as little as possible since WHNF will inherently introduce
* call-by-name behavior. *)
-let lexp_whnf e (ctx : DB.lexp_context) : lexp =
+let rec lexp_whnf e (ctx : DB.lexp_context) : lexp =
let rec lexp_whnf e (ctx : DB.lexp_context) : lexp =
match e with
| Var v -> (match lookup_value ctx v with
@@ -156,21 +172,28 @@ let lexp_whnf e (ctx : DB.lexp_context) : lexp =
| _ -> e) (* Keep `e`, assuming it's more readable! *)
| Case (l, e, rt, branches, default) ->
let e' = lexp_whnf e ctx in
+ let get_refl e =
+ let etype = get_type ctx e in (* FIXME we should not need get_type here *)
+ let elevel = match lexp_whnf (get_type ctx etype) ctx with
+ | Sort (_, Stype l) -> l
+ | _ -> Log.internal_error "" in
+ mkCall (DB.eq_refl, [Aerasable, elevel; Aerasable, etype; Aerasable, e]) in
let reduce name aargs =
try
let (_, _, branch) = SMap.find name branches in
- let (subst, _)
+ let subst
= List.fold_left
- (fun (s,d) (_, arg) ->
- (S.cons (L.mkSusp (lexp_whnf arg ctx) (S.shift d)) s,
- d + 1))
- (S.identity, 0)
+ (fun (s) (_, arg) -> S.cons (lexp_whnf arg ctx) s)
+ S.identity
aargs in
+ (* Substitute case Eq variable by the proof (Eq.refl l t e') *)
+ let subst = S.cons (get_refl e') subst in
lexp_whnf (push_susp branch subst) ctx
with Not_found
-> match default
with | Some (v,default)
- -> lexp_whnf (push_susp default (S.substitute e')) ctx
+ -> let subst = S.cons (get_refl e') (S.substitute e') in
+ lexp_whnf (push_susp default subst) ctx
| _ -> Log.log_error ~section:"WHNF" ~loc:l
("Unhandled constructor " ^
name ^ "in case expression");
@@ -198,9 +221,8 @@ let lexp_whnf e (ctx : DB.lexp_context) : lexp =
(** A very naive implementation of sets of pairs of lexps. *)
-type set_plexp = (lexp * lexp) list
-let set_empty : set_plexp = []
-let set_member_p (s : set_plexp) (e1 : lexp) (e2 : lexp) : bool
+and set_empty : set_plexp = []
+and set_member_p (s : set_plexp) (e1 : lexp) (e2 : lexp) : bool
= assert (e1 == Lexp.hc e1);
assert (e2 == Lexp.hc e2);
try let _ = List.find (fun (e1', e2')
@@ -208,14 +230,14 @@ let set_member_p (s : set_plexp) (e1 : lexp) (e2 : lexp) : bool
s
in true
with Not_found -> false
-let set_add (s : set_plexp) (e1 : lexp) (e2 : lexp) : set_plexp
+and set_add (s : set_plexp) (e1 : lexp) (e2 : lexp) : set_plexp
= (* assert (not (set_member_p s e1 e2)); *)
((e1, e2) :: s)
-let set_shift_n (s : set_plexp) (n : U.db_offset)
+and set_shift_n (s : set_plexp) (n : U.db_offset)
= List.map (let s = S.shift n in
fun (e1, e2) -> (Lexp.push_susp e1 s, Lexp.push_susp e2 s))
s
-let set_shift s : set_plexp = set_shift_n s 1
+and set_shift s : set_plexp = set_shift_n s 1
(********* Testing if two types are "convertible" aka "equivalent" *********)
@@ -225,7 +247,7 @@ let set_shift s : set_plexp = set_shift_n s 1
* `c` is the maximum "constant" level that occurs in `e`
* and `m` maps variable indices to the maxmimum depth at which they were
* found. *)
-let level_canon e =
+and level_canon e =
let add_var_depth v d ((c,m) as acc) =
let o = try IMap.find v m with Not_found -> -1 in
if o < d then (c, IMap.add v d m) else acc in
@@ -244,18 +266,21 @@ let level_canon e =
| _ -> (max_int, m)
in canon e 0 (0,IMap.empty)
-let level_leq (c1, m1) (c2, m2) =
+and level_leq (c1, m1) (c2, m2) =
c1 <= c2
&& c1 != max_int
&& IMap.for_all (fun i d -> try d <= IMap.find i m2 with Not_found -> false)
m1
(* Returns true if e₁ and e₂ are equal (upto alpha/beta/...). *)
-let rec conv_p' (ctx : DB.lexp_context) (vs : set_plexp) e1 e2 : bool =
+and conv_p' (ctx : DB.lexp_context) (vs : set_plexp) e1 e2 : bool =
let e1' = lexp_whnf e1 ctx in
let e2' = lexp_whnf e2 ctx in
+ Log.log_debug ("conv_p : e1' = `" ^ (lexp_string e1')
+ ^ "`; e2' = `" ^ (lexp_string e2') ^ "`");
e1' == e2' ||
let changed = not (e1 == e1' && e2 == e2') in
+ Log.log_debug ("changed : " ^ string_of_bool changed);
if changed && set_member_p vs e1' e2' then true else
let vs' = if changed then set_add vs e1' e2' else vs in
let conv_p = conv_p' ctx vs' in
@@ -319,19 +344,119 @@ let rec conv_p' (ctx : DB.lexp_context) (vs : set_plexp) e1 e2 : bool =
| _,_ -> false in
l1 == l2 && conv_args ctx vs' args1 args2
| (Cons (t1, (_, l1)), Cons (t2, (_, l2))) -> l1 = l2 && conv_p t1 t2
- (* I'm not sure to understand how to compare two Metavar *
- * Should I do a `lookup`? Or is it that simple: *)
- (*| (Metavar (id1,_,_), Metavar (id2,_,_)) -> id1 = id2*)
- (* FIXME: Various missing cases, such as Case. *)
- | (_, _) -> false
-
-let conv_p (ctx : DB.lexp_context) e1 e2
+ | (Case (_, te1, r1, cases1, def1), Case (_, te2, r2, cases2, def2))
+ -> Log.log_debug ("conv_p of case : e1' = `" ^ (lexp_string e1')
+ ^ "`; e2' = `" ^ (lexp_string e2') ^ "`");
+ eq e1' e2' ||
+ (Log.log_debug "subexpr"; conv_p te1 te2) &&
+ (Log.log_debug "return"; conv_p r1 r2) && (
+ Log.log_debug "branches";
+ (* Compare the branches *)
+ (* 1. Get the inductive for the field types *)
+ let call_split e = match e with
+ | Call (f, args) -> (f, args)
+ | _ -> (e,[]) in
+ (* We can arbitrarily use te1 since te1 and te2 are convertible *)
+ let etype = lexp_whnf (get_type ctx te1) ctx in
+ let it, aargs = call_split etype in
+ (* 2. Build the substitution for the inductive arguments *)
+ let fargs, ctors =
+ (match lexp_whnf it ctx with
+ | Inductive (_, _, fargs, constructors)
+ -> fargs, constructors
+ | _ -> Log.log_fatal ("Case of non-inductive in conv_p")) in
+ let fargs_subst = List.fold_left2 (fun s _farg (_, aarg) -> S.cons aarg s)
+ S.identity fargs aargs in
+ (* 3. Compare the branches *)
+ (* The map module doesn't have a function to compare two
+ maps with the key (which is needed to get the field
+ types from the inductive. Instead, we work with the
+ lists of associations. *)
+ (try
+ List.for_all2 (fun (l1, (_, fields1, e1)) (l2, (_, fields2, e2)) ->
+ l1 = l2 &&
+ let fieldtypes = SMap.find l1 ctors in
+ let rec mkctx ctx args s i vdefs1 vdefs2 fieldtypes =
+ match vdefs1, vdefs2, fieldtypes with
+ | [], [], [] -> Some (ctx, List.rev args, s)
+ | (ak1, vdef1)::vdefs1, (ak2, vdef2)::vdefs2,
+ (ak', vdef', ftype)::fieldtypes
+ -> if ak1 = ak2 && ak2 = ak' then
+ (* FIXME Should we compare the variable names ? *)
+ mkctx
+ (DB.lexp_ctx_cons ctx vdef1 Variable (mkSusp ftype s))
+ ((ak1, (mkVar (vdef1, i)))::args)
+ (ssink vdef1 s)
+ (i - 1)
+ vdefs1 vdefs2 fieldtypes
+ else None
+ | _,_,_ -> None in
+ match mkctx ctx [] fargs_subst (List.length fields1)
+ fields1 fields2 fieldtypes with
+ | None -> false
+ | Some (nctx, args, _subst) ->
+ (* TODO build head lexp the eq type *)
+ let offset = (List.length fields1) in
+ let subst = S.shift offset in
+ Log.log_debug "hlxp time";
+ let tlxp = mkSusp te1 subst in
+ Log.log_debug ("tlxp : `" ^ (lexp_string tlxp) ^ "`");
+ let tltp = mkSusp etype subst in
+ Log.log_debug ("etype : `" ^ (lexp_string etype) ^ "`");
+ Log.log_debug ("subst : `" ^ (subst_string subst) ^ "`");
+ Log.log_debug ("tltp : `" ^ (lexp_string tltp) ^ "`");
+ let tlev = (match lexp_whnf (get_type nctx tltp) nctx with
+ | Sort (_, Stype l) -> l
+ | _ -> Log.log_error "HMMM"; DB.level0) in
+ let ctor = mkSusp (mkCall (mkCons (it, (DB.dloc, l1)), aargs)) subst in
+ Log.log_debug ("ctor : `" ^ (lexp_string ctor) ^ "`");
+ let hlxp = mkCall (ctor, args) in
+ Log.log_debug ("hlxp : `" ^ (lexp_string hlxp) ^ "`");
+ let eqty = mkCall (DB.type_eq,
+ [(Aerasable, tlev); (* Typelevel *)
+ (Aerasable, tltp); (* Inductive type *)
+ (Anormal, tlxp); (* Target lexp *)
+ (Anormal, hlxp)]) in (* Lexp of the branch head *)
+ let nctx = DB.lexp_ctx_cons nctx (DB.dloc, None) Variable eqty in
+ conv_p' nctx (set_shift_n vs' (offset + 1)) e1 e2
+ ) (SMap.bindings cases1) (SMap.bindings cases2)
+ with
+ | Invalid_argument _ -> false (* If the lists have different length *)
+ )
+ && (match (def1, def2) with
+ | (Some (v1, e1), Some (v2, e2)) ->
+ (* FIXME should we compare the variable names ? *)
+ Log.log_debug "default";
+ let nctx = DB.lctx_extend ctx v1 Variable etype in
+ let subst = S.shift 1 in
+ let tlxp = mkSusp e1 subst in
+ let tltp = mkSusp etype subst in
+ let tlev = (match lexp_whnf (get_type nctx tltp) nctx with
+ | Sort (_, Stype l) -> l
+ | _ -> Log.log_error "HMMM"; DB.level0) in
+ let hlxp = mkVar ((DB.dloc, None), 0) in
+ let eqty = mkCall (DB.type_eq,
+ [(Aerasable, tlev); (* Typelevel *)
+ (Aerasable, tltp); (* Inductive type *)
+ (Anormal, tlxp); (* Target lexp *)
+ (Anormal, hlxp)]) in (* Lexp of the branch head *)
+ let nctx = DB.lexp_ctx_cons nctx (DB.dloc, None) Variable eqty in
+ conv_p' nctx (set_shift_n vs' 2) e1 e2
+ | None, None -> true
+ | _, _ -> false))
+ (* I'm not sure to understand how to compare two Metavar *
+ * Should I do a `lookup`? Or is it that simple: *)
+ (*| (Metavar (id1,_,_), Metavar (id2,_,_)) -> id1 = id2*)
+ (* FIXME: Various missing cases, such as Case. *)
+ | (_, _) -> false
+
+and conv_p (ctx : DB.lexp_context) e1 e2
= if e1 == e2 then true
else conv_p' ctx set_empty e1 e2
(********* Testing if a lexp is properly typed *********)
-let rec mkSLlub ctx e1 e2 =
+and mkSLlub ctx e1 e2 =
match (lexp_whnf e1 ctx, lexp_whnf e2 ctx) with
| (SortLevel SLz, _) -> e2
| (_, SortLevel SLz) -> e1
@@ -344,13 +469,7 @@ let rec mkSLlub ctx e1 e2 =
else if level_leq ce2 ce1 then e1
else mkSortLevel (mkSLlub' (e1, e2)) (* FIXME: Could be more canonical *)
-type sort_compose_result
- = SortResult of ltype
- | SortInvalid
- | SortK1NotType
- | SortK2NotType
-
-let sort_compose ctx1 ctx2 l ak k1 k2 =
+and sort_compose ctx1 ctx2 l ak k1 k2 =
(* BEWARE! Technically `k2` can refer to `v`, but this should only happen
* if `v` is a TypeLevel. *)
match (lexp_whnf k1 ctx1, lexp_whnf k2 ctx2) with
@@ -388,11 +507,11 @@ let sort_compose ctx1 ctx2 l ak k1 k2 =
| (Sort (_, _), _) -> SortK2NotType
| (_, _) -> SortK1NotType
-let dbset_push ak erased =
+and dbset_push ak erased =
let nerased = DB.set_sink 1 erased in
if ak = P.Aerasable then DB.set_set 0 nerased else nerased
-let nerased_let defs erased =
+and nerased_let defs erased =
(* Let bindings are not erasable, with the important exception of
* let-bindings of the form `x = y` where `y` is an erasable var.
* This exception is designed so that macros like `case` which need to
@@ -418,7 +537,7 @@ let nerased_let defs erased =
erased es
(* "check ctx e" should return τ when "Δ ⊢ e : τ" *)
-let rec check'' erased ctx e =
+and check'' erased ctx e =
let check = check'' in
let assert_type ctx e t t' =
if conv_p ctx t t' then ()
@@ -610,24 +729,38 @@ let rec check'' erased ctx e =
SMap.iter
(fun name (l, vdefs, branch)
-> let fieldtypes = SMap.find name constructors in
- let rec mkctx erased ctx s vdefs fieldtypes =
+ let rec mkctx erased ctx s hlxp vdefs fieldtypes =
match vdefs, fieldtypes with
- | [], [] -> (erased, ctx)
+ | [], [] -> (erased, ctx, hlxp)
(* FIXME: If ak is Aerasable, make sure the var only
* appears in type annotations. *)
| (ak, vdef)::vdefs, (ak', vdef', ftype)::fieldtypes
-> mkctx (dbset_push ak erased)
(DB.lexp_ctx_cons ctx vdef Variable (mkSusp ftype s))
- (S.cons (mkVar (vdef, 0))
- (S.mkShift s 1))
+ (ssink vdef s)
+ (mkCall (mkSusp hlxp (S.shift 1), [(ak, mkVar (vdef, 0))]))
vdefs fieldtypes
| _,_ -> (error_tc ~loc:l
"Wrong number of args to constructor!";
- (erased, ctx)) in
- let (nerased, nctx) = mkctx erased ctx s vdefs fieldtypes in
+ (erased, ctx, hlxp)) in
+ let hctor = mkCall (mkCons (it, (l, name)), aargs) in
+ let (nerased, nctx, hlxp) =
+ mkctx erased ctx s hctor vdefs fieldtypes in
+ (* Create Eq type between target and lexp matching the
+ branch head, and add it (erasable) to the context *)
+ let subst = S.shift (List.length vdefs) in
+ let tlxp = mkSusp e subst in
+ let tltp = mkSusp etype subst in
+ let eqty = mkCall (DB.type_eq,
+ [(Aerasable, DB.type0); (* Typelevel *) (* FIXME The real typelevel *)
+ (Aerasable, tltp); (* Inductive type *)
+ (Anormal, tlxp); (* Target lexp *)
+ (Anormal, hlxp)]) in (* Lexp of the branch head *)
+ let nerased = dbset_push Aerasable nerased in (* The eq proof is erasable *)
+ let nctx = DB.lexp_ctx_cons nctx (l, None) Variable eqty in
assert_type nctx branch
(check nerased nctx branch)
- (mkSusp ret (S.shift (List.length fieldtypes))))
+ (mkSusp ret (S.shift ((List.length fieldtypes) + 1))))
branches;
let diff = SMap.cardinal constructors - SMap.cardinal branches in
(match default with
@@ -635,8 +768,21 @@ let rec check'' erased ctx e =
-> if diff <= 0 then
warning_tc ~loc:l "Redundant default clause";
let nctx = (DB.lctx_extend ctx v (LetDef (0, e)) etype) in
- assert_type nctx d (check (DB.set_sink 1 erased) nctx d)
- (mkSusp ret (S.shift 1))
+ let nerased = DB.set_sink 1 erased in
+ let subst = S.shift 1 in
+ (* FIXME DRY this code *)
+ let tlxp = mkSusp e subst in
+ let tltp = mkSusp etype subst in
+ let hlxp = mkVar ((l, None), 0) in
+ let eqty = mkCall (DB.type_eq,
+ [(Aerasable, DB.type0); (* Typelevel *) (* FIXME The real typelevel *)
+ (Aerasable, tltp); (* Inductive type *)
+ (Anormal, tlxp); (* Target lexp *)
+ (Anormal, hlxp)]) in (* Lexp of the branch head *)
+ let nerased = dbset_push Aerasable nerased in (* The eq proof is erasable *)
+ let nctx = DB.lexp_ctx_cons nctx (l, None) Variable eqty in
+ assert_type nctx d (check nerased nctx d)
+ (mkSusp ret (S.shift 2))
| None
-> if diff > 0 then
error_tc ~loc:l ("Non-exhaustive match: "
@@ -682,24 +828,21 @@ let rec check'' erased ctx e =
check erased ctx e
| MVar (_, t, _) -> push_susp t s)
-let check' ctx e =
+and check' ctx e =
let res = check'' DB.set_empty ctx e in
(Log.stop_on_error (); res)
-let check = check'
+and check ctx e = check' ctx e
(** Compute the set of free (meta)variables. **)
-let rec list_union l1 l2 = match l1 with
+and list_union l1 l2 = match l1 with
| [] -> l2
| (x::l1) -> list_union l1 (if List.mem x l2 then l2 else (x::l2))
-type mv_set = (scope_level * ltype * ctx_length * vname) IMap.t
- (* Metavars that appear in non-erasable positions. *)
- * unit IMap.t
-let mv_set_empty : mv_set = (IMap.empty, IMap.empty)
-let mv_set_add (ms, nes) id x : mv_set = (IMap.add id x ms, IMap.add id () nes)
-let mv_set_union ((ms1, nes1) : mv_set) ((ms2, nes2) : mv_set) : mv_set
+and mv_set_empty : mv_set = (IMap.empty, IMap.empty)
+and mv_set_add (ms, nes) id x : mv_set = (IMap.add id x ms, IMap.add id () nes)
+and mv_set_union ((ms1, nes1) : mv_set) ((ms2, nes2) : mv_set) : mv_set
= (IMap.merge (fun _m oss1 oss2
-> match (oss1, oss2) with
| (None, _) -> oss2
@@ -715,23 +858,19 @@ let mv_set_union ((ms1, nes1) : mv_set) ((ms2, nes2) : mv_set) : mv_set
Some ss1)
ms1 ms2,
IMap.merge (fun _m _o1 _o2 -> Some ()) nes1 nes2)
-let mv_set_erase (ms, _nes) = (ms, IMap.empty)
+and mv_set_erase (ms, _nes) = (ms, IMap.empty)
-module LMap
- (* Memoization table. FIXME: Ideally the keys should be "weak", but
- * I haven't found any such functionality in OCaml's libs. *)
- = Hashtbl.Make
- (struct type t = lexp let hash = Hashtbl.hash let equal = (==) end)
-let fv_memo = LMap.create 1000
+and fv_memo = LMap.create 1000
+and fv_flush () = LMap.clear fv_memo
-let fv_empty = (DB.set_empty, mv_set_empty)
-let fv_union (fv1, mv1) (fv2, mv2)
+and fv_empty = (DB.set_empty, mv_set_empty)
+and fv_union (fv1, mv1) (fv2, mv2)
= (DB.set_union fv1 fv2, mv_set_union mv1 mv2)
-let fv_sink n (fvs, mvs) = (DB.set_sink n fvs, mvs)
-let fv_hoist n (fvs, mvs) = (DB.set_hoist n fvs, mvs)
-let fv_erase (fvs, mvs) = (fvs, mv_set_erase mvs)
+and fv_sink n (fvs, mvs) = (DB.set_sink n fvs, mvs)
+and fv_hoist n (fvs, mvs) = (DB.set_hoist n fvs, mvs)
+and fv_erase (fvs, mvs) = (fvs, mv_set_erase mvs)
-let rec fv (e : lexp) : (DB.set * mv_set) =
+and fv (e : lexp) : (DB.set * mv_set) =
let fv' e = match e with
| Imm _ -> fv_empty
| SortLevel SLz -> fv_empty
@@ -784,9 +923,9 @@ let rec fv (e : lexp) : (DB.set * mv_set) =
-> let s = fv_union (fv e) (fv_erase (fv t)) in
let s = match def with
| None -> s
- | Some (_, e) -> fv_union s (fv_hoist 1 (fv e)) in
+ | Some (_, e) -> fv_union s (fv_hoist 2 (fv e)) in
SMap.fold (fun _ (_, fields, e) s
- -> fv_union s (fv_hoist (List.length fields) (fv e)))
+ -> fv_union s (fv_hoist (List.length fields + 1) (fv e)))
cases s
| Metavar (id, s, name)
-> (match metavar_lookup id with
@@ -806,7 +945,7 @@ let rec fv (e : lexp) : (DB.set * mv_set) =
(** Finding the type of a expression. **)
(* This should never signal any warning/error. *)
-let rec get_type ctx e =
+and get_type ctx e =
match e with
| Imm (Float (_, _)) -> DB.type_float
| Imm (Integer (_, _)) -> DB.type_int
@@ -933,7 +1072,7 @@ let rec erase_type (lxp: L.lexp): E.elexp =
| L.Case(l, target, _, cases, default) ->
E.Case(l, (erase_type target), (clean_map cases),
- (clean_maybe default))
+ (clean_default default))
| L.Susp(l, s) -> erase_type (L.push_susp l s)
@@ -962,10 +1101,12 @@ and filter_arg_list lst =
and clean_decls decls =
List.map (fun (v, lxp, _) -> (v, (erase_type lxp))) decls
-and clean_maybe lxp =
- match lxp with
- | Some (v, lxp) -> Some (v, erase_type lxp)
- | None -> None
+and clean_default lxp =
+ match lxp with
+ | Some (v, lxp) ->
+ Some (v,
+ erase_type (L.push_susp lxp (S.substitute DB.type0)))
+ | None -> None
and clean_map cases =
let clean_arg_list lst =
@@ -979,7 +1120,8 @@ and clean_map cases =
clean_arg_list lst [] in
SMap.map (fun (l, args, expr)
- -> (l, (clean_arg_list args), (erase_type expr)))
+ -> (l, (clean_arg_list args),
+ erase_type (L.push_susp expr (S.substitute DB.type0))))
cases
(** Turning a set of declarations into an object. **)
=====================================
src/unification.ml
=====================================
@@ -46,6 +46,7 @@ let create_metavar (ctx : DB.lexp_context) (sl : scope_level) (t : ltype)
type constraint_kind =
| CKimpossible (* Unification is simply impossible. *)
| CKresidual (* We failed to find a unifier. *)
+ | CKassoc (* Couldn't associate because of checking mode *)
(* FIXME: Each constraint should additionally come with a description of how
it relates to its "top-level" or some other info which might let us
fix the problem (e.g. by introducing coercions). *)
@@ -54,8 +55,9 @@ type constraints = (constraint_kind * DB.lexp_context * lexp * lexp) list
type return_type = constraints
(** Alias for VMap.add*)
-let associate (id: meta_id) (lxp: lexp) (subst: meta_subst) : meta_subst
- = U.IMap.add id (MVal lxp) subst
+let associate (id: meta_id) (lxp: lexp) : unit
+ = metavar_table := U.IMap.add id (MVal lxp) (!metavar_table);
+ OL.fv_flush ()
let occurs_in (id: meta_id) (e : lexp) : bool = match metavar_lookup id with
| MVal _ -> Log.internal_error
@@ -174,13 +176,15 @@ let rec s_offset s = match s with
The metavar unifier is the end rule, it can't call unify with its parameter (changing their order)
*)
-let rec unify (e1: lexp) (e2: lexp)
+let rec unify ?checking
+ (e1: lexp) (e2: lexp)
(ctx : DB.lexp_context)
: return_type =
- unify' e1 e2 ctx OL.set_empty
+ unify' e1 e2 ctx OL.set_empty checking
and unify' (e1: lexp) (e2: lexp)
(ctx : DB.lexp_context) (vs : OL.set_plexp)
+ (c : scope_level option) (* checking mode scope level *)
: return_type =
if e1 == e2 then [] else
let e1' = OL.lexp_whnf e1 ctx in
@@ -190,20 +194,26 @@ and unify' (e1: lexp) (e2: lexp)
if changed && OL.set_member_p vs e1' e2' then [] else
let vs' = if changed then OL.set_add vs e1' e2' else vs in
match (e1', e2') with
- | ((Imm _, Imm _) | (Cons _, Cons _) | (Builtin _, Builtin _)
- | (Var _, Var _))
+ | ((Imm _, Imm _) | (Cons _, Cons _) | (Builtin _, Builtin _))
-> if OL.conv_p ctx e1' e2' then [] else [(CKimpossible, ctx, e1, e2)]
- | (l, (Metavar (idx, s, _) as r)) -> unify_metavar ctx idx s r l
- | ((Metavar (idx, s, _) as l), r) -> unify_metavar ctx idx s l r
- | (l, (Call _ as r)) -> unify_call r l ctx vs'
- (* | (l, (Case _ as r)) -> unify_case r l subst *)
- | (Arrow _ as l, r) -> unify_arrow l r ctx vs'
- | (Lambda _ as l, r) -> unify_lambda l r ctx vs'
- | (Call _ as l, r) -> unify_call l r ctx vs'
- (* | (Case _ as l, r) -> unify_case l r subst *)
- (* | (Inductive _ as l, r) -> unify_induct l r subst *)
- | (Sort _ as l, r) -> unify_sort l r ctx vs'
- | (SortLevel _ as l, r) -> unify_sortlvl l r ctx vs'
+ | (l, (Metavar (idx, s, _) as r)) -> unify_metavar c ctx idx s r l
+ | ((Metavar (idx, s, _) as l), r) -> unify_metavar c ctx idx s l r
+ | (l, (Call _ as r)) -> unify_call c r l ctx vs'
+ | ((Call _ as l), r) -> unify_call c l r ctx vs'
+ | (l, (Var _ as r)) -> unify_var r l ctx vs'
+ | ((Var _ as l), r) -> unify_var l r ctx vs'
+ | (l, (Arrow _ as r)) -> unify_arrow c r l ctx vs'
+ | ((Arrow _ as l), r) -> unify_arrow c l r ctx vs'
+ | (l, (Lambda _ as r)) -> unify_lambda c r l ctx vs'
+ | ((Lambda _ as l), r) -> unify_lambda c l r ctx vs'
+ (* | (l, (Case _ as r)) -> unify_case r l subst *)
+ (* | ((Case _ as l), r) -> unify_case l r subst *)
+ (* | (l, (Inductive _ as r)) -> unify_induct r l subst *)
+ (* | ((Inductive _ as l), r) -> unify_induct l r subst *)
+ | (l, (Sort _ as r)) -> unify_sort c r l ctx vs'
+ | ((Sort _ as l), r) -> unify_sort c l r ctx vs'
+ | (l, (SortLevel _ as r)) -> unify_sortlvl c r l ctx vs'
+ | ((SortLevel _ as l), r) -> unify_sortlvl c l r ctx vs'
| (Inductive (_loc1, label1, args1, consts1),
Inductive (_loc2, label2, args2, consts2))
-> (* print_string ("Unifying inductives "
@@ -211,7 +221,7 @@ and unify' (e1: lexp) (e2: lexp)
* ^ " and "
* ^ snd label2
* ^ "\n"); *)
- unify_inductive ctx vs' args1 args2 consts1 consts2 e1 e2
+ unify_inductive c ctx vs' args1 args2 consts1 consts2 e1 e2
| _ -> (if OL.conv_p ctx e1' e2' then []
else ((* print_string "Unification failure on default\n"; *)
[(CKresidual, ctx, e1, e2)]))
@@ -222,87 +232,77 @@ and unify' (e1: lexp) (e2: lexp)
- (Arrow, Arrow) -> if var_kind = var_kind
then unify ltype & lexp (Arrow (var_kind, _, ltype, lexp))
else None
- - (Arrow, Var) -> Constraint
- (_, _) -> None
*)
-and unify_arrow (arrow: lexp) (lxp: lexp) ctx vs
+and unify_arrow (checking : scope_level option) (arrow: lexp) (lxp: lexp) ctx vs
: return_type =
match (arrow, lxp) with
| (Arrow (var_kind1, v1, ltype1, _, lexp1),
Arrow (var_kind2, _, ltype2, _, lexp2))
-> if var_kind1 = var_kind2
- then (unify' ltype1 ltype2 ctx vs)
+ then (unify' ltype1 ltype2 ctx vs checking)
@(unify' lexp1 (srename v1 lexp2)
(DB.lexp_ctx_cons ctx v1 Variable ltype1)
- (OL.set_shift vs))
- else [(CKimpossible, ctx, arrow, lxp)]
- | (Arrow _, Imm _) -> [(CKimpossible, ctx, arrow, lxp)]
- | (Arrow _, Var _) -> ([(CKresidual, ctx, arrow, lxp)])
- | (Arrow _, _) -> unify' lxp arrow ctx vs
+ (OL.set_shift vs) checking)
+ else [(CKimpossible, ctx, arrow, lxp)]
| (_, _) -> [(CKimpossible, ctx, arrow, lxp)]
(** Unify a Lambda and a lexp if possible
- - Lamda , Lambda -> if var_kind = var_kind
+ - Lambda , Lambda -> if var_kind = var_kind
then UNIFY ltype & lxp else ERROR
- - Lambda , Var -> CONSTRAINT
- - Lambda , Call -> Constraint
- - Lambda , Let -> Constraint
- - Lambda , lexp -> unify lexp lambda subst
+ - Lambda , _ -> Impossible
*)
-and unify_lambda (lambda: lexp) (lxp: lexp) ctx vs : return_type =
+and unify_lambda (checking : scope_level option) (lambda: lexp) (lxp: lexp) ctx vs : return_type =
match (lambda, lxp) with
| (Lambda (var_kind1, v1, ltype1, lexp1),
Lambda (var_kind2, _, ltype2, lexp2))
-> if var_kind1 = var_kind2
- then (unify' ltype1 ltype2 ctx vs)
+ then (unify' ltype1 ltype2 ctx vs checking)
@(unify' lexp1 lexp2
(DB.lexp_ctx_cons ctx v1 Variable ltype1)
- (OL.set_shift vs))
+ (OL.set_shift vs) checking)
else [(CKimpossible, ctx, lambda, lxp)]
- | ((Lambda _, Var _)
- | (Lambda _, Let _)
- | (Lambda _, Call _)) -> [(CKresidual, ctx, lambda, lxp)]
- | (Lambda _, Arrow _)
- | (Lambda _, Imm _) -> [(CKimpossible, ctx, lambda, lxp)]
- | (Lambda _, _) -> unify' lxp lambda ctx vs
- | (_, _) -> [(CKimpossible, ctx, lambda, lxp)]
+ | (_, _) -> [(CKimpossible, ctx, lambda, lxp)]
(** Unify a Metavar and a lexp if possible
- - lexp , {metavar <-> none} -> UNIFY
- - lexp , {metavar <-> lexp} -> UNFIFY lexp subst[metavar]
- - metavar , metavar -> if Metavar = Metavar then OK else ERROR
- - metavar , lexp -> OK
+ - metavar , metavar -> if Metavar = Metavar then intersect
+ - metavar , metavar -> inverse subst (both sides)
+ - metavar , lexp -> inverse subst
*)
-and unify_metavar ctx idx s1 (lxp1: lexp) (lxp2: lexp)
+and unify_metavar (checking : scope_level option) ctx idx s1 (lxp1: lexp) (lxp2: lexp)
: return_type =
let unif idx s lxp =
- let t = match metavar_lookup idx with
+ let t, sl = match metavar_lookup idx with
| MVal _ -> Log.internal_error
"`lexp_whnf` returned an instantiated metavar!!"
- | MVar (_, t, _) -> push_susp t s in
+ | MVar (_, t, sl) -> push_susp t s, sl in
match Inverse_subst.apply_inv_subst lxp s with
| exception Inverse_subst.Not_invertible
- -> log_info ?loc:None ("Unification of metavar failed:\n "
- ^ "?[" ^ subst_string s ^ "]"
- ^ "\nAgainst:\n "
- ^ lexp_string lxp ^ "\n");
+ -> log_info ~loc:(lexp_location lxp)
+ ("Unification of metavar failed:\n "
+ ^ "?[" ^ subst_string s ^ "]"
+ ^ "\nAgainst:\n "
+ ^ lexp_string lxp ^ "\n");
[(CKresidual, ctx, lxp1, lxp2)]
| lxp' when occurs_in idx lxp' -> [(CKimpossible, ctx, lxp1, lxp2)]
| lxp'
- -> metavar_table := associate idx lxp' (!metavar_table);
- match unify t (OL.get_type ctx lxp) ctx with
- | [] as r -> r
- (* FIXME: Let's ignore the error for now. *)
- | _
- -> log_info ?loc:None
- ("Unification of metavar type failed:\n "
- ^ lexp_string t ^ " != "
- ^ lexp_string (OL.get_type ctx lxp)
- ^ "\n" ^ "for " ^ lexp_string lxp ^ "\n");
- [(CKresidual, ctx, lxp1, lxp2)] in
+ -> match checking with
+ | Some l when l >= sl -> [(CKassoc, ctx, lxp1, lxp2)]
+ | _ -> (
+ associate idx lxp';
+ match unify t (OL.get_type ctx lxp) ctx with
+ | [] as r -> r
+ (* FIXME: Let's ignore the error for now. *)
+ | _
+ -> log_info ?loc:None
+ ("Unification of metavar type failed:\n "
+ ^ lexp_string t ^ " != "
+ ^ lexp_string (OL.get_type ctx lxp)
+ ^ "\n" ^ "for " ^ lexp_string lxp ^ "\n");
+ [(CKresidual, ctx, lxp1, lxp2)]) in
match lxp2 with
| Metavar (idx2, s2, name)
- -> if idx = idx2 then
+ -> if idx = idx2 && checking == None then
match common_subset ctx s1 s2 with
| S.Identity 0 -> [] (* Optimization! *)
(* ¡ s1 != s2 !
@@ -353,7 +353,7 @@ and unify_metavar ctx idx s1 (lxp1: lexp) (lxp2: lexp)
* ^ "\n =\n "
* ^ subst_string (scompose s s2)
* ^ "\n"); *)
- metavar_table := associate idx lexp (!metavar_table);
+ associate idx lexp;
assert (OL.conv_p ctx lxp1 lxp2);
[]
else
@@ -364,18 +364,28 @@ and unify_metavar ctx idx s1 (lxp1: lexp) (lxp2: lexp)
| _ -> unif idx2 s2 lxp1)
| _ -> unif idx s1 lxp2
+(** Unify a Var (var) and a lexp (lxp)
+ - Var , Var -> IF same var THEN ok ELSE constraint
+ - Var , lexp -> Constraint
+*)
+and unify_var (var: lexp) (lxp: lexp) ctx vs
+ : return_type =
+ match (var, lxp) with
+ | (Var _, Var _) when OL.conv_p ctx var lxp -> []
+ | (_, _) -> [(CKresidual, ctx, var, lxp)]
+
(** Unify a Call (call) and a lexp (lxp)
- Call , Call -> UNIFY
- Call , lexp -> CONSTRAINT
*)
-and unify_call (call: lexp) (lxp: lexp) ctx vs
+and unify_call (checking : scope_level option) (call: lexp) (lxp: lexp) ctx vs
: return_type =
match (call, lxp) with
| (Call (lxp_left, lxp_list1), Call (lxp_right, lxp_list2))
when OL.conv_p ctx lxp_left lxp_right
-> List.fold_left (fun op ((ak1, e1), (ak2, e2))
-> if ak1 == ak2 then
- (unify' e1 e2 ctx vs)@op
+ (unify' e1 e2 ctx vs checking)@op
else [(CKimpossible, ctx, call, lxp)])
[]
(List.combine lxp_list1 lxp_list2)
@@ -438,31 +448,29 @@ and unify_call (call: lexp) (lxp: lexp) ctx vs
- SortLevel, SortLevel -> if SortLevel ~= SortLevel then OK else ERROR
- SortLevel, _ -> ERROR
*)
-and unify_sortlvl (sortlvl: lexp) (lxp: lexp) ctx vs : return_type =
+and unify_sortlvl (checking : scope_level option) (sortlvl: lexp) (lxp: lexp) ctx vs : return_type =
match sortlvl, lxp with
| (SortLevel s, SortLevel s2) -> (match s, s2 with
| SLz, SLz -> []
- | SLsucc l1, SLsucc l2 -> unify' l1 l2 ctx vs
+ | SLsucc l1, SLsucc l2 -> unify' l1 l2 ctx vs checking
| SLlub (l11, l12), SLlub (l21, l22)
-> (* FIXME: This SLlub representation needs to be
* more "canonicalized" otherwise it's too restrictive! *)
- (unify' l11 l21 ctx vs)@(unify' l12 l22 ctx vs)
+ (unify' l11 l21 ctx vs checking)@(unify' l12 l22 ctx vs checking)
| _, _ -> [(CKimpossible, ctx, sortlvl, lxp)])
| _, _ -> [(CKresidual, ctx, sortlvl, lxp)]
(** Unify a Sort and a lexp
- Sort, Sort -> if Sort ~= Sort then OK else ERROR
- - Sort, Var -> Constraint
- Sort, lexp -> ERROR
*)
-and unify_sort (sort_: lexp) (lxp: lexp) ctx vs : return_type =
+and unify_sort (checking : scope_level option) (sort_: lexp) (lxp: lexp) ctx vs : return_type =
match sort_, lxp with
| (Sort (_, srt), Sort (_, srt2)) -> (match srt, srt2 with
- | Stype lxp1, Stype lxp2 -> unify' lxp1 lxp2 ctx vs
+ | Stype lxp1, Stype lxp2 -> unify' lxp1 lxp2 ctx vs checking
| StypeOmega, StypeOmega -> []
| StypeLevel, StypeLevel -> []
| _, _ -> [(CKimpossible, ctx, sort_, lxp)])
- | Sort _, Var _ -> [(CKresidual, ctx, sort_, lxp)]
| _, _ -> [(CKimpossible, ctx, sort_, lxp)]
(************************ Helper function ************************************)
@@ -513,7 +521,7 @@ and is_same arglist arglist2 =
* | None -> test e subst)
* ) None lst *)
-and unify_inductive ctx vs args1 args2 consts1 consts2 e1 e2 =
+and unify_inductive (checking : scope_level option) ctx vs args1 args2 consts1 consts2 e1 e2 =
let unif_formals ctx vs args1 args2
= if not (List.length args1 == List.length args2) then
(ctx, vs, [(CKimpossible, ctx, e1, e2)])
@@ -522,7 +530,7 @@ and unify_inductive ctx vs args1 args2 consts1 consts2 e1 e2 =
-> (DB.lexp_ctx_cons ctx v1 Variable t1,
OL.set_shift vs,
if not (ak1 == ak2) then [(CKimpossible, ctx, e1, e2)]
- else (unify' t1 t2 ctx vs) @ residue))
+ else (unify' t1 t2 ctx vs checking) @ residue))
(ctx, vs, [])
(List.combine args1 args2) in
let (ctx, vs, residue) = unif_formals ctx vs args1 args2 in
=====================================
tests/unify_test.ml
=====================================
@@ -199,6 +199,7 @@ let test_input (lxp1: lexp) (lxp2: lexp): unif_res =
else (Unification, res, lxp1, lxp2)
| (CKresidual, _, _, _)::_ -> (Constraint, res, lxp1, lxp2)
| (CKimpossible, _, _, _)::_ -> (Nothing, res, lxp1, lxp2)
+ | _ -> failwith "impossible"
let check (lxp1: lexp) (lxp2: lexp) (res: result): bool =
let r, _, _, _ = test_input lxp1 lxp2
View it on GitLab: https://gitlab.com/monnier/typer/-/compare/a6e5e687015ef495363178f9f8891261…
--
View it on GitLab: https://gitlab.com/monnier/typer/-/compare/a6e5e687015ef495363178f9f8891261…
You're receiving this email because of your account on gitlab.com.
1
0
[Git][monnier/typer][ja-barszcz] 30 commits: * btl/builtins.typer (Eq_comm): Update FIXME
by Jean-Alexandre Barszcz 19 Aoû '20
by Jean-Alexandre Barszcz 19 Aoû '20
19 Aoû '20
Jean-Alexandre Barszcz pushed to branch ja-barszcz at Stefan / Typer
Commits:
2bd6aa15 by Stefan Monnier at 2020-08-10T23:52:31-04:00
* btl/builtins.typer (Eq_comm): Update FIXME
- - - - -
f04cab52 by Jean-Alexandre Barszcz at 2020-08-19T17:14:33-04:00
Delay parsing of declarations until elaboration for define-operator
* elab.ml (lexp_p_decls): Add a parameter for unparsed tokens, so that
later declarations can be parsed in a context with newly declared
operators
- - - - -
456370bc by Jean-Alexandre Barszcz at 2020-08-19T17:14:33-04:00
Remove the parsing error for tightly binding postfix operators
- - - - -
8beb9266 by Jean-Alexandre Barszcz at 2020-08-19T17:14:33-04:00
Dump the evaluation context when the variable names don't match
- - - - -
2e00884b by Jean-Alexandre Barszcz at 2020-08-19T17:14:33-04:00
Assign the builtins Int.+, etc to suitable variables Int_+, etc.
_+_ can be Int.+ by default, but we should also keep that value in
Int_+ in case _+_ gets reassigned (with a num typeclass, for
instance).
- - - - -
baeefc84 by Jean-Alexandre Barszcz at 2020-08-19T17:14:33-04:00
Apply the instanciated metavariable substs when displaying lexps
- - - - -
785f7194 by Jean-Alexandre Barszcz at 2020-08-19T17:41:38-04:00
Replace instanciated metavars when checking syntactic equality
- - - - -
5dc41cb5 by Jean-Alexandre Barszcz at 2020-08-19T17:41:38-04:00
[WIP] Make unification symmetric
- - - - -
b24651cf by Jean-Alexandre Barszcz at 2020-08-19T17:41:38-04:00
[WIP] Handle variables earlier during unification
- - - - -
ff15b9bf by Jean-Alexandre Barszcz at 2020-08-19T17:41:38-04:00
[WIP] experiments with Decidable and proofs
- - - - -
7f3efef9 by Jean-Alexandre Barszcz at 2020-08-19T17:41:38-04:00
[WIP] unify instead of conv_p in sform_lambda
- - - - -
e0cc1ee7 by Jean-Alexandre Barszcz at 2020-08-19T17:41:38-04:00
[WIP] proof of Decidable (a < b)
- - - - -
b3cf0b55 by Jean-Alexandre Barszcz at 2020-08-19T17:41:38-04:00
[WIP] First draft of an instance search algorithm
- - - - -
82322188 by Jean-Alexandre Barszcz at 2020-08-19T17:41:38-04:00
WIP WIP WIP
- - - - -
824bf9af by Jean-Alexandre Barszcz at 2020-08-19T17:41:38-04:00
WIP WIP getting there
- - - - -
1d95d938 by Jean-Alexandre Barszcz at 2020-08-19T17:41:38-04:00
[WIP] Add a set of typeclasses to the elab context
- - - - -
d3956bb9 by Jean-Alexandre Barszcz at 2020-08-19T17:41:38-04:00
[WIP] Add a syntax for records
- - - - -
5d320fcb by Jean-Alexandre Barszcz at 2020-08-19T17:41:38-04:00
[WIP] Extend the Decidable sample with conjunction (dep on records)
- - - - -
2b9a43b2 by Jean-Alexandre Barszcz at 2020-08-19T17:41:38-04:00
Resolve instances in the REPL (since exprs. are not generalized)
- - - - -
63c21f3c by Jean-Alexandre Barszcz at 2020-08-19T17:41:38-04:00
Resolve instances for recursive definitions
- - - - -
a11fe53d by Jean-Alexandre Barszcz at 2020-08-19T17:41:38-04:00
[WIP] Do the set_getenv
IIRC these were missing to correctly handle the elab context for macro
expansion and Elab_... primitives. Perhaps it would be simpler to call
set_getenv once before macro expansion rather than everywhere where
the context can change. Needs some experimentation and tests.
- - - - -
59739897 by Jean-Alexandre Barszcz at 2020-08-19T17:41:38-04:00
Num class example
- - - - -
18f5ae08 by Jean-Alexandre Barszcz at 2020-08-19T17:41:38-04:00
Num class (with records)
- - - - -
cb4d6cba by Jean-Alexandre Barszcz at 2020-08-19T17:41:38-04:00
Allow non-inductives to be typeclasses (Eq for instance)
- - - - -
be4bf5b6 by Jean-Alexandre Barszcz at 2020-08-19T17:41:38-04:00
Move the Eq builtin to debruijn.ml to make it available for elab.
- - - - -
9776b75d by Jean-Alexandre Barszcz at 2020-08-19T17:41:38-04:00
Make Eq.refl available to the ocaml code
* src/debruijn.ml : Add a definition of the lexp for Eq.refl
* src/builtin.ml : Register the constant Eq.refl
* btl/builtins.typer (Eq_refl) : Use the builtin variable ##Eq.refl
instead of registering the builtin with the `Built-in` form. This
ensures that we have the right variable and type, and might help to
keep things in sync between the ocaml and typer code.
- - - - -
a8488c58 by Jean-Alexandre Barszcz at 2020-08-19T17:41:38-04:00
[WIP] Add Eq to case
- - - - -
81c414f9 by Jean-Alexandre Barszcz at 2020-08-19T17:41:38-04:00
[WIP] Adding Eq to Case: mutual rec for (whnf & get_type) + conv_p of case?
- - - - -
2d37bcab by Jean-Alexandre Barszcz at 2020-08-19T17:41:38-04:00
[WIP] Fix whnf of case??
TODO test and explain the problem
- - - - -
a6e5e687 by Jean-Alexandre Barszcz at 2020-08-19T17:41:38-04:00
Algebra classes sample with proof of associativity of +
- - - - -
23 changed files:
- btl/builtins.typer
- btl/pervasive.typer
- + btl/records.typer
- + samples/alg_classes.typer
- + samples/decidable.typer
- + samples/num_class.typer
- + samples/num_class_recs.typer
- src/REPL.ml
- src/builtin.ml
- src/debruijn.ml
- src/debug_util.ml
- src/elab.ml
- src/env.ml
- src/eval.ml
- + src/instances.ml
- src/inverse_subst.ml
- src/lexp.ml
- src/log.ml
- src/myers.ml
- src/opslexp.ml
- src/sexp.ml
- src/unification.ml
- tests/unify_test.ml
Changes:
=====================================
btl/builtins.typer
=====================================
@@ -47,8 +47,8 @@ Void = typecons Void;
%% Eq : (l : TypeLevel) ≡> (t : Type_ l) ≡> t -> t -> Type_ l
%% Eq' : (l : TypeLevel) ≡> Type_ l -> Type_ l -> Type_ l
-Eq_refl : ((x : ?t) ≡> Eq x x); % FIXME: `Eq ?x ?x` causes an error!
-Eq_refl = Built-in "Eq.refl";
+Eq_refl : ((x : ?t) ≡> Eq x x);
+Eq_refl = ##Eq\.refl;
Eq_cast : (x : ?) ≡> (y : ?)
≡> (p : Eq x y)
@@ -63,8 +63,11 @@ Eq_cast = Built-in "Eq.cast";
%% Eq_comm : Eq ?x ?y -> Eq ?y ?x`;
Eq_comm : (x : ?t) ≡> (y : ?t) ≡> Eq x y -> Eq y x;
Eq_comm p = Eq_cast (f := lambda xy -> Eq xy x)
- %% FIXME: I can't figure out how `(p := p)`
- %% gets inferred here, yet it seems to work!?!
+ %% FIXME: The code is incorrectly accepted even without
+ %% this `(p := p)` because we just get a metavar which
+ %% remains uninstantiated and undetected (and then gets
+ %% throw away by erasure)!
+ (p := p)
Eq_refl;
%% General recursion!!
@@ -77,7 +80,7 @@ Eq_comm p = Eq_cast (f := lambda xy -> Eq xy x)
%%
%% But this is not sufficient, because you could use `Y` to create
%% new recursive *types* which then let you construct new arbitrary
-%% recursive values of previously uninhabited types.
+%% recursive values of previously non-existent types.
%% E.g. you could create `Y <something> = ((... → t) -> t) -> t`
%% and then give the term `λx. x x` inhabiting that type, and from that
%% get a proof of False.
@@ -100,10 +103,15 @@ true = datacons Bool true;
false = datacons Bool false;
%% Basic operators
-_+_ = Built-in "Int.+" : Int -> Int -> Int;
-_-_ = Built-in "Int.-" : Int -> Int -> Int;
-_*_ = Built-in "Int.*" : Int -> Int -> Int;
-_/_ = Built-in "Int./" : Int -> Int -> Int;
+Int_+ = Built-in "Int.+" : Int -> Int -> Int;
+Int_- = Built-in "Int.-" : Int -> Int -> Int;
+Int_* = Built-in "Int.*" : Int -> Int -> Int;
+Int_/ = Built-in "Int./" : Int -> Int -> Int;
+
+_+_ = Int_+;
+_-_ = Int_-;
+_*_ = Int_*;
+_/_ = Int_/;
%% modulo
Int_mod = Built-in "Int.mod" : Int -> Int -> Int;
@@ -355,6 +363,12 @@ Elab_isbound = Built-in "Elab.isbound" : String -> Elab_Context -> Bool;
Elab_isconstructor = Built-in "Elab.isconstructor"
: String -> Elab_Context -> Bool;
+%%
+%% Check if a symbol is an inductive in a particular context
+%%
+Elab_isinductive = Built-in "Elab.isinductive"
+ : String -> Elab_Context -> Bool;
+
%%
%% Check if the n'th field of a constructor is erasable
%% If the constructor isn't defined it will always return false
@@ -381,6 +395,20 @@ Elab_nth-arg' = Built-in "Elab.nth-arg" : String -> Int -> Elab_Context -> Strin
%%
Elab_arg-pos' = Built-in "Elab.arg-pos" : String -> String -> Elab_Context -> Int;
+%%
+%% Get the position of a field in a constructor
+%% It return -1 in case the field isn't defined
+%% see pervasive.typer for a more convenient function
+%%
+Elab_ind-ctor-arg-pos' = Built-in "Elab.ind-ctor-arg-pos" : String -> String -> String -> Elab_Context -> Int;
+
+%%
+%% Get the number of fields in a constructor
+%% It return -1 in case the field isn't defined
+%% see pervasive.typer for a more convenient function
+%%
+Elab_count-ctor-args' = Built-in "Elab.count-ctor-args" : String -> String -> Elab_Context -> Int;
+
%%
%% Get the docstring associated with a symbol
%%
=====================================
btl/pervasive.typer
=====================================
@@ -394,7 +394,7 @@ BoolMod = (##datacons
Pair = typecons (Pair (a : Type) (b : Type)) (pair (fst : a) (snd : b));
pair = datacons Pair pair;
-__\.__ =
+dot-impl =
let mksel o f =
let constructor = Sexp_node (Sexp_symbol "##datacons")
(cons (Sexp_symbol "?")
@@ -411,14 +411,15 @@ __\.__ =
(cons (Sexp_node (Sexp_symbol "_|_")
(cons o (cons branch nil)))
nil)
- in macro (lambda args
- -> IO_return
- case args
- | cons o tail
- => (case tail
- | cons f _ => mksel o f
- | nil => Sexp_error)
- | nil => Sexp_error);
+ in (lambda args ->
+ IO_return case args
+ | cons o tail
+ => (case tail
+ | cons f _ => mksel o f
+ | nil => Sexp_error)
+ | nil => Sexp_error);
+
+__\.__ = macro dot-impl;
%% Triplet (tuple with 3 values)
type Triplet (a : Type) (b : Type) (c : Type)
@@ -458,7 +459,8 @@ Not prop = prop -> False;
%% We don't use the `type` macro here because it would make these `true`
%% and `false` constructors override `Bool`'s, and we currently don't
%% want that.
-Decidable = typecons (Decidable (prop : Type_ ?ℓ))
+%% FIXME generalize typecons formal arguments
+Decidable = typecons (Decidable (ℓ ::: TypeLevel) (prop : Type_ ℓ))
(true (p ::: prop)) (false (p ::: Not prop));
%% Testing generalization in inductive type constructors.
@@ -547,6 +549,32 @@ in case (Int_eq r (-1))
| true => (none)
| false => (some r);
+%%
+%% If `Elab_ind-ctor-arg-pos'` returns (-1) it means:
+%% A- The constructor isn't defined, or
+%% B- The constructor has no argument named like this
+%%
+%% So in those case this function returns `none`
+%%
+Elab_ind-ctor-arg-pos a b c d = let
+ r = Elab_ind-ctor-arg-pos' a b c d;
+in case (Int_eq r (-1))
+ | true => (none)
+ | false => (some r);
+
+%%
+%% If `Elab_count-ctor-args'` returns (-1) it means:
+%% A- The constructor isn't defined, or
+%% B- The constructor has no argument named like this
+%%
+%% So in those case this function returns `none`
+%%
+Elab_count-ctor-args a b c = let
+ r = Elab_count-ctor-args' a b c;
+in case (Int_eq r (-1))
+ | true => (none)
+ | false => (some r);
+
%%%%
%%%% Common library
%%%%
@@ -634,6 +662,15 @@ plain-let_in_ = let lib = load "btl/plain-let.typer" in lib.plain-let-macro;
%%
_|_ = let lib = load "btl/polyfun.typer" in lib._|_;
+%%
+%% records : a simple datatype when there is only one case
+%%
+define-operator "#" 200 ();
+records = load "btl/records.typer";
+record = records.record;
+__\.__ = records.__\.__;
+_# = records._#;
+
%%%% Unit tests function for doing file
%% It's hard to do a primitive which execute test file
=====================================
btl/records.typer
=====================================
@@ -0,0 +1,82 @@
+record-impl : List Sexp -> IO Sexp;
+record-impl args =
+ let
+ %% Get a name (symbol) from a sexp
+ %% - (name t) -> name
+ %% - name -> name
+ get-name : Sexp -> Sexp;
+ get-name sxp =
+ case Sexp_wrap sxp
+ | node op _ => get-name op
+ | symbol _ => sxp
+ | _ => Sexp_error;
+
+ %% head is (Sexp_node type-name (arg list))
+ name-args = List_head Sexp_error args;
+ fields = List_tail args;
+
+ type-name = get-name name-args;
+
+ %% Create the inductive type definition.
+ inductive = Sexp_node (Sexp_symbol "typecons")
+ (cons name-args
+ (cons (Sexp_node (Sexp_symbol "rec") fields)
+ nil));
+
+ decl = make-decl type-name inductive;
+
+ in IO_return decl;
+
+record = macro record-impl;
+
+record-get-impl : List Sexp -> IO Sexp;
+record-get-impl args =
+ let
+ get tc f idx nargs ectx =
+ let arg_pats : Sexp -> Int -> Int -> List Sexp;
+ arg_pats s i n =
+ if (Int_eq n 0) then nil
+ else (if (Int_eq i 0)
+ then (cons s (arg_pats s (i - 1) (n - 1)))
+ else (cons (Sexp_symbol "_") (arg_pats s (i - 1) (n - 1))));
+
+ pat = (Sexp_node (quote (datacons (uquote (Sexp_symbol tc)) rec))
+ (arg_pats (Sexp_symbol "v") idx nargs));
+
+ branch = (quote ((uquote pat) => v));
+ in
+ (quote (lambda rec -> (##case_ (_|_ rec (uquote branch)))));
+
+ try-rec-get : List Sexp -> Elab_Context -> Option Sexp;
+ try-rec-get arg ectx =
+ case args
+ | (cons tc (cons f nil)) =>
+ (case (Sexp_wrap tc, Sexp_wrap f)
+ | (symbol tcstr, symbol fstr) =>
+ (case (Elab_count-ctor-args tcstr "rec" ectx,
+ Elab_ind-ctor-arg-pos tcstr "rec" fstr ectx)
+ | (some nargs, some idx) => some (get tcstr fstr idx nargs ectx)
+ | _ => none)
+ | _ => none)
+ | _ => none;
+ in
+ do {
+ ectx <- Elab_getenv ();
+ case try-rec-get args ectx
+ | some sxp => IO_return sxp
+ | _ => dot-impl args; %% Fallback on default dot implementation
+ };
+
+__\.__ = macro record-get-impl;
+
+record-make-impl : List Sexp -> IO Sexp;
+record-make-impl args =
+ IO_return case args
+ | (cons tc nil) => (quote (datacons (uquote tc) rec))
+ | _ => Sexp_error;
+
+_# = macro record-make-impl; %% I was going for a syntax close to
+ %% Erlang's, but the # doesn't separate
+ %% tokens ... Meh.
+
+record (Pair (a : Type) (b : Type)) (fst : a) (snd : a);
=====================================
samples/alg_classes.typer
=====================================
@@ -0,0 +1,84 @@
+case_ = ##case_; %% To ease debugging
+
+type Magma (α : Type)
+ | mkMagma (op : α -> α -> α);
+
+typeclass Magma;
+
+magma_op =
+ lambda magma_inst =>
+ case magma_inst
+ | mkMagma op => op;
+
+Associativity (op : ?α -> ?α -> ?α) =
+ (x : ?α) -> (y : ?α) -> (z : ?α) -> Eq (op (op x y) z) (op x (op y z));
+
+type Semigroup (α : Type)
+ | mkSemigroup (magma : Magma α) (assoc ::: Associativity magma_op);
+
+typeclass Semigroup;
+
+semigroup_magma =
+ lambda semigroup_inst =>
+ case semigroup_inst
+ | mkSemigroup magma => magma;
+
+IsLeftIdentity (id : ?α) (op : ?α -> ?α -> ?α) =
+ (x : ?α) -> Eq (op id x) x;
+
+IsRightIdentity (id : ?α) (op : ?α -> ?α -> ?α) =
+ (x : ?α) -> Eq (op x id) x;
+
+IsIdentity (id : ?α) (op : ?α -> ?α -> ?α) =
+ (Pair (IsLeftIdentity id op) (IsRightIdentity id op));
+
+type Monoid (α : Type)
+ | mkMonoid (semigroup : Semigroup α)
+ (identity : α)
+ (isIdent ::: IsIdentity identity magma_op);
+
+typeclass Monoid;
+
+type Nat
+ | Zero
+ | Succ Nat;
+
+plus : Nat -> Nat -> Nat;
+plus x y =
+ case x
+ | Zero => y
+ | Succ x' => Succ (plus x' y);
+
+natAdditiveMagma =
+ mkMagma plus;
+
+Eq_cong : % not sure about levels here
+ (t : (Type_ ?ℓ)) ≡> (r : (Type_ ?ℓ)) ≡>
+ (x : t) ≡> (y : t) ≡> (p : (Eq x y)) ≡>
+ (f : (t -> r)) -> (Eq (f x) (f y));
+Eq_cong f =
+ Eq_cast (p := p) (f := lambda xy -> Eq (f x) (f xy)) Eq_refl;
+
+natPlusAssoc : Associativity plus;
+natPlusAssoc x y z =
+ let
+ typeclass Eq
+ in
+ case x
+ | Zero => Eq_cast
+ (x := Zero)
+ (y := x)
+ (p := Eq_comm (instance ()))
+ (f := (lambda (Zx : Nat) -> Eq (plus (plus Zx y) z) (plus Zx (plus y z))))
+ Eq_refl
+ | Succ x' =>
+ Eq_cast
+ (x := Succ x')
+ (y := x)
+ (p := Eq_comm (instance ()))
+ (f := (lambda (sx'x : Nat) -> Eq (plus (plus sx'x y) z) (plus sx'x (plus y z))))
+ (Eq_cong (p := natPlusAssoc x' y z) Succ);
+
+natAdditiveSemigroup : Semigroup Nat;
+natAdditiveSemigroup =
+ mkSemigroup natAdditiveMagma (assoc := natPlusAssoc);
=====================================
samples/decidable.typer
=====================================
@@ -0,0 +1,168 @@
+False = Void;
+True = Unit;
+
+% FIXME improved "case" fails with no branches
+exfalso : False -> ?a;
+exfalso f = ##case_ f;
+
+%type Decidable (prop : Type)
+% | yes (p ::: prop)
+% | no (p ::: Not prop);
+yes = datacons Decidable true;
+no = datacons Decidable false;
+
+typeclass Decidable;
+
+Eq_trans :
+ (x : ?t) => (y : ?t) => (a : ?t) ->
+ (ax : Eq a x) => (ay : Eq a y) => Eq x y;
+Eq_trans a =
+ lambda (ax : Eq a x) (ay : Eq a y) =>
+ Eq_cast (f := lambda ax -> Eq ax y) ay;
+
+Eq_cong : % not sure about levels here
+ (t : (Type_ ?ℓ)) ≡> (r : (Type_ ?ℓ)) ≡>
+ (x : t) ≡> (y : t) ≡> (p : (Eq x y)) ≡>
+ (f : (t -> r)) -> (Eq (f x) (f y));
+Eq_cong f =
+ Eq_cast (p := p) (f := lambda xy -> Eq (f x) (f xy)) Eq_refl;
+
+discriminate_nocheck =
+ macro (lambda args ->
+ case args
+ | cons x (cons y nil) =>
+ do {
+ sd <- gensym ();
+ sp <- gensym ();
+ IO_return
+ (quote ((lambda (uquote sp) ->
+ (Eq_cast (p := (uquote sp))
+ (f := (lambda (uquote sd) ->
+ (case uquote sd
+ | (uquote x) => True
+ | _ => False)))
+ ())) : Not (Eq (uquote x) (uquote y))))
+ }
+ | _ => IO_return Sexp_error);
+
+discriminate =
+ macro (lambda args ->
+ case args
+ | cons x (cons y nil) =>
+ (case (Sexp_wrap x, Sexp_wrap y)
+ | (symbol sx, symbol sy) => % FIXME get the constructor even when its a call
+ do {
+ env <- Elab_getenv ();
+ if (and (Elab_isconstructor sx env)
+ (and (Elab_isconstructor sy env)
+ (not (Sexp_eq x y))))
+ then
+ Macro_expand discriminate_nocheck args
+ else (IO_return Sexp_error)
+ }
+ | _ => IO_return Sexp_error)
+ | _ => IO_return Sexp_error);
+
+test : (Not (Eq true false));
+test = discriminate true false;
+
+absurd =
+ lambda (p : ?prop) ->
+ lambda (contra : (Not ?prop)) ->
+ contra p;
+
+% We can't (usefully) have a `Decidable Bool` because it's
+% impossible to have a `Not Bool`. Instead, we can decide boolean
+% equality:
+
+decideBoolEq : (a : Bool) => (b : Bool) => Decidable (Eq a b);
+decideBoolEq =
+ lambda (a : Bool) (b : Bool) =>
+ case (a, b)
+ | (false, false) => yes (p := Eq_trans false)
+ | (false, true) => no (p := lambda (p : Eq a b) ->
+ absurd (Eq_trans (ax := Eq_trans a) b) (discriminate false true))
+ | (true, false) => no (p := lambda (p : Eq a b) ->
+ absurd (Eq_trans (ax := Eq_trans a) b) (discriminate true false))
+ | (true, true) => yes (p := Eq_trans true);
+
+type Nat
+ | zero
+ | succ Nat;
+
+type even (a : Nat)
+ | eZ (p ::: Eq a zero)
+ | eSS (p :: even ?a) (pss ::: Eq a (succ (succ ?a)));
+
+decideEven : (a : Nat) => Decidable (even a);
+decideEven =
+ lambda (a : Nat) =>
+ case a
+ | zero => yes (p := eZ)
+ | succ zero => no (p :=
+ lambda (p : even a) ->
+ case p
+ | eZ => absurd (Eq_trans a) (discriminate_nocheck zero (succ zero))
+ | eSS => absurd (Eq_trans a) (discriminate_nocheck (succ (succ ?)) (succ zero)))
+ | succ (succ a') =>
+ case (decideEven : Decidable (even a'))
+ | yes => yes (p := eSS)
+ | no => no (p :=
+ lambda (p : even a) ->
+ case p
+ | eZ => absurd (Eq_trans a) (discriminate_nocheck zero (succ (succ ?)))
+ | eSS => absurd (? : even a') (? : Not (even a')));
+
+type _<_ (a : Nat) (b : Nat)
+ | ltZ (pa ::: Eq a zero) (pb ::: Eq b (succ ?b))
+ | ltS (p :: (?a < ?b)) (pa ::: Eq a (succ ?a)) (pb ::: Eq b (succ ?b));
+
+decideLT : (a : Nat) => (b : Nat) => Decidable (a < b);
+decideLT =
+ lambda a b =>
+ case b
+ | zero => no (p :=
+ lambda (p : (a < b)) ->
+ case p
+ | ltZ => absurd (Eq_trans b) (discriminate_nocheck zero (succ ?))
+ | ltS => absurd (Eq_trans b) (discriminate_nocheck zero (succ ?)))
+ | succ b' =>
+ case a
+ | zero => yes (p := ltZ)
+ | succ a' =>
+ case (decideLT : (Decidable (a' < b')))
+ | yes => yes (p := ltS)
+ | no => no (p :=
+ lambda (p : (a < b)) ->
+ case p
+ | ltZ => absurd (Eq_trans a) (discriminate_nocheck zero (succ ?))
+ | ltS => absurd (? : (a' < b')) (? : Not (a' < b')));
+
+define-operator "∧" 111 130;
+
+record ((a : Type) ∧ (b : Type)) (fst : a) (snd : b);
+
+decideAnd : (P : Type) ≡> (Q : Type) ≡>
+ (Decidable P) => (Decidable Q) => (Decidable (P ∧ Q));
+decideAnd =
+ lambda P Q ≡>
+ lambda (decP : Decidable P) (decQ : Decidable Q) =>
+ case (decP, decQ)
+ | (yes (p := pP), yes (p := pQ)) => yes (p := _∧_ # pP pQ)
+ | (no (p := nP), _) =>
+ no (p := (lambda (proofs : P ∧ Q) -> absurd (_∧_.fst proofs) nP))
+ | (_, no (p := nQ)) =>
+ no (p := (lambda (proofs : P ∧ Q) -> absurd (_∧_.snd proofs) nQ));
+
+if_then_else_
+ = macro (lambda args ->
+ let e1 = List_nth 0 args Sexp_error;
+ e2 = List_nth 1 args Sexp_error;
+ e3 = List_nth 2 args Sexp_error;
+ in IO_return (quote (case (instance () : (Decidable (uquote e1)))
+ | yes => uquote e2
+ | no => uquote e3)));
+
+test2 : Bool;
+test2 = if ((even (succ zero)) ∧ (zero < zero)) then false else true;
+
=====================================
samples/num_class.typer
=====================================
@@ -0,0 +1,39 @@
+type Num (α : Type)
+ | mkNum (Num_+ : α -> α -> α)
+ (Num_- : α -> α -> α)
+ (Num_* : α -> α -> α)
+ (Num_/ : α -> α -> α);
+
+typeclass Num;
+
+_+_ = lambda numInst => case numInst | mkNum _+_ _ _ _ => _+_;
+_-_ = lambda numInst => case numInst | mkNum _ _-_ _ _ => _-_;
+_*_ = lambda numInst => case numInst | mkNum _ _ _*_ _ => _*_;
+_/_ = lambda numInst => case numInst | mkNum _ _ _ _/_ => _/_;
+
+IntNum : Num Int;
+IntNum =
+ mkNum (Num_+ := Int_+) (Num_- := Int_-) (Num_* := Int_*) (Num_/ := Int_/);
+
+IntegerNum : Num Integer;
+IntegerNum =
+ mkNum (Num_+ := Integer_+) (Num_- := Integer_-)
+ (Num_* := Integer_*) (Num_/ := Integer_/);
+
+FloatNum : Num Float;
+FloatNum =
+ mkNum (Num_+ := Float_+) (Num_- := Float_-)
+ (Num_* := Float_*) (Num_/ := Float_/);
+
+type FromInt (α : Type)
+ | mkFromInt (FromInt_fromInt : Int -> α);
+
+typeclass FromInt;
+
+fromInt = lambda fromIntInst => case fromIntInst | mkFromInt fromInt => fromInt;
+
+IntFromInt : FromInt Int;
+IntFromInt = mkFromInt (lambda x -> x);
+
+IntegerFromInt : FromInt Integer;
+IntegerFromInt = mkFromInt Int->Integer;
=====================================
samples/num_class_recs.typer
=====================================
@@ -0,0 +1,33 @@
+record (Num (α : Type))
+ (_+_ : α -> α -> α)
+ (_-_ : α -> α -> α)
+ (_*_ : α -> α -> α)
+ (_/_ : α -> α -> α);
+
+typeclass Num;
+
+_+_ = lambda numInst => Num._+_ numInst;
+_-_ = lambda numInst => Num._-_ numInst;
+_*_ = lambda numInst => Num._*_ numInst;
+_/_ = lambda numInst => Num._/_ numInst;
+
+IntNum : Num Int;
+IntNum = Num # Int_+ Int_- Int_* Int_/;
+
+IntegerNum : Num Integer;
+IntegerNum = Num # Integer_+ Integer_- Integer_* Integer_/;
+
+FloatNum : Num Float;
+FloatNum = Num # Float_+ Float_- Float_* Float_/;
+
+record (FromInt (α : Type)) (fromInt : Int -> α);
+
+typeclass FromInt;
+
+fromInt = lambda fromIntInst => FromInt.fromInt fromIntInst;
+
+IntFromInt : FromInt Int;
+IntFromInt = FromInt # (lambda x -> x);
+
+IntegerFromInt : FromInt Integer;
+IntegerFromInt = FromInt # Int->Integer;
=====================================
src/REPL.ml
=====================================
@@ -135,8 +135,11 @@ let ierase_type (lexps: (ldecl list list * lexpr list)) =
let ilexp_parse pexps lctx: ((ldecl list list * lexpr list) * elab_context) =
let pdecls, pexprs = pexps in
- let ldecls, lctx = Elab.lexp_p_decls pdecls lctx in
+ (* FIXME We take the parsed input here but we should take the
+ unparsed tokens directly instead *)
+ let ldecls, lctx = Elab.lexp_p_decls pdecls [] lctx in
let lexprs = Elab.lexp_parse_all pexprs lctx in
+ List.iter Elab.resolve_instances lexprs;
List.iter (fun lxp -> ignore (OL.check (ectx_to_lctx lctx) lxp))
lexprs;
(ldecls, lexprs), lctx
@@ -164,8 +167,7 @@ let ieval f str ectx rctx =
let raw_eval f str ectx rctx =
let pres = (f str) in
let sxps = lex default_stt pres in
- let nods = sexp_parse_all_to_list (ectx_to_grm ectx) sxps (Some ";") in
- let lxps, ectx = Elab.lexp_p_decls nods ectx in
+ let lxps, ectx = Elab.lexp_p_decls [] sxps ectx in
let elxps = List.map OL.clean_decls lxps in
(* At this point, `elxps` is a `(vname * elexp) list list`, where:
* - each `(vname * elexp)` is a definition
=====================================
src/builtin.ml
=====================================
@@ -99,19 +99,6 @@ let dloc = DB.dloc
let op_binary t = mkArrow (Anormal, (dloc, None), t, dloc,
mkArrow (Anormal, (dloc, None), t, dloc, t))
-let type_eq =
- let lv = (dloc, Some "l") in
- let tv = (dloc, Some "t") in
- mkArrow (Aerasable, lv,
- DB.type_level, dloc,
- mkArrow (Aerasable, tv,
- mkSort (dloc, Stype (mkVar (lv, 0))), dloc,
- mkArrow (Anormal, (dloc, None),
- mkVar (tv, 0), dloc,
- mkArrow (Anormal, (dloc, None),
- mkVar (tv, 1), dloc,
- mkSort (dloc, Stype (mkVar (lv, 3)))))))
-
let o2l_bool ctx b = get_predef (if b then "true" else "false") ctx
(* Typer list as seen during runtime. *)
@@ -161,7 +148,9 @@ let register_builtin_csts () =
add_builtin_cst "Integer" DB.type_integer;
add_builtin_cst "Float" DB.type_float;
add_builtin_cst "String" DB.type_string;
- add_builtin_cst "Elab_Context" DB.type_elabctx
+ add_builtin_cst "Elab_Context" DB.type_elabctx;
+ add_builtin_cst "Eq" DB.type_eq;
+ add_builtin_cst "Eq.refl" DB.eq_refl
let register_builtin_types () =
let _ = new_builtin_type "Sexp" DB.type0 in
@@ -175,7 +164,6 @@ let register_builtin_types () =
"Array" (mkArrow (Anormal, (dloc, None),
DB.type0, dloc, DB.type0)) in
let _ = new_builtin_type "FileHandle" DB.type0 in
- let _ = new_builtin_type "Eq" type_eq in
()
let _ = register_builtin_csts ();
=====================================
src/debruijn.ml
=====================================
@@ -94,6 +94,37 @@ let type_integer = mkBuiltin ((dloc, "Integer"), type0, None)
let type_float = mkBuiltin ((dloc, "Float"), type0, None)
let type_string = mkBuiltin ((dloc, "String"), type0, None)
let type_elabctx = mkBuiltin ((dloc, "Elab_Context"), type0, None)
+let type_eq_type =
+ let lv = (dloc, Some "l") in
+ let tv = (dloc, Some "t") in
+ mkArrow (Aerasable, lv,
+ type_level, dloc,
+ mkArrow (Aerasable, tv,
+ mkSort (dloc, Stype (mkVar (lv, 0))), dloc,
+ mkArrow (Anormal, (dloc, None),
+ mkVar (tv, 0), dloc,
+ mkArrow (Anormal, (dloc, None),
+ mkVar (tv, 1), dloc,
+ mkSort (dloc, Stype (mkVar (lv, 3)))))))
+let type_eq = mkBuiltin ((dloc, "Eq"), type_eq_type, None)
+let eq_refl =
+ let lv = (dloc, Some "l") in
+ let tv = (dloc, Some "t") in
+ let xv = (dloc, Some "x") in
+ mkBuiltin ((dloc, "Eq.refl"),
+ mkArrow (Aerasable, lv,
+ type_level, dloc,
+ mkArrow (Aerasable, tv,
+ mkSort (dloc, Stype (mkVar (lv, 0))), dloc,
+ mkArrow (Aerasable, xv,
+ mkVar (tv, 0), dloc,
+ mkCall (type_eq,
+ [Aerasable, mkVar (lv, 2);
+ Aerasable, mkVar (tv, 1);
+ Anormal, mkVar (xv, 0);
+ Anormal, mkVar (xv, 0)])))),
+ None)
+
(* easier to debug with type annotations *)
type env_elem = (vname * varbind * ltype)
@@ -112,26 +143,29 @@ type meta_scope
* lctx_length (* Length of ctx when the scope is added. *)
* (meta_id SMap.t ref) (* Metavars already known in this scope. *)
+type typeclass_ctx
+ = (ltype * lctx_length) list (* FIXME make it a set of lexps ? *)
+
(* This is the *elaboration context* (i.e. a context that holds
* a lexp context plus some side info. *)
type elab_context
- = Grammar.grammar * senv_type * lexp_context * meta_scope
+ = Grammar.grammar * senv_type * lexp_context * meta_scope * typeclass_ctx
let get_size (ctx : elab_context)
- = let (_, (n, _), lctx, _) = ctx in
+ = let (_, (n, _), lctx, _, _) = ctx in
assert (n = M.length lctx); n
let ectx_to_grm (ectx : elab_context) : Grammar.grammar =
- let (grm,_, _, _) = ectx in grm
+ let (grm,_, _, _, _) = ectx in grm
(* Extract the lexp context from the context used during elaboration. *)
let ectx_to_lctx (ectx : elab_context) : lexp_context =
- let (_,_, lctx, _) = ectx in lctx
+ let (_,_, lctx, _, _) = ectx in lctx
-let ectx_to_scope_level ((_, _, _, (sl, _, _)) : elab_context) : scope_level
+let ectx_to_scope_level ((_, _, _, (sl, _, _), _) : elab_context) : scope_level
= sl
-let ectx_local_scope_size ((_, (n, _), _, (_, slen, _)) as ectx) : int
+let ectx_local_scope_size ((_, (n, _), _, (_, slen, _), _) as ectx) : int
= get_size ectx - slen
(* Public methods: DO USE
@@ -142,7 +176,7 @@ let empty_lctx = M.nil
let empty_elab_context : elab_context
= (Grammar.default_grammar, empty_senv, empty_lctx,
- (0, 0, ref SMap.empty))
+ (0, 0, ref SMap.empty), [])
(* senv_lookup caller were using Not_found exception *)
exception Senv_Lookup_Fail of (string list)
@@ -150,7 +184,7 @@ let senv_lookup_fail relateds = raise (Senv_Lookup_Fail relateds)
(* Return its current DeBruijn index. *)
let senv_lookup (name: string) (ctx: elab_context): int =
- let (_, (n, map), _, _) = ctx in
+ let (_, (n, map), _, _, _) = ctx in
try n - (SMap.find name map) - 1
with Not_found
-> let get_related_names (n : db_ridx) name map =
@@ -189,11 +223,11 @@ let lctx_extend (ctx : lexp_context) (def: vname) (v: varbind) (t: lexp) =
let env_extend_rec (ctx: elab_context) (def: vname) (v: varbind) (t: lexp) =
let (loc, oname) = def in
- let (grm, (n, map), env, sl) = ctx in
+ let (grm, (n, map), env, sl, tcctx) = ctx in
let nmap = match oname with None -> map | Some name -> SMap.add name n map in
(grm, (n + 1, nmap),
lexp_ctx_cons env def v t,
- sl)
+ sl, tcctx)
let ectx_extend (ctx: elab_context) (def: vname) (v: varbind) (t: lexp) = env_extend_rec ctx def v t
@@ -207,28 +241,33 @@ let lctx_extend_rec (ctx : lexp_context) (defs: (vname * lexp * ltype) list) =
ctx
let ectx_extend_rec (ctx: elab_context) (defs: (vname * lexp * ltype) list) =
- let (grm, (n, senv), lctx, sl) = ctx in
+ let (grm, (n, senv), lctx, sl, tcctx) = ctx in
let senv', _ = List.fold_left
(fun (senv, i) ((_, oname), _, _) ->
(match oname with None -> senv
| Some name -> SMap.add name i senv),
i + 1)
(senv, n) defs in
- (grm, (n + List.length defs, senv'), lctx_extend_rec lctx defs, sl)
+ (grm, (n + List.length defs, senv'), lctx_extend_rec lctx defs, sl, tcctx)
let ectx_new_scope (ectx : elab_context) : elab_context =
- let (grm, senv, lctx, (scope, _, rmmap)) = ectx in
- (grm, senv, lctx, (scope + 1, Myers.length lctx, ref (!rmmap)))
+ let (grm, senv, lctx, (scope, _, rmmap), tcctx) = ectx in
+ (grm, senv, lctx, (scope + 1, Myers.length lctx, ref (!rmmap)), tcctx)
let ectx_get_scope (ectx : elab_context) : meta_scope =
- let (_, _, _, sl) = ectx in sl
+ let (_, _, _, sl, _) = ectx in sl
let ectx_get_grammar (ectx : elab_context) : Grammar.grammar =
- let (grm, _, _, _) = ectx in grm
+ let (grm, _, _, _, _) = ectx in grm
let env_lookup_by_index index (ctx: lexp_context): env_elem =
Myers.nth index ctx
+let env_add_typeclass (ectx : elab_context) (t : ltype) : elab_context =
+ let (grm, senv, lctx, sl, tcctx) = ectx in
+ let ntcctx = ((t, get_size ectx) :: tcctx) in
+ (grm, senv, lctx, sl, ntcctx)
+
(* Print context *)
let print_lexp_ctx_n (ctx : lexp_context) start =
let n = (M.length ctx) - 1 in
=====================================
src/debug_util.ml
=====================================
@@ -138,8 +138,6 @@ let arg_defs = [
Arg.Unit (add_p_option "pretok"), " Print pretok debug info");
("-tok",
Arg.Unit (add_p_option "tok"), " Print tok debug info");
- ("-sexp",
- Arg.Unit (add_p_option "sexp"), " Print sexp debug info");
("-pexp",
Arg.Unit (add_p_option "pexp"), " Print pexp debug info");
("-lexp",
@@ -152,7 +150,6 @@ let arg_defs = [
Arg.Unit (fun () ->
add_p_option "pretok" ();
add_p_option "tok" ();
- add_p_option "sexp" ();
add_p_option "pexp" ();
add_p_option "lexp" ();
add_p_option "lctx" ();
@@ -165,7 +162,6 @@ let parse_args () =
let make_default () =
arg_print_options := SMap.empty;
- add_p_option "sexp" ();
add_p_option "pexp" ();
add_p_option "lexp" ()
@@ -176,10 +172,8 @@ let format_source () =
let filename = List.hd (!arg_files) in
let pretoks = prelex_file filename in
let toks = lex default_stt pretoks in
- let nodes = sexp_parse_all_to_list (ectx_to_grm Elab.default_ectx)
- toks (Some ";") in
let ctx = Elab.default_ectx in
- let lexps, _ = Elab.lexp_p_decls nodes ctx in
+ let lexps, _ = Elab.lexp_p_decls [] toks ctx in
print_string (make_sep '-'); print_string "\n";
@@ -235,26 +229,12 @@ let main () =
print_string (make_title " Base Sexp");
debug_sexp_print_all toks; print_string "\n"));
- (* get node sexp *)
- print_string yellow;
- let nodes = sexp_parse_all_to_list (ectx_to_grm Elab.default_ectx)
- toks (Some ";") in
- print_string reset;
-
- (if (get_p_option "sexp") then(
- print_string (make_title " Node Sexp ");
- debug_sexp_print_all nodes; print_string "\n"));
-
- (* Parse All Declaration *)
- print_string yellow;
- print_string reset;
-
(* get lexp *)
let octx = Elab.default_ectx in
(* debug lexp parsing once merged *)
print_string yellow;
- let lexps, nctx = try Elab.lexp_p_decls nodes octx
+ let lexps, nctx = try Elab.lexp_p_decls [] toks octx
with e ->
print_string reset;
raise e in
=====================================
src/elab.ml
=====================================
@@ -57,6 +57,7 @@ open Grammar
module BI = Builtin
module Unif = Unification
+module Inst = Instances
module OL = Opslexp
module EL = Elexp
@@ -238,9 +239,9 @@ let ctx_define_rec (ctx: elab_context) decls =
* infer the types and perform macro-expansion.
*
* More specifically, we do it with 2 mutually recursive functions:
- * - `check` takes a Pexp along with its expected type and returns an Lexp
+ * - `check` takes an Sexp along with its expected type and returns an Lexp
* of that type (hopefully)
- * - `infer` takes a Pexp and infers its type (which it returns along with
+ * - `infer` takes an Sexp and infers its type (which it returns along with
* the Lexp).
* This is the idea of "bidirectional type checking", which minimizes
* the amount of "guessing" and/or annotations. Since we infer types anyway
@@ -257,6 +258,13 @@ let newMetavar (ctx : lexp_context) sl name t =
let meta = Unif.create_metavar ctx sl t in
mkMetavar (meta, S.identity, name)
+let newInstanceMetavar (ctx : elab_context) name t =
+ let lctx = ectx_to_lctx ctx in
+ let sl = ectx_to_scope_level ctx in
+ let meta = Unif.create_metavar lctx sl t in
+ Inst.add_instance_metavar meta ctx (fst name);
+ mkMetavar (meta, S.identity, name)
+
let newMetalevel (ctx : lexp_context) sl loc =
newMetavar ctx sl (loc, Some "ℓ") type_level
@@ -280,8 +288,8 @@ let sdform_define_operator (ctx : elab_context) loc sargs _ot : elab_context =
| Symbol (_, "") -> None
| Integer (_, n) -> Some n
| _ -> sexp_error (sexp_location s) "Expecting an integer or ()"; None in
- let (grm, a, b, c) = ctx in
- (SMap.add name (level l, level r) grm, a, b, c)
+ let (grm, a, b, c, d) = ctx in
+ (SMap.add name (level l, level r) grm, a, b, c, d)
| [o; _; _]
-> sexp_error (sexp_location o) "Expecting a string"; ctx
| _
@@ -466,11 +474,11 @@ let rec meta_to_var ids (e : lexp) =
-> let ncases
= SMap.map
(fun (l, fields, e)
- -> (l, fields, loop (o + List.length fields) e))
+ -> (l, fields, loop (o + List.length fields + 1) e))
cases in
mkCase (l, loop o e, loop o t, ncases,
match default with None -> None
- | Some (v, e) -> Some (v, loop (1 + o) e))
+ | Some (v, e) -> Some (v, loop (2 + o) e))
| Metavar (id, s, name)
-> if IMap.mem id ids then
mkVar (name, o + count - IMap.find id ids)
@@ -625,12 +633,83 @@ and get_implicit_arg ctx loc oname t =
and instantiate_implicit e t ctx =
let rec instantiate t args =
match OL.lexp_whnf t (ectx_to_lctx ctx) with
+ | Arrow ((Aerasable | Aimplicit) as ak, (_, v), t1, _, t2) when Inst.is_typeclass ctx t1
+ -> let arg = newInstanceMetavar ctx (lexp_location e, v) t1 in
+ instantiate (mkSusp t2 (S.substitute arg)) ((ak, arg)::args)
| Arrow ((Aerasable | Aimplicit) as ak, (_, v), t1, _, t2)
-> let arg = get_implicit_arg ctx (lexp_location e) v t1 in
instantiate (mkSusp t2 (S.substitute arg)) ((ak, arg)::args)
| _ -> (mkCall (e, List.rev args), t)
in instantiate t []
+and myers_filter_map_index (f : int -> 'a -> 'b option) (m : 'a M.myers)
+ : ('b M.myers)
+ = snd (M.fold_right
+ (fun x (i, l') ->
+ match (f i x) with
+ | Some y -> (i - 1, M.cons y l')
+ | None -> (i - 1, l'))
+ m (M.length m - 1, M.nil))
+
+and search_instance (ctx : elab_context) (loc : location) (t : ltype) : lexp option =
+ Log.log_debug ~loc ("Searching for t = `" ^ (lexp_string t) ^ "`");
+ let ctx = ectx_new_scope ctx in
+ let lctx = (ectx_to_lctx ctx) in
+ let sl = (ectx_to_scope_level ctx) in
+ let env_elem_match (i : int) (elem : DB.env_elem) : (int * DB.env_elem * lexp * ltype) option =
+ let ((_, namopt), _, t') = elem in
+ let var = mkVar ((loc,namopt), i) in
+ let t' = mkSusp t' (S.shift (i + 1)) in
+ let (e, t') = instantiate_implicit var t' ctx in
+ (* All candidates should have a type that is a typeclass *)
+ if not (Inst.is_typeclass ctx t') then None else
+ match Inst.check_typeclass_match t t' lctx sl with
+ | (Impossible | Possible) -> None
+ (* | Possible -> None *)
+ | (Match) -> Some (i, elem, e, t') in
+ let candidates =
+ myers_filter_map_index env_elem_match lctx in
+ Log.log_debug ("Candidates for instance of type `" ^ lexp_string t ^ "`:")
+ ~print_action:(fun () ->
+ M.iter (fun (i, ((_, so),_,t'),_, _) ->
+ lalign_print_int i 4;
+ lalign_print_string (match so with | Some s -> s | None -> "<none>") 10;
+ print_endline (lexp_string t')) candidates);
+ match M.safe_car candidates with
+ | None -> None
+ | Some (i, (vname, _, t'),e,t) ->
+ let t' = mkSusp t' (S.shift (i + 1)) in
+ Log.log_debug ~loc
+ ("Found candidate at index " ^ (string_of_int i) ^ ": `" ^
+ (lexp_string (Var (vname, i))) ^ " : " ^ (lexp_string t') ^ "`");
+ Some e
+
+and resolve_instances e =
+ let (_, (fv_map, _)) = OL.fv e in
+ U.IMap.iter (fun i (sl, t, cl, vn) ->
+ match Inst.instance_metavar_lookup i with
+ | Some (ctx, loc) ->
+ (match search_instance ctx loc t with
+ | Some e -> Unif.associate i e; resolve_instances e
+ | None ->
+ error ~loc ("No instance found for type `" ^ (lexp_string t) ^ "`")
+ )
+ | None -> ()
+ ) fv_map
+
+
+and resolve_instances_and_generalize ctx e =
+ resolve_instances e;
+ generalize ctx e
+
+and sdform_typeclass (ctx : elab_context) loc sargs _ot : elab_context =
+ match sargs with
+ | [se] ->
+ let (t, _) = infer se ctx in
+ Inst.add_typeclass ctx t
+ | _
+ -> sexp_error loc "typeclass expects 1 argument"; ctx
+
and infer_type pexp ectx var =
(* We could also use lexp_check with an argument of the form
* Sort (?s), but in most cases the metavar would be allocated
@@ -707,7 +786,8 @@ and check_inferred ctx e inferred_t t =
-> lexp_error (lexp_location e) e
("Type mismatch("
^ (match ck with | Unif.CKimpossible -> "impossible"
- | Unif.CKresidual -> "residue")
+ | Unif.CKresidual -> "residue"
+ | _ -> failwith "impossible" )
^ ")! Context expected:\n "
^ lexp_string t ^ "\nbut expression has type:\n "
^ lexp_string inferred_t ^ "\ncan't unify:\n "
@@ -738,16 +818,16 @@ and check_case rtype (loc, target, ppatterns) ctx =
let ltarget = ref tlxp in
let get_cs_as it' lctor =
+ let unify_ind expected actual =
+ match Unif.unify actual expected (ectx_to_lctx ctx) with
+ | (_::_)
+ -> lexp_error loc lctor
+ ("Expected pattern of type `" ^ lexp_string expected
+ ^ "` but got `" ^ lexp_string actual ^ "`")
+ | [] -> () in
match !it_cs_as with
| Some (it, cs, args)
- -> let _ = match Unif.unify it' it (ectx_to_lctx ctx) with
- | (_::_)
- -> lexp_error loc lctor
- ("Expected pattern of type `"
- ^ lexp_string it ^ "` but got `"
- ^ lexp_string it' ^ "`")
- | [] -> () in
- (cs, args)
+ -> unify_ind it it'; (cs, args)
| None
-> match OL.lexp_whnf it' (ectx_to_lctx ctx) with
| Inductive (_, _, fargs, constructors)
@@ -768,6 +848,7 @@ and check_case rtype (loc, target, ppatterns) ctx =
with | Call (f, args) -> (f, args)
| _ -> (e,[]) in
let (it, targs) = call_split tltp in
+ unify_ind it it';
let constructors = match OL.lexp_whnf it (ectx_to_lctx ctx) with
| Inductive (_, _, fargs, constructors)
-> assert (List.length fargs = List.length targs);
@@ -776,14 +857,42 @@ and check_case rtype (loc, target, ppatterns) ctx =
("Can't `case` on objects of this type: "
^ lexp_string tltp);
SMap.empty in
+ it_cs_as := Some (it, constructors, targs);
(constructors, targs) in
(* Read patterns one by one *)
let fold_fun (lbranches, dflt) (pat, pexp) =
+ let shift_to_extended_ctx nctx lexp =
+ mkSusp lexp (S.shift (M.length (ectx_to_lctx nctx)
+ - M.length (ectx_to_lctx ctx))) in
+
+ let ctx_extend_with_eq nctx head_lexp =
+ (* Add a proof of equality between the target and the branch
+ head to the context *)
+ let tlxp' = shift_to_extended_ctx nctx tlxp in
+ let tltp' = shift_to_extended_ctx nctx tltp in
+ let tkind = OL.get_type (ectx_to_lctx nctx) tltp' in
+ let tlevel = (match OL.lexp_whnf tkind (ectx_to_lctx nctx) with
+ | Sort (_, Stype l) -> l
+ | _ -> error "HMMM"; DB.level0) in
+ let head_lexp_type = OL.get_type (ectx_to_lctx nctx) head_lexp in
+ (match Unif.unify tltp' head_lexp_type (ectx_to_lctx nctx) with
+ | [] -> ()
+ | constraints -> Log.log_error "Unification failed for case Eq");
+ let eqty = mkCall (DB.type_eq,
+ [(Aerasable, tlevel); (* Typelevel *)
+ (Aerasable, tltp'); (* Inductive type *)
+ (Anormal, tlxp'); (* Target lexp *)
+ (Anormal, head_lexp)]) (* Lexp of the branch head *)
+ in ctx_extend nctx (loc, None) Variable eqty
+ in
+
let add_default v =
(if dflt != None then uniqueness_warn pat);
let nctx = ctx_extend ctx v Variable tltp in
+ let head_lexp = mkVar (v, 0) in
+ let nctx = ctx_extend_with_eq nctx head_lexp in
let rtype' = mkSusp rtype (S.shift (M.length (ectx_to_lctx nctx)
- M.length (ectx_to_lctx ctx))) in
let lexp = check pexp rtype' nctx in
@@ -864,6 +973,15 @@ and check_case rtype (loc, target, ppatterns) ctx =
make_nctx nctx (ssink var s) pargs cargs pe
((ak, var)::acc) in
let nctx, fargs = make_nctx ctx subst pargs cargs SMap.empty [] in
+ let head_lexp_ctor =
+ shift_to_extended_ctx nctx
+ (mkCall (lctor, List.map (fun (_, a) -> (Aerasable, a)) targs)) in
+ let head_lexp_args =
+ List.mapi (fun i (ak, vname) ->
+ (* This is not pretty :( *)
+ (ak, mkVar (vname, List.length fargs - i - 1))) fargs in
+ let head_lexp = mkCall (head_lexp_ctor, head_lexp_args) in
+ let nctx = ctx_extend_with_eq nctx head_lexp in
let rtype' = mkSusp rtype
(S.shift (M.length (ectx_to_lctx nctx)
- M.length (ectx_to_lctx ctx))) in
@@ -946,11 +1064,13 @@ and elab_call ctx (func, ltp) (sargs: sexp list) =
(* Don't instantiate after the last explicit arg: the rest is done,
* when needed in infer_and_check (via instantiate_implicit). *)
when not (sargs = [] && SMap.is_empty pending)
- -> let larg = get_implicit_arg
- ctx (match sargs with
- | [] -> loc
- | sarg::_ -> sexp_location sarg)
- v arg_type in
+ -> let larg = if Inst.is_typeclass ctx arg_type
+ then newInstanceMetavar ctx (loc, v) arg_type
+ else get_implicit_arg
+ ctx (match sargs with
+ | [] -> loc
+ | sarg::_ -> sexp_location sarg)
+ v arg_type in
handle_fun_args ((ak, larg) :: largs) sargs pending
(L.mkSusp ret_type (S.substitute larg))
| [], _
@@ -996,7 +1116,7 @@ and lexp_parse_inductive ctors ctx =
(fun (ak, n, t) aa
-> Arrow (ak, n, t, dummy_location, aa))
acc impossible in
- let g = generalize nctx altacc in
+ let g = resolve_instances_and_generalize nctx altacc in
let altacc' = g (fun _ne vname t l e
-> Arrow (Aerasable, vname, t, l, e))
altacc in
@@ -1110,9 +1230,9 @@ and lexp_check_decls (ectx : elab_context) (* External context. *)
(* FIXME: Generalize when/where possible, so things like `map` can be
defined without type annotations! *)
(* Preserve the new operators added to nctx. *)
- let ectx = let (_, a, b, c) = ectx in
- let (grm, _, _, _) = nctx in
- (grm, a, b, c) in
+ let ectx = let (_, a, b, c, _) = ectx in
+ let (grm, _, _, _, tcctx) = nctx in
+ (grm, a, b, c, tcctx) in
let (declmap, nctx)
= List.fold_right
(fun ((l, vname), pexp) (map, nctx) ->
@@ -1122,10 +1242,11 @@ and lexp_check_decls (ectx : elab_context) (* External context. *)
| (v', ForwardRef, t)
-> let adjusted_t = push_susp t (S.shift (i + 1)) in
let e = check pexp adjusted_t nctx in
- let (grm, ec, lc, sl) = nctx in
+ resolve_instances e;
+ let (grm, ec, lc, sl, tcctx) = nctx in
let d = (v', LetDef (i + 1, e), t) in
(IMap.add i ((l, Some vname), e, t) map,
- (grm, ec, Myers.set_nth i d lc, sl))
+ (grm, ec, Myers.set_nth i d lc, sl, tcctx))
| _ -> Log.internal_error "Defining same slot!")
defs (IMap.empty, nctx) in
let decls = List.rev (List.map (fun (_, d) -> d) (IMap.bindings declmap)) in
@@ -1161,7 +1282,7 @@ and infer_and_generalize_type (ctx : elab_context) se name =
| Arrow (ak, v, t1, l, t2) -> Arrow (ak, v, t1, l, strip_rettype t2)
| Sort _ | Metavar _ -> type0 (* Abritrary closed constant. *)
| _ -> t in
- let g = generalize nctx (strip_rettype t) in
+ let g = resolve_instances_and_generalize nctx (strip_rettype t) in
g (fun _ne name t l e
-> mkArrow (Aerasable, name, t, l, e))
t
@@ -1169,7 +1290,7 @@ and infer_and_generalize_type (ctx : elab_context) se name =
and infer_and_generalize_def (ctx : elab_context) se =
let nctx = ectx_new_scope ctx in
let (e,t) = infer se nctx in
- let g = generalize nctx e in
+ let g = resolve_instances_and_generalize nctx e in
let e' = g (fun ne vname t l e
-> mkLambda ((if ne then Aimplicit else Aerasable),
vname, t, e))
@@ -1181,142 +1302,164 @@ and infer_and_generalize_def (ctx : elab_context) se =
(e', t')
and lexp_decls_1
- (sdecls : sexp list)
+ (sdecls : sexp list) (* What's already parsed *)
+ (tokens : token list) (* Rest of input *)
(ectx : elab_context) (* External ctx. *)
(nctx : elab_context) (* New context. *)
(pending_decls : location SMap.t) (* Pending type decls. *)
(pending_defs : (symbol * sexp) list) (* Pending definitions. *)
- : (vname * lexp * ltype) list * sexp list * elab_context =
-
- let rec lexp_decls_1 sdecls ectx nctx pending_decls pending_defs =
- match sdecls with
- | [] -> (if not (SMap.is_empty pending_decls) then
- let (s, loc) = SMap.choose pending_decls in
- error ~loc ("Variable `" ^ s ^ "` declared but not defined!")
- else
- assert (pending_defs == []));
- [], [], nctx
-
- | Symbol (_, "") :: sdecls
- -> lexp_decls_1 sdecls ectx nctx pending_decls pending_defs
-
- | Node (Symbol (_, ("_;_" (* | "_;" | ";_" *))), sdecls') :: sdecls
- -> lexp_decls_1 (List.append sdecls' sdecls)
- ectx nctx pending_decls pending_defs
-
- | Node (Symbol (loc, "_:_"), args) :: sdecls
- (* FIXME: Move this to a "special form"! *)
- -> (match args with
- | [Symbol (loc, vname); stp]
- -> let ltp = infer_and_generalize_type nctx stp (loc, Some vname) in
- if SMap.mem vname pending_decls then
- (* Don't burp: take'em all and unify! *)
- let pt_idx = senv_lookup vname nctx in
- (* Take the previous type annotation. *)
- let pt = match Myers.nth pt_idx (ectx_to_lctx nctx) with
- | (_, ForwardRef, t) -> push_susp t (S.shift (pt_idx + 1))
- | _ -> Log.internal_error "Var not found at its index!" in
- (* Unify it with the new one. *)
- let _ = match Unif.unify ltp pt (ectx_to_lctx nctx) with
- | (_::_)
- -> lexp_error loc ltp
- ("New type annotation `"
- ^ lexp_string ltp ^ "` incompatible with previous `"
- ^ lexp_string pt ^ "`")
- | [] -> () in
- lexp_decls_1 sdecls ectx nctx pending_decls pending_defs
- else if List.exists (fun ((_, vname'), _) -> vname = vname')
- pending_defs then
- (error ~loc ("Variable `" ^ vname ^ "` already defined!");
- lexp_decls_1 sdecls ectx nctx pending_decls pending_defs)
- else lexp_decls_1 sdecls ectx
- (ectx_extend nctx (loc, Some vname) ForwardRef ltp)
- (SMap.add vname loc pending_decls)
- pending_defs
- | _ -> error ~loc "Invalid type declaration syntax";
- lexp_decls_1 sdecls ectx nctx pending_decls pending_defs)
-
- | Node (Symbol (l, "_=_") as head, args) :: sdecls
- (* FIXME: Move this to a "special form"! *)
- -> (match args with
- | [Symbol ((l, vname)); sexp]
- when SMap.is_empty pending_decls
- -> assert (pending_defs == []);
- (* Used to be true before we added define-operator. *)
- (* assert (ectx == nctx); *)
- let (lexp, ltp) = infer_and_generalize_def nctx sexp in
- let var = (l, Some vname) in
- (* Lexp decls are always recursive, so we have to shift by 1 to
- * account for the extra var (ourselves). *)
- [(var, mkSusp lexp (S.shift 1), ltp)], sdecls,
- ctx_define nctx var lexp ltp
-
- | [Symbol (l, vname); sexp]
- -> if SMap.mem vname pending_decls then
- let decl_loc = SMap.find vname pending_decls in
- let v = ({file = l.file;
- line = l.line;
- column = l.column;
- docstr = String.concat "\n" [decl_loc.docstr; l.docstr]},
- vname) in
- let pending_decls = SMap.remove vname pending_decls in
- let pending_defs = ((v, sexp) :: pending_defs) in
- if SMap.is_empty pending_decls then
- let nctx = ectx_new_scope nctx in
- let decls, nctx = lexp_check_decls ectx nctx pending_defs in
- decls, sdecls, nctx
- else
- lexp_decls_1 sdecls ectx nctx pending_decls pending_defs
-
- else
- (error ~loc:l ("`" ^ vname ^ "` defined but not declared!");
- lexp_decls_1 sdecls ectx nctx pending_decls pending_defs)
-
- | [Node (Symbol s, args) as d; body]
- -> (* FIXME: Make it a macro (and don't hardcode `lambda_->_`)! *)
- lexp_decls_1 ((Node (head,
- [Symbol s;
- Node (Symbol (sexp_location d, "lambda_->_"),
- [sexp_u_list args; body])]))
- :: sdecls)
- ectx nctx pending_decls pending_defs
-
- | _ -> error ~loc:l "Invalid definition syntax";
- lexp_decls_1 sdecls ectx nctx pending_decls pending_defs)
-
- | Node (Symbol (l, "define-operator"), args) :: sdecls
- (* FIXME: Move this to a "special form"! *)
- -> lexp_decls_1 sdecls ectx (sdform_define_operator nctx l args None)
- pending_decls pending_defs
-
- | Node (Symbol ((l, _) as v), sargs) :: sdecls
- -> (* expand macro and get the generated declarations *)
- let sdecl' = lexp_decls_macro v sargs nctx in
- lexp_decls_1 (sdecl' :: sdecls) ectx nctx
- pending_decls pending_defs
-
- | sexp :: sdecls
- -> error ~loc:(sexp_location sexp) "Invalid declaration syntax";
- lexp_decls_1 sdecls ectx nctx pending_decls pending_defs
+ : (vname * lexp * ltype) list * sexp list * token list * elab_context =
+
+ let rec lexp_decls_1 sdecls tokens nctx pending_decls pending_defs =
+ let sdecl, sdecls, toks =
+ match (sdecls, tokens) with
+ | (s :: sdecls, _) -> Some s, sdecls, tokens
+ | ([], []) -> None, [], []
+ | ([], _) ->
+ let (s, toks) = sexp_parse_all (ectx_get_grammar nctx)
+ tokens (Some ";") in
+ Some s, [], toks in
+ let recur prepend_sdecls nctx pending_decls pending_defs =
+ lexp_decls_1 (List.append prepend_sdecls sdecls)
+ toks nctx pending_decls pending_defs in
+ match sdecl with
+ | None -> (if not (SMap.is_empty pending_decls) then
+ let (s, loc) = SMap.choose pending_decls in
+ error ~loc ("Variable `" ^ s ^ "` declared but not defined!")
+ else
+ assert (pending_defs == []));
+ [], [], [], nctx
+
+ | Some (Symbol (_, ""))
+ -> recur [] nctx pending_decls pending_defs
+
+ | Some (Node (Symbol (_, ("_;_" (* | "_;" | ";_" *))), sdecls'))
+ -> recur sdecls' nctx pending_decls pending_defs
+
+ | Some (Node (Symbol (loc, "_:_"), args) as thesexp)
+ (* FIXME: Move this to a "special form"! *)
+ -> (match args with
+ | [Symbol (loc, vname); stp]
+ -> let ltp = infer_and_generalize_type nctx stp (loc, Some vname) in
+ if SMap.mem vname pending_decls then
+ (* Don't burp: take'em all and unify! *)
+ let pt_idx = senv_lookup vname nctx in
+ (* Take the previous type annotation. *)
+ let pt = match Myers.nth pt_idx (ectx_to_lctx nctx) with
+ | (_, ForwardRef, t) -> push_susp t (S.shift (pt_idx + 1))
+ | _ -> Log.internal_error "Var not found at its index!" in
+ (* Unify it with the new one. *)
+ let _ = match Unif.unify ltp pt (ectx_to_lctx nctx) with
+ | (_::_)
+ -> lexp_error loc ltp
+ ("New type annotation `"
+ ^ lexp_string ltp ^ "` incompatible with previous `"
+ ^ lexp_string pt ^ "`")
+ | [] -> () in
+ recur [] nctx pending_decls pending_defs
+ else if List.exists (fun ((_, vname'), _) -> vname = vname')
+ pending_defs then
+ (error ~loc ("Variable `" ^ vname ^ "` already defined!");
+ recur [] nctx pending_decls pending_defs)
+ else recur [] (ectx_extend nctx (loc, Some vname) ForwardRef ltp)
+ (SMap.add vname loc pending_decls)
+ pending_defs
+ | _ -> error ~loc ("Invalid type declaration syntax : `" ^
+ (sexp_string thesexp) ^ "`");
+ recur [] nctx pending_decls pending_defs)
+
+ | Some (Node (Symbol (l, "_=_") as head, args) as thesexp)
+ (* FIXME: Move this to a "special form"! *)
+ -> (match args with
+ | [Symbol ((l, vname)); sexp]
+ when SMap.is_empty pending_decls
+ -> assert (pending_defs == []);
+ (* Used to be true before we added define-operator. *)
+ (* assert (ectx == nctx); *)
+ let (lexp, ltp) = infer_and_generalize_def nctx sexp in
+ let var = (l, Some vname) in
+ (* Lexp decls are always recursive, so we have to shift by 1 to
+ * account for the extra var (ourselves). *)
+ [(var, mkSusp lexp (S.shift 1), ltp)], sdecls, toks,
+ ctx_define nctx var lexp ltp
+
+ | [Symbol (l, vname); sexp]
+ -> if SMap.mem vname pending_decls then
+ let decl_loc = SMap.find vname pending_decls in
+ let v = ({file = l.file;
+ line = l.line;
+ column = l.column;
+ docstr = String.concat "\n" [decl_loc.docstr;
+ l.docstr]},
+ vname) in
+ let pending_decls = SMap.remove vname pending_decls in
+ let pending_defs = ((v, sexp) :: pending_defs) in
+ if SMap.is_empty pending_decls then
+ let nctx = ectx_new_scope nctx in
+ let decls, nctx = lexp_check_decls ectx nctx pending_defs in
+ decls, sdecls, toks, nctx
+ else
+ recur [] nctx pending_decls pending_defs
+
+ else
+ (error ~loc:l ("`" ^ vname ^ "` defined but not declared!");
+ recur [] nctx pending_decls pending_defs)
+
+ | [Node (Symbol s, args) as d; body]
+ -> (* FIXME: Make it a macro (and don't hardcode `lambda_->_`)! *)
+ recur [Node (head,
+ [Symbol s;
+ Node (Symbol (sexp_location d, "lambda_->_"),
+ [sexp_u_list args; body])])]
+ nctx pending_decls pending_defs
+
+ | _ -> error ~loc:l ("Invalid definition syntax : `" ^
+ (sexp_string thesexp) ^ "`");
+ recur [] nctx pending_decls pending_defs)
+
+ | Some (Node (Symbol (l, "define-operator"), args))
+ (* FIXME: Move this to a "special form"! *)
+ -> recur [] (sdform_define_operator nctx l args None)
+ pending_decls pending_defs
+
+ | Some (Node (Symbol (l, "typeclass"), args))
+ -> recur [] (sdform_typeclass nctx l args None)
+ pending_decls pending_defs
+
+ | Some (Node (Symbol ((l, _) as v), sargs))
+ -> (* expand macro and get the generated declarations *)
+ let sdecl' = lexp_decls_macro v sargs nctx in
+ recur [sdecl'] nctx pending_decls pending_defs
+
+ | Some sexp
+ -> error ~loc:(sexp_location sexp) "Invalid declaration syntax";
+ recur [] nctx pending_decls pending_defs
in (EV.set_getenv nctx;
- let res = lexp_decls_1 sdecls ectx nctx pending_decls pending_defs in
+ let res = lexp_decls_1 sdecls tokens nctx
+ pending_decls pending_defs in
(Log.stop_on_error (); res))
-and lexp_p_decls (sdecls : sexp list) (ctx : elab_context)
+and lexp_p_decls (sdecls : sexp list) (tokens : token list) (ctx : elab_context)
: ((vname * lexp * ltype) list list * elab_context) =
- let impl sdecls ctx = match sdecls with
- | [] -> [], ectx_new_scope ctx
- | _ -> let decls, sdecls, nctx = lexp_decls_1 sdecls ctx ctx SMap.empty [] in
- let declss, nnctx = lexp_p_decls sdecls nctx in
- decls :: declss, nnctx in
- let res = impl sdecls ctx in (Log.stop_on_error (); res)
+ let rec impl sdecls tokens ctx =
+ match (sdecls, tokens) with
+ | ([], []) -> [], ectx_new_scope ctx
+ | _ ->
+ let decls, sdecls, tokens, nctx =
+ lexp_decls_1 sdecls tokens ctx ctx SMap.empty [] in
+ Log.stop_on_error ();
+ let declss, nnctx = impl sdecls tokens nctx in
+ decls :: declss, nnctx in
+ impl sdecls tokens ctx
and lexp_parse_all (p: sexp list) (ctx: elab_context) : lexp list =
+ Eval.set_getenv ctx;
let res = List.map (fun pe -> let e, _ = infer pe ctx in e) p in
(Log.stop_on_error (); res)
and lexp_parse_sexp (ctx: elab_context) (e : sexp) : lexp =
+ Eval.set_getenv ctx;
let e, _ = infer e ctx in (Log.stop_on_error (); e)
(* --------------------------------------------------------------------------
@@ -1641,10 +1784,21 @@ let rec sform_lambda kind ctx loc sargs ot =
-> (match olt1 with
| None -> ()
| Some lt1'
- -> if not (OL.conv_p (ectx_to_lctx ctx) lt1 lt1')
- then lexp_error (lexp_location lt1') lt1'
- ("Type mismatch! Context expected `"
- ^ lexp_string lt1 ^ "`"));
+ -> (match Unif.unify lt1' lt1 (ectx_to_lctx ctx) with
+ | ((ck, _ctx, t1, t2)::_)
+ -> lexp_error (lexp_location lt1') lt1'
+ ("Type mismatch("
+ ^ (match ck with | Unif.CKimpossible -> "impossible"
+ | Unif.CKresidual -> "residue"
+ | _ -> failwith "impossible")
+ ^ ")! Context expected:\n "
+ ^ lexp_string lt1 ^ "\nbut parameter has type:\n "
+ ^ lexp_string lt1' ^ "\ncan't unify:\n "
+ ^ lexp_string t1
+ ^ "\nwith:\n "
+ ^ lexp_string t2);
+ assert (not (OL.conv_p (ectx_to_lctx ctx) lt1' lt1))
+ | [] -> ()));
mklam lt1 (Some lt2)
| Arrow (ak2, v, lt1, _, lt2) when kind = Anormal
@@ -1695,7 +1849,7 @@ let rec sform_case ctx loc sargs ot = match sargs with
let sform_letin ctx loc sargs ot = match sargs with
| [sdecls; sbody]
- -> let declss, nctx = lexp_p_decls [sdecls] ctx in
+ -> let declss, nctx = lexp_p_decls [sdecls] [] ctx in
(* FIXME: Use `elaborate`. *)
let bdy, ltp = infer sbody (ectx_new_scope nctx) in
let s = List.fold_left (OL.lexp_defs_subst loc) S.identity declss in
@@ -1772,9 +1926,7 @@ let sform_load usr_elctx loc sargs ot =
let read_file file_name elctx =
let pres = prelex_file file_name in
let sxps = lex default_stt pres in
- let nods = sexp_parse_all_to_list (ectx_get_grammar elctx)
- sxps (Some ";") in
- let _, elctx = lexp_p_decls nods elctx
+ let _, elctx = lexp_p_decls [] sxps elctx
in elctx in
(* read file as elab_context *)
@@ -1810,6 +1962,22 @@ let sform_load usr_elctx loc sargs ot =
(tuple',Lazy)
+(**
+ Draft of a special form "instance" that gets refers to a variable
+ of the requested type in the context.
+ **)
+let sform_instance ctx loc sargs ot =
+ match sargs, ot with
+ | ([se; _], _) -> (* Dummy param to trigger the special form *)
+ let t = infer_type se ctx (loc, None) in
+ let mv = newInstanceMetavar ctx (loc, Some "instance") t in
+ (mv, Inferred t)
+ | ([_], Some t) -> (* Dummy param to trigger the special form *)
+ let mv = newInstanceMetavar ctx (loc, Some "instance") t in
+ (mv, Checked)
+ | _ -> (sexp_error loc "##instance expects a type argument if not checked";
+ sform_dummy_ret ctx loc)
+
(* Register special forms. *)
let register_special_forms () =
List.iter add_special_form
@@ -1839,6 +2007,7 @@ let register_special_forms () =
(* FIXME: These should be functions! *)
("decltype", sform_decltype);
("declexpr", sform_declexpr);
+ ("instance", sform_instance);
]
(* Default context with builtin types
@@ -1860,9 +2029,7 @@ let default_ectx
let read_file file_name elctx =
let pres = prelex_file file_name in
let sxps = lex default_stt pres in
- let nods = sexp_parse_all_to_list (ectx_get_grammar elctx)
- sxps (Some ";") in
- let _, lctx = lexp_p_decls nods elctx
+ let _, lctx = lexp_p_decls [] sxps elctx
in lctx in
(* Register predef *)
@@ -1922,10 +2089,8 @@ let lexp_expr_str str ctx =
let lexp_decl_str str ctx =
try let tenv = default_stt in
- let grm = ectx_get_grammar ctx in
- let limit = Some ";" in
- let sdecls = sexp_parse_str str tenv grm limit in
- lexp_p_decls sdecls ctx
+ let tokens = lex_str str tenv in
+ lexp_p_decls [] tokens ctx
with Log.Stop_Compilation s -> ([],ctx)
=====================================
src/env.ml
=====================================
@@ -167,6 +167,41 @@ let make_runtime_ctx = M.nil
let get_rte_size (ctx: runtime_env): int = M.length ctx
+let print_myers_list l print_fun start =
+ let n = (M.length l) - 1 in
+ print_string (make_title " ENVIRONMENT ");
+ make_rheader [(None, "INDEX");
+ (None, "VARIABLE NAME"); (Some ('l', 48), "VALUE")];
+ print_string (make_sep '-');
+
+ for i = start to n do
+ print_string " | ";
+ ralign_print_int (n - i) 5;
+ print_string " | ";
+ print_fun (M.nth (n - i) l);
+ done;
+ print_string (make_sep '=')
+
+let print_rte_ctx_n (ctx: runtime_env) start =
+ print_myers_list
+ ctx
+ (fun (n, vref) ->
+ let g = !vref in
+ let _ =
+ match n with
+ | (_, Some m) -> lalign_print_string m 12; print_string " | "
+ | _ -> print_string (make_line ' ' 12); print_string " | " in
+
+ value_print g; print_string "\n") start
+
+(* Only print user defined variables *)
+let print_rte_ctx ctx =
+ print_rte_ctx_n ctx (!L.builtin_size)
+
+(* Dump the whole context *)
+let dump_rte_ctx ctx =
+ print_rte_ctx_n ctx 0
+
let get_rte_variable (name: vname) (idx: int)
(ctx: runtime_env): value_type =
try (
@@ -177,7 +212,7 @@ let get_rte_variable (name: vname) (idx: int)
if n1 = n2 then
x
else (
- fatal
+ fatal ~print_action:(fun () -> dump_rte_ctx ctx)
("Variable lookup failure. Expected: \"" ^
n2 ^ "[" ^ (string_of_int idx) ^ "]" ^ "\" got \"" ^ n1 ^ "\"")))
@@ -212,37 +247,3 @@ let nfirst_rte_var n ctx =
List.rev acc in
loop 0 []
-let print_myers_list l print_fun start =
- let n = (M.length l) - 1 in
- print_string (make_title " ENVIRONMENT ");
- make_rheader [(None, "INDEX");
- (None, "VARIABLE NAME"); (Some ('l', 48), "VALUE")];
- print_string (make_sep '-');
-
- for i = start to n do
- print_string " | ";
- ralign_print_int (n - i) 5;
- print_string " | ";
- print_fun (M.nth (n - i) l);
- done;
- print_string (make_sep '=')
-
-let print_rte_ctx_n (ctx: runtime_env) start =
- print_myers_list
- ctx
- (fun (n, vref) ->
- let g = !vref in
- let _ =
- match n with
- | (_, Some m) -> lalign_print_string m 12; print_string " | "
- | _ -> print_string (make_line ' ' 12); print_string " | " in
-
- value_print g; print_string "\n") start
-
-(* Only print user defined variables *)
-let print_rte_ctx ctx =
- print_rte_ctx_n ctx (!L.builtin_size)
-
-(* Dump the whole context *)
-let dump_rte_ctx ctx =
- print_rte_ctx_n ctx 0
=====================================
src/eval.ml
=====================================
@@ -744,6 +744,14 @@ let constructor_p name ectx =
| _ -> false
with Senv_Lookup_Fail _ -> false
+let inductive_p name ectx =
+ try let idx = senv_lookup name ectx in
+ match OL.lexp_whnf (mkVar ((dummy_location, Some name), idx))
+ (ectx_to_lctx ectx) with
+ | Inductive _ -> true
+ | _ -> false
+ with Senv_Lookup_Fail _ -> false
+
let erasable_p name nth ectx =
let is_erasable ctors = match (smap_find_opt name ctors) with
| (Some args) ->
@@ -821,10 +829,43 @@ let ctor_arg_pos name arg ectx =
| _ -> (-1)
with Senv_Lookup_Fail _ -> (-1)
+let ind_ctor_arg_pos indname ctorname arg ectx =
+ let rec find_opt xs n = match xs with
+ | [] -> None
+ | (_, (_, Some x), _)::xs -> if x = arg then Some n else find_opt xs (n + 1)
+ | _::xs -> find_opt xs (n + 1) in
+ try let idx = senv_lookup indname ectx in
+ match OL.lexp_whnf (mkVar ((dummy_location, Some indname), idx))
+ (ectx_to_lctx ectx) with
+ | Inductive (_, _, _, ctors) ->
+ (match smap_find_opt ctorname ctors with
+ | (Some args) ->
+ (match (find_opt args 0) with
+ | None -> (-1)
+ | Some n -> n)
+ | _ -> (-1))
+ | _ -> (-1)
+ with Senv_Lookup_Fail _ -> (-1)
+
+let count_ctor_args indname ctorname ectx =
+ try let idx = senv_lookup indname ectx in
+ match OL.lexp_whnf (mkVar ((dummy_location, Some indname), idx))
+ (ectx_to_lctx ectx) with
+ | Inductive (_,_,_,ctors) ->
+ (match smap_find_opt ctorname ctors with
+ | Some args -> List.length args
+ | None -> (-1))
+ | _ -> (-1)
+ with Senv_Lookup_Fail _ -> (-1)
+
let is_constructor loc depth args_val = match args_val with
| [Vstring name; Velabctx ectx] -> o2v_bool (constructor_p name ectx)
| _ -> error loc "Elab.isconstructor takes a String and an Elab_Context as arguments"
+let is_inductive loc depth args_val = match args_val with
+ | [Vstring name; Velabctx ectx] -> o2v_bool (inductive_p name ectx)
+ | _ -> error loc "Elab.isinductive takes a String and an Elab_Context as arguments"
+
let is_nth_erasable loc depth args_val = match args_val with
| [Vstring name; Vint nth_arg; Velabctx ectx] -> o2v_bool (erasable_p name nth_arg ectx)
| _ -> error loc "Elab.is-nth-erasable takes a String, an Int and an Elab_Context as arguments"
@@ -841,6 +882,14 @@ let arg_pos loc depth args_val = match args_val with
| [Vstring t; Vstring a; Velabctx ectx] -> Vint (ctor_arg_pos t a ectx)
| _ -> error loc "Elab.arg-pos takes two String and an Elab_Context as arguments"
+let ind_ctor_arg_pos loc depth args_val = match args_val with
+ | [Vstring ind; Vstring ctor; Vstring field; Velabctx ectx] -> Vint (ind_ctor_arg_pos ind ctor field ectx)
+ | _ -> error loc "Elab.ind-ctor-arg-pos takes three String and an Elab_Context as arguments"
+
+let count_ctor_args loc depth args_val = match args_val with
+ | [Vstring ind; Vstring ctor; Velabctx ectx] -> Vint (count_ctor_args ind ctor ectx)
+ | _ -> error loc "Elab.count-ctor-args takes two String and an Elab_Context as arguments"
+
let array_append loc depth args_val = match args_val with
| [v; Varray a] ->
Varray (Array.append (Array.map (fun v -> v) a) (Array.make 1 v))
@@ -996,10 +1045,13 @@ let register_builtin_functions () =
("Elab.debug-doc", debug_doc, 2);
("Elab.isbound" , is_bound, 2);
("Elab.isconstructor", is_constructor, 2);
+ ("Elab.isinductive", is_inductive, 2);
("Elab.is-nth-erasable", is_nth_erasable, 3);
("Elab.is-arg-erasable", is_arg_erasable, 3);
("Elab.nth-arg" , nth_arg, 3);
("Elab.arg-pos" , arg_pos, 3);
+ ("Elab.ind-ctor-arg-pos", ind_ctor_arg_pos, 4);
+ ("Elab.count-ctor-args", count_ctor_args, 3);
("Array.append" , array_append,2);
("Array.create" , array_create,2);
("Array.length" , array_length,1);
=====================================
src/instances.ml
=====================================
@@ -0,0 +1,52 @@
+module Unif = Unification
+module U = Util
+module DB = Debruijn
+module L = Lexp
+module S = Subst
+module OL = Opslexp
+
+(* FIXME Is it possible to have multiple references to the same
+ instance metavar? It would break the following code *)
+let instance_metavar_table = ref (U.IMap.empty : (DB.elab_context * U.location) U.IMap.t)
+let instance_metavar_lookup (id : L.meta_id) : (DB.elab_context * U.location) option
+ = U.IMap.find_opt id (!instance_metavar_table)
+let add_instance_metavar (id : L.meta_id) (ctx : DB.elab_context) (loc : U.location) : unit
+ = instance_metavar_table := U.IMap.add id (ctx, loc) !instance_metavar_table
+
+let env_is_typeclass (ectx : DB.elab_context) (t : L.ltype) : bool =
+ let (_, _, _, _, tcctx) = ectx in
+ let cl = DB.get_size ectx in
+ List.exists (fun (t', cl') ->
+ let i = cl - cl' in
+ let t' = L.mkSusp t' (S.shift i) in
+ OL.conv_p (DB.ectx_to_lctx ectx) t t'
+ (*(Unif.unify ~checking:(max_int (* FIXME *)) t t' (DB.ectx_to_lctx ectx)) = []*)
+ ) tcctx
+
+
+let get_head (lctx : DB.lexp_context) (t : L.ltype) : L.ltype =
+ match OL.lexp_whnf t lctx with
+ | L.Call (head, _) -> head
+ | head -> head
+
+
+let is_typeclass (ctx : DB.elab_context) (t : L.ltype) =
+ let lctx = DB.ectx_to_lctx ctx in
+ let head = get_head lctx t in
+ env_is_typeclass ctx head
+
+let add_typeclass (ctx : DB.elab_context) (t : L.ltype) : DB.elab_context =
+ let lctx = DB.ectx_to_lctx ctx in
+ let head = get_head lctx t in
+ DB.env_add_typeclass ctx head
+
+type match_res = Impossible | Possible | Match
+
+let check_typeclass_match t1 t2 lctx sl =
+ match Unif.unify ~checking:sl t1 t2 lctx with
+ | [] -> Match
+ | constraints when List.exists (function | (Unif.CKimpossible,_,_,_) -> true
+ | _ -> false)
+ constraints -> Impossible
+ | _ -> Possible
+
=====================================
src/inverse_subst.ml
=====================================
@@ -300,11 +300,12 @@ and apply_inv_subst (e : lexp) (s : subst) : lexp = match e with
-> let s' = L.fold_left
(fun s (_,ov) -> ssink ov s)
s cargs in
- (l, cargs, apply_inv_subst e s'))
+ let s'' = ssink (l, None) s' in
+ (l, cargs, apply_inv_subst e s''))
cases,
match default with
| None -> default
- | Some (v,e) -> Some (v, apply_inv_subst e (ssink v s)))
+ | Some (v,e) -> Some (v, apply_inv_subst e (ssink (l, None) (ssink v s))))
| Metavar (id, s', name)
-> match metavar_lookup id with
| MVal e -> apply_inv_subst (push_susp e s') s
=====================================
src/lexp.ml
=====================================
@@ -150,7 +150,7 @@ type metavar_info =
| MVal of lexp (* Exp to which the var is instantiated. *)
| MVar of scope_level (* Outermost scope in which the var appears. *)
* ltype (* Expected type. *)
- (* We'd like to keep the lexp_content in which the type is to be
+ (* We'd like to keep the lexp_context in which the type is to be
* understood, but lexp_context is not yet defined here,
* so we just keep the length of the lexp_context. *)
* ctx_length
@@ -274,7 +274,7 @@ let hcs_table : ((lexp * subst), lexp) Hashtbl.t = Hashtbl.create 1000
let rec mkSusp e s =
if S.identity_p s then e else
(* We apply the substitution eagerly to some terms.
- * There's no deep technical rason for that:
+ * There's no deep technical reason for that:
* it just seemed like a good idea to do it eagerly when it's easy. *)
match e with
| Imm _ -> e
@@ -313,7 +313,7 @@ let rec sunshift n =
let _ = assert (S.identity_p (scompose (S.shift 5) (sunshift 5)))
(* The quick test below seemed to indicate that about 50% of the "sink"s
- * are applied on top of another "sink" and hence cound be combined into
+ * are applied on top of another "sink" and hence could be combined into
* a single "Lift^n" constructor. Doesn't seem high enough to justify
* the complexity of adding a `Lift` to `subst`.
*)
@@ -409,11 +409,11 @@ let rec push_susp e s = (* Push a suspension one level down. *)
-> let s' = L.fold_left
(fun s (_,ov) -> ssink ov s)
s cargs in
- (l, cargs, mkSusp e s'))
+ (l, cargs, mkSusp e (ssink (l, None) s')))
cases,
match default with
| None -> default
- | Some (v,e) -> Some (v, mkSusp e (ssink v s)))
+ | Some (v,e) -> Some (v, mkSusp e (ssink (l, None) (ssink v s))))
(* Susp should never appear around Var/Susp/Metavar because mkSusp
* pushes the subst into them eagerly. IOW if there's a Susp(Var..)
* or Susp(Metavar..) it's because some chunk of code should use mkSusp
@@ -475,11 +475,12 @@ let clean e =
-> let s' = L.fold_left
(fun s (_,ov) -> ssink ov s)
s cargs in
- (l, cargs, clean s' e))
+ let s'' = ssink (l, None) s' in
+ (l, cargs, clean s'' e))
cases,
match default with
| None -> default
- | Some (v,e) -> Some (v, clean (ssink v s) e))
+ | Some (v,e) -> Some (v, clean (ssink (l, None) (ssink v s)) e))
| Susp (e, s') -> clean (scompose s' s) e
| Var _ -> if S.identity_p s then e
else clean S.identity (mkSusp e s)
@@ -805,7 +806,7 @@ and lexp_str ctx (exp : lexp) : string =
| Metavar (idx, subst, (loc, name))
(* print metavar result if any *)
-> (match metavar_lookup idx with
- | MVal e -> lexp_str ctx e
+ | MVal e -> lexp_str ctx (push_susp e subst)
| _ -> "?" ^ maybename name ^ (subst_string subst) ^ (index idx))
| Let (_, decls, body) ->
@@ -992,8 +993,18 @@ let rec eq e1 e2 =
&& (match (def1, def2) with
| (Some (_, e1), Some (_, e2)) -> eq e1 e2
| _ -> def1 = def2)
- | (Metavar (i1, s1, _), Metavar (i2, s2, _))
- -> i1 = i2 && subst_eq s1 s2
+ | (Metavar (i1, s1, _), Metavar (i2, s2, _)) when i1 == i2
+ -> subst_eq s1 s2
+ | (Metavar (i1, s1, _), _) when
+ (match metavar_lookup i1 with MVal _ -> true | _ -> false)
+ -> (match metavar_lookup i1 with
+ | MVal l -> eq (push_susp l s1) e2
+ | _ -> Log.internal_error "impossible")
+ | (_, Metavar (i2, s2, _)) when
+ (match metavar_lookup i2 with MVal _ -> true | _ -> false)
+ -> (match metavar_lookup i2 with
+ | MVal l -> eq e1 (push_susp l s2)
+ | _ -> Log.internal_error "impossible")
| _ -> false
and subst_eq s1 s2 =
=====================================
src/log.ml
=====================================
@@ -133,11 +133,13 @@ let print_entry entry =
let log_entry (entry : log_entry) =
if (entry.level <= typer_log_config.level)
then (
- log_push entry;
- if (typer_log_config.print_at_log)
+ if (typer_log_config.print_at_log ||
+ entry.level >= Debug)
then
(print_entry entry;
flush stdout)
+ else
+ log_push entry
)
let count_msgs (lvlp : log_level -> bool) =
=====================================
src/myers.ml
=====================================
@@ -54,11 +54,21 @@ let car l =
| Mnil -> raise Not_found
| Mcons (x, _, _, _) -> x
+let safe_car l =
+ match l with
+ | Mnil -> None
+ | Mcons (x, _, _, _) -> Some x
+
let cdr l =
match l with
| Mnil -> Mnil
| Mcons (_, l, _, _) -> l
+let safe_cdr l =
+ match l with
+ | Mnil -> None
+ | Mcons (_, l, _, _) -> Some l
+
let case l n c =
match l with
| Mnil -> n ()
@@ -136,3 +146,6 @@ let rec fold_right f l i = match l with
let map f l = fold_right (fun x l' -> cons (f x) l') l nil
let iteri f l = fold_left (fun i x -> f i x; i + 1) 0 l
+
+let iter (f : 'a -> unit) (l : 'a myers) : unit
+ = fold_left (fun _ x -> f x; ()) () l
=====================================
src/opslexp.ml
=====================================
@@ -38,6 +38,22 @@ module S = Subst
(* module L = List *)
module DB = Debruijn
+type set_plexp = (lexp * lexp) list
+type sort_compose_result
+ = SortResult of ltype
+ | SortInvalid
+ | SortK1NotType
+ | SortK2NotType
+type mv_set = (scope_level * ltype * ctx_length * vname) IMap.t
+ (* Metavars that appear in non-erasable positions. *)
+ * unit IMap.t
+
+module LMap
+ (* Memoization table. FIXME: Ideally the keys should be "weak", but
+ * I haven't found any such functionality in OCaml's libs. *)
+ = Hashtbl.Make
+ (struct type t = lexp let hash = Hashtbl.hash let equal = (==) end)
+
let error_tc = Log.log_error ~section:"TC"
let warning_tc = Log.log_warning ~section:"TC"
@@ -132,7 +148,7 @@ let lexp_close lctx e =
* but only on *types*. If you must use it on code, be sure to use its
* return value as little as possible since WHNF will inherently introduce
* call-by-name behavior. *)
-let lexp_whnf e (ctx : DB.lexp_context) : lexp =
+let rec lexp_whnf e (ctx : DB.lexp_context) : lexp =
let rec lexp_whnf e (ctx : DB.lexp_context) : lexp =
match e with
| Var v -> (match lookup_value ctx v with
@@ -156,21 +172,28 @@ let lexp_whnf e (ctx : DB.lexp_context) : lexp =
| _ -> e) (* Keep `e`, assuming it's more readable! *)
| Case (l, e, rt, branches, default) ->
let e' = lexp_whnf e ctx in
+ let get_refl e =
+ let etype = get_type ctx e in (* FIXME we should not need get_type here *)
+ let elevel = match lexp_whnf (get_type ctx etype) ctx with
+ | Sort (_, Stype l) -> l
+ | _ -> Log.internal_error "" in
+ mkCall (DB.eq_refl, [Aerasable, elevel; Aerasable, etype; Aerasable, e]) in
let reduce name aargs =
try
let (_, _, branch) = SMap.find name branches in
- let (subst, _)
+ let subst
= List.fold_left
- (fun (s,d) (_, arg) ->
- (S.cons (L.mkSusp (lexp_whnf arg ctx) (S.shift d)) s,
- d + 1))
- (S.identity, 0)
+ (fun (s) (_, arg) -> S.cons (lexp_whnf arg ctx) s)
+ S.identity
aargs in
+ (* Substitute case Eq variable by the proof (Eq.refl l t e') *)
+ let subst = S.cons (get_refl e') subst in
lexp_whnf (push_susp branch subst) ctx
with Not_found
-> match default
with | Some (v,default)
- -> lexp_whnf (push_susp default (S.substitute e')) ctx
+ -> let subst = S.cons (get_refl e') (S.substitute e') in
+ lexp_whnf (push_susp default subst) ctx
| _ -> Log.log_error ~section:"WHNF" ~loc:l
("Unhandled constructor " ^
name ^ "in case expression");
@@ -198,9 +221,8 @@ let lexp_whnf e (ctx : DB.lexp_context) : lexp =
(** A very naive implementation of sets of pairs of lexps. *)
-type set_plexp = (lexp * lexp) list
-let set_empty : set_plexp = []
-let set_member_p (s : set_plexp) (e1 : lexp) (e2 : lexp) : bool
+and set_empty : set_plexp = []
+and set_member_p (s : set_plexp) (e1 : lexp) (e2 : lexp) : bool
= assert (e1 == Lexp.hc e1);
assert (e2 == Lexp.hc e2);
try let _ = List.find (fun (e1', e2')
@@ -208,14 +230,14 @@ let set_member_p (s : set_plexp) (e1 : lexp) (e2 : lexp) : bool
s
in true
with Not_found -> false
-let set_add (s : set_plexp) (e1 : lexp) (e2 : lexp) : set_plexp
+and set_add (s : set_plexp) (e1 : lexp) (e2 : lexp) : set_plexp
= (* assert (not (set_member_p s e1 e2)); *)
((e1, e2) :: s)
-let set_shift_n (s : set_plexp) (n : U.db_offset)
+and set_shift_n (s : set_plexp) (n : U.db_offset)
= List.map (let s = S.shift n in
fun (e1, e2) -> (Lexp.push_susp e1 s, Lexp.push_susp e2 s))
s
-let set_shift s : set_plexp = set_shift_n s 1
+and set_shift s : set_plexp = set_shift_n s 1
(********* Testing if two types are "convertible" aka "equivalent" *********)
@@ -225,7 +247,7 @@ let set_shift s : set_plexp = set_shift_n s 1
* `c` is the maximum "constant" level that occurs in `e`
* and `m` maps variable indices to the maxmimum depth at which they were
* found. *)
-let level_canon e =
+and level_canon e =
let add_var_depth v d ((c,m) as acc) =
let o = try IMap.find v m with Not_found -> -1 in
if o < d then (c, IMap.add v d m) else acc in
@@ -244,18 +266,21 @@ let level_canon e =
| _ -> (max_int, m)
in canon e 0 (0,IMap.empty)
-let level_leq (c1, m1) (c2, m2) =
+and level_leq (c1, m1) (c2, m2) =
c1 <= c2
&& c1 != max_int
&& IMap.for_all (fun i d -> try d <= IMap.find i m2 with Not_found -> false)
m1
(* Returns true if e₁ and e₂ are equal (upto alpha/beta/...). *)
-let rec conv_p' (ctx : DB.lexp_context) (vs : set_plexp) e1 e2 : bool =
+and conv_p' (ctx : DB.lexp_context) (vs : set_plexp) e1 e2 : bool =
let e1' = lexp_whnf e1 ctx in
let e2' = lexp_whnf e2 ctx in
+ Log.log_debug ("conv_p : e1' = `" ^ (lexp_string e1')
+ ^ "`; e2' = `" ^ (lexp_string e2') ^ "`");
e1' == e2' ||
let changed = not (e1 == e1' && e2 == e2') in
+ Log.log_debug ("changed : " ^ string_of_bool changed);
if changed && set_member_p vs e1' e2' then true else
let vs' = if changed then set_add vs e1' e2' else vs in
let conv_p = conv_p' ctx vs' in
@@ -319,19 +344,119 @@ let rec conv_p' (ctx : DB.lexp_context) (vs : set_plexp) e1 e2 : bool =
| _,_ -> false in
l1 == l2 && conv_args ctx vs' args1 args2
| (Cons (t1, (_, l1)), Cons (t2, (_, l2))) -> l1 = l2 && conv_p t1 t2
- (* I'm not sure to understand how to compare two Metavar *
- * Should I do a `lookup`? Or is it that simple: *)
- (*| (Metavar (id1,_,_), Metavar (id2,_,_)) -> id1 = id2*)
- (* FIXME: Various missing cases, such as Case. *)
- | (_, _) -> false
-
-let conv_p (ctx : DB.lexp_context) e1 e2
+ | (Case (_, te1, r1, cases1, def1), Case (_, te2, r2, cases2, def2))
+ -> Log.log_debug ("conv_p of case : e1' = `" ^ (lexp_string e1')
+ ^ "`; e2' = `" ^ (lexp_string e2') ^ "`");
+ eq e1' e2' ||
+ (Log.log_debug "subexpr"; conv_p te1 te2) &&
+ (Log.log_debug "return"; conv_p r1 r2) && (
+ Log.log_debug "branches";
+ (* Compare the branches *)
+ (* 1. Get the inductive for the field types *)
+ let call_split e = match e with
+ | Call (f, args) -> (f, args)
+ | _ -> (e,[]) in
+ (* We can arbitrarily use te1 since te1 and te2 are convertible *)
+ let etype = lexp_whnf (get_type ctx te1) ctx in
+ let it, aargs = call_split etype in
+ (* 2. Build the substitution for the inductive arguments *)
+ let fargs, ctors =
+ (match lexp_whnf it ctx with
+ | Inductive (_, _, fargs, constructors)
+ -> fargs, constructors
+ | _ -> Log.log_fatal ("Case of non-inductive in conv_p")) in
+ let fargs_subst = List.fold_left2 (fun s _farg (_, aarg) -> S.cons aarg s)
+ S.identity fargs aargs in
+ (* 3. Compare the branches *)
+ (* The map module doesn't have a function to compare two
+ maps with the key (which is needed to get the field
+ types from the inductive. Instead, we work with the
+ lists of associations. *)
+ (try
+ List.for_all2 (fun (l1, (_, fields1, e1)) (l2, (_, fields2, e2)) ->
+ l1 = l2 &&
+ let fieldtypes = SMap.find l1 ctors in
+ let rec mkctx ctx args s i vdefs1 vdefs2 fieldtypes =
+ match vdefs1, vdefs2, fieldtypes with
+ | [], [], [] -> Some (ctx, List.rev args, s)
+ | (ak1, vdef1)::vdefs1, (ak2, vdef2)::vdefs2,
+ (ak', vdef', ftype)::fieldtypes
+ -> if ak1 = ak2 && ak2 = ak' then
+ (* FIXME Should we compare the variable names ? *)
+ mkctx
+ (DB.lexp_ctx_cons ctx vdef1 Variable (mkSusp ftype s))
+ ((ak1, (mkVar (vdef1, i)))::args)
+ (ssink vdef1 s)
+ (i - 1)
+ vdefs1 vdefs2 fieldtypes
+ else None
+ | _,_,_ -> None in
+ match mkctx ctx [] fargs_subst (List.length fields1)
+ fields1 fields2 fieldtypes with
+ | None -> false
+ | Some (nctx, args, _subst) ->
+ (* TODO build head lexp the eq type *)
+ let offset = (List.length fields1) in
+ let subst = S.shift offset in
+ Log.log_debug "hlxp time";
+ let tlxp = mkSusp te1 subst in
+ Log.log_debug ("tlxp : `" ^ (lexp_string tlxp) ^ "`");
+ let tltp = mkSusp etype subst in
+ Log.log_debug ("etype : `" ^ (lexp_string etype) ^ "`");
+ Log.log_debug ("subst : `" ^ (subst_string subst) ^ "`");
+ Log.log_debug ("tltp : `" ^ (lexp_string tltp) ^ "`");
+ let tlev = (match lexp_whnf (get_type nctx tltp) nctx with
+ | Sort (_, Stype l) -> l
+ | _ -> Log.log_error "HMMM"; DB.level0) in
+ let ctor = mkSusp (mkCall (mkCons (it, (DB.dloc, l1)), aargs)) subst in
+ Log.log_debug ("ctor : `" ^ (lexp_string ctor) ^ "`");
+ let hlxp = mkCall (ctor, args) in
+ Log.log_debug ("hlxp : `" ^ (lexp_string hlxp) ^ "`");
+ let eqty = mkCall (DB.type_eq,
+ [(Aerasable, tlev); (* Typelevel *)
+ (Aerasable, tltp); (* Inductive type *)
+ (Anormal, tlxp); (* Target lexp *)
+ (Anormal, hlxp)]) in (* Lexp of the branch head *)
+ let nctx = DB.lexp_ctx_cons nctx (DB.dloc, None) Variable eqty in
+ conv_p' nctx (set_shift_n vs' (offset + 1)) e1 e2
+ ) (SMap.bindings cases1) (SMap.bindings cases2)
+ with
+ | Invalid_argument _ -> false (* If the lists have different length *)
+ )
+ && (match (def1, def2) with
+ | (Some (v1, e1), Some (v2, e2)) ->
+ (* FIXME should we compare the variable names ? *)
+ Log.log_debug "default";
+ let nctx = DB.lctx_extend ctx v1 Variable etype in
+ let subst = S.shift 1 in
+ let tlxp = mkSusp e1 subst in
+ let tltp = mkSusp etype subst in
+ let tlev = (match lexp_whnf (get_type nctx tltp) nctx with
+ | Sort (_, Stype l) -> l
+ | _ -> Log.log_error "HMMM"; DB.level0) in
+ let hlxp = mkVar ((DB.dloc, None), 0) in
+ let eqty = mkCall (DB.type_eq,
+ [(Aerasable, tlev); (* Typelevel *)
+ (Aerasable, tltp); (* Inductive type *)
+ (Anormal, tlxp); (* Target lexp *)
+ (Anormal, hlxp)]) in (* Lexp of the branch head *)
+ let nctx = DB.lexp_ctx_cons nctx (DB.dloc, None) Variable eqty in
+ conv_p' nctx (set_shift_n vs' 2) e1 e2
+ | None, None -> true
+ | _, _ -> false))
+ (* I'm not sure to understand how to compare two Metavar *
+ * Should I do a `lookup`? Or is it that simple: *)
+ (*| (Metavar (id1,_,_), Metavar (id2,_,_)) -> id1 = id2*)
+ (* FIXME: Various missing cases, such as Case. *)
+ | (_, _) -> false
+
+and conv_p (ctx : DB.lexp_context) e1 e2
= if e1 == e2 then true
else conv_p' ctx set_empty e1 e2
(********* Testing if a lexp is properly typed *********)
-let rec mkSLlub ctx e1 e2 =
+and mkSLlub ctx e1 e2 =
match (lexp_whnf e1 ctx, lexp_whnf e2 ctx) with
| (SortLevel SLz, _) -> e2
| (_, SortLevel SLz) -> e1
@@ -344,13 +469,7 @@ let rec mkSLlub ctx e1 e2 =
else if level_leq ce2 ce1 then e1
else mkSortLevel (mkSLlub' (e1, e2)) (* FIXME: Could be more canonical *)
-type sort_compose_result
- = SortResult of ltype
- | SortInvalid
- | SortK1NotType
- | SortK2NotType
-
-let sort_compose ctx1 ctx2 l ak k1 k2 =
+and sort_compose ctx1 ctx2 l ak k1 k2 =
(* BEWARE! Technically `k2` can refer to `v`, but this should only happen
* if `v` is a TypeLevel. *)
match (lexp_whnf k1 ctx1, lexp_whnf k2 ctx2) with
@@ -388,11 +507,11 @@ let sort_compose ctx1 ctx2 l ak k1 k2 =
| (Sort (_, _), _) -> SortK2NotType
| (_, _) -> SortK1NotType
-let dbset_push ak erased =
+and dbset_push ak erased =
let nerased = DB.set_sink 1 erased in
if ak = P.Aerasable then DB.set_set 0 nerased else nerased
-let nerased_let defs erased =
+and nerased_let defs erased =
(* Let bindings are not erasable, with the important exception of
* let-bindings of the form `x = y` where `y` is an erasable var.
* This exception is designed so that macros like `case` which need to
@@ -418,7 +537,7 @@ let nerased_let defs erased =
erased es
(* "check ctx e" should return τ when "Δ ⊢ e : τ" *)
-let rec check'' erased ctx e =
+and check'' erased ctx e =
let check = check'' in
let assert_type ctx e t t' =
if conv_p ctx t t' then ()
@@ -610,24 +729,38 @@ let rec check'' erased ctx e =
SMap.iter
(fun name (l, vdefs, branch)
-> let fieldtypes = SMap.find name constructors in
- let rec mkctx erased ctx s vdefs fieldtypes =
+ let rec mkctx erased ctx s hlxp vdefs fieldtypes =
match vdefs, fieldtypes with
- | [], [] -> (erased, ctx)
+ | [], [] -> (erased, ctx, hlxp)
(* FIXME: If ak is Aerasable, make sure the var only
* appears in type annotations. *)
| (ak, vdef)::vdefs, (ak', vdef', ftype)::fieldtypes
-> mkctx (dbset_push ak erased)
(DB.lexp_ctx_cons ctx vdef Variable (mkSusp ftype s))
- (S.cons (mkVar (vdef, 0))
- (S.mkShift s 1))
+ (ssink vdef s)
+ (mkCall (mkSusp hlxp (S.shift 1), [(ak, mkVar (vdef, 0))]))
vdefs fieldtypes
| _,_ -> (error_tc ~loc:l
"Wrong number of args to constructor!";
- (erased, ctx)) in
- let (nerased, nctx) = mkctx erased ctx s vdefs fieldtypes in
+ (erased, ctx, hlxp)) in
+ let hctor = mkCall (mkCons (it, (l, name)), aargs) in
+ let (nerased, nctx, hlxp) =
+ mkctx erased ctx s hctor vdefs fieldtypes in
+ (* Create Eq type between target and lexp matching the
+ branch head, and add it (erasable) to the context *)
+ let subst = S.shift (List.length vdefs) in
+ let tlxp = mkSusp e subst in
+ let tltp = mkSusp etype subst in
+ let eqty = mkCall (DB.type_eq,
+ [(Aerasable, DB.type0); (* Typelevel *) (* FIXME The real typelevel *)
+ (Aerasable, tltp); (* Inductive type *)
+ (Anormal, tlxp); (* Target lexp *)
+ (Anormal, hlxp)]) in (* Lexp of the branch head *)
+ let nerased = dbset_push Aerasable nerased in (* The eq proof is erasable *)
+ let nctx = DB.lexp_ctx_cons nctx (l, None) Variable eqty in
assert_type nctx branch
(check nerased nctx branch)
- (mkSusp ret (S.shift (List.length fieldtypes))))
+ (mkSusp ret (S.shift ((List.length fieldtypes) + 1))))
branches;
let diff = SMap.cardinal constructors - SMap.cardinal branches in
(match default with
@@ -635,8 +768,21 @@ let rec check'' erased ctx e =
-> if diff <= 0 then
warning_tc ~loc:l "Redundant default clause";
let nctx = (DB.lctx_extend ctx v (LetDef (0, e)) etype) in
- assert_type nctx d (check (DB.set_sink 1 erased) nctx d)
- (mkSusp ret (S.shift 1))
+ let nerased = DB.set_sink 1 erased in
+ let subst = S.shift 1 in
+ (* FIXME DRY this code *)
+ let tlxp = mkSusp e subst in
+ let tltp = mkSusp etype subst in
+ let hlxp = mkVar ((l, None), 0) in
+ let eqty = mkCall (DB.type_eq,
+ [(Aerasable, DB.type0); (* Typelevel *) (* FIXME The real typelevel *)
+ (Aerasable, tltp); (* Inductive type *)
+ (Anormal, tlxp); (* Target lexp *)
+ (Anormal, hlxp)]) in (* Lexp of the branch head *)
+ let nerased = dbset_push Aerasable nerased in (* The eq proof is erasable *)
+ let nctx = DB.lexp_ctx_cons nctx (l, None) Variable eqty in
+ assert_type nctx d (check nerased nctx d)
+ (mkSusp ret (S.shift 2))
| None
-> if diff > 0 then
error_tc ~loc:l ("Non-exhaustive match: "
@@ -682,24 +828,21 @@ let rec check'' erased ctx e =
check erased ctx e
| MVar (_, t, _) -> push_susp t s)
-let check' ctx e =
+and check' ctx e =
let res = check'' DB.set_empty ctx e in
(Log.stop_on_error (); res)
-let check = check'
+and check ctx e = check' ctx e
(** Compute the set of free (meta)variables. **)
-let rec list_union l1 l2 = match l1 with
+and list_union l1 l2 = match l1 with
| [] -> l2
| (x::l1) -> list_union l1 (if List.mem x l2 then l2 else (x::l2))
-type mv_set = (scope_level * ltype * ctx_length * vname) IMap.t
- (* Metavars that appear in non-erasable positions. *)
- * unit IMap.t
-let mv_set_empty : mv_set = (IMap.empty, IMap.empty)
-let mv_set_add (ms, nes) id x : mv_set = (IMap.add id x ms, IMap.add id () nes)
-let mv_set_union ((ms1, nes1) : mv_set) ((ms2, nes2) : mv_set) : mv_set
+and mv_set_empty : mv_set = (IMap.empty, IMap.empty)
+and mv_set_add (ms, nes) id x : mv_set = (IMap.add id x ms, IMap.add id () nes)
+and mv_set_union ((ms1, nes1) : mv_set) ((ms2, nes2) : mv_set) : mv_set
= (IMap.merge (fun _m oss1 oss2
-> match (oss1, oss2) with
| (None, _) -> oss2
@@ -715,23 +858,19 @@ let mv_set_union ((ms1, nes1) : mv_set) ((ms2, nes2) : mv_set) : mv_set
Some ss1)
ms1 ms2,
IMap.merge (fun _m _o1 _o2 -> Some ()) nes1 nes2)
-let mv_set_erase (ms, _nes) = (ms, IMap.empty)
+and mv_set_erase (ms, _nes) = (ms, IMap.empty)
-module LMap
- (* Memoization table. FIXME: Ideally the keys should be "weak", but
- * I haven't found any such functionality in OCaml's libs. *)
- = Hashtbl.Make
- (struct type t = lexp let hash = Hashtbl.hash let equal = (==) end)
-let fv_memo = LMap.create 1000
+and fv_memo = LMap.create 1000
+and fv_flush () = LMap.clear fv_memo
-let fv_empty = (DB.set_empty, mv_set_empty)
-let fv_union (fv1, mv1) (fv2, mv2)
+and fv_empty = (DB.set_empty, mv_set_empty)
+and fv_union (fv1, mv1) (fv2, mv2)
= (DB.set_union fv1 fv2, mv_set_union mv1 mv2)
-let fv_sink n (fvs, mvs) = (DB.set_sink n fvs, mvs)
-let fv_hoist n (fvs, mvs) = (DB.set_hoist n fvs, mvs)
-let fv_erase (fvs, mvs) = (fvs, mv_set_erase mvs)
+and fv_sink n (fvs, mvs) = (DB.set_sink n fvs, mvs)
+and fv_hoist n (fvs, mvs) = (DB.set_hoist n fvs, mvs)
+and fv_erase (fvs, mvs) = (fvs, mv_set_erase mvs)
-let rec fv (e : lexp) : (DB.set * mv_set) =
+and fv (e : lexp) : (DB.set * mv_set) =
let fv' e = match e with
| Imm _ -> fv_empty
| SortLevel SLz -> fv_empty
@@ -784,9 +923,9 @@ let rec fv (e : lexp) : (DB.set * mv_set) =
-> let s = fv_union (fv e) (fv_erase (fv t)) in
let s = match def with
| None -> s
- | Some (_, e) -> fv_union s (fv_hoist 1 (fv e)) in
+ | Some (_, e) -> fv_union s (fv_hoist 2 (fv e)) in
SMap.fold (fun _ (_, fields, e) s
- -> fv_union s (fv_hoist (List.length fields) (fv e)))
+ -> fv_union s (fv_hoist (List.length fields + 1) (fv e)))
cases s
| Metavar (id, s, name)
-> (match metavar_lookup id with
@@ -806,7 +945,7 @@ let rec fv (e : lexp) : (DB.set * mv_set) =
(** Finding the type of a expression. **)
(* This should never signal any warning/error. *)
-let rec get_type ctx e =
+and get_type ctx e =
match e with
| Imm (Float (_, _)) -> DB.type_float
| Imm (Integer (_, _)) -> DB.type_int
@@ -933,7 +1072,7 @@ let rec erase_type (lxp: L.lexp): E.elexp =
| L.Case(l, target, _, cases, default) ->
E.Case(l, (erase_type target), (clean_map cases),
- (clean_maybe default))
+ (clean_default default))
| L.Susp(l, s) -> erase_type (L.push_susp l s)
@@ -962,10 +1101,12 @@ and filter_arg_list lst =
and clean_decls decls =
List.map (fun (v, lxp, _) -> (v, (erase_type lxp))) decls
-and clean_maybe lxp =
- match lxp with
- | Some (v, lxp) -> Some (v, erase_type lxp)
- | None -> None
+and clean_default lxp =
+ match lxp with
+ | Some (v, lxp) ->
+ Some (v,
+ erase_type (L.push_susp lxp (S.substitute DB.type0)))
+ | None -> None
and clean_map cases =
let clean_arg_list lst =
@@ -979,7 +1120,8 @@ and clean_map cases =
clean_arg_list lst [] in
SMap.map (fun (l, args, expr)
- -> (l, (clean_arg_list args), (erase_type expr)))
+ -> (l, (clean_arg_list args),
+ erase_type (L.push_susp expr (S.substitute DB.type0))))
cases
(** Turning a set of declarations into an object. **)
=====================================
src/sexp.ml
=====================================
@@ -160,13 +160,18 @@ let rec sexp_parse (g : grammar) (rest : sexp list)
mk_node ((l,"")::op) largs rargs true),
rest)
| (Some ll, None) when ll > level
- (* A closer without matching opener.
- * It might simply be a postfix symbol that binds very tightly.
- * We currently signal an error because it's more common for
- * it to be a closer with missing opener. *)
- -> sexp_error l ("Lonely postfix/closer \""^name^"\"");
- sexp_parse rest' level op largs
- [mk_node [(l,name);(l,"")] [] rargs true]
+ (* A closer without matching opener or a postfix symbol
+ that binds very tightly. Previously, we signaled an
+ error (assuming the former), but it prevented the use
+ tightly binding postfix operators.
+
+ For example, it signaled spurious errors when parsing
+ expressions with a tightly binding postfix # operator
+ that implemented record construction by taking an
+ inductive as argument and returning the inductive's only
+ constructor. *)
+ -> sexp_parse rest' level op largs
+ [mk_node [(l,name);(l,"")] [] rargs true]
| (Some ll, Some rl) when ll > level
(* A new infix which binds more tightly, i.e. does not close
* the current `op' but takes its `rargs' instead. *)
=====================================
src/unification.ml
=====================================
@@ -46,6 +46,7 @@ let create_metavar (ctx : DB.lexp_context) (sl : scope_level) (t : ltype)
type constraint_kind =
| CKimpossible (* Unification is simply impossible. *)
| CKresidual (* We failed to find a unifier. *)
+ | CKassoc (* Couldn't associate because of checking mode *)
(* FIXME: Each constraint should additionally come with a description of how
it relates to its "top-level" or some other info which might let us
fix the problem (e.g. by introducing coercions). *)
@@ -54,8 +55,9 @@ type constraints = (constraint_kind * DB.lexp_context * lexp * lexp) list
type return_type = constraints
(** Alias for VMap.add*)
-let associate (id: meta_id) (lxp: lexp) (subst: meta_subst) : meta_subst
- = U.IMap.add id (MVal lxp) subst
+let associate (id: meta_id) (lxp: lexp) : unit
+ = metavar_table := U.IMap.add id (MVal lxp) (!metavar_table);
+ OL.fv_flush ()
let occurs_in (id: meta_id) (e : lexp) : bool = match metavar_lookup id with
| MVal _ -> Log.internal_error
@@ -174,13 +176,15 @@ let rec s_offset s = match s with
The metavar unifier is the end rule, it can't call unify with its parameter (changing their order)
*)
-let rec unify (e1: lexp) (e2: lexp)
+let rec unify ?checking
+ (e1: lexp) (e2: lexp)
(ctx : DB.lexp_context)
: return_type =
- unify' e1 e2 ctx OL.set_empty
+ unify' e1 e2 ctx OL.set_empty checking
and unify' (e1: lexp) (e2: lexp)
(ctx : DB.lexp_context) (vs : OL.set_plexp)
+ (c : scope_level option) (* checking mode scope level *)
: return_type =
if e1 == e2 then [] else
let e1' = OL.lexp_whnf e1 ctx in
@@ -190,20 +194,26 @@ and unify' (e1: lexp) (e2: lexp)
if changed && OL.set_member_p vs e1' e2' then [] else
let vs' = if changed then OL.set_add vs e1' e2' else vs in
match (e1', e2') with
- | ((Imm _, Imm _) | (Cons _, Cons _) | (Builtin _, Builtin _)
- | (Var _, Var _))
+ | ((Imm _, Imm _) | (Cons _, Cons _) | (Builtin _, Builtin _))
-> if OL.conv_p ctx e1' e2' then [] else [(CKimpossible, ctx, e1, e2)]
- | (l, (Metavar (idx, s, _) as r)) -> unify_metavar ctx idx s r l
- | ((Metavar (idx, s, _) as l), r) -> unify_metavar ctx idx s l r
- | (l, (Call _ as r)) -> unify_call r l ctx vs'
- (* | (l, (Case _ as r)) -> unify_case r l subst *)
- | (Arrow _ as l, r) -> unify_arrow l r ctx vs'
- | (Lambda _ as l, r) -> unify_lambda l r ctx vs'
- | (Call _ as l, r) -> unify_call l r ctx vs'
- (* | (Case _ as l, r) -> unify_case l r subst *)
- (* | (Inductive _ as l, r) -> unify_induct l r subst *)
- | (Sort _ as l, r) -> unify_sort l r ctx vs'
- | (SortLevel _ as l, r) -> unify_sortlvl l r ctx vs'
+ | (l, (Metavar (idx, s, _) as r)) -> unify_metavar c ctx idx s r l
+ | ((Metavar (idx, s, _) as l), r) -> unify_metavar c ctx idx s l r
+ | (l, (Call _ as r)) -> unify_call c r l ctx vs'
+ | ((Call _ as l), r) -> unify_call c l r ctx vs'
+ | (l, (Var _ as r)) -> unify_var r l ctx vs'
+ | ((Var _ as l), r) -> unify_var l r ctx vs'
+ | (l, (Arrow _ as r)) -> unify_arrow c r l ctx vs'
+ | ((Arrow _ as l), r) -> unify_arrow c l r ctx vs'
+ | (l, (Lambda _ as r)) -> unify_lambda c r l ctx vs'
+ | ((Lambda _ as l), r) -> unify_lambda c l r ctx vs'
+ (* | (l, (Case _ as r)) -> unify_case r l subst *)
+ (* | ((Case _ as l), r) -> unify_case l r subst *)
+ (* | (l, (Inductive _ as r)) -> unify_induct r l subst *)
+ (* | ((Inductive _ as l), r) -> unify_induct l r subst *)
+ | (l, (Sort _ as r)) -> unify_sort c r l ctx vs'
+ | ((Sort _ as l), r) -> unify_sort c l r ctx vs'
+ | (l, (SortLevel _ as r)) -> unify_sortlvl c r l ctx vs'
+ | ((SortLevel _ as l), r) -> unify_sortlvl c l r ctx vs'
| (Inductive (_loc1, label1, args1, consts1),
Inductive (_loc2, label2, args2, consts2))
-> (* print_string ("Unifying inductives "
@@ -211,7 +221,7 @@ and unify' (e1: lexp) (e2: lexp)
* ^ " and "
* ^ snd label2
* ^ "\n"); *)
- unify_inductive ctx vs' args1 args2 consts1 consts2 e1 e2
+ unify_inductive c ctx vs' args1 args2 consts1 consts2 e1 e2
| _ -> (if OL.conv_p ctx e1' e2' then []
else ((* print_string "Unification failure on default\n"; *)
[(CKresidual, ctx, e1, e2)]))
@@ -222,87 +232,77 @@ and unify' (e1: lexp) (e2: lexp)
- (Arrow, Arrow) -> if var_kind = var_kind
then unify ltype & lexp (Arrow (var_kind, _, ltype, lexp))
else None
- - (Arrow, Var) -> Constraint
- (_, _) -> None
*)
-and unify_arrow (arrow: lexp) (lxp: lexp) ctx vs
+and unify_arrow (checking : scope_level option) (arrow: lexp) (lxp: lexp) ctx vs
: return_type =
match (arrow, lxp) with
| (Arrow (var_kind1, v1, ltype1, _, lexp1),
Arrow (var_kind2, _, ltype2, _, lexp2))
-> if var_kind1 = var_kind2
- then (unify' ltype1 ltype2 ctx vs)
+ then (unify' ltype1 ltype2 ctx vs checking)
@(unify' lexp1 (srename v1 lexp2)
(DB.lexp_ctx_cons ctx v1 Variable ltype1)
- (OL.set_shift vs))
- else [(CKimpossible, ctx, arrow, lxp)]
- | (Arrow _, Imm _) -> [(CKimpossible, ctx, arrow, lxp)]
- | (Arrow _, Var _) -> ([(CKresidual, ctx, arrow, lxp)])
- | (Arrow _, _) -> unify' lxp arrow ctx vs
+ (OL.set_shift vs) checking)
+ else [(CKimpossible, ctx, arrow, lxp)]
| (_, _) -> [(CKimpossible, ctx, arrow, lxp)]
(** Unify a Lambda and a lexp if possible
- - Lamda , Lambda -> if var_kind = var_kind
+ - Lambda , Lambda -> if var_kind = var_kind
then UNIFY ltype & lxp else ERROR
- - Lambda , Var -> CONSTRAINT
- - Lambda , Call -> Constraint
- - Lambda , Let -> Constraint
- - Lambda , lexp -> unify lexp lambda subst
+ - Lambda , _ -> Impossible
*)
-and unify_lambda (lambda: lexp) (lxp: lexp) ctx vs : return_type =
+and unify_lambda (checking : scope_level option) (lambda: lexp) (lxp: lexp) ctx vs : return_type =
match (lambda, lxp) with
| (Lambda (var_kind1, v1, ltype1, lexp1),
Lambda (var_kind2, _, ltype2, lexp2))
-> if var_kind1 = var_kind2
- then (unify' ltype1 ltype2 ctx vs)
+ then (unify' ltype1 ltype2 ctx vs checking)
@(unify' lexp1 lexp2
(DB.lexp_ctx_cons ctx v1 Variable ltype1)
- (OL.set_shift vs))
+ (OL.set_shift vs) checking)
else [(CKimpossible, ctx, lambda, lxp)]
- | ((Lambda _, Var _)
- | (Lambda _, Let _)
- | (Lambda _, Call _)) -> [(CKresidual, ctx, lambda, lxp)]
- | (Lambda _, Arrow _)
- | (Lambda _, Imm _) -> [(CKimpossible, ctx, lambda, lxp)]
- | (Lambda _, _) -> unify' lxp lambda ctx vs
- | (_, _) -> [(CKimpossible, ctx, lambda, lxp)]
+ | (_, _) -> [(CKimpossible, ctx, lambda, lxp)]
(** Unify a Metavar and a lexp if possible
- - lexp , {metavar <-> none} -> UNIFY
- - lexp , {metavar <-> lexp} -> UNFIFY lexp subst[metavar]
- - metavar , metavar -> if Metavar = Metavar then OK else ERROR
- - metavar , lexp -> OK
+ - metavar , metavar -> if Metavar = Metavar then intersect
+ - metavar , metavar -> inverse subst (both sides)
+ - metavar , lexp -> inverse subst
*)
-and unify_metavar ctx idx s1 (lxp1: lexp) (lxp2: lexp)
+and unify_metavar (checking : scope_level option) ctx idx s1 (lxp1: lexp) (lxp2: lexp)
: return_type =
let unif idx s lxp =
- let t = match metavar_lookup idx with
+ let t, sl = match metavar_lookup idx with
| MVal _ -> Log.internal_error
"`lexp_whnf` returned an instantiated metavar!!"
- | MVar (_, t, _) -> push_susp t s in
+ | MVar (_, t, sl) -> push_susp t s, sl in
match Inverse_subst.apply_inv_subst lxp s with
| exception Inverse_subst.Not_invertible
- -> log_info ?loc:None ("Unification of metavar failed:\n "
- ^ "?[" ^ subst_string s ^ "]"
- ^ "\nAgainst:\n "
- ^ lexp_string lxp ^ "\n");
+ -> log_info ~loc:(lexp_location lxp)
+ ("Unification of metavar failed:\n "
+ ^ "?[" ^ subst_string s ^ "]"
+ ^ "\nAgainst:\n "
+ ^ lexp_string lxp ^ "\n");
[(CKresidual, ctx, lxp1, lxp2)]
| lxp' when occurs_in idx lxp' -> [(CKimpossible, ctx, lxp1, lxp2)]
| lxp'
- -> metavar_table := associate idx lxp' (!metavar_table);
- match unify t (OL.get_type ctx lxp) ctx with
- | [] as r -> r
- (* FIXME: Let's ignore the error for now. *)
- | _
- -> log_info ?loc:None
- ("Unification of metavar type failed:\n "
- ^ lexp_string t ^ " != "
- ^ lexp_string (OL.get_type ctx lxp)
- ^ "\n" ^ "for " ^ lexp_string lxp ^ "\n");
- [(CKresidual, ctx, lxp1, lxp2)] in
+ -> match checking with
+ | Some l when l >= sl -> [(CKassoc, ctx, lxp1, lxp2)]
+ | _ -> (
+ associate idx lxp';
+ match unify t (OL.get_type ctx lxp) ctx with
+ | [] as r -> r
+ (* FIXME: Let's ignore the error for now. *)
+ | _
+ -> log_info ?loc:None
+ ("Unification of metavar type failed:\n "
+ ^ lexp_string t ^ " != "
+ ^ lexp_string (OL.get_type ctx lxp)
+ ^ "\n" ^ "for " ^ lexp_string lxp ^ "\n");
+ [(CKresidual, ctx, lxp1, lxp2)]) in
match lxp2 with
| Metavar (idx2, s2, name)
- -> if idx = idx2 then
+ -> if idx = idx2 && checking == None then
match common_subset ctx s1 s2 with
| S.Identity 0 -> [] (* Optimization! *)
(* ¡ s1 != s2 !
@@ -353,7 +353,7 @@ and unify_metavar ctx idx s1 (lxp1: lexp) (lxp2: lexp)
* ^ "\n =\n "
* ^ subst_string (scompose s s2)
* ^ "\n"); *)
- metavar_table := associate idx lexp (!metavar_table);
+ associate idx lexp;
assert (OL.conv_p ctx lxp1 lxp2);
[]
else
@@ -364,18 +364,28 @@ and unify_metavar ctx idx s1 (lxp1: lexp) (lxp2: lexp)
| _ -> unif idx2 s2 lxp1)
| _ -> unif idx s1 lxp2
+(** Unify a Var (var) and a lexp (lxp)
+ - Var , Var -> IF same var THEN ok ELSE constraint
+ - Var , lexp -> Constraint
+*)
+and unify_var (var: lexp) (lxp: lexp) ctx vs
+ : return_type =
+ match (var, lxp) with
+ | (Var _, Var _) when OL.conv_p ctx var lxp -> []
+ | (_, _) -> [(CKresidual, ctx, var, lxp)]
+
(** Unify a Call (call) and a lexp (lxp)
- Call , Call -> UNIFY
- Call , lexp -> CONSTRAINT
*)
-and unify_call (call: lexp) (lxp: lexp) ctx vs
+and unify_call (checking : scope_level option) (call: lexp) (lxp: lexp) ctx vs
: return_type =
match (call, lxp) with
| (Call (lxp_left, lxp_list1), Call (lxp_right, lxp_list2))
when OL.conv_p ctx lxp_left lxp_right
-> List.fold_left (fun op ((ak1, e1), (ak2, e2))
-> if ak1 == ak2 then
- (unify' e1 e2 ctx vs)@op
+ (unify' e1 e2 ctx vs checking)@op
else [(CKimpossible, ctx, call, lxp)])
[]
(List.combine lxp_list1 lxp_list2)
@@ -438,31 +448,29 @@ and unify_call (call: lexp) (lxp: lexp) ctx vs
- SortLevel, SortLevel -> if SortLevel ~= SortLevel then OK else ERROR
- SortLevel, _ -> ERROR
*)
-and unify_sortlvl (sortlvl: lexp) (lxp: lexp) ctx vs : return_type =
+and unify_sortlvl (checking : scope_level option) (sortlvl: lexp) (lxp: lexp) ctx vs : return_type =
match sortlvl, lxp with
| (SortLevel s, SortLevel s2) -> (match s, s2 with
| SLz, SLz -> []
- | SLsucc l1, SLsucc l2 -> unify' l1 l2 ctx vs
+ | SLsucc l1, SLsucc l2 -> unify' l1 l2 ctx vs checking
| SLlub (l11, l12), SLlub (l21, l22)
-> (* FIXME: This SLlub representation needs to be
* more "canonicalized" otherwise it's too restrictive! *)
- (unify' l11 l21 ctx vs)@(unify' l12 l22 ctx vs)
+ (unify' l11 l21 ctx vs checking)@(unify' l12 l22 ctx vs checking)
| _, _ -> [(CKimpossible, ctx, sortlvl, lxp)])
| _, _ -> [(CKresidual, ctx, sortlvl, lxp)]
(** Unify a Sort and a lexp
- Sort, Sort -> if Sort ~= Sort then OK else ERROR
- - Sort, Var -> Constraint
- Sort, lexp -> ERROR
*)
-and unify_sort (sort_: lexp) (lxp: lexp) ctx vs : return_type =
+and unify_sort (checking : scope_level option) (sort_: lexp) (lxp: lexp) ctx vs : return_type =
match sort_, lxp with
| (Sort (_, srt), Sort (_, srt2)) -> (match srt, srt2 with
- | Stype lxp1, Stype lxp2 -> unify' lxp1 lxp2 ctx vs
+ | Stype lxp1, Stype lxp2 -> unify' lxp1 lxp2 ctx vs checking
| StypeOmega, StypeOmega -> []
| StypeLevel, StypeLevel -> []
| _, _ -> [(CKimpossible, ctx, sort_, lxp)])
- | Sort _, Var _ -> [(CKresidual, ctx, sort_, lxp)]
| _, _ -> [(CKimpossible, ctx, sort_, lxp)]
(************************ Helper function ************************************)
@@ -513,7 +521,7 @@ and is_same arglist arglist2 =
* | None -> test e subst)
* ) None lst *)
-and unify_inductive ctx vs args1 args2 consts1 consts2 e1 e2 =
+and unify_inductive (checking : scope_level option) ctx vs args1 args2 consts1 consts2 e1 e2 =
let unif_formals ctx vs args1 args2
= if not (List.length args1 == List.length args2) then
(ctx, vs, [(CKimpossible, ctx, e1, e2)])
@@ -522,7 +530,7 @@ and unify_inductive ctx vs args1 args2 consts1 consts2 e1 e2 =
-> (DB.lexp_ctx_cons ctx v1 Variable t1,
OL.set_shift vs,
if not (ak1 == ak2) then [(CKimpossible, ctx, e1, e2)]
- else (unify' t1 t2 ctx vs) @ residue))
+ else (unify' t1 t2 ctx vs checking) @ residue))
(ctx, vs, [])
(List.combine args1 args2) in
let (ctx, vs, residue) = unif_formals ctx vs args1 args2 in
=====================================
tests/unify_test.ml
=====================================
@@ -199,6 +199,7 @@ let test_input (lxp1: lexp) (lxp2: lexp): unif_res =
else (Unification, res, lxp1, lxp2)
| (CKresidual, _, _, _)::_ -> (Constraint, res, lxp1, lxp2)
| (CKimpossible, _, _, _)::_ -> (Nothing, res, lxp1, lxp2)
+ | _ -> failwith "impossible"
let check (lxp1: lexp) (lxp2: lexp) (res: result): bool =
let r, _, _, _ = test_input lxp1 lxp2
View it on GitLab: https://gitlab.com/monnier/typer/-/compare/2f5e0deb9f057a3a1232e4fc282692f9…
--
View it on GitLab: https://gitlab.com/monnier/typer/-/compare/2f5e0deb9f057a3a1232e4fc282692f9…
You're receiving this email because of your account on gitlab.com.
1
0
[Git][monnier/typer][master] 4 commits: Delay parsing of declarations until elaboration for define-operator
by Jean-Alexandre Barszcz 19 Aoû '20
by Jean-Alexandre Barszcz 19 Aoû '20
19 Aoû '20
Jean-Alexandre Barszcz pushed to branch master at Stefan / Typer
Commits:
f04cab52 by Jean-Alexandre Barszcz at 2020-08-19T17:14:33-04:00
Delay parsing of declarations until elaboration for define-operator
* elab.ml (lexp_p_decls): Add a parameter for unparsed tokens, so that
later declarations can be parsed in a context with newly declared
operators
- - - - -
456370bc by Jean-Alexandre Barszcz at 2020-08-19T17:14:33-04:00
Remove the parsing error for tightly binding postfix operators
- - - - -
8beb9266 by Jean-Alexandre Barszcz at 2020-08-19T17:14:33-04:00
Dump the evaluation context when the variable names don't match
- - - - -
2e00884b by Jean-Alexandre Barszcz at 2020-08-19T17:14:33-04:00
Assign the builtins Int.+, etc to suitable variables Int_+, etc.
_+_ can be Int.+ by default, but we should also keep that value in
Int_+ in case _+_ gets reassigned (with a num typeclass, for
instance).
- - - - -
6 changed files:
- btl/builtins.typer
- src/REPL.ml
- src/debug_util.ml
- src/elab.ml
- src/env.ml
- src/sexp.ml
Changes:
=====================================
btl/builtins.typer
=====================================
@@ -103,10 +103,15 @@ true = datacons Bool true;
false = datacons Bool false;
%% Basic operators
-_+_ = Built-in "Int.+" : Int -> Int -> Int;
-_-_ = Built-in "Int.-" : Int -> Int -> Int;
-_*_ = Built-in "Int.*" : Int -> Int -> Int;
-_/_ = Built-in "Int./" : Int -> Int -> Int;
+Int_+ = Built-in "Int.+" : Int -> Int -> Int;
+Int_- = Built-in "Int.-" : Int -> Int -> Int;
+Int_* = Built-in "Int.*" : Int -> Int -> Int;
+Int_/ = Built-in "Int./" : Int -> Int -> Int;
+
+_+_ = Int_+;
+_-_ = Int_-;
+_*_ = Int_*;
+_/_ = Int_/;
%% modulo
Int_mod = Built-in "Int.mod" : Int -> Int -> Int;
=====================================
src/REPL.ml
=====================================
@@ -135,7 +135,9 @@ let ierase_type (lexps: (ldecl list list * lexpr list)) =
let ilexp_parse pexps lctx: ((ldecl list list * lexpr list) * elab_context) =
let pdecls, pexprs = pexps in
- let ldecls, lctx = Elab.lexp_p_decls pdecls lctx in
+ (* FIXME We take the parsed input here but we should take the
+ unparsed tokens directly instead *)
+ let ldecls, lctx = Elab.lexp_p_decls pdecls [] lctx in
let lexprs = Elab.lexp_parse_all pexprs lctx in
List.iter (fun lxp -> ignore (OL.check (ectx_to_lctx lctx) lxp))
lexprs;
@@ -164,8 +166,7 @@ let ieval f str ectx rctx =
let raw_eval f str ectx rctx =
let pres = (f str) in
let sxps = lex default_stt pres in
- let nods = sexp_parse_all_to_list (ectx_to_grm ectx) sxps (Some ";") in
- let lxps, ectx = Elab.lexp_p_decls nods ectx in
+ let lxps, ectx = Elab.lexp_p_decls [] sxps ectx in
let elxps = List.map OL.clean_decls lxps in
(* At this point, `elxps` is a `(vname * elexp) list list`, where:
* - each `(vname * elexp)` is a definition
=====================================
src/debug_util.ml
=====================================
@@ -138,8 +138,6 @@ let arg_defs = [
Arg.Unit (add_p_option "pretok"), " Print pretok debug info");
("-tok",
Arg.Unit (add_p_option "tok"), " Print tok debug info");
- ("-sexp",
- Arg.Unit (add_p_option "sexp"), " Print sexp debug info");
("-pexp",
Arg.Unit (add_p_option "pexp"), " Print pexp debug info");
("-lexp",
@@ -152,7 +150,6 @@ let arg_defs = [
Arg.Unit (fun () ->
add_p_option "pretok" ();
add_p_option "tok" ();
- add_p_option "sexp" ();
add_p_option "pexp" ();
add_p_option "lexp" ();
add_p_option "lctx" ();
@@ -165,7 +162,6 @@ let parse_args () =
let make_default () =
arg_print_options := SMap.empty;
- add_p_option "sexp" ();
add_p_option "pexp" ();
add_p_option "lexp" ()
@@ -176,10 +172,8 @@ let format_source () =
let filename = List.hd (!arg_files) in
let pretoks = prelex_file filename in
let toks = lex default_stt pretoks in
- let nodes = sexp_parse_all_to_list (ectx_to_grm Elab.default_ectx)
- toks (Some ";") in
let ctx = Elab.default_ectx in
- let lexps, _ = Elab.lexp_p_decls nodes ctx in
+ let lexps, _ = Elab.lexp_p_decls [] toks ctx in
print_string (make_sep '-'); print_string "\n";
@@ -235,26 +229,12 @@ let main () =
print_string (make_title " Base Sexp");
debug_sexp_print_all toks; print_string "\n"));
- (* get node sexp *)
- print_string yellow;
- let nodes = sexp_parse_all_to_list (ectx_to_grm Elab.default_ectx)
- toks (Some ";") in
- print_string reset;
-
- (if (get_p_option "sexp") then(
- print_string (make_title " Node Sexp ");
- debug_sexp_print_all nodes; print_string "\n"));
-
- (* Parse All Declaration *)
- print_string yellow;
- print_string reset;
-
(* get lexp *)
let octx = Elab.default_ectx in
(* debug lexp parsing once merged *)
print_string yellow;
- let lexps, nctx = try Elab.lexp_p_decls nodes octx
+ let lexps, nctx = try Elab.lexp_p_decls [] toks octx
with e ->
print_string reset;
raise e in
=====================================
src/elab.ml
=====================================
@@ -1181,136 +1181,152 @@ and infer_and_generalize_def (ctx : elab_context) se =
(e', t')
and lexp_decls_1
- (sdecls : sexp list)
+ (sdecls : sexp list) (* What's already parsed *)
+ (tokens : token list) (* Rest of input *)
(ectx : elab_context) (* External ctx. *)
(nctx : elab_context) (* New context. *)
(pending_decls : location SMap.t) (* Pending type decls. *)
(pending_defs : (symbol * sexp) list) (* Pending definitions. *)
- : (vname * lexp * ltype) list * sexp list * elab_context =
-
- let rec lexp_decls_1 sdecls ectx nctx pending_decls pending_defs =
- match sdecls with
- | [] -> (if not (SMap.is_empty pending_decls) then
- let (s, loc) = SMap.choose pending_decls in
- error ~loc ("Variable `" ^ s ^ "` declared but not defined!")
- else
- assert (pending_defs == []));
- [], [], nctx
-
- | Symbol (_, "") :: sdecls
- -> lexp_decls_1 sdecls ectx nctx pending_decls pending_defs
-
- | Node (Symbol (_, ("_;_" (* | "_;" | ";_" *))), sdecls') :: sdecls
- -> lexp_decls_1 (List.append sdecls' sdecls)
- ectx nctx pending_decls pending_defs
-
- | Node (Symbol (loc, "_:_"), args) :: sdecls
- (* FIXME: Move this to a "special form"! *)
- -> (match args with
- | [Symbol (loc, vname); stp]
- -> let ltp = infer_and_generalize_type nctx stp (loc, Some vname) in
- if SMap.mem vname pending_decls then
- (* Don't burp: take'em all and unify! *)
- let pt_idx = senv_lookup vname nctx in
- (* Take the previous type annotation. *)
- let pt = match Myers.nth pt_idx (ectx_to_lctx nctx) with
- | (_, ForwardRef, t) -> push_susp t (S.shift (pt_idx + 1))
- | _ -> Log.internal_error "Var not found at its index!" in
- (* Unify it with the new one. *)
- let _ = match Unif.unify ltp pt (ectx_to_lctx nctx) with
- | (_::_)
- -> lexp_error loc ltp
- ("New type annotation `"
- ^ lexp_string ltp ^ "` incompatible with previous `"
- ^ lexp_string pt ^ "`")
- | [] -> () in
- lexp_decls_1 sdecls ectx nctx pending_decls pending_defs
- else if List.exists (fun ((_, vname'), _) -> vname = vname')
- pending_defs then
- (error ~loc ("Variable `" ^ vname ^ "` already defined!");
- lexp_decls_1 sdecls ectx nctx pending_decls pending_defs)
- else lexp_decls_1 sdecls ectx
- (ectx_extend nctx (loc, Some vname) ForwardRef ltp)
- (SMap.add vname loc pending_decls)
- pending_defs
- | _ -> error ~loc "Invalid type declaration syntax";
- lexp_decls_1 sdecls ectx nctx pending_decls pending_defs)
-
- | Node (Symbol (l, "_=_") as head, args) :: sdecls
- (* FIXME: Move this to a "special form"! *)
- -> (match args with
- | [Symbol ((l, vname)); sexp]
- when SMap.is_empty pending_decls
- -> assert (pending_defs == []);
- (* Used to be true before we added define-operator. *)
- (* assert (ectx == nctx); *)
- let (lexp, ltp) = infer_and_generalize_def nctx sexp in
- let var = (l, Some vname) in
- (* Lexp decls are always recursive, so we have to shift by 1 to
- * account for the extra var (ourselves). *)
- [(var, mkSusp lexp (S.shift 1), ltp)], sdecls,
- ctx_define nctx var lexp ltp
-
- | [Symbol (l, vname); sexp]
- -> if SMap.mem vname pending_decls then
- let decl_loc = SMap.find vname pending_decls in
- let v = ({file = l.file;
- line = l.line;
- column = l.column;
- docstr = String.concat "\n" [decl_loc.docstr; l.docstr]},
- vname) in
- let pending_decls = SMap.remove vname pending_decls in
- let pending_defs = ((v, sexp) :: pending_defs) in
- if SMap.is_empty pending_decls then
- let nctx = ectx_new_scope nctx in
- let decls, nctx = lexp_check_decls ectx nctx pending_defs in
- decls, sdecls, nctx
- else
- lexp_decls_1 sdecls ectx nctx pending_decls pending_defs
-
- else
- (error ~loc:l ("`" ^ vname ^ "` defined but not declared!");
- lexp_decls_1 sdecls ectx nctx pending_decls pending_defs)
-
- | [Node (Symbol s, args) as d; body]
- -> (* FIXME: Make it a macro (and don't hardcode `lambda_->_`)! *)
- lexp_decls_1 ((Node (head,
- [Symbol s;
- Node (Symbol (sexp_location d, "lambda_->_"),
- [sexp_u_list args; body])]))
- :: sdecls)
- ectx nctx pending_decls pending_defs
-
- | _ -> error ~loc:l "Invalid definition syntax";
- lexp_decls_1 sdecls ectx nctx pending_decls pending_defs)
-
- | Node (Symbol (l, "define-operator"), args) :: sdecls
- (* FIXME: Move this to a "special form"! *)
- -> lexp_decls_1 sdecls ectx (sdform_define_operator nctx l args None)
- pending_decls pending_defs
-
- | Node (Symbol ((l, _) as v), sargs) :: sdecls
- -> (* expand macro and get the generated declarations *)
- let sdecl' = lexp_decls_macro v sargs nctx in
- lexp_decls_1 (sdecl' :: sdecls) ectx nctx
- pending_decls pending_defs
-
- | sexp :: sdecls
- -> error ~loc:(sexp_location sexp) "Invalid declaration syntax";
- lexp_decls_1 sdecls ectx nctx pending_decls pending_defs
+ : (vname * lexp * ltype) list * sexp list * token list * elab_context =
+
+ let rec lexp_decls_1 sdecls tokens nctx pending_decls pending_defs =
+ let sdecl, sdecls, toks =
+ match (sdecls, tokens) with
+ | (s :: sdecls, _) -> Some s, sdecls, tokens
+ | ([], []) -> None, [], []
+ | ([], _) ->
+ let (s, toks) = sexp_parse_all (ectx_get_grammar nctx)
+ tokens (Some ";") in
+ Some s, [], toks in
+ let recur prepend_sdecls nctx pending_decls pending_defs =
+ lexp_decls_1 (List.append prepend_sdecls sdecls)
+ toks nctx pending_decls pending_defs in
+ match sdecl with
+ | None -> (if not (SMap.is_empty pending_decls) then
+ let (s, loc) = SMap.choose pending_decls in
+ error ~loc ("Variable `" ^ s ^ "` declared but not defined!")
+ else
+ assert (pending_defs == []));
+ [], [], [], nctx
+
+ | Some (Symbol (_, ""))
+ -> recur [] nctx pending_decls pending_defs
+
+ | Some (Node (Symbol (_, ("_;_" (* | "_;" | ";_" *))), sdecls'))
+ -> recur sdecls' nctx pending_decls pending_defs
+
+ | Some (Node (Symbol (loc, "_:_"), args) as thesexp)
+ (* FIXME: Move this to a "special form"! *)
+ -> (match args with
+ | [Symbol (loc, vname); stp]
+ -> let ltp = infer_and_generalize_type nctx stp (loc, Some vname) in
+ if SMap.mem vname pending_decls then
+ (* Don't burp: take'em all and unify! *)
+ let pt_idx = senv_lookup vname nctx in
+ (* Take the previous type annotation. *)
+ let pt = match Myers.nth pt_idx (ectx_to_lctx nctx) with
+ | (_, ForwardRef, t) -> push_susp t (S.shift (pt_idx + 1))
+ | _ -> Log.internal_error "Var not found at its index!" in
+ (* Unify it with the new one. *)
+ let _ = match Unif.unify ltp pt (ectx_to_lctx nctx) with
+ | (_::_)
+ -> lexp_error loc ltp
+ ("New type annotation `"
+ ^ lexp_string ltp ^ "` incompatible with previous `"
+ ^ lexp_string pt ^ "`")
+ | [] -> () in
+ recur [] nctx pending_decls pending_defs
+ else if List.exists (fun ((_, vname'), _) -> vname = vname')
+ pending_defs then
+ (error ~loc ("Variable `" ^ vname ^ "` already defined!");
+ recur [] nctx pending_decls pending_defs)
+ else recur [] (ectx_extend nctx (loc, Some vname) ForwardRef ltp)
+ (SMap.add vname loc pending_decls)
+ pending_defs
+ | _ -> error ~loc ("Invalid type declaration syntax : `" ^
+ (sexp_string thesexp) ^ "`");
+ recur [] nctx pending_decls pending_defs)
+
+ | Some (Node (Symbol (l, "_=_") as head, args) as thesexp)
+ (* FIXME: Move this to a "special form"! *)
+ -> (match args with
+ | [Symbol ((l, vname)); sexp]
+ when SMap.is_empty pending_decls
+ -> assert (pending_defs == []);
+ (* Used to be true before we added define-operator. *)
+ (* assert (ectx == nctx); *)
+ let (lexp, ltp) = infer_and_generalize_def nctx sexp in
+ let var = (l, Some vname) in
+ (* Lexp decls are always recursive, so we have to shift by 1 to
+ * account for the extra var (ourselves). *)
+ [(var, mkSusp lexp (S.shift 1), ltp)], sdecls, toks,
+ ctx_define nctx var lexp ltp
+
+ | [Symbol (l, vname); sexp]
+ -> if SMap.mem vname pending_decls then
+ let decl_loc = SMap.find vname pending_decls in
+ let v = ({file = l.file;
+ line = l.line;
+ column = l.column;
+ docstr = String.concat "\n" [decl_loc.docstr;
+ l.docstr]},
+ vname) in
+ let pending_decls = SMap.remove vname pending_decls in
+ let pending_defs = ((v, sexp) :: pending_defs) in
+ if SMap.is_empty pending_decls then
+ let nctx = ectx_new_scope nctx in
+ let decls, nctx = lexp_check_decls ectx nctx pending_defs in
+ decls, sdecls, toks, nctx
+ else
+ recur [] nctx pending_decls pending_defs
+
+ else
+ (error ~loc:l ("`" ^ vname ^ "` defined but not declared!");
+ recur [] nctx pending_decls pending_defs)
+
+ | [Node (Symbol s, args) as d; body]
+ -> (* FIXME: Make it a macro (and don't hardcode `lambda_->_`)! *)
+ recur [Node (head,
+ [Symbol s;
+ Node (Symbol (sexp_location d, "lambda_->_"),
+ [sexp_u_list args; body])])]
+ nctx pending_decls pending_defs
+
+ | _ -> error ~loc:l ("Invalid definition syntax : `" ^
+ (sexp_string thesexp) ^ "`");
+ recur [] nctx pending_decls pending_defs)
+
+ | Some (Node (Symbol (l, "define-operator"), args))
+ (* FIXME: Move this to a "special form"! *)
+ -> recur [] (sdform_define_operator nctx l args None)
+ pending_decls pending_defs
+
+ | Some (Node (Symbol ((l, _) as v), sargs))
+ -> (* expand macro and get the generated declarations *)
+ let sdecl' = lexp_decls_macro v sargs nctx in
+ recur [sdecl'] nctx pending_decls pending_defs
+
+ | Some sexp
+ -> error ~loc:(sexp_location sexp) "Invalid declaration syntax";
+ recur [] nctx pending_decls pending_defs
in (EV.set_getenv nctx;
- let res = lexp_decls_1 sdecls ectx nctx pending_decls pending_defs in
+ let res = lexp_decls_1 sdecls tokens nctx
+ pending_decls pending_defs in
(Log.stop_on_error (); res))
-and lexp_p_decls (sdecls : sexp list) (ctx : elab_context)
+and lexp_p_decls (sdecls : sexp list) (tokens : token list) (ctx : elab_context)
: ((vname * lexp * ltype) list list * elab_context) =
- let impl sdecls ctx = match sdecls with
- | [] -> [], ectx_new_scope ctx
- | _ -> let decls, sdecls, nctx = lexp_decls_1 sdecls ctx ctx SMap.empty [] in
- let declss, nnctx = lexp_p_decls sdecls nctx in
- decls :: declss, nnctx in
- let res = impl sdecls ctx in (Log.stop_on_error (); res)
+ let rec impl sdecls tokens ctx =
+ match (sdecls, tokens) with
+ | ([], []) -> [], ectx_new_scope ctx
+ | _ ->
+ let decls, sdecls, tokens, nctx =
+ lexp_decls_1 sdecls tokens ctx ctx SMap.empty [] in
+ Log.stop_on_error ();
+ let declss, nnctx = impl sdecls tokens nctx in
+ decls :: declss, nnctx in
+ impl sdecls tokens ctx
and lexp_parse_all (p: sexp list) (ctx: elab_context) : lexp list =
let res = List.map (fun pe -> let e, _ = infer pe ctx in e) p in
@@ -1695,7 +1711,7 @@ let rec sform_case ctx loc sargs ot = match sargs with
let sform_letin ctx loc sargs ot = match sargs with
| [sdecls; sbody]
- -> let declss, nctx = lexp_p_decls [sdecls] ctx in
+ -> let declss, nctx = lexp_p_decls [sdecls] [] ctx in
(* FIXME: Use `elaborate`. *)
let bdy, ltp = infer sbody (ectx_new_scope nctx) in
let s = List.fold_left (OL.lexp_defs_subst loc) S.identity declss in
@@ -1772,9 +1788,7 @@ let sform_load usr_elctx loc sargs ot =
let read_file file_name elctx =
let pres = prelex_file file_name in
let sxps = lex default_stt pres in
- let nods = sexp_parse_all_to_list (ectx_get_grammar elctx)
- sxps (Some ";") in
- let _, elctx = lexp_p_decls nods elctx
+ let _, elctx = lexp_p_decls [] sxps elctx
in elctx in
(* read file as elab_context *)
@@ -1860,9 +1874,7 @@ let default_ectx
let read_file file_name elctx =
let pres = prelex_file file_name in
let sxps = lex default_stt pres in
- let nods = sexp_parse_all_to_list (ectx_get_grammar elctx)
- sxps (Some ";") in
- let _, lctx = lexp_p_decls nods elctx
+ let _, lctx = lexp_p_decls [] sxps elctx
in lctx in
(* Register predef *)
@@ -1922,10 +1934,8 @@ let lexp_expr_str str ctx =
let lexp_decl_str str ctx =
try let tenv = default_stt in
- let grm = ectx_get_grammar ctx in
- let limit = Some ";" in
- let sdecls = sexp_parse_str str tenv grm limit in
- lexp_p_decls sdecls ctx
+ let tokens = lex_str str tenv in
+ lexp_p_decls [] tokens ctx
with Log.Stop_Compilation s -> ([],ctx)
=====================================
src/env.ml
=====================================
@@ -167,6 +167,41 @@ let make_runtime_ctx = M.nil
let get_rte_size (ctx: runtime_env): int = M.length ctx
+let print_myers_list l print_fun start =
+ let n = (M.length l) - 1 in
+ print_string (make_title " ENVIRONMENT ");
+ make_rheader [(None, "INDEX");
+ (None, "VARIABLE NAME"); (Some ('l', 48), "VALUE")];
+ print_string (make_sep '-');
+
+ for i = start to n do
+ print_string " | ";
+ ralign_print_int (n - i) 5;
+ print_string " | ";
+ print_fun (M.nth (n - i) l);
+ done;
+ print_string (make_sep '=')
+
+let print_rte_ctx_n (ctx: runtime_env) start =
+ print_myers_list
+ ctx
+ (fun (n, vref) ->
+ let g = !vref in
+ let _ =
+ match n with
+ | (_, Some m) -> lalign_print_string m 12; print_string " | "
+ | _ -> print_string (make_line ' ' 12); print_string " | " in
+
+ value_print g; print_string "\n") start
+
+(* Only print user defined variables *)
+let print_rte_ctx ctx =
+ print_rte_ctx_n ctx (!L.builtin_size)
+
+(* Dump the whole context *)
+let dump_rte_ctx ctx =
+ print_rte_ctx_n ctx 0
+
let get_rte_variable (name: vname) (idx: int)
(ctx: runtime_env): value_type =
try (
@@ -177,7 +212,7 @@ let get_rte_variable (name: vname) (idx: int)
if n1 = n2 then
x
else (
- fatal
+ fatal ~print_action:(fun () -> dump_rte_ctx ctx)
("Variable lookup failure. Expected: \"" ^
n2 ^ "[" ^ (string_of_int idx) ^ "]" ^ "\" got \"" ^ n1 ^ "\"")))
@@ -212,37 +247,3 @@ let nfirst_rte_var n ctx =
List.rev acc in
loop 0 []
-let print_myers_list l print_fun start =
- let n = (M.length l) - 1 in
- print_string (make_title " ENVIRONMENT ");
- make_rheader [(None, "INDEX");
- (None, "VARIABLE NAME"); (Some ('l', 48), "VALUE")];
- print_string (make_sep '-');
-
- for i = start to n do
- print_string " | ";
- ralign_print_int (n - i) 5;
- print_string " | ";
- print_fun (M.nth (n - i) l);
- done;
- print_string (make_sep '=')
-
-let print_rte_ctx_n (ctx: runtime_env) start =
- print_myers_list
- ctx
- (fun (n, vref) ->
- let g = !vref in
- let _ =
- match n with
- | (_, Some m) -> lalign_print_string m 12; print_string " | "
- | _ -> print_string (make_line ' ' 12); print_string " | " in
-
- value_print g; print_string "\n") start
-
-(* Only print user defined variables *)
-let print_rte_ctx ctx =
- print_rte_ctx_n ctx (!L.builtin_size)
-
-(* Dump the whole context *)
-let dump_rte_ctx ctx =
- print_rte_ctx_n ctx 0
=====================================
src/sexp.ml
=====================================
@@ -160,13 +160,18 @@ let rec sexp_parse (g : grammar) (rest : sexp list)
mk_node ((l,"")::op) largs rargs true),
rest)
| (Some ll, None) when ll > level
- (* A closer without matching opener.
- * It might simply be a postfix symbol that binds very tightly.
- * We currently signal an error because it's more common for
- * it to be a closer with missing opener. *)
- -> sexp_error l ("Lonely postfix/closer \""^name^"\"");
- sexp_parse rest' level op largs
- [mk_node [(l,name);(l,"")] [] rargs true]
+ (* A closer without matching opener or a postfix symbol
+ that binds very tightly. Previously, we signaled an
+ error (assuming the former), but it prevented the use
+ tightly binding postfix operators.
+
+ For example, it signaled spurious errors when parsing
+ expressions with a tightly binding postfix # operator
+ that implemented record construction by taking an
+ inductive as argument and returning the inductive's only
+ constructor. *)
+ -> sexp_parse rest' level op largs
+ [mk_node [(l,name);(l,"")] [] rargs true]
| (Some ll, Some rl) when ll > level
(* A new infix which binds more tightly, i.e. does not close
* the current `op' but takes its `rargs' instead. *)
View it on GitLab: https://gitlab.com/monnier/typer/-/compare/2bd6aa15e783ef5ce69df7339a9dcfe2…
--
View it on GitLab: https://gitlab.com/monnier/typer/-/compare/2bd6aa15e783ef5ce69df7339a9dcfe2…
You're receiving this email because of your account on gitlab.com.
1
0