let add_level_info prec t = Ast.AttributedTerm (`Level prec, t)
-let rec top_pos t = add_level_info ~-1 t
+let top_pos t = add_level_info ~-1 t
let rec remove_level_info =
function
~sep:[space] (List.map (fun x -> [f x]) l)
;;
-let pp_ast0 t k =
+let pp_ast0 status t k =
let rec aux =
function
| Ast.Appl ts ->
in
let match_box =
hvbox false false [
- hvbox false true [
+ hvbox false false [
hvbox false true [keyword "match"; space; break; top_pos (k what)];
break;
hvbox false true indty_box;
keyword "let"; space;
hvbox false true [
aux_var var; space;
- builtin_symbol "\\def"; break; top_pos (k s) ];
- break; space; keyword "in"; space ];
+ builtin_symbol "\\def"; break; top_pos (k s); space; keyword "in"; space ];
+ ];
break;
k t ])
+(*
| Ast.LetRec (rec_kind, funs, where) ->
let rec_op =
match rec_kind with `Inductive -> "rec" | `CoInductive -> "corec"
((hvbox false false
(fst_row :: List.flatten tl_rows
@ [ break; keyword "in"; break; k where ])))
+*)
| Ast.Implicit `JustOne -> builtin_symbol "?"
| Ast.Implicit `Vector -> builtin_symbol "…"
| Ast.Meta (n, l) ->
and special_k = function
| Ast.AttributedTerm (attrs, t) -> Ast.AttributedTerm (attrs, k t)
| t ->
- prerr_endline ("unexpected special: " ^ NotationPp.pp_term t);
+ prerr_endline ("unexpected special: " ^ NotationPp.pp_term status t);
assert false
in
aux t
type db = {
level1_patterns21: NotationPt.term IntMap.t;
- compiled21: ((NotationPt.term -> (NotationEnv.t * NotationPt.term list * int) option)) Lazy.t option;
+ compiled21: ((NotationPt.term -> (NotationEnv.t * NotationPt.term list * int) option)) Lazy.t;
pattern21_matrix: (NotationPt.term * pattern_id) list;
counter: pattern_id
}
let initial_db = {
level1_patterns21 = IntMap.empty;
- compiled21 = None;
+ compiled21 = lazy (Content2presMatcher.Matcher21.compiler []);
pattern21_matrix = [];
counter = ~-1
}
method content_pres_db: db
end
-class status =
+class virtual status =
object
+ inherit NCic.status
val content_pres_db = initial_db
method content_pres_db = content_pres_db
method set_content_pres_db v = {< content_pres_db = v >}
method set_content_pres_status
- : 'status. #g_status as 'status -> 'self
+ : 'status. (#g_status as 'status) -> 'self
= fun o -> {< content_pres_db = o#content_pres_db >}
end
let get_compiled21 status =
- match status#content_pres_db.compiled21 with
- | None -> assert false
- | Some f -> Lazy.force f
+ Lazy.force status#content_pres_db.compiled21
let set_compiled21 status f =
status#set_content_pres_db
- { status#content_pres_db with compiled21 = Some f }
+ { status#content_pres_db with compiled21 = f }
let add_idrefs =
List.fold_right (fun idref t -> Ast.AttributedTerm (`IdRef idref, t))
Ast.AttributedTerm (attr, subst_singleton pos env t)
| t -> NotationUtil.group (subst pos env t)
and subst pos env = function
- | Ast.AttributedTerm (attr, t) ->
+ | Ast.AttributedTerm (_attr, t) ->
(* prerr_endline ("loosing attribute " ^ NotationPp.pp_attribute attr); *)
subst pos env t
| Ast.Variable var ->
| Ast.Literal l as t ->
let t = add_idrefs idrefs t in
(match l with
- | `Keyword k -> [ add_keyword_attrs t ]
+ | `Keyword _k -> [ add_keyword_attrs t ]
| _ -> [ t ])
| Ast.Layout l -> [ Ast.Layout (subst_layout pos env l) ]
| t -> [ NotationUtil.visit_ast (subst_singleton pos env) t ]
let rec pp_value = function
| NotationEnv.NumValue _ as v -> v
| NotationEnv.StringValue _ as v -> v
-(* | NotationEnv.TermValue t when t == term -> NotationEnv.TermValue (pp_ast0 t pp_ast1) *)
+(* | NotationEnv.TermValue t when t == term -> NotationEnv.TermValue (pp_ast0 status t pp_ast1) *)
| NotationEnv.TermValue t -> NotationEnv.TermValue (pp_ast1 status t)
| NotationEnv.OptValue None as v -> v
| NotationEnv.OptValue (Some v) ->
Ast.AttributedTerm (attrs, pp_ast1 status term')
| _ ->
(match get_compiled21 status term with
- | None -> pp_ast0 term (pp_ast1 status)
+ | None -> pp_ast0 status term (pp_ast1 status)
| Some (env, ctors, pid) ->
let idrefs =
List.flatten (List.map NotationUtil.get_idrefs ctors)
let pp_ast status ast =
debug_print (lazy "pp_ast <-");
let ast' = pp_ast1 status ast in
- debug_print (lazy ("pp_ast -> " ^ NotationPp.pp_term ast'));
+ debug_print (lazy ("pp_ast -> " ^ NotationPp.pp_term status ast'));
ast'
let fill_pos_info l1_pattern = l1_pattern
in
aux [] env
-let instantiate_level2 env term =
+let instantiate_level2 status env term =
(* prerr_endline ("istanzio: " ^ NotationPp.pp_term term); *)
let fresh_env = ref [] in
let lookup_fresh_name n =
in
let rec aux env term =
match term with
- | Ast.AttributedTerm (a, term) -> (*Ast.AttributedTerm (a, *)aux env term
+ | Ast.AttributedTerm (_a, term) -> (*Ast.AttributedTerm (a, *)aux env term
| Ast.Appl terms -> Ast.Appl (List.map (aux env) terms)
| Ast.Binder (binder, var, body) ->
Ast.Binder (binder, aux_capture_var env var, aux env body)
List.map (aux_branch env) patterns)
| Ast.LetIn (var, t1, t3) ->
Ast.LetIn (aux_capture_var env var, aux env t1, aux env t3)
+(*
| Ast.LetRec (kind, definitions, body) ->
Ast.LetRec (kind, List.map (aux_definition env) definitions,
aux env body)
+*)
| Ast.Uri (name, None) -> Ast.Uri (name, None)
| Ast.Uri (name, Some substs) ->
Ast.Uri (name, Some (aux_substs env substs))
Ast.Pattern (head, hrefs, vars) ->
Ast.Pattern (head, hrefs, List.map (aux_capture_var env) vars)
| Ast.Wildcard -> Ast.Wildcard
- and aux_definition env (params, var, term, i) =
- (List.map (aux_capture_var env) params, aux_capture_var env var, aux env term, i)
+ (*and aux_definition env (params, var, term, i) =
+ (List.map (aux_capture_var env) params, aux_capture_var env var, aux env term, i)*)
and aux_substs env substs =
List.map (fun (name, term) -> (name, aux env term)) substs
and aux_meta_substs env meta_substs = List.map (aux_opt env) meta_substs
| Ast.TermVar (name,(Ast.Level l|Ast.Self l)) ->
Ast.AttributedTerm (`Level l,Env.lookup_term env name)
| Ast.FreshVar name -> Ast.Ident (lookup_fresh_name name, None)
- | Ast.Ascription (term, name) -> assert false
+ | Ast.Ascription (_term, _name) -> assert false
and aux_magic env = function
| Ast.Default (some_pattern, none_pattern) ->
let some_pattern_names = NotationUtil.names_of_term some_pattern in
| _ ->
prerr_endline (sprintf
"lookup of %s in env %s did not return an optional value"
- name (NotationPp.pp_env env));
+ name (NotationPp.pp_env status env));
assert false))
| Ast.Fold (`Left, base_pattern, names, rec_pattern) ->
let acc_name = List.hd names in (* names can't be empty, cfr. parser *)
| _ -> assert false
in
instantiate_fold_right env)
- | Ast.If (_, p_true, p_false) as t ->
+ | Ast.If (_, _p_true, _p_false) as t ->
aux env (NotationUtil.find_branch (Ast.Magic t))
| Ast.Fail -> assert false
| _ -> assert false
projects / helm.git / blobdiff