Typer
Discussions par mois
- ----- 2026 -----
- juin
- mai
- avril
- mars
- février
- janvier
- ----- 2025 -----
- décembre
- novembre
- octobre
- septembre
- août
- juillet
- juin
- mai
- avril
- mars
- février
- janvier
- ----- 2024 -----
- décembre
- novembre
- octobre
- septembre
- août
- juillet
- juin
- mai
- avril
- mars
- février
- janvier
- ----- 2023 -----
- décembre
- novembre
- octobre
- septembre
- août
- juillet
- juin
- mai
- avril
- mars
- février
- janvier
- ----- 2022 -----
- décembre
- novembre
- octobre
- septembre
- août
- juillet
- juin
- mai
- avril
- mars
- février
- janvier
- ----- 2021 -----
- décembre
- novembre
- octobre
- septembre
- août
- juillet
- juin
- mai
- avril
- mars
- février
- janvier
- ----- 2020 -----
- décembre
- novembre
- octobre
- septembre
- août
- juillet
- juin
- mai
- avril
- mars
- février
- janvier
- ----- 2019 -----
- décembre
- novembre
- octobre
- septembre
- août
- juillet
- juin
- mai
- avril
- mars
- février
- janvier
- ----- 2018 -----
- décembre
- novembre
- octobre
- septembre
- août
- juillet
- juin
- mai
- avril
- mars
- février
- janvier
- ----- 2017 -----
- décembre
- novembre
- octobre
- septembre
- août
- juillet
- juin
- mai
- avril
- mars
- février
- janvier
- ----- 2016 -----
- décembre
- novembre
- octobre
- septembre
- août
- juillet
- juin
- mai
- avril
- mars
- février
Juillet 2020
- 2 participants
- 13 discussions
[Git][monnier/typer][ja-barszcz] 21 commits: Delay parsing of declarations until elaboration for define-operator
by Jean-Alexandre Barszcz 05 Aoû '20
by Jean-Alexandre Barszcz 05 Aoû '20
05 Aoû '20
Jean-Alexandre Barszcz pushed to branch ja-barszcz at Stefan / Typer
Commits:
1a5bfcae by Jean-Alexandre Barszcz at 2020-07-28T22:51:58-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
- - - - -
b5f1c7d5 by Jean-Alexandre Barszcz at 2020-07-28T22:51:58-04:00
Remove the parsing error for tightly binding postfix operators
- - - - -
ee058a31 by Jean-Alexandre Barszcz at 2020-07-28T22:51:59-04:00
Dump the evaluation context when the variable names don't match
- - - - -
5295751f by Jean-Alexandre Barszcz at 2020-07-28T22:51:59-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).
- - - - -
5ea4cce6 by Jean-Alexandre Barszcz at 2020-07-28T22:51:59-04:00
[WIP] Make unification symmetric
- - - - -
aa399556 by Jean-Alexandre Barszcz at 2020-07-28T22:51:59-04:00
[WIP] Handle variables earlier during unification
- - - - -
f475bf95 by Jean-Alexandre Barszcz at 2020-07-28T22:51:59-04:00
[WIP] experiments with Decidable and proofs
- - - - -
76a5c700 by Jean-Alexandre Barszcz at 2020-07-28T22:51:59-04:00
[WIP] unify instead of conv_p in sform_lambda
- - - - -
baa434b7 by Jean-Alexandre Barszcz at 2020-07-28T22:51:59-04:00
[WIP] proof of Decidable (a < b)
- - - - -
c80ece7c by Jean-Alexandre Barszcz at 2020-07-28T22:51:59-04:00
[WIP] First draft of an instance search algorithm
- - - - -
1f5e6f8b by Jean-Alexandre Barszcz at 2020-07-28T22:51:59-04:00
WIP WIP WIP
- - - - -
21b400fb by Jean-Alexandre Barszcz at 2020-07-28T22:51:59-04:00
WIP WIP getting there
- - - - -
51237885 by Jean-Alexandre Barszcz at 2020-07-28T22:51:59-04:00
[WIP] Add a set of typeclasses to the elab context
- - - - -
f3c2b6c5 by Jean-Alexandre Barszcz at 2020-07-28T22:51:59-04:00
[WIP] Add a syntax for records
- - - - -
44f942af by Jean-Alexandre Barszcz at 2020-07-28T22:51:59-04:00
[WIP] Extend the Decidable sample with conjunction (dep on records)
- - - - -
3bda7d77 by Jean-Alexandre Barszcz at 2020-07-28T22:51:59-04:00
Resolve instances in the REPL (since exprs. are not generalized)
- - - - -
44615264 by Jean-Alexandre Barszcz at 2020-07-28T22:51:59-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.
- - - - -
e05c55e5 by Jean-Alexandre Barszcz at 2020-07-28T22:51:59-04:00
Num class example
- - - - -
dba40a0c by Jean-Alexandre Barszcz at 2020-07-28T22:51:59-04:00
Num class (with records)
- - - - -
f8129e1c by Jean-Alexandre Barszcz at 2020-07-28T22:51:59-04:00
Move the Eq builtin to debruijn.ml to make it available for elab.
- - - - -
f57ebf87 by Jean-Alexandre Barszcz at 2020-07-28T22:51:59-04:00
[WIP] (Broken) Add Eq to case
- - - - -
20 changed files:
- btl/builtins.typer
- btl/pervasive.typer
- + btl/records.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/log.ml
- src/myers.ml
- src/opslexp.ml
- src/sexp.ml
- src/unification.ml
- tests/unify_test.ml
Changes:
=====================================
btl/builtins.typer
=====================================
@@ -100,10 +100,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 +360,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 +392,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/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,8 @@ 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
let register_builtin_types () =
let _ = new_builtin_type "Sexp" DB.type0 in
@@ -175,7 +163,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,20 @@ 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)
+
(* easier to debug with type annotations *)
type env_elem = (vname * varbind * ltype)
@@ -112,26 +126,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 +159,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 +167,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 +206,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 +224,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
@@ -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
| _
@@ -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 "
@@ -781,9 +861,36 @@ and check_case rtype (loc, target, ppatterns) ctx =
(* 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 +971,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 +1062,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 +1114,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 +1228,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 +1240,10 @@ 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
+ 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 +1279,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 +1287,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 +1299,160 @@ 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 =
+ 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 +1777,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 +1842,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 +1919,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 +1955,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 +2000,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 +2022,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 +2082,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,61 @@
+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_ind (lctx : DB.lexp_context) (t : L.ltype) : L.ltype option =
+ match OL.lexp_whnf t lctx with
+ | L.Call (typecons, _) ->
+ (match OL.lexp_whnf typecons lctx with
+ | L.Inductive _ as ind -> Some ind
+ | _ -> None
+ )
+ | L.Inductive _ as ind -> Some ind
+ | _ -> None
+
+
+let is_typeclass (ctx : DB.elab_context) (t : L.ltype) =
+ let lctx = DB.ectx_to_lctx ctx in
+ match get_ind lctx t with
+ | Some ind -> env_is_typeclass ctx ind
+ | None -> false
+
+let add_typeclass (ctx : DB.elab_context) (t : L.ltype) : DB.elab_context =
+ let lctx = DB.ectx_to_lctx ctx in
+ match get_ind lctx t with
+ | Some ind -> DB.env_add_typeclass ctx ind
+ | None -> Log.log_error ("Failed to add type class to context "
+ ^ " because it is not an inductive : `"
+ ^ (L.lexp_string t) ^ "`"); ctx
+
+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/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
=====================================
@@ -166,7 +166,7 @@ let lexp_whnf e (ctx : DB.lexp_context) : lexp =
d + 1))
(S.identity, 0)
aargs in
- lexp_whnf (push_susp branch subst) ctx
+ lexp_whnf (push_susp branch (S.mkShift subst 1)) ctx (* FIXME not sure about the subt here *)
with Not_found
-> match default
with | Some (v,default)
@@ -610,9 +610,9 @@ 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, s, hlxp)
(* FIXME: If ak is Aerasable, make sure the var only
* appears in type annotations. *)
| (ak, vdef)::vdefs, (ak', vdef', ftype)::fieldtypes
@@ -620,14 +620,27 @@ let rec check'' erased ctx e =
(DB.lexp_ctx_cons ctx vdef Variable (mkSusp ftype s))
(S.cons (mkVar (vdef, 0))
(S.mkShift s 1))
+ (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, s, hlxp)) in
+ let (nerased, nctx, subst, hlxp) =
+ mkctx erased ctx s (mkCons (it, (l, name))) vdefs fieldtypes in
+ (* Create Eq type between target and lexp matching the
+ branch head, and add it (erasable) to the context *)
+ let tlxp = mkSusp e subst in
+ let tltp = mkSusp etype subst in
+ let eqty = mkCall (DB.type_eq,
+ [(Aerasable, DB.type0); (* Typelevel *)
+ (Aerasable, tltp); (* Inductive type *)
+ (Anormal, tlxp); (* Target lexp *)
+ (Anormal, hlxp)]) in (* Lexp of the branch head *)
+ let nerased = dbset_push Aerasable nerased in
+ 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
@@ -723,6 +736,7 @@ module LMap
= Hashtbl.Make
(struct type t = lexp let hash = Hashtbl.hash let equal = (==) end)
let fv_memo = LMap.create 1000
+let fv_flush () = LMap.clear fv_memo
let fv_empty = (DB.set_empty, mv_set_empty)
let fv_union (fv1, mv1) (fv2, mv2)
=====================================
src/sexp.ml
=====================================
@@ -160,13 +160,10 @@ 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 it might simply be
+ * a postfix symbol that binds very tightly. *)
+ -> 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/0da3daa94006b453964de8f17812e492…
--
View it on GitLab: https://gitlab.com/monnier/typer/-/compare/0da3daa94006b453964de8f17812e492…
You're receiving this email because of your account on gitlab.com.
2
3
04 Aoû '20
Alice de Berny pushed to branch alice at Stefan / Typer
Commits:
028fb86e by irradiee at 2020-07-24T09:11:53-04:00
remove susbt hash table
- - - - -
af983619 by irradiee at 2020-07-31T09:11:10-04:00
remove lexp_type & clean code
- - - - -
19 changed files:
- GNUmakefile
- − profiling.txt
- − samples/acctime.typer
- src/REPL.ml
- src/builtin.ml
- src/debruijn.ml
- src/debug_util.ml
- src/elab.ml
- src/elexp.ml
- src/env.ml
- src/eval.ml
- src/inverse_subst.ml
- src/lexp.ml
- − src/lexp_type.ml
- src/opslexp.ml
- src/subst.ml
- src/unification.ml
- src/util.ml
- − stats.txt
Changes:
=====================================
GNUmakefile
=====================================
@@ -4,15 +4,15 @@ 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)
-TIME_FILE := ./samples/acctime.typer
-
-# camlLexp__hc / camlLexp__hc_eq / camlLexp_type__lexp_hash / camlSubst__subst_hash
-MOTIF := camlSubst__hcsb_
+DEPSORT_FILES := $(shell ocamldep -sort -I src $(SRC_NO_DEBUG))
-OBFLAGS = -tag debug -tag e -lib str -build-dir $(BUILDDIR) -pkg zarith -pkg unix
+OBFLAGS = -tag debug -tag e -lib str -build-dir $(BUILDDIR) -pkg zarith
# OBFLAGS := -I $(SRCDIR) -build-dir $(BUILDDIR) -pkg str
# OBFLAGS_DEBUG := -tag debug -tag e -tag "warn(+20)"
# OBFLAGS_RELEASE := -tag unsafe -tag inline
@@ -22,17 +22,6 @@ COMPILE_MODE = byte
# DEBUG ?= 1
# VERBOSE ?= 1
-OCAMLCP := ocamlcp
-OCAMLOPTP := ocamloptp
-OCAMLOPT := ocamlopt
-OCAMLDEP := ocamldep
-GPROF := gprof
-GREP := grep
-
-OCAMLFLAGS := -I src
-SRC_NO_DEBUG := $(filter-out ./src/debug_util.ml, $(SRC_FILES))
-DEPSORT_FILES := $(shell ocamldep -sort -I src $(SRC_NO_DEBUG))
-
all: typer debug tests-build
# ifeq ($(OS), Windows_NT)
@@ -136,24 +125,14 @@ profiling-cp:
# profiling bytecode
# ============================
ocamlfind $(OCAMLCP) -o profiling -linkpkg -package zarith -package unix \
- $(OCAMLFLAGS) str.cma -P f $(DEPSORT_FILES)
+ -I src str.cma -P f $(DEPSORT_FILES)
profiling-optp:
# ============================
# profiling native
# ============================
ocamlfind $(OCAMLOPTP) -o profiling -linkpkg -package zarith -package unix \
- $(OCAMLFLAGS) str.cmxa -P f $(DEPSORT_FILES)
-
-time:
- # ============================
- # time native
- # ============================
- ocamlfind $(OCAMLOPT) -p -o profiling -linkpkg -package zarith -package unix \
- $(OCAMLFLAGS) str.cmxa $(DEPSORT_FILES)
- ./profiling --batch $(TIME_FILE)
- $(GPROF) ./profiling >> profiling.txt
- $(GREP) $(MOTIF) profiling.txt
+ -I src str.cmxa -P f $(DEPSORT_FILES)
# Clean up
clean-profiling:
=====================================
profiling.txt deleted
=====================================
The diff for this file was not included because it is too large.
=====================================
samples/acctime.typer deleted
=====================================
@@ -1,2159 +0,0 @@
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
-
-accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
-accumulate = lambda (t : Type) ≡>
- lambda (acc-op : (t -> t -> t)) ->
- lambda (init : t) ->
- lambda (list : List t) ->
- case list
- | cons hd tl => accumulate acc-op (acc-op init hd) tl
- | nil => init;
-
-
-map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
-map = lambda (a : Type) ≡>
- lambda (b : Type) ≡>
- lambda (list : List a) ->
- lambda (f : a -> b) ->
- case list
- | cons hd tl => (cons (f hd) (map tl f))
- | nil => nil;
-
-list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
-
-% main = accumulate _+_ 0 list;
-% main = map list (lambda x -> (x + 1));
=====================================
src/REPL.ml
=====================================
@@ -44,7 +44,7 @@ open Prelexer
open Lexer
open Sexp
open Pexp
-open Lexp_type
+
open Lexp
open Eval
@@ -203,9 +203,10 @@ let help_msg =
%help (%h) : print help
"
-let readfiles_aux files (i, lctx, rctx) prt =
+
+let readfiles files (i, lctx, rctx) prt =
(* Read specified files *)
- List.fold_left (fun (i, lctx, rctx) file ->
+ List.fold_left (fun (i, lctx, rctx) file ->
(if prt then (
print_string " In["; ralign_print_int i 2; print_string "] >> ";
@@ -220,9 +221,6 @@ let readfiles_aux files (i, lctx, rctx) prt =
)
(i, lctx, rctx) files
-let readfiles files (i, lctx, rctx) prt =
- let res = readfiles_aux files (i, lctx, rctx) prt in
- res
(* Specials commands %[command-name] [args] *)
let rec repl i clxp rctx =
@@ -234,7 +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) !lshrct !nf_lshrct)
+ | "%lcollisions" | "%cl" -> (get_stats_hashtbl (WHC.stats hc_table))
(* command with arguments *)
| _ when (ipt.[0] = '%' && ipt.[1] != ' ') -> (
@@ -244,16 +242,9 @@ let rec repl i clxp rctx =
try
readfiles args (i, clxp, rctx) false
with Log.Stop_Compilation msg ->
- (handle_stopped_compilation msg; (i,clxp,rctx)) in
- repl clxp rctx
- | "%readfiletime"::args ->
- (time_process := true;
- let (i, clxp, rctx) =
- try
- get_unix_stats_processtime (fun () -> (readfiles args (i, clxp, rctx) false))
- with Log.Stop_Compilation msg ->
- (handle_stopped_compilation msg; (i,clxp,rctx)) in
- repl clxp rctx)
+ (handle_stopped_compilation msg; (i,clxp,rctx))
+ in
+ repl clxp rctx;
| "%who"::args | "%w"::args -> (
let _ = match args with
| ["all"] -> dump_rte_ctx rctx
@@ -295,7 +286,6 @@ let arg_defs = [
("--verbosity",
Arg.String Log.set_typer_log_level_str, "Set the logging level");
("-v", Arg.Unit Log.increment_log_level, "Increment verbosity");
- ("--time", Arg.Set time_process, "Get time for process");
(* ("--debug", Arg.Set arg_debug, "Print the Elexp representation") *)
(*"-I",
Arg.String (fun f -> searchpath := f::!searchpath),
@@ -319,16 +309,9 @@ let main () =
let (i, ectx, rctx) = (
try
- if !time_process
- then
- let res =
- get_unix_stats_processtime (fun () -> (readfiles
- (List.rev !arg_files) (1, ectx, rctx) (not !arg_batch))) in
- (print_and_clear_log (); res)
- else
- let res =
- readfiles_aux (List.rev !arg_files) (1, ectx, rctx) (not !arg_batch) in
- (print_and_clear_log (); res)
+ let res =
+ readfiles (List.rev !arg_files) (1, ectx, rctx) (not !arg_batch) in
+ print_and_clear_log (); res
with
| Log.Stop_Compilation msg ->
handle_stopped_compilation msg; exit 1
=====================================
src/builtin.ml
=====================================
@@ -57,7 +57,7 @@ open Util
open Sexp (* Integer/Float *)
open Pexp (* arg_kind *)
-open Lexp_type
+
module OL = Opslexp
open Lexp
=====================================
src/debruijn.ml
=====================================
@@ -36,7 +36,7 @@ module Str = Str
open Util
-open Lexp_type
+
open Lexp
module M = Myers
=====================================
src/debug_util.ml
=====================================
@@ -37,7 +37,7 @@ open Debug
(* ASTs *)
open Sexp
open Pexp
-open Lexp_type
+
open Lexp
(* AST reader *)
=====================================
src/elab.ml
=====================================
@@ -45,7 +45,7 @@ open Lexer
open Sexp
open Pexp
-open Lexp_type
+
open Lexp
open Env
@@ -395,23 +395,23 @@ let rec meta_to_var ids (e : lexp) =
*)
(* `o` is the binding offset until the root. *)
- let rec adjust_subst o (s : subst) = match S.subst_subst' s with
- | Identity n
+ let rec adjust_subst o (s : subst) = match s with
+ | S.Identity n
-> let o' = o - n in
if o' < 0 then
(* This metavar's original context is outside of our scope
* (case (B) above), so don't let it refer to the new vars. *)
- S.hcsb (Identity (n + count))
+ S.Identity (n + count)
else
- S.hcsb (Identity n)
- | Cons (e, s', n)
+ S.Identity n
+ | S.Cons (e, s', n)
-> let o' = o - n in
if o' < 0 then
(* This metavar's original context is outside of our scope
* (case (B) above), so don't let it refer to the new vars. *)
- S.hcsb (Cons (e, s', n + count))
+ S.Cons (e, s', n + count)
else
- S.hcsb (Cons (loop o' e, adjust_subst o' s', n))
+ S.Cons (loop o' e, adjust_subst o' s', n)
(* `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). *)
=====================================
src/elexp.ml
=====================================
@@ -35,7 +35,6 @@ open Sexp (* Sexp type *)
open Pexp (* Anormal *)
module U = Util
-module LT = Lexp_type
module L = Lexp
type vname = U.vname
@@ -78,7 +77,7 @@ type elexp =
(* A Type expression. There's no useful operation we can apply to it,
* but they can appear in the code. *)
- | Type of LT.lexp
+ | Type of L.lexp
let rec elexp_location e =
match e with
=====================================
src/env.ml
=====================================
@@ -36,7 +36,6 @@ open Sexp
open Elexp
module M = Myers
-module LT = Lexp_type
module L = Lexp
module BI = Z (* Was Big_int *)
module DB = Debruijn
@@ -59,7 +58,7 @@ type value_type =
| Vsexp of sexp (* Values passed to macros. *)
(* Unable to eval during macro expansion, only throw if the value is used *)
| Vundefined
- | Vtype of LT.lexp (* The lexp value can't be trusted. *)
+ | Vtype of L.lexp (* The lexp value can't be trusted. *)
| Vin of in_channel
| Vout of out_channel
| Vcommand of (unit -> value_type)
@@ -242,7 +241,7 @@ let print_rte_ctx_n (ctx: runtime_env) start =
(* Only print user defined variables *)
let print_rte_ctx ctx =
- print_rte_ctx_n ctx (!LT.builtin_size)
+ print_rte_ctx_n ctx (!L.builtin_size)
(* Dump the whole context *)
let dump_rte_ctx ctx =
=====================================
src/eval.ml
=====================================
@@ -35,7 +35,7 @@ open Fmt
open Sexp
open Pexp (* Arg_kind *)
-open Lexp_type
+
open Lexp (* Varbind *)
open Elexp
=====================================
src/inverse_subst.ml
=====================================
@@ -39,7 +39,7 @@ this program. If not, see <http://www.gnu.org/licenses/>. *)
* So either left or right inverse can be used!
*)
-open Lexp_type
+
open Lexp
open Util
module S = Subst
@@ -69,7 +69,7 @@ let transfo (s: subst) : substIR option =
let shiftVar (var: lexp) (offset: int): int =
indexOf (mkSusp var (S.shift offset)) (* Helper : shift the index of a var *)
in
- match S.subst_subst' s with
+ match s with
| Cons ((Var _ as v, h), s, o) ->
let off_acc = off_acc + o in
(match transfo s off_acc (idx + 1) imp_cnt with
@@ -146,7 +146,7 @@ let fill (l: (int * int) list) (nbVar: int) (shift: int): subst option =
let is_identity (s : subst) =
let rec is_identity (s : subst) acc =
- match S.subst_subst' s with
+ match s with
| Cons((Var(_, idx), _), s1, 0) when idx = acc -> is_identity s1 (acc + 1)
| Identity o -> acc = o
| _ -> S.identity_p s
@@ -182,7 +182,7 @@ let inverse (s: subst) : subst option =
(* Returns false if the application of the inverse substitution is not
* possible. This happens when the substitution replaces some variables
* with non-variables, in which case the "inverse" is ambiguous. *)
-let rec invertible (s: subst) : bool = match S.subst_subst' s with
+let rec invertible (s: subst) : bool = match s with
| Identity _ -> true
| Cons (e, s, _)
-> (let e' = lexp_lexp' e in
@@ -194,7 +194,7 @@ exception Ambiguous
(* Lookup variable i in s⁻¹ *)
let rec lookup_inv_subst (i : db_index) (s : subst) : db_index
- = match S.subst_subst' s with
+ = match s with
| (Identity o | Cons (_, _, o)) when i < o -> raise Not_invertible
| Identity o -> i - o
| Cons ((Var (_, i'), _), s, o) when i' = i - o
@@ -240,7 +240,7 @@ let shift_inv_subst n s
* One way to do it is to compute s⁻¹ and then pass it to `compose`.
* But we can try and do it more directly.
*)
-let rec compose_inv_subst (s' : subst) (s : subst) = match S.subst_subst' s' with
+let rec compose_inv_subst (s' : subst) (s : subst) = match s' with
| Cons (e, s', o) ->
let s = shift_inv_subst o s in
(* FIXME: Why don't we ever return a Shift? *)
=====================================
src/lexp.ml
=====================================
@@ -20,19 +20,154 @@ more details.
You should have received a copy of the GNU General Public License along with
this program. If not, see <http://www.gnu.org/licenses/>. *)
-(* open Unify *)
-module S = Subst
-
+module U = Util
+module L = List
+module SMap = U.SMap
open Fmt
open Sexp
open Pexp
-open Lexp_type
-
open Myers
open Grammar
+(* open Unify *)
+module S = Subst
+
+type vname = U.vname
+type vref = U.vref
+type meta_id = int (* Identifier of a meta variable. *)
+
+type label = symbol
+
+type attribute_key = (int * string) (* rev_dbi * Var name *)
+module AttributeMap = Map.Make (struct type t = attribute_key let compare = compare end)
+
+(*************** Elaboration to Lexp *********************)
+
+(* The scoping of `Let` is tricky:
+ *
+ * Since it's a recursive let, the definition part of each binding is
+ * valid in the "final" scope which includes all the new bindings.
+ *
+ * But the type of each binding is not defined in that same scope. Instead
+ * it's defined in the scope of all the previous bindings.
+ *
+ * For exemple the type of the second binding of such a Let is defined in
+ * the scope of the surrounded context extended with the first binding.
+ * And the type of the 3rd binding is defined in the scope of the
+ * surrounded context extended with the first and the second bindings. *)
+
+type ltype = lexp
+ and subst = lexp S.subst
+ and lexp = int * lexp'
+ and lexp' =
+ | Imm of sexp (* Used for strings, ... *)
+ | SortLevel of sort_level
+ | Sort of U.location * sort
+ | Builtin of symbol * ltype * lexp AttributeMap.t option
+ | Var of vref
+ | Susp of lexp * subst (* Lazy explicit substitution: e[σ]. *)
+ (* This "Let" allows recursion. *)
+ | Let of U.location * (vname * lexp * ltype) list * lexp
+ | Arrow of arg_kind * vname * ltype * U.location * ltype
+ | Lambda of arg_kind * vname * ltype * lexp
+ | Call of lexp * (arg_kind * lexp) list (* Curried call. *)
+ | Inductive of U.location * label
+ * ((arg_kind * vname * ltype) list) (* formal Args *)
+ * ((arg_kind * vname * ltype) list) SMap.t
+ | Cons of lexp * symbol (* = Type info * ctor_name *)
+ | Case of U.location * lexp
+ * ltype (* The type of the return value of all branches *)
+ * (U.location * (arg_kind * vname) list * lexp) SMap.t
+ * (vname * lexp) option (* Default. *)
+ (* The `subst` will be applied to the the metavar's value when it
+ * gets instantiated. *)
+ | Metavar of meta_id * subst * vname
+ (* (\* For logical metavars, there's no substitution. *\)
+ * | Metavar of (U.location * string) * metakind * metavar ref
+ * and metavar =
+ * (\* An uninstantiated var, along with a venv (stipulating over which vars
+ * * it should be closed), and its type.
+ * * If its type is not given, it implies its type should be a sort. *\)
+ * | MetaUnset of (lexp option * lexp) VMap.t * ltype option * scope_level
+ * | MetaSet of lexp
+ * and metakind =
+ * | MetaGraft of subst
+ * (\* Forward reference or Free var: Not known yet, but not instantiable by
+ * * unification. *\)
+ * | MetaFoF
+ * and subst = lexp VMap.t *)
+ (*
+ * The PTS I'm imagining looks like:
+ *
+ * S = { TypeLevel, TypeOmega, Type ℓ }
+ * A = { Level : TypeLevel, Z : Level, S : Level → Level,
+ * Type : (ℓ : Level) → Type (S ℓ) }
+ * R = { (TypeLevel, Type ℓ, TypeOmega),
+ * (TypeLevel, TypeOmega, TypeOmega),
+ * (Type ℓ, TypeOmega, TypeOmega),
+ * (Type ℓ₁, Type ℓ₂, Type (max l₁ l₂) }
+ *)
+ and sort =
+ | Stype of lexp
+ | StypeOmega
+ | StypeLevel
+ and sort_level =
+ | SLz
+ | SLsucc of lexp
+ | SLlub of lexp * lexp
+
+type varbind =
+ | Variable
+ | ForwardRef
+ | LetDef of U.db_offset * lexp
+
+(* For metavariables, we give each metavar a (hopefully) unique integer
+ * and then we store its corresponding info into the `metavar_table`
+ * global map.
+ *
+ * Instead of this single ref-cell holding an IntMap, we could use many
+ * ref-cells, and do away with the unique integer. The reasons why we
+ * do it this way are:
+ * - for printing purposes, we want to have a printable unique identifier
+ * for each metavar. OCaml does not offer any way to turn a ref-cell
+ * into some kind of printable identifier (can't get a hash of the address,
+ * no `eq` hash-tables, ...).
+ * - Hashtbl.hash as well as `compare` happily follow ref-cell indirections:
+ * `compare (ref 0) (ref 0)` tells us they're equal! So we need the unique
+ * integer in order to produce a hash anyway (and we'd have to write the hash
+ * function by hand, tho that might be a good idea anyway).
+ *)
+
+(* Scope level is used to detect "out of scope" metavars.
+ * See http://okmij.org/ftp/ML/generalization.html
+ * The ctx_length keeps track of the length of the lctx in which the
+ * metavar is meant to be defined. *)
+type scope_level = int
+type ctx_length = int
+
+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
+ * understood, but lexp_context is not yet defined here,
+ * so we just keep the length of the lexp_context. *)
+ * ctx_length
+type meta_subst = metavar_info U.IMap.t
+
+let dummy_scope_level = 0
+let impossible = Imm Sexp.dummy_epsilon
+
+let builtin_size = ref 0
+
+let metavar_table = ref (U.IMap.empty : meta_subst)
+let metavar_lookup (id : meta_id) : metavar_info
+ = try U.IMap.find id (!metavar_table)
+ with Not_found
+ -> Log.log_fatal ~section:"LEXP" "metavar lookup failure!"
+
(********************** Hash-consing **********************)
(** hash-consing test **
@@ -41,10 +176,12 @@ open Grammar
* biggest bucket length: 205 / 22
* found/new lexp entries: - / 2 *)
-let lexp_lexp' (e, h) = e
+let lexp_lexp' (h, e) = e
+let lexp_hash (h, e) = h
-let lexp'_hash (expr : lexp') =
- match expr with
+(* 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
@@ -93,14 +230,16 @@ let lexp'_hash (expr : lexp') =
| _ -> 0))))
| Metavar (id, s, v)
-> U.combine_hash 12 (U.combine_hash id
- (U.combine_hash (S.subst_hash s) (Hashtbl.hash v)))
+ (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) (S.subst_hash subst))
+ -> U.combine_hash 14 (U.combine_hash (lexp_hash lp) (Hashtbl.hash subst))
+(* equality function for hash table
+ * using physical eq for sub-lexp and compare for subst *)
let hc_eq e1 e2 =
e1 == e2 ||
match (lexp_lexp' e1, lexp_lexp' e2) with
@@ -117,7 +256,7 @@ let hc_eq e1 e2 =
| (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 && s1 == s2
+ | (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
@@ -143,30 +282,19 @@ let hc_eq e1 e2 =
| (Some (_, e1), Some (_, e2)) -> e1 == e2
| _ -> def1 = def2)
| (Metavar (i1, s1, _), Metavar (i2, s2, _))
- -> i1 = i2 && s1 == 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 = hc_eq x y
- let hash = lexp_hash
- end)
-
-(* counter for lexp found in WHC *)
-let lshrct = ref 0
-
-(* counter for lexp not found in WHC *)
-let nf_lshrct = ref 0
+ let equal x y = hc_eq x y
+ let hash = lexp_hash
+ end)
let hc_table : WHC.t = WHC.create 1000
let hc (s : lexp') : lexp =
- let lp = (s, lexp'_hash s) in
- try let lp' = WHC.find hc_table lp in (U.shrct_inc lshrct 1; lp')
- with Not_found -> (U.shrct_inc nf_lshrct 1; WHC.add hc_table lp; lp)
+ let lp = (s, lexp'_hash s) in
+ WHC.merge hc_table lp
let impossible = hc (Imm Sexp.dummy_epsilon)
@@ -618,7 +746,7 @@ let rec lexp_unparse lxp =
(* FIXME: ¡Unify lexp_print and lexp_string! *)
and lexp_string lxp = sexp_string (lexp_unparse lxp)
-and subst_string s = match S.subst_subst' s with
+and subst_string s = match s with
| Identity o -> "↑" ^ string_of_int o
| Cons (l, s, 0) -> lexp_name l ^ " · " ^ subst_string s
| Cons (l, s, o)
@@ -998,7 +1126,7 @@ let rec eq e1 e2 =
and subst_eq s1 s2 =
s1 == s2 ||
- match (S.subst_subst' s1, S.subst_subst' s2) with
+ match (s1, s2) with
| (Identity o1, Identity o2) -> o1 = o2
| (Cons (e1, s1, o1), Cons (e2, s2, o2))
-> if o1 = o2 then
=====================================
src/lexp_type.ml deleted
=====================================
@@ -1,195 +0,0 @@
-(* lexp_type.ml --- Lambda-expressions: the core language.
-
-Copyright (C) 2011-2020 Free Software Foundation, Inc.
-
-Author: Stefan Monnier <monnier(a)iro.umontreal.ca>
-Keywords: languages, lisp, dependent types.
-
-This file is part of Typer.
-
-Typer is free software; you can redistribute it and/or modify it under the
-terms of the GNU General Public License as published by the Free Software
-Foundation, either version 3 of the License, or (at your option) any
-later version.
-
-Typer is distributed in the hope that it will be useful, but WITHOUT ANY
-WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
-FOR A PARTICULAR PURPOSE. See the GNU General Public License for
-more details.
-
-You should have received a copy of the GNU General Public License along with
-this program. If not, see <http://www.gnu.org/licenses/>. *)
-
-module U = Util
-module L = List
-module SMap = U.SMap
-
-
-open Sexp
-open Pexp
-
-
-type vname = U.vname
-type vref = U.vref
-type meta_id = int (* Identifier of a meta variable. *)
-
-type label = symbol
-
-type attribute_key = (int * string) (* rev_dbi * Var name *)
-module AttributeMap = Map.Make (struct type t = attribute_key let compare = compare end)
-
-(*************** Elaboration to Lexp *********************)
-
-(* The scoping of `Let` is tricky:
- *
- * Since it's a recursive let, the definition part of each binding is
- * valid in the "final" scope which includes all the new bindings.
- *
- * But the type of each binding is not defined in that same scope. Instead
- * it's defined in the scope of all the previous bindings.
- *
- * For exemple the type of the second binding of such a Let is defined in
- * the scope of the surrounded context extended with the first binding.
- * And the type of the 3rd binding is defined in the scope of the
- * surrounded context extended with the first and the second bindings. *)
-
-type ltype = lexp
- and lexp = lexp' * int
- and lexp' =
- | Imm of sexp (* Used for strings, ... *)
- | SortLevel of sort_level
- | Sort of U.location * sort
- | Builtin of symbol * ltype * lexp AttributeMap.t option
- | Var of vref
- | Susp of lexp * subst (* Lazy explicit substitution: e[σ]. *)
- (* This "Let" allows recursion. *)
- | Let of U.location * (vname * lexp * ltype) list * lexp
- | Arrow of arg_kind * vname * ltype * U.location * ltype
- | Lambda of arg_kind * vname * ltype * lexp
- | Call of lexp * (arg_kind * lexp) list (* Curried call. *)
- | Inductive of U.location * label
- * ((arg_kind * vname * ltype) list) (* formal Args *)
- * ((arg_kind * vname * ltype) list) SMap.t
- | Cons of lexp * symbol (* = Type info * ctor_name *)
- | Case of U.location * lexp
- * ltype (* The type of the return value of all branches *)
- * (U.location * (arg_kind * vname) list * lexp) SMap.t
- * (vname * lexp) option (* Default. *)
- (* The `subst` will be applied to the the metavar's value when it
- * gets instantiated. *)
- | Metavar of meta_id * subst * vname
- (* (\* For logical metavars, there's no substitution. *\)
- * | Metavar of (U.location * string) * metakind * metavar ref
- * and metavar =
- * (\* An uninstantiated var, along with a venv (stipulating over which vars
- * * it should be closed), and its type.
- * * If its type is not given, it implies its type should be a sort. *\)
- * | MetaUnset of (lexp option * lexp) VMap.t * ltype option * scope_level
- * | MetaSet of lexp
- * and metakind =
- * | MetaGraft of subst
- * (\* Forward reference or Free var: Not known yet, but not instantiable by
- * * unification. *\)
- * | MetaFoF
- * and subst = lexp VMap.t *)
- (*
- * The PTS I'm imagining looks like:
- *
- * S = { TypeLevel, TypeOmega, Type ℓ }
- * A = { Level : TypeLevel, Z : Level, S : Level → Level,
- * Type : (ℓ : Level) → Type (S ℓ) }
- * R = { (TypeLevel, Type ℓ, TypeOmega),
- * (TypeLevel, TypeOmega, TypeOmega),
- * (Type ℓ, TypeOmega, TypeOmega),
- * (Type ℓ₁, Type ℓ₂, Type (max l₁ l₂) }
- *)
-and sort =
- | Stype of lexp
- | StypeOmega
- | StypeLevel
-and sort_level =
- | SLz
- | SLsucc of lexp
- | SLlub of lexp * lexp
-
-(* We define here substitutions which take a variable within a source context
-* Δₛ and should return an expression valid in target context Δₜ.
-*
-* The current implementation only handles a very limited subset of such
-* substitutions. One of the many limitations is that we can only encode
-* substitutions which map variables to variables.
-*)
-
-and db_index = int (* DeBruijn index. *)
-and db_offset = int (* DeBruijn index offset. *)
-
-(* Substitution, i.e. a mapping from db_index to lexp *)
-(* @TODO: change Cons name *)
-and subst = subst' * int
- and subst' =
- | Identity of db_offset (* Identity o ≡ id ∘ ↑ₒ *)
- | Cons of lexp * subst * db_offset (* Cons (e, s, o) ≡ (e · s) ∘ ↑ₒ *)
- (* Myers's extra pointers down the list:
- * * int * lexp subst * db_offset *)
-(* Lift (n,m) increases indices≥N by M.
- * IOW, it takes variables from a source context Δₛ₁Δₛ₂ to a destination
- * context Δₛ₁ΔₜΔₛ₂ where Δₛ₂ has size N and Δₜ has size M. *)
- (* | Lift of db_index * db_offset *)
-
-(* Build Myers's "stack" element. *)
-(* let mkCons e s o = match s with
-* | Cons (_, _, _, sk1, Cons (_, _, _, sk2, s2, o2), o1) when sk1 >= sk2
-* -> Cons (e, s, o, sk1 + sk2 + 1, s2, o1 + o2 + o)
-* | _ -> Cons (e, s, o, 1, s, o) *)
-
-
-type varbind =
- | Variable
- | ForwardRef
- | LetDef of U.db_offset * lexp
-
-let lexp_hash (e, h) = h
-
-(* For metavariables, we give each metavar a (hopefully) unique integer
- * and then we store its corresponding info into the `metavar_table`
- * global map.
- *
- * Instead of this single ref-cell holding an IntMap, we could use many
- * ref-cells, and do away with the unique integer. The reasons why we
- * do it this way are:
- * - for printing purposes, we want to have a printable unique identifier
- * for each metavar. OCaml does not offer any way to turn a ref-cell
- * into some kind of printable identifier (can't get a hash of the address,
- * no `eq` hash-tables, ...).
- * - Hashtbl.hash as well as `compare` happily follow ref-cell indirections:
- * `compare (ref 0) (ref 0)` tells us they're equal! So we need the unique
- * integer in order to produce a hash anyway (and we'd have to write the hash
- * function by hand, tho that might be a good idea anyway).
- *)
-
-(* Scope level is used to detect "out of scope" metavars.
- * See http://okmij.org/ftp/ML/generalization.html
- * The ctx_length keeps track of the length of the lctx in which the
- * metavar is meant to be defined. *)
-type scope_level = int
-type ctx_length = int
-
-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
- * understood, but lexp_context is not yet defined here,
- * so we just keep the length of the lexp_context. *)
- * ctx_length
-type meta_subst = metavar_info U.IMap.t
-
-let dummy_scope_level = 0
-
-let builtin_size = ref 0
-
-let metavar_table = ref (U.IMap.empty : meta_subst)
-let metavar_lookup (id : meta_id) : metavar_info
- = try U.IMap.find id (!metavar_table)
- with Not_found
- -> Log.log_fatal ~section:"LEXP" "metavar lookup failure!"
=====================================
src/opslexp.ml
=====================================
@@ -30,7 +30,7 @@ module P = Pexp
(* open Grammar *)
open Lexp
module E = Elexp
-open Lexp_type
+
module L = Lexp
module M = Myers
=====================================
src/subst.ml
=====================================
@@ -20,7 +20,6 @@ You should have received a copy of the GNU General Public License along with
this program. If not, see <http://www.gnu.org/licenses/>. *)
module U = Util
-open Lexp_type
(* Implementation of the subsitution calculus.
*
@@ -104,58 +103,43 @@ open Lexp_type
*
*)
-(********************** Hash-consing **********************)
-
-(** hash-consing test **
- * with: subst'_hash
- * median bucket length: 7
- * biggest bucket length: 22
- * found/new subst entries: 7 *)
-
-let subst_hash (s, h) = h
-let subst_subst' (s, h) = s
-
-(* counter for subst found in WHCSB *)
-let sshrct = ref 0
-
-(* counter for subst not found in WHCSB *)
-let nf_sshrct = ref 0
-
-let hcsb_eq sb1 sb2 =
- sb1 == sb2 ||
- match (subst_subst' sb1, subst_subst' sb2) with
- | (Identity off1, Identity off2) -> off1 = off2
- | (Cons (lp1, lps1, off1), Cons (lp2, lps2, off2))
- -> lp1 == lp2 && lps1 == lps2 && off1 = off2
- | _ -> false
-
-let subst'_hash (sb : subst') : int =
- match sb with
- | Identity off
- -> U.combine_hash 1 (Hashtbl.hash off)
- | Cons (lp, sb, off)
- -> U.combine_hash 2
- (U.combine_hash (U.combine_hash
- (lexp_hash lp) (subst_hash sb)) (Hashtbl.hash off))
-
-module WHCSB = Weak.Make (struct type t = subst
- let equal x y = hcsb_eq x y
- let hash = subst_hash
- end)
-
-let hcsb_table : WHCSB.t = WHCSB.create 1000
+(* We define here substitutions which take a variable within a source context
+ * Δₛ and should return an expression valid in target context Δₜ.
+ *
+ * The current implementation only handles a very limited subset of such
+ * substitutions. One of the many limitations is that we can only encode
+ * substitutions which map variables to variables.
+ *)
-let hcsb (s : subst') : subst =
- let sb = (s, subst'_hash s) in
- try let sb' = WHCSB.find hcsb_table sb in (U.shrct_inc sshrct 1; sb')
- with Not_found -> (U.shrct_inc nf_sshrct 1; WHCSB.add hcsb_table sb; sb)
+type db_index = int (* DeBruijn index. *)
+type db_offset = int (* DeBruijn index offset. *)
+
+(* Substitution, i.e. a mapping from db_index to 'a
+ * In practice, 'a is always lexp, but we keep it as a parameter:
+ * - for better modularity of the code.
+ * - to break a mutual dependency between the Lexp and the Subst modules. *)
+type 'a subst = (* lexp subst *)
+ | Identity of db_offset (* Identity o ≡ id ∘ ↑ₒ *)
+ | Cons of 'a * 'a subst * db_offset (* Cons (e, s, o) ≡ (e · s) ∘ ↑ₒ *)
+ (* Myers's extra pointers down the list:
+ * * int * 'a subst * db_offset *)
+(* Lift (n,m) increases indices≥N by M.
+ * IOW, it takes variables from a source context Δₛ₁Δₛ₂ to a destination
+ * context Δₛ₁ΔₜΔₛ₂ where Δₛ₂ has size N and Δₜ has size M. *)
+ (* | Lift of db_index * db_offset *)
+
+(* Build Myers's "stack" element. *)
+(* let mkCons e s o = match s with
+ * | Cons (_, _, _, sk1, Cons (_, _, _, sk2, s2, o2), o1) when sk1 >= sk2
+ * -> Cons (e, s, o, sk1 + sk2 + 1, s2, o1 + o2 + o)
+ * | _ -> Cons (e, s, o, 1, s, o) *)
(* Apply a substitution to a single variable. *)
let lookup (mkVar : 'b -> db_index -> 'a)
(mkShift: 'a -> db_offset -> 'a)
- (s: subst) (l : 'b) (v:db_index) : 'a =
- let rec lookup' (o:db_offset) (s: subst) (v:db_index) : 'a =
- match subst_subst' s with
+ (s: 'a subst) (l : 'b) (v:db_index) : 'a =
+ let rec lookup' (o:db_offset) (s: 'a subst) (v:db_index) : 'a =
+ match s with
| Identity o' -> mkVar l (v + o + o')
(* Use Myers's fastlane when applicable:
* | Cons (_, _, _, sk, s, o') when v >= sk -> lookup' (o + o') s (v - sk) *)
@@ -164,49 +148,48 @@ let lookup (mkVar : 'b -> db_index -> 'a)
else mkShift e o
in lookup' 0 s v
-(* ici *)
let mkShift s (m:db_offset) =
if m>0 then
- match subst_subst' s with Identity o -> hcsb (Identity (o + m))
- | Cons (e, s, o) -> hcsb (Cons (e, s, o + m))
+ match s with Identity o -> Identity (o + m)
+ | Cons (e, s, o) -> Cons (e, s, o + m)
else s
(* A substitution which adds M to every deBruijn index.
* I.e. one that takes variables from a context Δₛ to an extended
* context ΔₛΔₜ where Δₜ has size M. *)
-let shift (m:db_offset) : subst = hcsb (Identity m)
+let shift (m:db_offset) = Identity m
(* Return a substitution which replaces #0 with `e` and then applies `s`
* to the rest. *)
-let cons e s : subst = hcsb (Cons (e, s, 0))
+let cons e s = Cons (e, s, 0)
(* The trivial substitution which doesn't do anything. *)
-let identity = hcsb (Identity 0)
+let identity = Identity 0
(* Test if a substitution is trivial. The "_p" stands for "predicate". *)
-let identity_p s = match subst_subst' s with | Identity o -> o = 0 | _ -> false
+let identity_p s = match s with | Identity o -> o = 0 | _ -> false
(* Compose two substitutions. This implements the merging rules.
* Returns s₁ ∘ s₂ (i.e. s₁ is applied before s₂) *)
-let compose (mkSusp : 'a -> subst -> 'a)
- (s1: subst) (s2: subst) : subst =
+let compose (mkSusp : 'a -> 'a subst -> 'a)
+ (s1: 'a subst) (s2: 'a subst) : 'a subst =
(* There is a bit of flexibility in what we return, in the sense
* that some shifts can be pushed more or less down. Here we
* want the shifts to float as far outside as possible. *)
- let rec compose' (s1: subst) (s2: subst) : subst =
- match subst_subst' s1 with
+ let rec compose' (s1: 'a subst) (s2: 'a subst) : 'a subst =
+ match s1 with
| Identity o1
- -> let rec compose_id o1 s o = match subst_subst' s with
- | Identity o2 -> hcsb (Identity (o + o1 + o2))
+ -> let rec compose_id o1 s o = match s with
+ | Identity o2 -> Identity (o + o1 + o2)
| Cons (e2, s2, o2) (* , sk2, s2', o2' *)
-> (* Myers's fastlane:
* if o1 >= sk2 then compose_id (o1 - sk2) s2' (o + o2') *)
if o1 > 0 then compose_id (o1 - 1) s2 (o + o2)
- else hcsb (Cons (e2, s2, o + o2))
+ else Cons (e2, s2, o + o2)
in compose_id o1 s2 0
| Cons (e1, s1, o1)
- -> let rec compose_cons o1 s o = match subst_subst' s with
- | Identity o2 -> hcsb (Cons (e1, s1, o + o1 + o2))
+ -> let rec compose_cons o1 s o = match s with
+ | Identity o2 -> Cons (e1, s1, o + o1 + o2)
| Cons (e2, s2, o2) (* , sk2, s2', o2' *)
-> (* Myers's fastlane:
* if o1 >= sk2 then compose_cons (o1 - sk1) s2' (o + o2') *)
@@ -214,7 +197,7 @@ let compose (mkSusp : 'a -> subst -> 'a)
else
(* Pull out o2's shift and compose the two Cons. *)
let s' = cons e2 s2 in
- hcsb (Cons (mkSusp e1 s', compose' s1 s', o + o2))
+ Cons (mkSusp e1 s', compose' s1 s', o + o2)
in compose_cons o1 s2 0
in compose' s1 s2
@@ -222,7 +205,7 @@ let compose (mkSusp : 'a -> subst -> 'a)
* I.e. take a substitution from Δs to Δₜ and return a substitution
* from Δs,x to Δₜ,x.
* Also known as `lift`. *)
-let sink (mkVar : 'b -> db_index -> 'a) (l:'b) (s:subst) =
+let sink (mkVar : 'b -> db_index -> 'a) (l:'b) (s:'a subst) =
cons (mkVar l 0) (mkShift s 1)
(* Return a substitution which replaces #0 with `e`. *)
=====================================
src/unification.ml
=====================================
@@ -19,7 +19,7 @@ more details.
You should have received a copy of the GNU General Public License along with
this program. If not, see <http://www.gnu.org/licenses/>. *)
-open Lexp_type
+
open Lexp
(* open Sexp *)
@@ -134,41 +134,41 @@ let occurs_in (id: meta_id) (e : lexp) : bool = match metavar_lookup id with
*)
let common_subset ctx (s1 : subst) (s2 : subst) =
let rec loop (s1 : subst) (s2 : subst) o1 o2 o =
- match (S.subst_subst' s1, S.subst_subst' s2) with
- | (Cons (le1, s1', o1'), Cons (le2, s2', o2'))
+ match (s1, s2) with
+ | (S.Cons (le1, s1', o1'), S.Cons (le2, s2', o2'))
-> let o1 = o1 + o1' in
let o2 = o2 + o2' in
(* FIXME: We should check if le1 and le2 are *unifiable* instead! *)
if not (le1 = impossible || le1 = impossible)
&& OL.conv_p ctx (mkSusp le1 (S.shift o1)) (mkSusp le2 (S.shift o2))
then match loop s1' s2' o1 o2 1 with
- | (Identity 1, _) -> S.hcsb (Identity o) (* Optimization! *)
- | (sb, _) as s' -> S.hcsb (Cons (mkVar ((lexp_location le1, None), 0),
- s', o))
+ | S.Identity 1 -> S.Identity o (* Optimization! *)
+ | s' -> S.Cons (mkVar ((lexp_location le1, None), 0),
+ s', o)
else loop s1' s2' o1 o2 (o + 1)
(* If one of them reached `Identity`, unroll it, knowing that
*
* Identity 0 = #0 · #1 · #2 ... = #0 · (Identity 1)
*)
- | (Cons _, Identity o2')
- -> loop s1 (S.hcsb (Cons (mkVar ((U.dummy_location, None), 0),
- S.hcsb (Identity 1), o2')))
+ | (S.Cons _, S.Identity o2')
+ -> loop s1 (S.Cons (mkVar ((U.dummy_location, None), 0),
+ S.Identity 1, o2'))
o1 o2 o
- | (Identity o1', Cons _)
- -> loop (S.hcsb (Cons (mkVar ((U.dummy_location, None), 0),
- S.hcsb (Identity 1), o1')))
+ | (S.Identity o1', S.Cons _)
+ -> loop (S.Cons (mkVar ((U.dummy_location, None), 0),
+ S.Identity 1, o1'))
s2 o1 o2 o
- | (Identity o1', Identity o2')
+ | (S.Identity o1', S.Identity o2')
-> assert (o1 + o1' = o2 + o2');
- S.hcsb (Identity o)
+ S.Identity o
in loop s1 s2 0 0 0
(* Return the number of vars difference between input and output context. *
* Could be returned directly by `common_subset`, but it's pretty easy to
* compute it here instead. *)
-let rec s_offset (s : subst) = match S.subst_subst' s with
- | Identity o -> o
- | Cons (_, s', o) -> o - 1 + s_offset s'
+let rec s_offset (s : subst) = match s with
+ | S.Identity o -> o
+ | S.Cons (_, s', o) -> o - 1 + s_offset s'
(************************** Top level unify **********************************)
@@ -313,7 +313,7 @@ and unify_metavar ctx idx s1 (lxp1: lexp) (lxp2: lexp)
| Metavar (idx2, s2, name)
-> if idx = idx2 then
match common_subset ctx s1 s2 with
- | (Identity 0, _) -> [] (* Optimization! *)
+ | S.Identity 0 -> [] (* Optimization! *)
(* ¡ s1 != s2 !
* Create a new metavar that can only refer to those vars
* which are mapped identically by `s1` and `s2`
@@ -321,7 +321,7 @@ and unify_metavar ctx idx s1 (lxp1: lexp) (lxp2: lexp)
* This metavar doesn't necessarily live exactly in `ctx`
* nor even a proper prefix of it, tho :-( !!
*)
- | (sb, _) as s ->
+ | s ->
(* print_string "Metavar idx-idx s1!=s2\n"; *)
assert (not (OL.conv_p ctx lxp1 lxp2));
match (Inverse_subst.inverse s,
=====================================
src/util.ml
=====================================
@@ -121,42 +121,17 @@ let option_map (fn : 'a -> 'b) (opt : 'a option) : 'b option =
let combine_hash e1 e2 = (e1 * 31) lxor e2
-let rec combine_hashes map =
- match map with
+let rec combine_hashes li =
+ match li with
| [] -> 31
| e :: l -> combine_hash (e * 31) (combine_hashes l)
-let get_stats_hashtbl stats lshrct nf_lshrct =
+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
- found/new lexp entries: %i\n"
- tl ne sumb smallb medianb bigb (lshrct / nf_lshrct)
-
-let shrct_inc e acc = e := !e + acc
-
-let get_total_unix_stats_processtime (times : Unix.process_times) =
- Printf.printf "\n\tUser time for the process: %f\n
- System time for the process: %f\n
- User time for the children processes: %f\n
- System time for the children processes: %f\n"
- times.tms_utime times.tms_stime times.tms_cutime times.tms_cstime
-
-let hc_total_time = ref 0.0
-
-let inc_hc_total_time f =
- let t = Unix.gettimeofday () in
- let res = f () in (hc_total_time :=
- !hc_total_time +. Unix.gettimeofday () -. t; res)
-
-let get_unix_stats_processtime f =
- let t = Unix.gettimeofday () in
- let res = f () in (Printf.printf "\t(Unix) process time: %f\n"
- (Unix.gettimeofday () -. t); res)
-
-let print_total_hctime hctime =
- Printf.printf "\t(Unix) total hc time: %f\n" hctime
+ biggest bucket length: %i\n"
+ tl ne sumb smallb medianb bigb
=====================================
stats.txt deleted
=====================================
@@ -1,111 +0,0 @@
-## hash-consing lexp
-# with subst hash table
-with: Hashtbl.hash (on master branch) / lexp'_hash
-median bucket length: 7 / 7
-biggest bucket length: 205 / 22
-found/new lexp entries: - / 2
-
-# without subst hash table
-with: lexp'_hash
-median bucket length: 7
-biggest bucket length: 36
-found/new lexp entries: 3
-
-## hash-consing subst
-
-with: subst'_hash
-median bucket length: 7
-biggest bucket length: 22
-found/new subst entries: 7
-
-## acctime.typer file with Unix.time (s)
-
-# on master branch
-# average = 6.645643
-
-6.627967
-6.612033
-6.668800
-6.604124
-6.574740
-6.608807
-6.609707
-6.603383
-6.879818
-6.903172
-6.624097
-6.590640
-6.625796
-6.589031
-6.586007
-6.667166
-6.594401
-6.651891
-
-# on this branch
-# with subst hash
-# average = 7.738261
-
-7.679965
-7.709951
-7.678673
-7.709191
-7.705138
-7.630524
-7.619517
-7.754700
-7.806102
-7.715318
-7.859585
-7.672065
-7.706296
-7.829695
-7.929891
-7.944672
-7.614767
-7.728893
-7.732013
-
-# subst hash table without subst hash
-# average = 7.620327
-
-7.625761
-7.535479
-7.598095
-7.551590
-7.613274
-7.524923
-7.552562
-7.621846
-7.598882
-7.632416
-7.695533
-7.684801
-7.579720
-7.799411
-7.598517
-7.712421
-
-# without subst hash table
-# average = 5.829157
-
-5.855567
-5.818960
-5.827624
-5.802086
-5.819951
-5.806960
-5.804491
-5.766256
-5.772987
-5.808192
-5.832567
-5.828493
-5.809422
-6.046799
-5.813889
-5.811058
-5.811843
-5.864935
-5.846754
-5.834313
View it on GitLab: https://gitlab.com/monnier/typer/-/compare/f807baf505996160fcc627eaaaead332…
--
View it on GitLab: https://gitlab.com/monnier/typer/-/compare/f807baf505996160fcc627eaaaead332…
You're receiving this email because of your account on gitlab.com.
2
1
[Git][monnier/typer][ja-barszcz] 21 commits: Delay parsing of declarations until elaboration for define-operator
by Jean-Alexandre Barszcz 29 Jul '20
by Jean-Alexandre Barszcz 29 Jul '20
29 Jul '20
Jean-Alexandre Barszcz pushed to branch ja-barszcz at Stefan / Typer
Commits:
a08107b5 by Jean-Alexandre Barszcz at 2020-07-28T22:09:10-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
- - - - -
631d652e by Jean-Alexandre Barszcz at 2020-07-28T22:10:13-04:00
Remove the parsing error for tightly binding postfix operators
- - - - -
cdfc117c by Jean-Alexandre Barszcz at 2020-07-28T22:10:13-04:00
Dump the evaluation context when the variable names don't match
- - - - -
63ae1fea by Jean-Alexandre Barszcz at 2020-07-28T22:10:13-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).
- - - - -
bfdee451 by Jean-Alexandre Barszcz at 2020-07-28T22:10:13-04:00
[WIP] Make unification symmetric
- - - - -
b8f917be by Jean-Alexandre Barszcz at 2020-07-28T22:10:13-04:00
[WIP] Handle variables earlier during unification
- - - - -
ac2ecf96 by Jean-Alexandre Barszcz at 2020-07-28T22:10:13-04:00
[WIP] experiments with Decidable and proofs
- - - - -
ec06f4fc by Jean-Alexandre Barszcz at 2020-07-28T22:10:13-04:00
[WIP] unify instead of conv_p in sform_lambda
- - - - -
7c30e0eb by Jean-Alexandre Barszcz at 2020-07-28T22:10:13-04:00
[WIP] proof of Decidable (a < b)
- - - - -
5bc4b6bb by Jean-Alexandre Barszcz at 2020-07-28T22:10:13-04:00
[WIP] First draft of an instance search algorithm
- - - - -
c767b2e9 by Jean-Alexandre Barszcz at 2020-07-28T22:10:13-04:00
WIP WIP WIP
- - - - -
c1a000e6 by Jean-Alexandre Barszcz at 2020-07-28T22:18:32-04:00
WIP WIP getting there
- - - - -
45d83e1a by Jean-Alexandre Barszcz at 2020-07-28T22:19:22-04:00
[WIP] Add a set of typeclasses to the elab context
- - - - -
7546e4f6 by Jean-Alexandre Barszcz at 2020-07-28T22:19:22-04:00
[WIP] Add a syntax for records
- - - - -
040f8943 by Jean-Alexandre Barszcz at 2020-07-28T22:19:22-04:00
[WIP] Extend the Decidable sample with conjunction (dep on records)
- - - - -
9a59263b by Jean-Alexandre Barszcz at 2020-07-28T22:19:22-04:00
Resolve instances in the REPL (since exprs. are not generalized)
- - - - -
2f880b02 by Jean-Alexandre Barszcz at 2020-07-28T22:19:22-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.
- - - - -
9a930f76 by Jean-Alexandre Barszcz at 2020-07-28T22:19:22-04:00
Num class example
- - - - -
28c78ffc by Jean-Alexandre Barszcz at 2020-07-28T22:19:22-04:00
Num class (with records)
- - - - -
dff7b36f by Jean-Alexandre Barszcz at 2020-07-28T22:19:22-04:00
Move the Eq builtin to debruijn.ml to make it available for elab.
- - - - -
0da3daa9 by Jean-Alexandre Barszcz at 2020-07-28T22:42:59-04:00
[WIP] (Broken) Add Eq to case
- - - - -
20 changed files:
- btl/builtins.typer
- btl/pervasive.typer
- + btl/records.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/log.ml
- src/myers.ml
- src/opslexp.ml
- src/sexp.ml
- src/unification.ml
- tests/unify_test.ml
Changes:
=====================================
btl/builtins.typer
=====================================
@@ -100,10 +100,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 +360,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 +392,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/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,8 @@ 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
let register_builtin_types () =
let _ = new_builtin_type "Sexp" DB.type0 in
@@ -175,7 +163,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,20 @@ 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)
+
(* easier to debug with type annotations *)
type env_elem = (vname * varbind * ltype)
@@ -112,26 +126,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 +159,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 +167,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 +206,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 +224,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
@@ -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
| _
@@ -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 "
@@ -781,9 +861,36 @@ and check_case rtype (loc, target, ppatterns) ctx =
(* 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 +971,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 +1062,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 +1114,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 +1228,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 +1240,10 @@ 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
+ 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 +1279,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 +1287,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 +1299,162 @@ 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, [], []
+ | ([], _) ->
+ Log.log_debug "Parsing the next declaration sexp";
+ let (s, toks) = sexp_parse_all (ectx_get_grammar nctx)
+ tokens (Some ";") in
+ Log.log_debug ("Parsed decl : `" ^ (sexp_string s) ^ "`");
+ 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 =
+ 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 +1779,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 +1844,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 +1921,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 +1957,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 +2002,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 +2024,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 +2084,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,61 @@
+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_ind (lctx : DB.lexp_context) (t : L.ltype) : L.ltype option =
+ match OL.lexp_whnf t lctx with
+ | L.Call (typecons, _) ->
+ (match OL.lexp_whnf typecons lctx with
+ | L.Inductive _ as ind -> Some ind
+ | _ -> None
+ )
+ | L.Inductive _ as ind -> Some ind
+ | _ -> None
+
+
+let is_typeclass (ctx : DB.elab_context) (t : L.ltype) =
+ let lctx = DB.ectx_to_lctx ctx in
+ match get_ind lctx t with
+ | Some ind -> env_is_typeclass ctx ind
+ | None -> false
+
+let add_typeclass (ctx : DB.elab_context) (t : L.ltype) : DB.elab_context =
+ let lctx = DB.ectx_to_lctx ctx in
+ match get_ind lctx t with
+ | Some ind -> DB.env_add_typeclass ctx ind
+ | None -> Log.log_error ("Failed to add type class to context "
+ ^ " because it is not an inductive : `"
+ ^ (L.lexp_string t) ^ "`"); ctx
+
+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/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
=====================================
@@ -166,7 +166,7 @@ let lexp_whnf e (ctx : DB.lexp_context) : lexp =
d + 1))
(S.identity, 0)
aargs in
- lexp_whnf (push_susp branch subst) ctx
+ lexp_whnf (push_susp branch (S.mkShift subst 1)) ctx (* FIXME not sure about the subt here *)
with Not_found
-> match default
with | Some (v,default)
@@ -610,9 +610,9 @@ 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, s, hlxp)
(* FIXME: If ak is Aerasable, make sure the var only
* appears in type annotations. *)
| (ak, vdef)::vdefs, (ak', vdef', ftype)::fieldtypes
@@ -620,14 +620,27 @@ let rec check'' erased ctx e =
(DB.lexp_ctx_cons ctx vdef Variable (mkSusp ftype s))
(S.cons (mkVar (vdef, 0))
(S.mkShift s 1))
+ (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, s, hlxp)) in
+ let (nerased, nctx, subst, hlxp) =
+ mkctx erased ctx s (mkCons (it, (l, name))) vdefs fieldtypes in
+ (* Create Eq type between target and lexp matching the
+ branch head, and add it (erasable) to the context *)
+ let tlxp = mkSusp e subst in
+ let tltp = mkSusp etype subst in
+ let eqty = mkCall (DB.type_eq,
+ [(Aerasable, DB.type0); (* Typelevel *)
+ (Aerasable, tltp); (* Inductive type *)
+ (Anormal, tlxp); (* Target lexp *)
+ (Anormal, hlxp)]) in (* Lexp of the branch head *)
+ let nerased = dbset_push Aerasable nerased in
+ 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
@@ -723,6 +736,7 @@ module LMap
= Hashtbl.Make
(struct type t = lexp let hash = Hashtbl.hash let equal = (==) end)
let fv_memo = LMap.create 1000
+let fv_flush () = LMap.clear fv_memo
let fv_empty = (DB.set_empty, mv_set_empty)
let fv_union (fv1, mv1) (fv2, mv2)
=====================================
src/sexp.ml
=====================================
@@ -160,13 +160,10 @@ 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 it might simply be
+ * a postfix symbol that binds very tightly. *)
+ -> 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/2a7b7e3f99aaa3880c58e70a49b0f519…
--
View it on GitLab: https://gitlab.com/monnier/typer/-/compare/2a7b7e3f99aaa3880c58e70a49b0f519…
You're receiving this email because of your account on gitlab.com.
1
0
23 Jul '20
Alice de Berny pushed to branch alice at Stefan / Typer
Commits:
3376edac by irradiee at 2020-06-05T10:14:41-04:00
correction physical equality of lexp
- - - - -
4 changed files:
- src/elab.ml
- src/lexp.ml
- src/opslexp.ml
- src/unification.ml
Changes:
=====================================
src/elab.ml
=====================================
@@ -1009,7 +1009,7 @@ and lexp_parse_inductive ctors ctx =
->
hc (Arrow (Aerasable, vname, t, l, e)))
altacc in
- if lexp_lexp' altacc' == lexp_lexp' altacc
+ if altacc' == altacc
then acc (* No generalization! *)
else
(* Convert the Lexp back into a list of fields. *)
=====================================
src/lexp.ml
=====================================
@@ -188,6 +188,15 @@ let metavar_lookup (id : meta_id) : metavar_info
| e :: l -> e lxor (apply_lxor l)
let combine_hash e1 e2 = e1 lxor e2
+
+let smap_hash e smap =
+ (combine_hash
+ (apply_lxor
+ (List.map (fun e -> let (ak, n, lt) = e in
+ (combine_hash (Hashtbl.hash ak)
+ (combine_hash (Hashtbl.hash n) (lexp_hash lt))))
+ e)) (Hashtbl.hash smap))
+
(* Hashtbl.hash for not lexp types
* TODO: - find something else
* - extract the first arg of 2 arg types ? (SMap)*)
@@ -238,14 +247,11 @@ let combine_hash e1 e2 = e1 lxor e2
(combine_hash (Hashtbl.hash ak) (lexp_hash lp))) args))
| Susp (lp, subst) -> combine_hash (lexp_hash lp) (Hashtbl.hash subst)
-let impossible = (let imp = Imm Sexp.dummy_epsilon in (imp, dummy_hash))
-
let compare_hash x y =
let (x', h1) = x in
let (y', h2) = y in
compare h1 h2 = 0
-(* May be a tree ? *)
module WHC = Weak.Make (struct type t = lexp
(* Using (=) instead of `compare` results
* in an *enormous* slowdown. Apparently
@@ -259,6 +265,8 @@ let hc_table : WHC.t = WHC.create 1000
let hc (e : lexp') : lexp =
let lp = (e, lexp'_hash e) in WHC.merge hc_table lp
+let impossible = hc (Imm Sexp.dummy_epsilon)
+
let mkImm s = hc (Imm s)
let mkSortLevel l = hc (SortLevel l)
let mkSort (l, s) = hc (Sort (l, s))
@@ -1040,10 +1048,8 @@ and lexp_str_decls ctx decls =
(** Syntactic equality (i.e. without β). *******)
let rec eq e1 e2 =
- let e1' = lexp_lexp' e1 in
- let e2' = lexp_lexp' e2 in
- e1' == e2' ||
- match (e1', e2') with
+ 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
=====================================
src/opslexp.ml
=====================================
@@ -211,8 +211,8 @@ let lexp_whnf e (ctx : DB.lexp_context) : lexp =
type set_plexp = (lexp * lexp) list
let set_empty : set_plexp = []
let set_member_p (s : set_plexp) (e1 : lexp) (e2 : lexp) : bool
- = assert (lexp_lexp' e1 == lexp_lexp' (Lexp.hc (lexp_lexp' e1)));
- assert (lexp_lexp' e2 == lexp_lexp' (Lexp.hc (lexp_lexp' e2)));
+ = assert (e1 == Lexp.hc (lexp_lexp' e1));
+ assert (e2 == Lexp.hc (lexp_lexp' e2));
try let _ = List.find (fun (e1', e2')
-> L.eq e1 e1' && L.eq e2 e2')
s
@@ -266,14 +266,12 @@ let level_leq (c1, m1) (c2, m2) =
let rec 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
- let e1'' = lexp'_whnf e1 ctx in
- let e2'' = lexp'_whnf e2 ctx in
- e1'' == e2'' ||
- let changed = not (lexp_lexp' e1 == e1'' && lexp_lexp' e2 == e2'') in
+ e1' == e2' ||
+ let changed = not (e1 == e1' && e2 == e2') in
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
@@ -331,7 +329,7 @@ let rec conv_p' (ctx : DB.lexp_context) (vs : set_plexp) e1 e2 : bool =
(set_shift vs)
args1 args2
| _,_ -> false in
- lexp_lexp' l1 == lexp_lexp' l2 && conv_args ctx vs' args1 args2
+ 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: *)
@@ -340,7 +338,7 @@ let rec conv_p' (ctx : DB.lexp_context) (vs : set_plexp) e1 e2 : bool =
| (_, _) -> false
let conv_p (ctx : DB.lexp_context) e1 e2
- = if lexp_lexp' e1 == lexp_lexp' e2 then true
+ = if e1 == e2 then true
else conv_p' ctx set_empty e1 e2
(********* Testing if a lexp is properly typed *********)
=====================================
src/unification.ml
=====================================
@@ -184,30 +184,28 @@ let rec unify (e1: lexp) (e2: lexp)
and unify' (e1: lexp) (e2: lexp)
(ctx : DB.lexp_context) (vs : OL.set_plexp)
: return_type =
- if lexp_lexp' e1 == lexp_lexp' e2 then [] else
+ if e1 == e2 then [] else
let e1' = OL.lexp_whnf e1 ctx in
let e2' = OL.lexp_whnf e2 ctx in
- let e1'' = lexp_lexp' e1' in
- let e2'' = lexp_lexp' e2' in
- if e1'' == e2'' then [] else
+ if e1' == e2' then [] else
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 e2' e1'
- | ((Metavar (idx, s, _) as l), r) -> unify_metavar ctx idx s e1' e2'
- | (l, (Call _ as r)) -> unify_call e2' e1' 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 e1' e2' ctx vs'
- | (Lambda _ as l, r) -> unify_lambda e1' e2' ctx vs'
- | (Call _ as l, r) -> unify_call e1' e2' 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 e1' e2' ctx vs'
- | (SortLevel _ as l, r) -> unify_sortlvl e1' e2' 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 "
View it on GitLab: https://gitlab.com/monnier/typer/-/commit/3376edace9286d4aff35fb4f87be0628e…
--
View it on GitLab: https://gitlab.com/monnier/typer/-/commit/3376edace9286d4aff35fb4f87be0628e…
You're receiving this email because of your account on gitlab.com.
2
1
Alice de Berny pushed to branch alice at Stefan / Typer
Commits:
7af89c25 by irradiee at 2020-07-17T15:50:19-04:00
add stats
- - - - -
f807baf5 by irradiee at 2020-07-22T10:56:44-04:00
add stats on subst table
- - - - -
7 changed files:
- GNUmakefile
- + profiling.txt
- + samples/acctime.typer
- src/REPL.ml
- src/lexp.ml
- src/util.ml
- + stats.txt
Changes:
=====================================
GNUmakefile
=====================================
@@ -7,8 +7,12 @@ BUILDDIR := _build
SRC_FILES := $(wildcard ./src/*.ml)
CPL_FILES := $(wildcard ./$(BUILDDIR)/src/*.cmo)
TEST_FILES := $(wildcard ./tests/*_test.ml)
+TIME_FILE := ./samples/acctime.typer
-OBFLAGS = -tag debug -tag e -lib str -build-dir $(BUILDDIR) -pkg zarith
+# camlLexp__hc / camlLexp__hc_eq / camlLexp_type__lexp_hash / camlSubst__subst_hash
+MOTIF := camlSubst__hcsb_
+
+OBFLAGS = -tag debug -tag e -lib str -build-dir $(BUILDDIR) -pkg zarith -pkg unix
# OBFLAGS := -I $(SRCDIR) -build-dir $(BUILDDIR) -pkg str
# OBFLAGS_DEBUG := -tag debug -tag e -tag "warn(+20)"
# OBFLAGS_RELEASE := -tag unsafe -tag inline
@@ -22,6 +26,8 @@ OCAMLCP := ocamlcp
OCAMLOPTP := ocamloptp
OCAMLOPT := ocamlopt
OCAMLDEP := ocamldep
+GPROF := gprof
+GREP := grep
OCAMLFLAGS := -I src
SRC_NO_DEBUG := $(filter-out ./src/debug_util.ml, $(SRC_FILES))
@@ -85,7 +91,6 @@ install: tests
tests: tests-build tests-run
-# @TODO: delete
test:
$(OCAMLBUILD) tests/lexp_test.$(COMPILE_MODE) -I src $(OBFLAGS)
@$(OCAMLBUILD) tests/utest_main.$(COMPILE_MODE) -I src $(OBFLAGS)
@@ -130,22 +135,25 @@ profiling-cp:
# ============================
# profiling bytecode
# ============================
- ocamlfind $(OCAMLCP) -o profiling -linkpkg -package zarith \
+ ocamlfind $(OCAMLCP) -o profiling -linkpkg -package zarith -package unix \
$(OCAMLFLAGS) str.cma -P f $(DEPSORT_FILES)
profiling-optp:
# ============================
# profiling native
# ============================
- ocamlfind $(OCAMLOPTP) -o profiling -linkpkg -package zarith \
+ ocamlfind $(OCAMLOPTP) -o profiling -linkpkg -package zarith -package unix \
$(OCAMLFLAGS) str.cmxa -P f $(DEPSORT_FILES)
time:
# ============================
# time native
# ============================
- ocamlfind $(OCAMLOPT) -p -o profiling -linkpkg -package zarith \
+ ocamlfind $(OCAMLOPT) -p -o profiling -linkpkg -package zarith -package unix \
$(OCAMLFLAGS) str.cmxa $(DEPSORT_FILES)
+ ./profiling --batch $(TIME_FILE)
+ $(GPROF) ./profiling >> profiling.txt
+ $(GREP) $(MOTIF) profiling.txt
# Clean up
clean-profiling:
=====================================
profiling.txt
=====================================
The diff for this file was not included because it is too large.
=====================================
samples/acctime.typer
=====================================
@@ -0,0 +1,2159 @@
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
+
+accumulate : (t : Type) ≡> (acc-op : (t -> t -> t)) -> (init : t) -> (list : List t) -> t;
+accumulate = lambda (t : Type) ≡>
+ lambda (acc-op : (t -> t -> t)) ->
+ lambda (init : t) ->
+ lambda (list : List t) ->
+ case list
+ | cons hd tl => accumulate acc-op (acc-op init hd) tl
+ | nil => init;
+
+
+map : (a : Type) ≡> (b : Type) ≡> (list : List a) -> (f : a -> b) -> List b;
+map = lambda (a : Type) ≡>
+ lambda (b : Type) ≡>
+ lambda (list : List a) ->
+ lambda (f : a -> b) ->
+ case list
+ | cons hd tl => (cons (f hd) (map tl f))
+ | nil => nil;
+
+list = (cons 1 (cons 2 (cons 3 (cons 4 nil))));
+
+% main = accumulate _+_ 0 list;
+% main = map list (lambda x -> (x + 1));
=====================================
src/REPL.ml
=====================================
@@ -203,7 +203,7 @@ let help_msg =
%help (%h) : print help
"
-let readfiles files (i, lctx, rctx) prt =
+let readfiles_aux files (i, lctx, rctx) prt =
(* Read specified files *)
List.fold_left (fun (i, lctx, rctx) file ->
@@ -220,6 +220,10 @@ let readfiles files (i, lctx, rctx) prt =
)
(i, lctx, rctx) files
+let readfiles files (i, lctx, rctx) prt =
+ let res = readfiles_aux files (i, lctx, rctx) prt in
+ res
+
(* Specials commands %[command-name] [args] *)
let rec repl i clxp rctx =
let repl = repl (i + 1) in
@@ -230,8 +234,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) !lshrct !nf_lshrct !Subst.sshrct !Subst.nf_sshrct)
- | "%scollisions" | "%scl" -> (get_stats_hashtbl (Subst.WHCSB.stats Subst.hcsb_table) !lshrct !nf_lshrct !Subst.sshrct !Subst.nf_sshrct)
+ | "%lcollisions" | "%cl" -> (get_stats_hashtbl (WHC.stats hc_table) !lshrct !nf_lshrct)
(* command with arguments *)
| _ when (ipt.[0] = '%' && ipt.[1] != ' ') -> (
@@ -247,7 +250,7 @@ let rec repl i clxp rctx =
(time_process := true;
let (i, clxp, rctx) =
try
- readfiles args (i, clxp, rctx) false
+ get_unix_stats_processtime (fun () -> (readfiles args (i, clxp, rctx) false))
with Log.Stop_Compilation msg ->
(handle_stopped_compilation msg; (i,clxp,rctx)) in
repl clxp rctx)
@@ -319,11 +322,12 @@ let main () =
if !time_process
then
let res =
- readfiles (List.rev !arg_files) (1, ectx, rctx) (not !arg_batch) in
+ get_unix_stats_processtime (fun () -> (readfiles
+ (List.rev !arg_files) (1, ectx, rctx) (not !arg_batch))) in
(print_and_clear_log (); res)
else
let res =
- readfiles (List.rev !arg_files) (1, ectx, rctx) (not !arg_batch) in
+ readfiles_aux (List.rev !arg_files) (1, ectx, rctx) (not !arg_batch) in
(print_and_clear_log (); res)
with
| Log.Stop_Compilation msg ->
=====================================
src/lexp.ml
=====================================
@@ -36,9 +36,10 @@ open Grammar
(********************** Hash-consing **********************)
(** hash-consing test **
-* with: Hashtbl.hash - lexp'_hash
-* median bucket length: 7 - 7
-* biggest bucket length: 205 - 22 *)
+* with: Hashtbl.hash / lexp'_hash
+* median bucket length: 7 / 7
+* biggest bucket length: 205 / 22
+* found/new lexp entries: - / 2 *)
let lexp_lexp' (e, h) = e
=====================================
src/util.ml
=====================================
@@ -126,7 +126,7 @@ let rec combine_hashes map =
| [] -> 31
| e :: l -> combine_hash (e * 31) (combine_hashes l)
-let get_stats_hashtbl stats lshrct nf_lshrct sshrct nf_sshrct =
+let get_stats_hashtbl stats lshrct nf_lshrct =
let (tl, ne, sumb, smallb, medianb, bigb) = stats in
Printf.printf "\n\ttable length: %i\n
number of entries: %i\n
@@ -134,8 +134,29 @@ let get_stats_hashtbl stats lshrct nf_lshrct sshrct nf_sshrct =
smallest bucket length: %i\n
median bucket length: %i\n
biggest bucket length: %i\n
- found/new lexp entries: %i\n
- found/new subst entries: %i\n"
- tl ne sumb smallb medianb bigb (lshrct / nf_lshrct) (sshrct / nf_sshrct)
+ found/new lexp entries: %i\n"
+ tl ne sumb smallb medianb bigb (lshrct / nf_lshrct)
let shrct_inc e acc = e := !e + acc
+
+let get_total_unix_stats_processtime (times : Unix.process_times) =
+ Printf.printf "\n\tUser time for the process: %f\n
+ System time for the process: %f\n
+ User time for the children processes: %f\n
+ System time for the children processes: %f\n"
+ times.tms_utime times.tms_stime times.tms_cutime times.tms_cstime
+
+let hc_total_time = ref 0.0
+
+let inc_hc_total_time f =
+ let t = Unix.gettimeofday () in
+ let res = f () in (hc_total_time :=
+ !hc_total_time +. Unix.gettimeofday () -. t; res)
+
+let get_unix_stats_processtime f =
+ let t = Unix.gettimeofday () in
+ let res = f () in (Printf.printf "\t(Unix) process time: %f\n"
+ (Unix.gettimeofday () -. t); res)
+
+let print_total_hctime hctime =
+ Printf.printf "\t(Unix) total hc time: %f\n" hctime
=====================================
stats.txt
=====================================
@@ -0,0 +1,111 @@
+## hash-consing lexp
+# with subst hash table
+with: Hashtbl.hash (on master branch) / lexp'_hash
+median bucket length: 7 / 7
+biggest bucket length: 205 / 22
+found/new lexp entries: - / 2
+
+# without subst hash table
+with: lexp'_hash
+median bucket length: 7
+biggest bucket length: 36
+found/new lexp entries: 3
+
+## hash-consing subst
+
+with: subst'_hash
+median bucket length: 7
+biggest bucket length: 22
+found/new subst entries: 7
+
+## acctime.typer file with Unix.time (s)
+
+# on master branch
+# average = 6.645643
+
+6.627967
+6.612033
+6.668800
+6.604124
+6.574740
+6.608807
+6.609707
+6.603383
+6.879818
+6.903172
+6.624097
+6.590640
+6.625796
+6.589031
+6.586007
+6.667166
+6.594401
+6.651891
+
+# on this branch
+# with subst hash
+# average = 7.738261
+
+7.679965
+7.709951
+7.678673
+7.709191
+7.705138
+7.630524
+7.619517
+7.754700
+7.806102
+7.715318
+7.859585
+7.672065
+7.706296
+7.829695
+7.929891
+7.944672
+7.614767
+7.728893
+7.732013
+
+# subst hash table without subst hash
+# average = 7.620327
+
+7.625761
+7.535479
+7.598095
+7.551590
+7.613274
+7.524923
+7.552562
+7.621846
+7.598882
+7.632416
+7.695533
+7.684801
+7.579720
+7.799411
+7.598517
+7.712421
+
+# without subst hash table
+# average = 5.829157
+
+5.855567
+5.818960
+5.827624
+5.802086
+5.819951
+5.806960
+5.804491
+5.766256
+5.772987
+5.808192
+5.832567
+5.828493
+5.809422
+6.046799
+5.813889
+5.811058
+5.811843
+5.864935
+5.846754
+5.834313
View it on GitLab: https://gitlab.com/monnier/typer/-/compare/47cb679f83f1c2d8964d7a8c07de4f03…
--
View it on GitLab: https://gitlab.com/monnier/typer/-/compare/47cb679f83f1c2d8964d7a8c07de4f03…
You're receiving this email because of your account on gitlab.com.
1
0
[Git][monnier/typer][report/hmdup] Simplify the rules a bit; not bidi any more :-(
by Stefan 15 Jul '20
by Stefan 15 Jul '20
15 Jul '20
Stefan pushed to branch report/hmdup at Stefan / Typer
Commits:
20732788 by Stefan Monnier at 2020-07-14T22:14:30-04:00
Simplify the rules a bit; not bidi any more :-(
- - - - -
1 changed file:
- paper.tex
Changes:
=====================================
paper.tex
=====================================
@@ -50,8 +50,8 @@
\usepackage[utf8]{inputenc}
\usepackage{amsmath,mathtools,stmaryrd}
\usepackage{mathpartir}
-\usepackage{mdframed,empheq}
-\usepackage{parskip}
+%% \usepackage{mdframed,empheq}
+%% \usepackage{parskip}
\usepackage{fancybox} %For \ovalbox
\usepackage{extarrows} %For \overrightarrow
@@ -333,6 +333,14 @@ minimizing the amount of type annotations was secondary to the design.
\Jsynth{x}{\tau[\vec \tau/\vec t]}
}
+ \Infer[(HM-Let)]{
+ \Jsynth{e_1}{\tau_1} \\
+ \overrightarrow{t\:*} = \kw{gen}(\Gamma,\tau_1) \\
+ \Jsynth[\Gamma,x\:\MDArw{t\:*}{\tau_1}]{e_2}{\tau}
+ }{
+ \Jsynth{\Let x {e_1}{e_2}}{\tau}
+ }
+
\Infer[(HM-Lam)]{
\Jsynth[\Gamma,x\:\tau_1] e {\tau_2}
}{
@@ -347,14 +355,6 @@ minimizing the amount of type annotations was secondary to the design.
\Jsynth{e_1~e_2}{\tau_2}
}
- \Infer[(HM-Let)]{
- \Jsynth{e_1}{\tau_1} \\
- \tau_1' = \kw{gen}(\Gamma,\tau_1) \\
- \Jsynth[\Gamma,x\:\tau_1']{e_2}{\tau}
- }{
- \Jsynth{\Let x {e_1}{e_2}}{\tau}
- }
-
%% \Infer{
%% \Jsynth e \tau' \\ \Junify \tau {\tau'}
%% }{
@@ -412,49 +412,49 @@ $u_2$ was instantiated to.
-\begin{figure}
- \begin{mathpar}
- \Infer[(BC-Var)]{
- \Gamma(x) = \tau
- }{
- \Jsynth{x}{\tau}
- }
-
- \Infer[(BC-Let)]{
- \Jsynth{e_1}{\tau_1} \\
- \Jpoly[\Gamma,x\:\tau_1]{e_2}{\tau_2}
- }{
- \Jpoly{\Let x {e_1}{e_2}}{\tau_2}
- }
-
- \Infer[(BC-App)]{
- %% \Jsynth{e_1}{\Arw{\tau_1}{\tau_2}} \\
- \Jsynth{e_1}{\Arw{\tau_1}{\tau_2}} \\
- \Jcheck{e_2}{\tau_1}
- }{
- \Jsynth{e_1~e_2}{\tau_2}
- }
-
- %% \Infer{
- %% \Jsynth e \tau' \\ \Junify \tau {\tau'}
- %% }{
- %% \Jcheck{e}{\tau}
- %% }
-
- \Infer[(BC-Lam)]{
- \Jcheck[\Gamma,x\:\tau_1] e {\tau_2}
- }{
- \Jcheck{\Lam x e}{\Arw{\tau_1}{\tau_2}}
- }
-
- \Infer[(BC-HT)]{\Jcheck e \tau}{\Jsynth{\HasType{e}{\tau}}{\tau}}
-
- \Infer[(BC-Check)]{\Jsynth e \tau' \\ \tau = \tau'}{\Jcheck{e}{\tau}}
- %%
- \end{mathpar}
- \caption{Basic bidirectional type checking rules}
- \label{fig:bidi-check}
-\end{figure}
+%% \begin{figure}
+%% \begin{mathpar}
+%% \Infer[(BC-Var)]{
+%% \Gamma(x) = \tau
+%% }{
+%% \Jsynth{x}{\tau}
+%% }
+
+%% \Infer[(BC-Let)]{
+%% \Jsynth{e_1}{\tau_1} \\
+%% \Jpoly[\Gamma,x\:\tau_1]{e_2}{\tau_2}
+%% }{
+%% \Jpoly{\Let x {e_1}{e_2}}{\tau_2}
+%% }
+
+%% \Infer[(BC-App)]{
+%% %% \Jsynth{e_1}{\Arw{\tau_1}{\tau_2}} \\
+%% \Jsynth{e_1}{\Arw{\tau_1}{\tau_2}} \\
+%% \Jcheck{e_2}{\tau_1}
+%% }{
+%% \Jsynth{e_1~e_2}{\tau_2}
+%% }
+
+%% %% \Infer{
+%% %% \Jsynth e \tau' \\ \Junify \tau {\tau'}
+%% %% }{
+%% %% \Jcheck{e}{\tau}
+%% %% }
+
+%% \Infer[(BC-Lam)]{
+%% \Jcheck[\Gamma,x\:\tau_1] e {\tau_2}
+%% }{
+%% \Jcheck{\Lam x e}{\Arw{\tau_1}{\tau_2}}
+%% }
+
+%% \Infer[(BC-Ann)]{\Jcheck e \tau}{\Jsynth{\HasType{e}{\tau}}{\tau}}
+
+%% \Infer[(BC-Check)]{\Jsynth e \tau' \\ \tau = \tau'}{\Jcheck{e}{\tau}}
+%% %%
+%% \end{mathpar}
+%% \caption{Basic bidirectional type checking rules}
+%% \label{fig:bidi-check}
+%% \end{figure}
Figure~\cite{fig:bidi-check} shows the traditional bidirectional rules to
type check the $\lambda$-calculus.
@@ -494,7 +494,7 @@ type check the $\lambda$-calculus.
\Jcheck{\Lam x e}{\Arw{\tau_1}{\tau_2}}
}
\\\\
- \Infer[(BI-HT)]{\Jcheck e \tau}{\Jsynth{\HasType{e}{\tau}}{\tau}}
+ \Infer[(BI-Ann)]{\Jcheck e \tau}{\Jsynth{\HasType{e}{\tau}}{\tau}}
\Infer[(BI-Check)]{\Jsynth e \tau}{\Jcheck{e}{\tau}}
@@ -520,10 +520,87 @@ a $\Lam{x}{e}$.
\section{System F}
-%% \newcommand \JsynthCoerce [3][\Gamma] {#1 \vdash #2 \Longrightarrow #3}
+\newcommand \JsynthCoerce [3][\Gamma] {#1 \vdash #2 \Longrightarrow #3}
\newcommand \JcheckCoerce [3][\Gamma] {#1 \vdash #2 \Longleftarrow #3}
%% \newcommand \Jmono [1] {\kw{monotype}(#1)}
+%% \begin{figure}
+%% \begin{mathpar}
+%% \Infer[(SF-Var)]{
+%% \Gamma(x) = \tau
+%% }{
+%% \Jsynth{x}{\tau}
+%% }
+
+%% \Infer[(SF-Let)]{
+%% \Jsynth{e_1}{\tau_1} \\
+%% \overrightarrow{t\:*} = \kw{gen}(\Gamma,\tau_1) \\
+%% \Jpoly[\Gamma,x\:\MDArw{t\:*}{\tau_1}]{e_2}{\tau}
+%% }{
+%% \Jpoly{\Let x {e_1}{e_2}}{\tau}
+%% }
+
+%% \Infer[(SF-App)]{
+%% %% \Jsynth{e_1}{\Arw{\tau_1}{\tau_2}} \\
+%% \JcheckCoerce{e_1}{\Arw{\tau_1}{\tau_2}} \\
+%% \JcheckCoerce{e_2}{\tau_1}
+%% }{
+%% \Jsynth{e_1~e_2}{\tau_2}
+%% }
+
+%% %%
+%% \Infer[(SF-Ann)]{
+%% \JcheckCoerce e \tau
+%% }{
+%% \Jsynth{\HasType{e}{\tau}}{\tau}
+%% }
+
+%% \Infer[(SF-Lam)]{
+%% \JcheckCoerce[\Gamma,x\:\tau_1] e {\tau_2}
+%% }{
+%% \Jcheck{\Lam x e}{\Arw{\tau_1}{\tau_2}}
+%% }
+%% %%
+
+%% %% FIXME: Not needed?
+%% %% \Infer[(SF-Check)]{\Jsynth e \tau}{\Jcheck{e}{\tau}}
+
+%% \Infer[(SF-Guess)]{
+%% \Jcheck e {\tau}
+%% }{
+%% %% FIXME: Make it \JsynthCoerce?
+%% \Jsynth e {\tau}
+%% }
+%% \\\\
+%% \Infer[(SF-Poly)]{
+%% \JcheckCoerce[\Gamma,\overrightarrow{t\:*}] e {\tau}
+%% }{
+%% \JcheckCoerce{e}{\MDArw{t\:*}{\tau}}
+%% }
+
+%% \Infer[(SF-Inst)]{
+%% \Jsynth e {\MDArw{t\:*}{\tau}} \\
+%% }{
+%% \JcheckCoerce{e}{\tau[\vec \tau/\vec t]}
+%% }
+%% %%
+%% %% \Infer[(SF-Poly)]{
+%% %% \Jcheck[\Gamma,\overrightarrow{t\:*}] e {\tau}
+%% %% }{
+%% %% \JcheckCoerce{e}{\MDArw{t\:*}{\tau}}
+%% %% }
+%% %%
+%% %% \Infer[(SF-Coerce)]{
+%% %% %% \Jmono{\tau} \\
+%% %% \Jsynth e \tau' \\
+%% %% \Jcoerce {\tau'} \tau
+%% %% }{
+%% %% \JcheckCoerce{e}{\tau}
+%% %% }
+%% \end{mathpar}
+%% \caption{Bidirectional type inference for System F}
+%% \label{fig:system-f}
+%% \end{figure}
\begin{figure}
\begin{mathpar}
\Infer[(SF-Var)]{
@@ -534,62 +611,53 @@ a $\Lam{x}{e}$.
\Infer[(SF-Let)]{
\Jsynth{e_1}{\tau_1} \\
- \tau_1' = \kw{gen}(\Gamma,\tau_1) \\
- \Jpoly[\Gamma,x\:\tau_1']{e_2}{\tau}
+ \overrightarrow{t\:*} = \kw{gen}(\Gamma,\tau_1) \\
+ \Jsynth[\Gamma,x\:\MDArw{t\:*}{\tau_1}]{e_2}{\tau}
}{
- \Jpoly{\Let x {e_1}{e_2}}{\tau}
+ \Jsynth{\Let x {e_1}{e_2}}{\tau}
}
\Infer[(SF-App)]{
%% \Jsynth{e_1}{\Arw{\tau_1}{\tau_2}} \\
- \JcheckCoerce{e_1}{\Arw{\tau_1}{\tau_2}} \\
- \JcheckCoerce{e_2}{\tau_1}
+ \JsynthCoerce{e_1}{\Arw{\tau_1}{\tau_2}} \\
+ \JsynthCoerce{e_2}{\tau_1}
}{
\Jsynth{e_1~e_2}{\tau_2}
}
%%
- \Infer[(SF-HT)]{
- \JcheckCoerce e \tau
+ \Infer[(SF-Ann)]{
+ \JsynthCoerce e \tau
}{
\Jsynth{\HasType{e}{\tau}}{\tau}
}
\Infer[(SF-Lam)]{
- \JcheckCoerce[\Gamma,x\:\tau_1] e {\tau_2}
+ \JsynthCoerce[\Gamma,x\:\tau_1] e {\tau_2}
}{
- \Jcheck{\Lam x e}{\Arw{\tau_1}{\tau_2}}
+ \Jsynth{\Lam x e}{\Arw{\tau_1}{\tau_2}}
}
%%
- %% FIXME: Not needed?
- %% \Infer[(SF-Check)]{\Jsynth e \tau}{\Jcheck{e}{\tau}}
-
- \Infer[(SF-Guess)]{
- \Jcheck e {\tau}
- }{
- %% FIXME: Make it \JsynthCoerce?
- \Jsynth e {\tau}
- }
\\\\
\Infer[(SF-Poly)]{
- \JcheckCoerce[\Gamma,\overrightarrow{t\:*}] e {\tau}
+ \JsynthCoerce[\Gamma,\overrightarrow{t\:*}] e {\tau}
}{
- \JcheckCoerce{e}{\MDArw{t\:*}{\tau}}
+ \JsynthCoerce{e}{\MDArw{t\:*}{\tau}}
}
\Infer[(SF-Inst)]{
\Jsynth e {\MDArw{t\:*}{\tau}} \\
}{
- \JcheckCoerce{e}{\tau[\vec \tau/\vec t]}
+ \JsynthCoerce{e}{\tau[\vec \tau/\vec t]}
}
-
+ %%
%% \Infer[(SF-Poly)]{
%% \Jcheck[\Gamma,\overrightarrow{t\:*}] e {\tau}
%% }{
%% \JcheckCoerce{e}{\MDArw{t\:*}{\tau}}
%% }
-
+ %%
%% \Infer[(SF-Coerce)]{
%% %% \Jmono{\tau} \\
%% \Jsynth e \tau' \\
@@ -597,8 +665,8 @@ a $\Lam{x}{e}$.
%% }{
%% \JcheckCoerce{e}{\tau}
%% }
-\ \end{mathpar}
- \caption{Bidirectional type inference for System F}
+ \end{mathpar}
+ \caption{Type inference for System F}
\label{fig:system-f}
\end{figure}
@@ -607,26 +675,40 @@ a $\Lam{x}{e}$.
It is usually accepted wisdom that extending HM-inference to a more
sophisticated type system requires the addition of explicit annotations.
While we do not intend to require as few annotations as systems like
-\MLF{}~\cite{Botlan03}, we do consider it important to make good use of existing
-type annotations to try and reduce the amount of annotations needed.
-To this end, we need to pay attention to the places where redundant type
-information can be better used. In the original Hindley-Milner algorithm,
-we can see that the only place where we might ``burn off'' excess
-information is in the call to \kw{unify} in the application rule, where the
-type $\tau_1$ of the argument might be inferred both from $e_2$ and from $e_1$.
+\MLF{}~\cite{Botlan03}, we do consider it important to make good use of
+existing type information to try and reduce the amount of annotations
+needed. To this end, we need to pay attention to the places where redundant
+type information can be better used. In the original Hindley-Milner
+algorithm, we can see that the only place where we might ``burn off'' excess
+information is in the \textsc{HM-App} rule, where the type $\tau_1$ of the
+argument might be inferred both from $e_2$ and from $e_1$.
+
Our inference algorithm takes inspiration from bidirectional type systems to
-try and make better use of that information.
+try and make better use of that information. In such systems, the
+application rule usually looks something like:
+\begin{displaymath}
+ \Infer[(BI-App)]{
+ \Jsynth{e_1}{\Arw{\tau_1}{\tau_2}} \\
+ \Jcheck{e_2}{\tau_1}
+ }{
+ \Jsynth{e_1~e_2}{\tau_2}
+ }
+\end{displaymath}
+Which means that to \emph{synthesize} the type of ``${e_1~e_2}$'' we first
+synthesize the type of $e_1$, which gives us both $\tau_1$ and $\tau_2$ after
+which we can just \emph{check} the type of $e_2$ against $\tau_1$.
+This is because in the vast majority of cases we already know the type of
+the function we're calling.
The only change to the syntax of the language is the addition of the form
$\HasType{e}{\tau}$. While the specific form of the type annotations is not
-a primary
-concern for us, we did want to avoid ``non-standard'' annotations such as
-the freeze annotation of FreezeML~\cite{Emrich20} or the constrained
+a primary concern for us, we did want to avoid ``non-standard'' annotations
+such as the freeze annotation of FreezeML~\cite{Emrich20} or the constrained
quantifiers of \MLF:
%%
\begin{displaymath}
\begin{array}{cc@{\;\;::=\;\;}l}
- \textit{(types)} & \tau & t ~|~ \Meta{u} ~|~ \Arw{\tau_1}{\tau_2} ~|~ \DArw t * \tau \\
+ \textit{(types)} & \tau & t ~|~ \Arw{\tau_1}{\tau_2} ~|~ \DArw t * \tau \\
\textit{(terms)} & e & x ~|~ \Lam x e ~|~ e_1~e_2 ~|~ \Let x {e_1} {e_2}
~|~ \HasType{e}{\tau} \\
\textit{(context)} & \Gamma & \bullet ~|~ \Gamma,x\:\tau ~|~ \Gamma,t\:* \\
@@ -634,11 +716,14 @@ quantifiers of \MLF:
\end{array}
\end{displaymath}
%%
-Figure~\ref{fig:system-f} shows how we extend the previous rules to handle
-System-F. There are now three judgments: $\Jsynth e \tau$ which synthesizes
-a type, as before, $\Jcheck e \tau$ which only \emph{checks}, taking all three
-arguments $\Gamma$, $e$, and $\tau$ as input, and $\JcheckCoerce e \tau$ which \FIXME{explain}. The rules also use $\Jpoly e \tau$ which is
-just a shorthand for a pair of rules, one that checks and one that synthesizes.
+Figure~\ref{fig:system-f} shows an idealized form of how we extend
+Hindley-Milner to handle System-F. There are now three judgments: $\Jsynth
+e \tau$ which synthesizes a type, as before, $\Jcheck e \tau$ which only
+\emph{checks}, taking all three arguments $\Gamma$, $e$, and $\tau$ as input, and
+$\JcheckCoerce e \tau$ which checks that $e$ is well-typed and that it can be
+coerced to type $\tau$ by judicious addition of type abstractions and type
+applications. The rules also use $\Jpoly e \tau$ which is just a shorthand for
+a pair of rules, one that checks and one that synthesizes.
\FIXME{The text below is out of date}
The first three lines are equivalent to the base Hindley-Milner system
@@ -763,7 +848,7 @@ incompatible with things like value polymorphism.
\Infer[(EF-Let)]{
\JEsynth{e_1}{\tau_1}{E_1} \\
- \overrightarrow{t\:*} = \kw{fmv!}(\Gamma,\tau_1) \\
+ \overrightarrow{t\:*} = \kw{gen}(\Gamma, \tau_1) \\
\JEpoly[\Gamma,x\:\MDArw{t\:*}{\tau_1}]{e_2}{\tau}{E_2}
}{
\JEpoly{\Let x {e_1}{e_2}}{\tau}{
@@ -772,32 +857,29 @@ incompatible with things like value polymorphism.
\Infer[(EF-App)]{
%% \Jsynth{e_1}{\Arw{\tau_1}{\tau_2}} \\
- \Jfresh{u_1,u_2} \\
- \JEcheckCoerce{e_1}{\Arw{u_1}{u_2}}{E_1} \\
- \JEcheck{e_2}{u_1}{E_2}
+ \JEcheckCoerce{e_1}{\Arw{\tau_1}{\tau_2}}{E_1} \\
+ \JEcheck{e_2}{\tau_1}{E_2}
}{
- \JEsynth{e_1~e_2}{u_2}{E_1~E_2}
+ \JEsynth{e_1~e_2}{\tau_2}{E_1~E_2}
}
- \Infer[(EF-Lam)]{
- \Jfresh {\Meta{u_1},\Meta{u_2}} \\
- \Junify {\tau}{\Arw{\Meta{u_1}}{\Meta{u_2}}} \\
- \JEcheckCoerce[\Gamma,x\:\Meta{u_1}]{e}{\Meta{u_2}}{E}
+ \Infer[(EF-Ann)]{
+ \JEcheckCoerce e \tau E
}{
- \JEcheck{\Lam x e}{\tau}{\Lam{x\:\Meta{u_1}}{E}}
+ \JEsynth{(\HasType{e}{\tau})}{\tau}{E}
}
- \Infer[(EF-HT)]{
- \JEcheckCoerce e \tau E
+ \Infer[(EF-Lam)]{
+ \JEcheckCoerce[\Gamma,x\:\tau_1]{e}{\tau_2}{E}
}{
- \JEsynth{\HasType{e}{\tau}}{\tau}{E}
+ \JEcheck{\Lam x e}{\Arw{\tau_1}{\tau_2}}{\Lam{x\:\tau_1}{E}}
}
- \Infer[(EF-Infer)]{
- \Jfresh{\Meta{u}} \\ \JEcheck{e}{\Meta{u}}{E}
+ \Infer[(EF-Guess)]{
+ \JEcheck{e}{\tau}{E}
}{
%% FIXME: Make it \JsynthCoerce?
- \JEsynth{e}{\Meta{u}}{E}
+ \JEsynth{e}{\tau}{E}
}
\Infer[(EF-Poly)]{
@@ -806,43 +888,42 @@ incompatible with things like value polymorphism.
\JEcheckCoerce{e}{\MDArw{t\:*}{\tau}}{\TLam{\overrightarrow{t\:*}}{E}}
}
- \Infer[(EF-Coerce)]{
+ \Infer[(EF-Inst)]{
%% \Jmono{\tau} \\
- \JEsynth{e}{\tau}{E} \\
- \JEcoerce {E}{\tau}{E'}{\tau'}
+ \JEsynth e {\MDArw{t\:*}{\tau}}{E} \\
}{
- \JEcheckCoerce{e}{\tau'}{E'}
+ \JEcheckCoerce{e}{\tau[\vec \tau/\vec t]}{\TApp{e}{\vec \tau}}
}
%% FIXME: The rules below don't make much sense yet, I think!
%%
- \Infer[(CO-Inst)]{
- \Jfresh {\vec {\Meta{u}}} \\
- \Junify{\tau[\vec {\Meta{u}}/\vec t]}{\tau'}
- }{
- \JEcoerce {E} {\MDArw{t\:*}{\tau}}
- {\TApp{E}{\vec {\Meta{u}}}} {\tau'}
- }
+ %% \Infer[(CO-Inst)]{
+ %% \Jfresh {\vec {\Meta{u}}} \\
+ %% \Junify{\tau[\vec {\Meta{u}}/\vec t]}{\tau'}
+ %% }{
+ %% \JEcoerce {E} {\MDArw{t\:*}{\tau}}
+ %% {\TApp{E}{\vec {\Meta{u}}}} {\tau'}
+ %% }
- \Infer[(CO-Gen)]{
- \Jfresh {\vec {\Meta{u}}} \\
- \JEcoerce {E} {\tau} {E'} {\tau'[\vec {\Meta{u}}/\vec t]} \\
- \vec {\Meta{u}} \subset \kw{fmv}(\Gamma,\tau'[\vec {\Meta{u}}/\vec t])
- }{
- \JEcoerce {E} {\tau} {\TLam{\overrightarrow{t\:*}}{E'}} {\MDArw{t\:*}{\tau'}}
- }
+ %% \Infer[(CO-Gen)]{
+ %% \Jfresh {\vec {\Meta{u}}} \\
+ %% \JEcoerce {E} {\tau} {E'} {\tau'[\vec {\Meta{u}}/\vec t]} \\
+ %% \vec {\Meta{u}} \subset \kw{fmv}(\Gamma,\tau'[\vec {\Meta{u}}/\vec t])
+ %% }{
+ %% \JEcoerce {E} {\tau} {\TLam{\overrightarrow{t\:*}}{E'}} {\MDArw{t\:*}{\tau'}}
+ %% }
\end{mathpar}
- \FIXME{
- Rule \textsc{CO-Gen} has many problems:
- \begin{itemize}
- \item Maybe "u" was instantiated to some other
- (uninstantiated) metavar. \\
- If so, should it still be in `fmv`?
- \item We're using $\Gamma$ even though we don't actually have it!
- \item Define `fmv`!!
- \item `fmv` is not quite the same as the previous `fmv!`!!
- \end{itemize}
- }
+ %% \FIXME{
+ %% Rule \textsc{CO-Gen} has many problems:
+ %% \begin{itemize}
+ %% \item Maybe "u" was instantiated to some other
+ %% (uninstantiated) metavar. \\
+ %% If so, should it still be in `fmv`?
+ %% \item We're using $\Gamma$ even though we don't actually have it!
+ %% \item Define `fmv`!!
+ %% \item `fmv` is not quite the same as the previous `fmv!`!!
+ %% \end{itemize}
+ %% }
\caption{Elaboration for System F}
\label{fig:elab-system-f}
\end{figure}
View it on GitLab: https://gitlab.com/monnier/typer/-/commit/20732788c43cab1470c19eddf7b0a9a98…
--
View it on GitLab: https://gitlab.com/monnier/typer/-/commit/20732788c43cab1470c19eddf7b0a9a98…
You're receiving this email because of your account on gitlab.com.
1
0
Alice de Berny pushed to branch alice at Stefan / Typer
Commits:
47cb679f by irradiee at 2020-07-10T06:43:41-04:00
add time & profiling
- - - - -
8 changed files:
- .gitignore
- GNUmakefile
- src/REPL.ml
- src/debug_util.ml
- src/lexp.ml
- src/lexp_type.ml
- src/subst.ml
- src/util.ml
Changes:
=====================================
.gitignore
=====================================
@@ -34,8 +34,12 @@ _tags
# Files generated by profilers
gmon.out
ocamlprof.dump
+profiling
# Files auto-generated for ELPA packaging and other Emacs stuff
emacs/*-autoloads.el
emacs/*-pkg.el
emacs/*.elc
+
+# Dependencies
+.depend
=====================================
GNUmakefile
=====================================
@@ -8,10 +8,9 @@ SRC_FILES := $(wildcard ./src/*.ml)
CPL_FILES := $(wildcard ./$(BUILDDIR)/src/*.cmo)
TEST_FILES := $(wildcard ./tests/*_test.ml)
-# @TODO: remove -pkg unix
-OBFLAGS = -tag debug -tag profile -lib str -build-dir $(BUILDDIR) -pkg zarith -pkg unix
+OBFLAGS = -tag debug -tag e -lib str -build-dir $(BUILDDIR) -pkg zarith
# OBFLAGS := -I $(SRCDIR) -build-dir $(BUILDDIR) -pkg str
-# OBFLAGS_DEBUG := -tag debug -tag profile -tag "warn(+20)"
+# OBFLAGS_DEBUG := -tag debug -tag e -tag "warn(+20)"
# OBFLAGS_RELEASE := -tag unsafe -tag inline
COMPILE_MODE = byte
# COMPILE_MODE = native
@@ -19,6 +18,15 @@ COMPILE_MODE = byte
# DEBUG ?= 1
# VERBOSE ?= 1
+OCAMLCP := ocamlcp
+OCAMLOPTP := ocamloptp
+OCAMLOPT := ocamlopt
+OCAMLDEP := ocamldep
+
+OCAMLFLAGS := -I src
+SRC_NO_DEBUG := $(filter-out ./src/debug_util.ml, $(SRC_FILES))
+DEPSORT_FILES := $(shell ocamldep -sort -I src $(SRC_NO_DEBUG))
+
all: typer debug tests-build
# ifeq ($(OS), Windows_NT)
@@ -46,13 +54,12 @@ debug:
$(OCAMLBUILD) src/debug_util.$(COMPILE_MODE) -I src $(OBFLAGS)
@$(MV) $(BUILDDIR)/src/debug_util.$(COMPILE_MODE) $(BUILDDIR)/debug_util
-
# interactive typer
typer:
# ============================
# Build typer
# ============================
- $(OCAMLBUILD) src/REPL.$(COMPILE_MODE) -I src $(OBFLAGS)
+ $(OCAMLBUILD) src/REPL.$(COMPILE_MODE) -I src $(OBFLAGS)
@$(MV) $(BUILDDIR)/src/REPL.$(COMPILE_MODE) $(BUILDDIR)/typer
tests-build:
@@ -78,6 +85,14 @@ install: tests
tests: tests-build tests-run
+# @TODO: delete
+test:
+ $(OCAMLBUILD) tests/lexp_test.$(COMPILE_MODE) -I src $(OBFLAGS)
+ @$(OCAMLBUILD) tests/utest_main.$(COMPILE_MODE) -I src $(OBFLAGS)
+ @$(MV) $(BUILDDIR)/tests/utest_main.$(COMPILE_MODE) \
+ $(BUILDDIR)/tests/utests
+ @./$(BUILDDIR)/tests/utests --verbose= 3
+
# Make language doc
doc-tex:
texi2pdf ./doc/manual.texi --pdf --build=clean
@@ -110,3 +125,36 @@ run/typer-file:
run/test-file:
@./$(BUILDDIR)/test
+
+profiling-cp:
+ # ============================
+ # profiling bytecode
+ # ============================
+ ocamlfind $(OCAMLCP) -o profiling -linkpkg -package zarith \
+ $(OCAMLFLAGS) str.cma -P f $(DEPSORT_FILES)
+
+profiling-optp:
+ # ============================
+ # profiling native
+ # ============================
+ ocamlfind $(OCAMLOPTP) -o profiling -linkpkg -package zarith \
+ $(OCAMLFLAGS) str.cmxa -P f $(DEPSORT_FILES)
+
+time:
+ # ============================
+ # time native
+ # ============================
+ ocamlfind $(OCAMLOPT) -p -o profiling -linkpkg -package zarith \
+ $(OCAMLFLAGS) str.cmxa $(DEPSORT_FILES)
+
+# Clean up
+clean-profiling:
+ -rm -rf profiling
+ -rm -rf src/*.cm[iox] src/*.o
+ -rm -rf ocamlprof.dump
+ -rm -rf .depend
+ -rm -rf gmon.out
+
+# Dependencies
+depend:
+ $(OCAMLDEP) -sort $(OCAMLFLAGS) src/*.ml > .depend
=====================================
src/REPL.ml
=====================================
@@ -203,7 +203,7 @@ let help_msg =
%help (%h) : print help
"
-let readfiles_aux files (i, lctx, rctx) prt =
+let readfiles files (i, lctx, rctx) prt =
(* Read specified files *)
List.fold_left (fun (i, lctx, rctx) file ->
@@ -220,10 +220,6 @@ let readfiles_aux files (i, lctx, rctx) prt =
)
(i, lctx, rctx) files
-let readfiles files (i, lctx, rctx) prt =
- let res = readfiles_aux files (i, lctx, rctx) prt in
- (print_total_hctime !hc_total_time; res)
-
(* Specials commands %[command-name] [args] *)
let rec repl i clxp rctx =
let repl = repl (i + 1) in
@@ -234,8 +230,8 @@ 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) !Subst.sshrct !Subst.nf_sshrct)
- | "%scollisions" | "%scl" -> (get_stats_hashtbl (Subst.WHCSB.stats Subst.hcsb_table) !Subst.sshrct !Subst.nf_sshrct)
+ | "%lcollisions" | "%cl" -> (get_stats_hashtbl (WHC.stats hc_table) !lshrct !nf_lshrct !Subst.sshrct !Subst.nf_sshrct)
+ | "%scollisions" | "%scl" -> (get_stats_hashtbl (Subst.WHCSB.stats Subst.hcsb_table) !lshrct !nf_lshrct !Subst.sshrct !Subst.nf_sshrct)
(* command with arguments *)
| _ when (ipt.[0] = '%' && ipt.[1] != ' ') -> (
@@ -251,7 +247,7 @@ let rec repl i clxp rctx =
(time_process := true;
let (i, clxp, rctx) =
try
- get_unix_stats_processtime (fun () -> (readfiles args (i, clxp, rctx) false))
+ readfiles args (i, clxp, rctx) false
with Log.Stop_Compilation msg ->
(handle_stopped_compilation msg; (i,clxp,rctx)) in
repl clxp rctx)
@@ -323,12 +319,11 @@ let main () =
if !time_process
then
let res =
- get_unix_stats_processtime (fun () -> (readfiles
- (List.rev !arg_files) (1, ectx, rctx) (not !arg_batch))) in
+ readfiles (List.rev !arg_files) (1, ectx, rctx) (not !arg_batch) in
(print_and_clear_log (); res)
else
let res =
- readfiles_aux (List.rev !arg_files) (1, ectx, rctx) (not !arg_batch) in
+ readfiles (List.rev !arg_files) (1, ectx, rctx) (not !arg_batch) in
(print_and_clear_log (); res)
with
| Log.Stop_Compilation msg ->
=====================================
src/debug_util.ml
=====================================
@@ -29,7 +29,6 @@
* print out each compilation' steps
*
* --------------------------------------------------------------------------- *)
-
(* Utilities *)
open Util
open Fmt
@@ -38,6 +37,7 @@ open Debug
(* ASTs *)
open Sexp
open Pexp
+open Lexp_type
open Lexp
(* AST reader *)
=====================================
src/lexp.ml
=====================================
@@ -154,17 +154,18 @@ module WHC = Weak.Make (struct type t = lexp
let hash = lexp_hash
end)
-let hc_table : WHC.t = WHC.create 1000
+(* counter for lexp found in WHC *)
+let lshrct = ref 0
+
+(* counter for lexp not found in WHC *)
+let nf_lshrct = ref 0
-let hc_aux (e : lexp') : lexp =
- let lp = (e, lexp'_hash e) in WHC.merge hc_table lp
+let hc_table : WHC.t = WHC.create 1000
-let hc (e : lexp') : lexp =
- if !U.time_process
- then
- U.inc_hc_total_time (fun () -> hc_aux e)
- else
- hc_aux e
+let hc (s : lexp') : lexp =
+ let lp = (s, lexp'_hash s) in
+ try let lp' = WHC.find hc_table lp in (U.shrct_inc lshrct 1; lp')
+ with Not_found -> (U.shrct_inc nf_lshrct 1; WHC.add hc_table lp; lp)
let impossible = hc (Imm Sexp.dummy_epsilon)
=====================================
src/lexp_type.ml
=====================================
@@ -124,6 +124,7 @@ and db_index = int (* DeBruijn index. *)
and db_offset = int (* DeBruijn index offset. *)
(* Substitution, i.e. a mapping from db_index to lexp *)
+(* @TODO: change Cons name *)
and subst = subst' * int
and subst' =
| Identity of db_offset (* Identity o ≡ id ∘ ↑ₒ *)
=====================================
src/subst.ml
=====================================
@@ -121,8 +121,6 @@ let sshrct = ref 0
(* counter for subst not found in WHCSB *)
let nf_sshrct = ref 0
-let shrct_inc e acc = e := !e + acc
-
let hcsb_eq sb1 sb2 =
sb1 == sb2 ||
match (subst_subst' sb1, subst_subst' sb2) with
@@ -149,8 +147,8 @@ let hcsb_table : WHCSB.t = WHCSB.create 1000
let hcsb (s : subst') : subst =
let sb = (s, subst'_hash s) in
- try let sb' = WHCSB.find hcsb_table sb in (shrct_inc sshrct 1; sb')
- with Not_found -> (shrct_inc nf_sshrct 1; WHCSB.add hcsb_table sb; sb)
+ try let sb' = WHCSB.find hcsb_table sb in (U.shrct_inc sshrct 1; sb')
+ with Not_found -> (U.shrct_inc nf_sshrct 1; WHCSB.add hcsb_table sb; sb)
(* Apply a substitution to a single variable. *)
let lookup (mkVar : 'b -> db_index -> 'a)
=====================================
src/util.ml
=====================================
@@ -126,7 +126,7 @@ let rec combine_hashes map =
| [] -> 31
| e :: l -> combine_hash (e * 31) (combine_hashes l)
-let get_stats_hashtbl stats sshrct nf_sshrct =
+let get_stats_hashtbl stats lshrct nf_lshrct sshrct nf_sshrct =
let (tl, ne, sumb, smallb, medianb, bigb) = stats in
Printf.printf "\n\ttable length: %i\n
number of entries: %i\n
@@ -134,27 +134,8 @@ let get_stats_hashtbl stats sshrct nf_sshrct =
smallest bucket length: %i\n
median bucket length: %i\n
biggest bucket length: %i\n
+ found/new lexp entries: %i\n
found/new subst entries: %i\n"
- tl ne sumb smallb medianb bigb (sshrct / nf_sshrct)
+ tl ne sumb smallb medianb bigb (lshrct / nf_lshrct) (sshrct / nf_sshrct)
-let get_total_unix_stats_processtime (times : Unix.process_times) =
- Printf.printf "\n\tUser time for the process: %f\n
- System time for the process: %f\n
- User time for the children processes: %f\n
- System time for the children processes: %f\n"
- times.tms_utime times.tms_stime times.tms_cutime times.tms_cstime
-
-let hc_total_time = ref 0.0
-
-let inc_hc_total_time f =
- let t = Unix.gettimeofday () in
- let res = f () in (hc_total_time :=
- !hc_total_time +. Unix.gettimeofday () -. t; res)
-
-let get_unix_stats_processtime f =
- let t = Unix.gettimeofday () in
- let res = f () in (Printf.printf "\t(Unix) process time: %f\n"
- (Unix.gettimeofday () -. t); res)
-
-let print_total_hctime hctime =
- Printf.printf "\t(Unix) total hc time: %f\n" hctime
+let shrct_inc e acc = e := !e + acc
View it on GitLab: https://gitlab.com/monnier/typer/-/commit/47cb679f83f1c2d8964d7a8c07de4f03f…
--
View it on GitLab: https://gitlab.com/monnier/typer/-/commit/47cb679f83f1c2d8964d7a8c07de4f03f…
You're receiving this email because of your account on gitlab.com.
1
0
08 Jul '20
Stefan pushed to branch report/hmdup at Stefan / Typer
Commits:
9322269d by Stefan Monnier at 2020-07-07T22:39:46-04:00
Rewrite rules to keep unification implicit
- - - - -
1 changed file:
- paper.tex
Changes:
=====================================
paper.tex
=====================================
@@ -329,26 +329,22 @@ minimizing the amount of type annotations was secondary to the design.
\begin{mathpar}
\Infer[(HM-Var)]{
\Gamma(x) = \MDArw{t\:*}\tau \\
- \Jfresh {\vec u}
}{
- \Jsynth{x}{\tau[\vec u/\vec t]}
+ \Jsynth{x}{\tau[\vec \tau/\vec t]}
}
\Infer[(HM-Lam)]{
- \Jfresh u \\
- \Jsynth[\Gamma,x\:u] e {\tau}
+ \Jsynth[\Gamma,x\:\tau_1] e {\tau_2}
}{
- \Jsynth{\Lam x e}{\Arw{u}{\tau}}
+ \Jsynth{\Lam x e}{\Arw{\tau_1}{\tau_2}}
}
\Infer[(HM-App)]{
%% \Jsynth{e_1}{\Arw{\tau_1}{\tau_2}} \\
- \Jsynth{e_1}{\tau} \\
- \Jfresh{u_2} \\
- \Junify{\tau}{\Arw{\tau_1}{u_2}} \\
+ \Jsynth{e_1}{\Arw{\tau_1}{\tau_2}} \\
\Jsynth{e_2}{\tau_1}
}{
- \Jsynth{e_1~e_2}{u_2}
+ \Jsynth{e_1~e_2}{\tau_2}
}
\Infer[(HM-Let)]{
@@ -367,8 +363,8 @@ minimizing the amount of type annotations was secondary to the design.
%%
\end{mathpar}
- \caption{Hindley-Milner type inference in the style of algorithm J}
- \label{fig:algo-j}
+ \caption{Hindley-Milner type inference}
+ \label{fig:hm}
\end{figure}
As a warm up and to clarify the notation used in the rest of the article, we
@@ -377,7 +373,7 @@ the $\lambda$-calculus we will use for that is the following:
%%
\begin{displaymath}
\begin{array}{cc@{\;\;::=\;\;}l}
- \textit{(types)} & \tau & t ~|~ \Meta{u} ~|~ \Arw{\tau_1}{\tau_2} ~|~ \DArw t * \tau \\
+ \textit{(types)} & \tau & t ~|~ \Arw{\tau_1}{\tau_2} ~|~ \DArw t * \tau \\
\textit{(terms)} & e & x ~|~ \Lam x e ~|~ e_1~e_2 ~|~ \Let x {e_1} {e_2} \\
\textit{(context)} & \Gamma & \bullet ~|~ \Gamma,x\:\tau ~|~ \Gamma,t\:* \\
%% \textit{(substitutions)} & \sigma & \textsf{id} ~|~ \sigma,\Meta{u}\mapsto\tau
@@ -480,12 +476,10 @@ type check the $\lambda$-calculus.
\Infer[(BI-App)]{
%% \Jsynth{e_1}{\Arw{\tau_1}{\tau_2}} \\
- \Jsynth{e_1}{\tau_1} \\
- \Jfresh{u_1, u_2} \\
- \Junify{\tau_1}{\Arw{u_1}{u_2}} \\
- \Jcheck{e_2}{u_1}
+ \Jsynth{e_1}{\Arw{\tau_1}{\tau_2}} \\
+ \Jcheck{e_2}{\tau_1}
}{
- \Jsynth{e_1~e_2}{u_2}
+ \Jsynth{e_1~e_2}{\tau_2}
}
%% \Infer{
@@ -495,21 +489,19 @@ type check the $\lambda$-calculus.
%% }
\Infer[(BI-Lam)]{
- \Jfresh{\Meta{u_1}, \Meta{u_2}} \\
- \Junify{\tau}{\Arw{u_1}{u_2}} \\
- \Jcheck[\Gamma,x\:\Meta{u_1}] e {\Meta{u_2}}
+ \Jcheck[\Gamma,x\:\tau_1] e {\tau_2}
}{
- \Jcheck{\Lam x e}{\tau}
+ \Jcheck{\Lam x e}{\Arw{\tau_1}{\tau_2}}
}
\\\\
\Infer[(BI-HT)]{\Jcheck e \tau}{\Jsynth{\HasType{e}{\tau}}{\tau}}
- \Infer[(BI-Check)]{\Jsynth e \tau' \\ \Junify{\tau}{\tau'}}{\Jcheck{e}{\tau}}
+ \Infer[(BI-Check)]{\Jsynth e \tau}{\Jcheck{e}{\tau}}
- \Infer[(BI-Infer)]{
- \Jfresh{\Meta{u}} \\ \Jcheck e {\Meta{u}}
+ \Infer[(BI-Guess)]{
+ \Jcheck e {\tau}
}{
- \Jsynth e {\Meta{u}}
+ \Jsynth e {\tau}
}
\end{mathpar}
\caption{Basic bidirectional type inference rules}
@@ -550,22 +542,11 @@ a $\Lam{x}{e}$.
\Infer[(SF-App)]{
%% \Jsynth{e_1}{\Arw{\tau_1}{\tau_2}} \\
- \Jfresh{u_1,u_2} \\
- \JcheckCoerce{e_1}{\Arw{u_1}{u_2}} \\
- \JcheckCoerce{e_2}{u_1}
- }{
- \Jsynth{e_1~e_2}{u_2}
- }
-
- \Infer[(SF-Lam)]{
- \Jfresh{u_1, u_2} \\
- %% FIXME: Introduce polymorphism?!
- \Junify{\tau}{\Arw{u_1}{u_2}} \\
- \JcheckCoerce[\Gamma,x\:u_1] e {u_2}
+ \JcheckCoerce{e_1}{\Arw{\tau_1}{\tau_2}} \\
+ \JcheckCoerce{e_2}{\tau_1}
}{
- \Jcheck{\Lam x e}{\tau}
+ \Jsynth{e_1~e_2}{\tau_2}
}
- %%
%%
\Infer[(SF-HT)]{
@@ -574,27 +555,49 @@ a $\Lam{x}{e}$.
\Jsynth{\HasType{e}{\tau}}{\tau}
}
- \Infer[(SF-Infer)]{
- \Jfresh{\Meta{u}} \\ \Jcheck e {\Meta{u}}
+ \Infer[(SF-Lam)]{
+ \JcheckCoerce[\Gamma,x\:\tau_1] e {\tau_2}
}{
- %% FIXME: Make it \JsynthCoerce?
- \Jsynth e {\Meta{u}}
+ \Jcheck{\Lam x e}{\Arw{\tau_1}{\tau_2}}
}
+ %%
+
+ %% FIXME: Not needed?
+ %% \Infer[(SF-Check)]{\Jsynth e \tau}{\Jcheck{e}{\tau}}
+ \Infer[(SF-Guess)]{
+ \Jcheck e {\tau}
+ }{
+ %% FIXME: Make it \JsynthCoerce?
+ \Jsynth e {\tau}
+ }
+ \\\\
\Infer[(SF-Poly)]{
- \Jcheck[\Gamma,\overrightarrow{t\:*}] e {\tau}
+ \JcheckCoerce[\Gamma,\overrightarrow{t\:*}] e {\tau}
}{
\JcheckCoerce{e}{\MDArw{t\:*}{\tau}}
}
- \Infer[(SF-Coerce)]{
- %% \Jmono{\tau} \\
- \Jsynth e \tau' \\
- \Jcoerce {\tau'} \tau
+ \Infer[(SF-Inst)]{
+ \Jsynth e {\MDArw{t\:*}{\tau}} \\
}{
- \JcheckCoerce{e}{\tau}
+ \JcheckCoerce{e}{\tau[\vec \tau/\vec t]}
}
- \end{mathpar}
+
+ %% \Infer[(SF-Poly)]{
+ %% \Jcheck[\Gamma,\overrightarrow{t\:*}] e {\tau}
+ %% }{
+ %% \JcheckCoerce{e}{\MDArw{t\:*}{\tau}}
+ %% }
+
+ %% \Infer[(SF-Coerce)]{
+ %% %% \Jmono{\tau} \\
+ %% \Jsynth e \tau' \\
+ %% \Jcoerce {\tau'} \tau
+ %% }{
+ %% \JcheckCoerce{e}{\tau}
+ %% }
+\ \end{mathpar}
\caption{Bidirectional type inference for System F}
\label{fig:system-f}
\end{figure}
View it on GitLab: https://gitlab.com/monnier/typer/-/commit/9322269d8eb62ed4407405dae9079ca3c…
--
View it on GitLab: https://gitlab.com/monnier/typer/-/commit/9322269d8eb62ed4407405dae9079ca3c…
You're receiving this email because of your account on gitlab.com.
1
0
Salut Simon,
Donc pour clarifier les idées, voici ce à quoi je pensais:
Pour permettre de séparer l'allocation et l'initialisation, on pourrait
ajouter une sorte de ST monad qui pourrait ressembler un peu à du "alias
types" ou qqch du genre. Le type du monad aurait une forme comme
LLT : Store → Store → Type → Type
donc qqch du type `LLT s₁ s₂ τ` est une commande qui attend un Store de
la forme `s₁`, se termine avec un Store de la forme `s₂`, et renvoie une
valeur de type `τ`.
Les primitives pourraient ressembler à:
bind : LLT ?s₁ ?s₂ ?τ₁ → (?τ₁ → LLT ?s₂ ?s₃ ?τ₂) → LLT ?s₁ ?s₃ ?τ₂;
runLLT : LLT emptyStore ?s ?τ → ?τ;
exportPtr : LLTPtr ?ℓ → LLT (?s :: {?ℓ ↦ ?τ}) ?s ?τ;
Il faudra une forme une peu différente, parce que je ne vois pas encore
comment donner un type à "malloc", mais ça devrait pouvoir se faire.
Stefan
1
0
Alice de Berny pushed to branch alice at Stefan / Typer
Commits:
e0c92648 by irradiee at 2020-07-01T18:33:36-04:00
check performance
- - - - -
6 changed files:
- GNUmakefile
- src/REPL.ml
- src/lexp.ml
- src/lexp_type.ml
- src/subst.ml
- src/util.ml
Changes:
=====================================
GNUmakefile
=====================================
@@ -8,7 +8,8 @@ SRC_FILES := $(wildcard ./src/*.ml)
CPL_FILES := $(wildcard ./$(BUILDDIR)/src/*.cmo)
TEST_FILES := $(wildcard ./tests/*_test.ml)
-OBFLAGS = -tag debug -tag profile -lib str -build-dir $(BUILDDIR) -pkg zarith
+# @TODO: remove -pkg unix
+OBFLAGS = -tag debug -tag profile -lib str -build-dir $(BUILDDIR) -pkg zarith -pkg unix
# OBFLAGS := -I $(SRCDIR) -build-dir $(BUILDDIR) -pkg str
# OBFLAGS_DEBUG := -tag debug -tag profile -tag "warn(+20)"
# OBFLAGS_RELEASE := -tag unsafe -tag inline
@@ -45,6 +46,7 @@ debug:
$(OCAMLBUILD) src/debug_util.$(COMPILE_MODE) -I src $(OBFLAGS)
@$(MV) $(BUILDDIR)/src/debug_util.$(COMPILE_MODE) $(BUILDDIR)/debug_util
+
# interactive typer
typer:
# ============================
=====================================
src/REPL.ml
=====================================
@@ -203,10 +203,9 @@ let help_msg =
%help (%h) : print help
"
-
-let readfiles files (i, lctx, rctx) prt =
+let readfiles_aux files (i, lctx, rctx) prt =
(* Read specified files *)
- List.fold_left (fun (i, lctx, rctx) file ->
+ List.fold_left (fun (i, lctx, rctx) file ->
(if prt then (
print_string " In["; ralign_print_int i 2; print_string "] >> ";
@@ -221,6 +220,9 @@ let readfiles files (i, lctx, rctx) prt =
)
(i, lctx, rctx) files
+let readfiles files (i, lctx, rctx) prt =
+ let res = readfiles_aux files (i, lctx, rctx) prt in
+ (print_total_hctime !hc_total_time; res)
(* Specials commands %[command-name] [args] *)
let rec repl i clxp rctx =
@@ -232,8 +234,8 @@ 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 (WHC.stats hc_table) !lshrct !sshrct)
- | "%scollisions" | "%scl" -> (get_stats (Subst.WHCSB.stats Subst.hcsb_table) !lshrct !sshrct)
+ | "%lcollisions" | "%cl" -> (get_stats_hashtbl (WHC.stats hc_table) !Subst.sshrct !Subst.nf_sshrct)
+ | "%scollisions" | "%scl" -> (get_stats_hashtbl (Subst.WHCSB.stats Subst.hcsb_table) !Subst.sshrct !Subst.nf_sshrct)
(* command with arguments *)
| _ when (ipt.[0] = '%' && ipt.[1] != ' ') -> (
@@ -243,9 +245,16 @@ let rec repl i clxp rctx =
try
readfiles args (i, clxp, rctx) false
with Log.Stop_Compilation msg ->
- (handle_stopped_compilation msg; (i,clxp,rctx))
- in
- repl clxp rctx;
+ (handle_stopped_compilation msg; (i,clxp,rctx)) in
+ repl clxp rctx
+ | "%readfiletime"::args ->
+ (time_process := true;
+ let (i, clxp, rctx) =
+ try
+ get_unix_stats_processtime (fun () -> (readfiles args (i, clxp, rctx) false))
+ with Log.Stop_Compilation msg ->
+ (handle_stopped_compilation msg; (i,clxp,rctx)) in
+ repl clxp rctx)
| "%who"::args | "%w"::args -> (
let _ = match args with
| ["all"] -> dump_rte_ctx rctx
@@ -287,6 +296,7 @@ let arg_defs = [
("--verbosity",
Arg.String Log.set_typer_log_level_str, "Set the logging level");
("-v", Arg.Unit Log.increment_log_level, "Increment verbosity");
+ ("--time", Arg.Set time_process, "Get time for process");
(* ("--debug", Arg.Set arg_debug, "Print the Elexp representation") *)
(*"-I",
Arg.String (fun f -> searchpath := f::!searchpath),
@@ -310,9 +320,16 @@ let main () =
let (i, ectx, rctx) = (
try
- let res =
- readfiles (List.rev !arg_files) (1, ectx, rctx) (not !arg_batch) in
- print_and_clear_log (); res
+ if !time_process
+ then
+ let res =
+ get_unix_stats_processtime (fun () -> (readfiles
+ (List.rev !arg_files) (1, ectx, rctx) (not !arg_batch))) in
+ (print_and_clear_log (); res)
+ else
+ let res =
+ readfiles_aux (List.rev !arg_files) (1, ectx, rctx) (not !arg_batch) in
+ (print_and_clear_log (); res)
with
| Log.Stop_Compilation msg ->
handle_stopped_compilation msg; exit 1
=====================================
src/lexp.ml
=====================================
@@ -35,160 +35,115 @@ open Grammar
(********************** Hash-consing **********************)
- (** hash-consing test **
- * with: Hashtbl.hash - lexp'_hash
- * median bucket length: 7 - 7
- * biggest bucket length: 205 - 22 *)
-
- let lexp_lexp' (e, h) = e
-
-let rec apply_lxor (map : int list) : int =
- match map with
- | [] -> 31
- | e :: l -> (e * 31) lxor (apply_lxor l)
-
-let attributemap_combine_hash (k: (int * string)) (v: lexp) (p: int) : int =
-shrct_inc lshrct 1;
- (p * 31) lxor (((Hashtbl.hash k) * 31) lxor (lexp_hash v))
-
-let ind_stringmap_combine_hash (k: string) (v: ((arg_kind * vname * ltype) list)) (p: int) : int =
- (p * 31) lxor ((Hashtbl.hash k) * 31) lxor
- (apply_lxor (List.map (fun e -> let (ak, n, lt) = e in
- shrct_inc lshrct 1;
- (U.combine_hash (Hashtbl.hash ak)
- (U.combine_hash (Hashtbl.hash n) (lexp_hash lt)))) v))
-
-let case_stringmap_combine_hash (k: string) (v: (U.location * (arg_kind * vname) list * lexp)) (p: int) : int =
- shrct_inc lshrct 1;
- let (loc, li, lp) = v in
- (p * 31) lxor ((Hashtbl.hash k) * 31) lxor
- (Hashtbl.hash loc) lxor (Hashtbl.hash li) lxor (lexp_hash lp)
-
-
-(* Hashtbl.hash for not lexp types
- * TODO: - find something else
- * - extract the first arg of 2 arg types ? (SMap) *)
- let lexp'_hash (expr : lexp') =
+(** hash-consing test **
+* with: Hashtbl.hash - lexp'_hash
+* median bucket length: 7 - 7
+* biggest bucket length: 205 - 22 *)
+
+let lexp_lexp' (e, h) = e
+
+let lexp'_hash (expr : lexp') =
match expr 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 -> shrct_inc lshrct 1; lexp_hash lp
- | SLlub (lp1, lp2)
- -> shrct_inc lshrct 2; U.combine_hash (lexp_hash lp1) (lexp_hash lp2))
+ -> 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 -> shrct_inc lshrct 1; lexp_hash lp
+ | Stype lp -> lexp_hash lp
| StypeOmega -> Hashtbl.hash s
| StypeLevel -> Hashtbl.hash s))
| Builtin (v, t, m)
- -> shrct_inc lshrct 1; U.combine_hash 4 (U.combine_hash
+ -> U.combine_hash 4 (U.combine_hash
(U.combine_hash (Hashtbl.hash v) (lexp_hash t))
(match m with
- | Some m -> (AttributeMap.fold attributemap_combine_hash
- m 31)
- | None -> 404))
+ | Some m -> Hashtbl.hash m
+ | None -> 404))
| Var v -> U.combine_hash 5 (Hashtbl.hash v)
| Let (l, ds, e)
- -> shrct_inc lshrct 1;
- U.combine_hash 6 (U.combine_hash (Hashtbl.hash l)
- (U.combine_hash (apply_lxor (List.map (fun e -> let (n, lp, lt) = e in
- shrct_inc lshrct 2;
- (U.combine_hash (Hashtbl.hash n) (U.combine_hash (lexp_hash lp) (lexp_hash lt))))
- ds)) (lexp_hash 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)
- -> shrct_inc lshrct 2;
- 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))))
+ -> 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)
- -> shrct_inc lshrct 2;
- 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)))
+ -> 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 (apply_lxor (List.map (fun e -> let (ak, n, lt) = e in
- shrct_inc lshrct 1;
+ (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))
- (SMap.fold ind_stringmap_combine_hash
- cs 21)))
- | Cons (t, n) -> shrct_inc lshrct 1; U.combine_hash 10 (U.combine_hash (lexp_hash t) (Hashtbl.hash n))
+ (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)
- -> shrct_inc lshrct 2;
- 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
- (SMap.fold case_stringmap_combine_hash bs 21)
- (match d with
- | Some (n, lp) -> shrct_inc lshrct 1; U.combine_hash (Hashtbl.hash n) (lexp_hash lp)
- | _ -> 0))))
+ -> 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)
- -> shrct_inc sshrct 1;
- U.combine_hash 12 (U.combine_hash id
- (U.combine_hash (S.subst_hash s) (Hashtbl.hash v)))
+ -> U.combine_hash 12 (U.combine_hash id
+ (U.combine_hash (S.subst_hash s) (Hashtbl.hash v)))
| Call (e, args)
- -> shrct_inc lshrct 1; U.combine_hash 13 (U.combine_hash (lexp_hash e)
- (apply_lxor (List.map (fun e -> let (ak, lp) = e in
- shrct_inc lshrct 1;
+ -> 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)
- -> shrct_inc lshrct 1; shrct_inc sshrct 1;
- U.combine_hash 14 (U.combine_hash (lexp_hash lp) (S.subst_hash subst))
+ -> U.combine_hash 14 (U.combine_hash (lexp_hash lp) (S.subst_hash subst))
let hc_eq e1 e2 =
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
- (* TODO: == via hcs ? *)
- | ((Susp (e1, s1) as e), _) -> compare e (lexp_lexp' e2) = 0
- | (_, (Susp (e2, s2) as e)) -> compare (lexp_lexp' e1) e = 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, cases1), Inductive (_, l2, as2, cases2))
- -> 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))
- cases1 cases2
- | (Cons (t1, (_, l1)), Cons (t2, (_, l2))) -> t1 == t2 && l1 = l2
- | (Case (_, e1, r1, cases1, def1), Case (_, e2, r2, cases2, def2))
- -> e1 == e2 && r1 == r2
- && SMap.equal (fun (_, fields1, e1) (_, fields2, e2)
- -> e1 == e2 && List.for_all2 (fun (ak1, _) (ak2, _)
- -> ak1 = ak2)
- fields1 fields2)
- cases1 cases2
- && (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
+ | (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 && s1 == s2
+ | (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, cases1), Inductive (_, l2, as2, cases2))
+ -> 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)) cases1 cases2
+ | (Cons (t1, (_, l1)), Cons (t2, (_, l2))) -> t1 == t2 && l1 = l2
+ | (Case (_, e1, r1, cases1, def1), Case (_, e2, r2, cases2, def2))
+ -> e1 == e2 && r1 == r2 && SMap.equal
+ (fun (_, fields1, e1) (_, fields2, e2)
+ -> e1 == e2 && List.for_all2
+ (fun (ak1, _) (ak2, _) -> ak1 = ak2) fields1 fields2) cases1 cases2
+ && (match (def1, def2) with
+ | (Some (_, e1), Some (_, e2)) -> e1 == e2
+ | _ -> def1 = def2)
+ | (Metavar (i1, s1, _), Metavar (i2, s2, _))
+ -> i1 = i2 && s1 == s2
+ | _ -> false
module WHC = Weak.Make (struct type t = lexp
(* Using (=) instead of `compare` results
@@ -200,8 +155,16 @@ module WHC = Weak.Make (struct type t = lexp
end)
let hc_table : WHC.t = WHC.create 1000
+
+let hc_aux (e : lexp') : lexp =
+ let lp = (e, lexp'_hash e) in WHC.merge hc_table lp
+
let hc (e : lexp') : lexp =
-let lp = (e, lexp'_hash e) in WHC.merge hc_table lp
+ if !U.time_process
+ then
+ U.inc_hc_total_time (fun () -> hc_aux e)
+ else
+ hc_aux e
let impossible = hc (Imm Sexp.dummy_epsilon)
@@ -220,9 +183,9 @@ let mkMetavar (n, s, v) = hc (Metavar (n, s, v))
let mkCall (f, es)
= let f' = lexp_lexp' f in
match f', es with
- | Call (f'', es'), _ -> hc (Call (f'', es' @ es))
- | _, [] -> f
- | _ -> hc (Call (f, es))
+ | Call (f'', es'), _ -> hc (Call (f'', es' @ es))
+ | _, [] -> f
+ | _ -> hc (Call (f, es))
and lexp_head e =
let e' = lexp_lexp' e in
@@ -831,128 +794,128 @@ and lexp_str ctx (exp : lexp) : string =
let e' = lexp_lexp' exp in
match e' with
- | Imm(value) -> (match value with
- | String (_, s) -> tval ("\"" ^ s ^ "\"")
- | Integer(_, s) -> tval (string_of_int s)
- | Float (_, s) -> tval (string_of_float s)
- | e -> sexp_string e)
-
- | Susp (e, s) -> lexp_str ctx (push_susp e s)
-
- | Var ((loc, name), idx) -> maybename name ^ (index idx) ;
-
- | Metavar (idx, subst, (loc, name))
- (* print metavar result if any *)
- -> (match metavar_lookup idx with
- | MVal e -> lexp_str ctx e
- | _ -> "?" ^ maybename name ^ (subst_string subst) ^ (index idx))
-
- | Let (_, decls, body) ->
- (* Print first decls without indent *)
- let h1, decls, idt_lvl =
- match lexp_str_decls inter_ctx decls with
- | h1::decls -> h1, decls, 2
- | _ -> "", [], 1 in
-
- let decls = List.fold_left (fun str elem ->
- str ^ nl ^ (make_indent 1) ^ elem ^ " ") h1 decls in
-
- let n = String.length decls in
- (* remove last newline *)
- let decls = if (n > 0) then
- String.sub decls 0 (n - 2)
- else decls in
-
- (keyword "let ") ^ decls ^ (keyword " in ") ^ newline ^
- (make_indent idt_lvl) ^ (lexp_stri idt_lvl body)
-
- | Arrow(k, (_, Some name), tp, loc, expr) ->
- "(" ^ name ^ " : " ^ (lexp_str' tp) ^ ") " ^
- (kind_str k) ^ " " ^ (lexp_str' expr)
-
- | Arrow(k, (_, None), tp, loc, expr) ->
- "(" ^ (lexp_str' tp) ^ " "
- ^ (kind_str k) ^ " " ^ (lexp_str' expr) ^ ")"
-
- | Lambda(k, (loc, name), ltype, lbody) ->
- let arg = "(" ^ maybename name ^ " : " ^ (lexp_str' ltype) ^ ")" in
-
- (keyword "lambda ") ^ arg ^ " " ^ (kind_str k) ^ newline ^
- (make_indent 1) ^ (lexp_stri 1 lbody)
-
- | Cons(t, (_, ctor_name)) ->
- (keyword "datacons ") ^ (lexp_str' t) ^ " " ^ ctor_name
-
- | Call(fname, args) ->
- let name, idx = get_name fname in
- let binop_str op (_, lhs) (_, rhs) =
- "(" ^ (lexp_str' lhs) ^ op ^ (index idx) ^ " " ^ (lexp_str' rhs) ^ ")" in
-
- let print_arg str (arg_type, lxp) =
- match arg_type with
- | Aerasable when pp_erasable ctx -> str ^ " " ^ (lexp_str' lxp)
- | Aimplicit when pp_implicit ctx -> str ^ " " ^ (lexp_str' lxp)
- | Anormal -> str ^ " " ^ (lexp_str' lxp)
- | _ -> str in (
-
- match args with
- | [lhs; rhs] when is_binary_op name ->
- binop_str (" " ^ (get_binary_op_name name)) lhs rhs
-
- | _ -> let args = List.fold_left print_arg "" args in
- "(" ^ (lexp_str' fname) ^ args ^ ")")
-
- | Inductive (_, (_, name), [], ctors) ->
- (keyword "typecons") ^ " (" ^ name ^") " ^ newline ^
- (lexp_str_ctor ctx ctors)
-
- | Inductive (_, (_, name), args, ctors)
- -> let args_str
- = List.fold_left
- (fun str (arg_kind, (_, name), ltype)
- -> str ^ " (" ^ maybename name ^ " " ^ (kindp_str arg_kind) ^ " "
- ^ (lexp_str' ltype) ^ ")")
- "" args in
-
- (keyword "typecons") ^ " (" ^ name ^ args_str ^") " ^
+ | Imm(value) -> (match value with
+ | String (_, s) -> tval ("\"" ^ s ^ "\"")
+ | Integer(_, s) -> tval (string_of_int s)
+ | Float (_, s) -> tval (string_of_float s)
+ | e -> sexp_string e)
+
+ | Susp (e, s) -> lexp_str ctx (push_susp e s)
+
+ | Var ((loc, name), idx) -> maybename name ^ (index idx) ;
+
+ | Metavar (idx, subst, (loc, name))
+ (* print metavar result if any *)
+ -> (match metavar_lookup idx with
+ | MVal e -> lexp_str ctx e
+ | _ -> "?" ^ maybename name ^ (subst_string subst) ^ (index idx))
+
+ | Let (_, decls, body) ->
+ (* Print first decls without indent *)
+ let h1, decls, idt_lvl =
+ match lexp_str_decls inter_ctx decls with
+ | h1::decls -> h1, decls, 2
+ | _ -> "", [], 1 in
+
+ let decls = List.fold_left (fun str elem ->
+ str ^ nl ^ (make_indent 1) ^ elem ^ " ") h1 decls in
+
+ let n = String.length decls in
+ (* remove last newline *)
+ let decls = if (n > 0) then
+ String.sub decls 0 (n - 2)
+ else decls in
+
+ (keyword "let ") ^ decls ^ (keyword " in ") ^ newline ^
+ (make_indent idt_lvl) ^ (lexp_stri idt_lvl body)
+
+ | Arrow(k, (_, Some name), tp, loc, expr) ->
+ "(" ^ name ^ " : " ^ (lexp_str' tp) ^ ") " ^
+ (kind_str k) ^ " " ^ (lexp_str' expr)
+
+ | Arrow(k, (_, None), tp, loc, expr) ->
+ "(" ^ (lexp_str' tp) ^ " "
+ ^ (kind_str k) ^ " " ^ (lexp_str' expr) ^ ")"
+
+ | Lambda(k, (loc, name), ltype, lbody) ->
+ let arg = "(" ^ maybename name ^ " : " ^ (lexp_str' ltype) ^ ")" in
+
+ (keyword "lambda ") ^ arg ^ " " ^ (kind_str k) ^ newline ^
+ (make_indent 1) ^ (lexp_stri 1 lbody)
+
+ | Cons(t, (_, ctor_name)) ->
+ (keyword "datacons ") ^ (lexp_str' t) ^ " " ^ ctor_name
+
+ | Call(fname, args) ->
+ let name, idx = get_name fname in
+ let binop_str op (_, lhs) (_, rhs) =
+ "(" ^ (lexp_str' lhs) ^ op ^ (index idx) ^ " " ^ (lexp_str' rhs) ^ ")" in
+
+ let print_arg str (arg_type, lxp) =
+ match arg_type with
+ | Aerasable when pp_erasable ctx -> str ^ " " ^ (lexp_str' lxp)
+ | Aimplicit when pp_implicit ctx -> str ^ " " ^ (lexp_str' lxp)
+ | Anormal -> str ^ " " ^ (lexp_str' lxp)
+ | _ -> str in (
+
+ match args with
+ | [lhs; rhs] when is_binary_op name ->
+ binop_str (" " ^ (get_binary_op_name name)) lhs rhs
+
+ | _ -> let args = List.fold_left print_arg "" args in
+ "(" ^ (lexp_str' fname) ^ args ^ ")")
+
+ | Inductive (_, (_, name), [], ctors) ->
+ (keyword "typecons") ^ " (" ^ name ^") " ^ newline ^
(lexp_str_ctor ctx ctors)
- | Case (_, target, _ret, map, dflt) ->(
- let str = (keyword "case ") ^ (lexp_str' target) in
- let arg_str arg
- = List.fold_left (fun str v
- -> match v with
- | (_, (_, None)) -> str ^ " _"
- | (_, (_, Some n)) -> str ^ " " ^ n)
- "" arg in
-
- let str = SMap.fold (fun k (_, arg, exp) str ->
- str ^ nl ^ (make_indent 1) ^
- "| " ^ (fun_call k) ^ (arg_str arg) ^ " => " ^ (lexp_stri 1 exp))
- map str in
-
- match dflt with
- | None -> str
- | Some (v, df) ->
- str ^ nl ^ (make_indent 1)
- ^ "| " ^ (match v with (_, None) -> "_"
- | (_, Some name) -> name)
- ^ " => " ^ (lexp_stri 1 df))
-
- | 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_ω"
-
- | SortLevel (SLz) -> "##TypeLevel.z"
- | SortLevel (SLsucc e) -> "(##TypeLevel.succ " ^ lexp_string e ^ ")"
- | SortLevel (SLlub (e1, e2))
- -> "(##TypeLevel.∪ " ^ lexp_string e1 ^ " " ^ lexp_string e2 ^ ")"
+ | Inductive (_, (_, name), args, ctors)
+ -> let args_str
+ = List.fold_left
+ (fun str (arg_kind, (_, name), ltype)
+ -> str ^ " (" ^ maybename name ^ " " ^ (kindp_str arg_kind) ^ " "
+ ^ (lexp_str' ltype) ^ ")")
+ "" args in
+
+ (keyword "typecons") ^ " (" ^ name ^ args_str ^") " ^
+ (lexp_str_ctor ctx ctors)
+
+ | Case (_, target, _ret, map, dflt) ->(
+ let str = (keyword "case ") ^ (lexp_str' target) in
+ let arg_str arg
+ = List.fold_left (fun str v
+ -> match v with
+ | (_, (_, None)) -> str ^ " _"
+ | (_, (_, Some n)) -> str ^ " " ^ n)
+ "" arg in
+
+ let str = SMap.fold (fun k (_, arg, exp) str ->
+ str ^ nl ^ (make_indent 1) ^
+ "| " ^ (fun_call k) ^ (arg_str arg) ^ " => " ^ (lexp_stri 1 exp))
+ map str in
+
+ match dflt with
+ | None -> str
+ | Some (v, df) ->
+ str ^ nl ^ (make_indent 1)
+ ^ "| " ^ (match v with (_, None) -> "_"
+ | (_, Some name) -> name)
+ ^ " => " ^ (lexp_stri 1 df))
+
+ | 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_ω"
+
+ | SortLevel (SLz) -> "##TypeLevel.z"
+ | SortLevel (SLsucc e) -> "(##TypeLevel.succ " ^ lexp_string e ^ ")"
+ | SortLevel (SLlub (e1, e2))
+ -> "(##TypeLevel.∪ " ^ lexp_string e1 ^ " " ^ lexp_string e2 ^ ")"
and lexp_str_ctor ctx ctors =
@@ -1005,34 +968,28 @@ let rec eq e1 e2 =
| (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
+ -> 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
+ -> 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
| (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
+ -> 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
&& (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, _))
-> i1 = i2 && subst_eq s1 s2
| _ -> false
=====================================
src/lexp_type.ml
=====================================
@@ -103,43 +103,43 @@ type ltype = lexp
* (Type ℓ, TypeOmega, TypeOmega),
* (Type ℓ₁, Type ℓ₂, Type (max l₁ l₂) }
*)
- and sort =
- | Stype of lexp
- | StypeOmega
- | StypeLevel
- and sort_level =
- | SLz
- | SLsucc of lexp
- | SLlub of lexp * lexp
-
- (* We define here substitutions which take a variable within a source context
- * Δₛ and should return an expression valid in target context Δₜ.
- *
- * The current implementation only handles a very limited subset of such
- * substitutions. One of the many limitations is that we can only encode
- * substitutions which map variables to variables.
- *)
-
- and db_index = int (* DeBruijn index. *)
- and db_offset = int (* DeBruijn index offset. *)
-
- (* Substitution, i.e. a mapping from db_index to lexp *)
- and subst = subst' * int
- and subst' =
- | Identity of db_offset (* Identity o ≡ id ∘ ↑ₒ *)
- | Cons of lexp * subst * db_offset (* Cons (e, s, o) ≡ (e · s) ∘ ↑ₒ *)
- (* Myers's extra pointers down the list:
- * * int * lexp subst * db_offset *)
- (* Lift (n,m) increases indices≥N by M.
- * IOW, it takes variables from a source context Δₛ₁Δₛ₂ to a destination
- * context Δₛ₁ΔₜΔₛ₂ where Δₛ₂ has size N and Δₜ has size M. *)
- (* | Lift of db_index * db_offset *)
-
- (* Build Myers's "stack" element. *)
- (* let mkCons e s o = match s with
- * | Cons (_, _, _, sk1, Cons (_, _, _, sk2, s2, o2), o1) when sk1 >= sk2
- * -> Cons (e, s, o, sk1 + sk2 + 1, s2, o1 + o2 + o)
- * | _ -> Cons (e, s, o, 1, s, o) *)
+and sort =
+ | Stype of lexp
+ | StypeOmega
+ | StypeLevel
+and sort_level =
+ | SLz
+ | SLsucc of lexp
+ | SLlub of lexp * lexp
+
+(* We define here substitutions which take a variable within a source context
+* Δₛ and should return an expression valid in target context Δₜ.
+*
+* The current implementation only handles a very limited subset of such
+* substitutions. One of the many limitations is that we can only encode
+* substitutions which map variables to variables.
+*)
+
+and db_index = int (* DeBruijn index. *)
+and db_offset = int (* DeBruijn index offset. *)
+
+(* Substitution, i.e. a mapping from db_index to lexp *)
+and subst = subst' * int
+ and subst' =
+ | Identity of db_offset (* Identity o ≡ id ∘ ↑ₒ *)
+ | Cons of lexp * subst * db_offset (* Cons (e, s, o) ≡ (e · s) ∘ ↑ₒ *)
+ (* Myers's extra pointers down the list:
+ * * int * lexp subst * db_offset *)
+(* Lift (n,m) increases indices≥N by M.
+ * IOW, it takes variables from a source context Δₛ₁Δₛ₂ to a destination
+ * context Δₛ₁ΔₜΔₛ₂ where Δₛ₂ has size N and Δₜ has size M. *)
+ (* | Lift of db_index * db_offset *)
+
+(* Build Myers's "stack" element. *)
+(* let mkCons e s o = match s with
+* | Cons (_, _, _, sk1, Cons (_, _, _, sk2, s2, o2), o1) when sk1 >= sk2
+* -> Cons (e, s, o, sk1 + sk2 + 1, s2, o1 + o2 + o)
+* | _ -> Cons (e, s, o, 1, s, o) *)
type varbind =
@@ -147,7 +147,7 @@ type varbind =
| ForwardRef
| LetDef of U.db_offset * lexp
- let lexp_hash (e, h) = h
+let lexp_hash (e, h) = h
(* For metavariables, we give each metavar a (hopefully) unique integer
* and then we store its corresponding info into the `metavar_table`
@@ -192,10 +192,3 @@ let metavar_lookup (id : meta_id) : metavar_info
= try U.IMap.find id (!metavar_table)
with Not_found
-> Log.log_fatal ~section:"LEXP" "metavar lookup failure!"
-
-(* counter for lexp sharing *)
-let lshrct = ref 0
-
-(* counter for subst sharing *)
-let sshrct = ref 0
-let shrct_inc e acc = e := !e + acc
=====================================
src/subst.ml
=====================================
@@ -104,43 +104,53 @@ open Lexp_type
*
*)
- (********************** Hash-consing **********************)
-
- (** hash-consing test **
- * with: subst'_hash
- * median bucket length: 7
- * biggest bucket length: 22 *)
-
- let subst_hash (s, h) = h
- let subst_subst' (s, h) = s
-
- let hcsb_eq sb1 sb2 =
- sb1 == sb2 ||
- match (subst_subst' sb1, subst_subst' sb2) with
- | (Identity off1, Identity off2) -> off1 = off2
- | (Cons (lp1, lps1, off1), Cons (lp2, lps2, off2))
- -> lp1 == lp2 && lps1 == lps2 && off1 = off2
- | _ -> false
-
- let subst'_hash (sb : subst') : int =
- match sb with
- | Identity off
- -> U.combine_hash 1 (Hashtbl.hash off)
- | Cons (lp, sb, off)
- -> shrct_inc lshrct 1; shrct_inc sshrct 1;
- U.combine_hash 2
+(********************** Hash-consing **********************)
+
+(** hash-consing test **
+ * with: subst'_hash
+ * median bucket length: 7
+ * biggest bucket length: 22
+ * found/new subst entries: 7 *)
+
+let subst_hash (s, h) = h
+let subst_subst' (s, h) = s
+
+(* counter for subst found in WHCSB *)
+let sshrct = ref 0
+
+(* counter for subst not found in WHCSB *)
+let nf_sshrct = ref 0
+
+let shrct_inc e acc = e := !e + acc
+
+let hcsb_eq sb1 sb2 =
+ sb1 == sb2 ||
+ match (subst_subst' sb1, subst_subst' sb2) with
+ | (Identity off1, Identity off2) -> off1 = off2
+ | (Cons (lp1, lps1, off1), Cons (lp2, lps2, off2))
+ -> lp1 == lp2 && lps1 == lps2 && off1 = off2
+ | _ -> false
+
+let subst'_hash (sb : subst') : int =
+ match sb with
+ | Identity off
+ -> U.combine_hash 1 (Hashtbl.hash off)
+ | Cons (lp, sb, off)
+ -> U.combine_hash 2
(U.combine_hash (U.combine_hash
- (lexp_hash lp) (subst_hash sb)) (Hashtbl.hash off))
+ (lexp_hash lp) (subst_hash sb)) (Hashtbl.hash off))
- module WHCSB = Weak.Make (struct type t = subst
- let equal x y = hcsb_eq x y
- let hash = subst_hash
- end)
+module WHCSB = Weak.Make (struct type t = subst
+ let equal x y = hcsb_eq x y
+ let hash = subst_hash
+ end)
- let hcsb_table : WHCSB.t = WHCSB.create 1000
+let hcsb_table : WHCSB.t = WHCSB.create 1000
- let hcsb (s : subst') : subst =
- let sb = (s, subst'_hash s) in WHCSB.merge hcsb_table sb
+let hcsb (s : subst') : subst =
+ let sb = (s, subst'_hash s) in
+ try let sb' = WHCSB.find hcsb_table sb in (shrct_inc sshrct 1; sb')
+ with Not_found -> (shrct_inc nf_sshrct 1; WHCSB.add hcsb_table sb; sb)
(* Apply a substitution to a single variable. *)
let lookup (mkVar : 'b -> db_index -> 'a)
=====================================
src/util.ml
=====================================
@@ -51,6 +51,8 @@ let loc_string loc =
let loc_print loc = print_string (loc_string loc)
+let time_process = ref false
+
let string_implode chars = String.concat "" (List.map (String.make 1) chars)
let string_sub str b e = String.sub str b (e - b)
@@ -117,9 +119,14 @@ let option_map (fn : 'a -> 'b) (opt : 'a option) : 'b option =
| None -> None
| Some x -> Some (fn x)
-let combine_hash (e1: int) (e2: int) : int = (e1 * 31) lxor e2
+let combine_hash e1 e2 = (e1 * 31) lxor e2
+
+let rec combine_hashes map =
+ match map with
+ | [] -> 31
+ | e :: l -> combine_hash (e * 31) (combine_hashes l)
-let get_stats stats lshrct sshrct =
+let get_stats_hashtbl stats sshrct nf_sshrct =
let (tl, ne, sumb, smallb, medianb, bigb) = stats in
Printf.printf "\n\ttable length: %i\n
number of entries: %i\n
@@ -127,5 +134,27 @@ let get_stats stats lshrct sshrct =
smallest bucket length: %i\n
median bucket length: %i\n
biggest bucket length: %i\n
- lexp sharing counter: %i\n
- subst sharing counter: %i\n" tl ne sumb smallb medianb bigb lshrct sshrct;
+ found/new subst entries: %i\n"
+ tl ne sumb smallb medianb bigb (sshrct / nf_sshrct)
+
+let get_total_unix_stats_processtime (times : Unix.process_times) =
+ Printf.printf "\n\tUser time for the process: %f\n
+ System time for the process: %f\n
+ User time for the children processes: %f\n
+ System time for the children processes: %f\n"
+ times.tms_utime times.tms_stime times.tms_cutime times.tms_cstime
+
+let hc_total_time = ref 0.0
+
+let inc_hc_total_time f =
+ let t = Unix.gettimeofday () in
+ let res = f () in (hc_total_time :=
+ !hc_total_time +. Unix.gettimeofday () -. t; res)
+
+let get_unix_stats_processtime f =
+ let t = Unix.gettimeofday () in
+ let res = f () in (Printf.printf "\t(Unix) process time: %f\n"
+ (Unix.gettimeofday () -. t); res)
+
+let print_total_hctime hctime =
+ Printf.printf "\t(Unix) total hc time: %f\n" hctime
View it on GitLab: https://gitlab.com/monnier/typer/-/commit/e0c9264806f6c4503e251b033d3167fbd…
--
View it on GitLab: https://gitlab.com/monnier/typer/-/commit/e0c9264806f6c4503e251b033d3167fbd…
You're receiving this email because of your account on gitlab.com.
1
0