Juillet 2020 - Typer - mailman.iro.umontreal.ca

[Git][monnier/typer][ja-barszcz] 21 commits: Delay parsing of declarations until elaboration for define-operator
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

[Git][monnier/typer][alice] 2 commits: remove susbt hash table
by Alice de Berny 03 Aoû '20

03 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 28 Jul '20

28 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

[Git][monnier/typer][alice] correction physical equality of lexp
by Alice de Berny 23 Jul '20

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

[Git][monnier/typer][alice] 2 commits: add stats
by Alice de Berny 22 Jul '20

22 Jul '20

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 14 Jul '20

14 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

[Git][monnier/typer][alice] add time & profiling
by Alice de Berny 10 Jul '20

10 Jul '20

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

[Git][monnier/typer][report/hmdup] Rewrite rules to keep unification implicit
by Stefan 07 Jul '20

07 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

Low-level Typer?
by Stefan Monnier 02 Jul '20

02 Jul '20

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

[Git][monnier/typer][alice] check performance
by Alice de Berny 01 Jul '20

01 Jul '20

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

2024

2023

2022

2021

2020

2019

2018

2017

2016

Typer Juillet 2020