in
aux 1 context
-let interpretate_term ~(context: Cic.name list) ~env ~uri ~is_path ast
+let interpretate_term ?(create_dummy_ids=false) ~(context: Cic.name list) ~env ~uri ~is_path ast
~localization_tbl
=
+ (* create_dummy_ids shouldbe used only for interpretating patterns *)
assert (uri = None);
let rec aux ~localize loc (context: Cic.name list) = function
| CicNotationPt.AttributedTerm (`Loc loc, term) ->
do_branch' context args
in
let (indtype_uri, indtype_no) =
+ if create_dummy_ids then
+ (UriManager.uri_of_string "cic:/fake_indty.con", 0)
+ else
match indty_ident with
| Some (indty_ident, _) ->
(match resolve env (Id indty_ident) () with
let cic_body =
let unlocalized_body = aux ~localize:false loc context' body in
match unlocalized_body with
- Cic.Rel 1 -> `AvoidLetInNoAppl
- | Cic.Appl (Cic.Rel 1::l) ->
+ Cic.Rel n when n <= List.length defs -> `AvoidLetInNoAppl n
+ | Cic.Appl (Cic.Rel n::l) when n <= List.length defs ->
(try
let l' =
List.map
(function t ->
let t',subst,metasenv =
- CicMetaSubst.delift_rels [] [] 1 t
+ CicMetaSubst.delift_rels [] [] (List.length defs) t
in
assert (subst=[]);
assert (metasenv=[]);
match body with
CicNotationPt.AttributedTerm (_,CicNotationPt.Appl(_::l)) ->
let l' = List.map (aux ~localize loc context) l in
- `AvoidLetIn l'
+ `AvoidLetIn (n,l')
| _ -> assert false
else
- `AvoidLetIn l'
+ `AvoidLetIn (n,l')
with
CicMetaSubst.DeliftingARelWouldCaptureAFreeVariable ->
if localize then
(name, decr_idx, cic_type, cic_body))
defs
in
- let counter = ref ~-1 in
- let build_term funs =
- (* this is the body of the fold_right function below. Rationale: Fix
- * and CoFix cases differs only in an additional index in the
- * inductiveFun list, see Cic.term *)
- match kind with
- | `Inductive ->
- (fun (var, _, _, _) cic ->
- incr counter;
- let fix = Cic.Fix (!counter,funs) in
- match cic with
- `Recipe (`AddLetIn cic) ->
- `Term (Cic.LetIn (Cic.Name var, fix, cic))
- | `Recipe (`AvoidLetIn l) -> `Term (Cic.Appl (fix::l))
- | `Recipe `AvoidLetInNoAppl -> `Term fix
- | `Term t -> `Term (Cic.LetIn (Cic.Name var, fix, t)))
+ let fix_or_cofix n =
+ match kind with
+ `Inductive -> Cic.Fix (n,inductiveFuns)
| `CoInductive ->
- let funs =
- List.map (fun (name, _, typ, body) -> (name, typ, body)) funs
+ let coinductiveFuns =
+ List.map
+ (fun (name, _, typ, body) -> name, typ, body)
+ inductiveFuns
in
- (fun (var, _, _, _) cic ->
- incr counter;
- let cofix = Cic.CoFix (!counter,funs) in
- match cic with
- `Recipe (`AddLetIn cic) ->
- `Term (Cic.LetIn (Cic.Name var, cofix, cic))
- | `Recipe (`AvoidLetIn l) -> `Term (Cic.Appl (cofix::l))
- | `Recipe `AvoidLetInNoAppl -> `Term cofix
- | `Term t -> `Term (Cic.LetIn (Cic.Name var, cofix, t)))
+ Cic.CoFix (n,coinductiveFuns)
in
- (match
- List.fold_right (build_term inductiveFuns) inductiveFuns
- (`Recipe cic_body)
- with
- `Recipe _ -> assert false
- | `Term t -> t)
+ let counter = ref ~-1 in
+ let build_term funs (var,_,_,_) t =
+ incr counter;
+ Cic.LetIn (Cic.Name var, fix_or_cofix !counter, t)
+ in
+ (match cic_body with
+ `AvoidLetInNoAppl n ->
+ let n' = List.length inductiveFuns - n in
+ fix_or_cofix n'
+ | `AvoidLetIn (n,l) ->
+ let n' = List.length inductiveFuns - n in
+ Cic.Appl (fix_or_cofix n'::l)
+ | `AddLetIn cic_body ->
+ List.fold_right (build_term inductiveFuns) inductiveFuns
+ cic_body)
| CicNotationPt.Ident _
| CicNotationPt.Uri _ when is_path -> raise PathNotWellFormed
| CicNotationPt.Ident (name, subst)
let localization_tbl = Cic.CicHash.create 23 in
(* here we are throwing away useful localization informations!!! *)
fst (
- interpretate_term ~context ~env:Environment.empty ~uri:None ~is_path:true
+ interpretate_term ~create_dummy_ids:true
+ ~context ~env:Environment.empty ~uri:None ~is_path:true
path ~localization_tbl, localization_tbl)
let interpretate_obj ~context ~env ~uri ~is_path obj ~localization_tbl =
CicNotationUtil.cic_name_of_name var :: context,
domain_of_term_option ~loc ~context ty @ res)
(add_defs context,[]) params))
- @ domain_of_term_option ~loc ~context typ
+ @ domain_of_term_option ~loc ~context:context' typ
@ domain_of_term ~loc ~context:context' body
) [] defs
in
sig
val disambiguate_term :
?fresh_instances:bool ->
- dbd:HMysql.dbd ->
+ dbd:HSql.dbd ->
context:Cic.context ->
metasenv:Cic.metasenv ->
?initial_ugraph:CicUniv.universe_graph ->
val disambiguate_obj :
?fresh_instances:bool ->
- dbd:HMysql.dbd ->
+ dbd:HSql.dbd ->
aliases:DisambiguateTypes.environment ->(* previous interpretation status *)
universe:DisambiguateTypes.multiple_environment option ->
uri:UriManager.uri option -> (* required only for inductive types *)
- CicNotationPt.obj disambiguator_input ->
+ CicNotationPt.term CicNotationPt.obj disambiguator_input ->
((DisambiguateTypes.domain_item * DisambiguateTypes.codomain_item) list *
Cic.metasenv * (* new metasenv *)
Cic.obj *
disambiguate_thing ~dbd ~context ~metasenv ~initial_ugraph ~aliases
~universe ~uri:None ~pp_thing:CicNotationPp.pp_term
~domain_of_thing:domain_of_term
- ~interpretate_thing:interpretate_term
+ ~interpretate_thing:(interpretate_term (?create_dummy_ids:None))
~refine_thing:refine_term (text,prefix_len,term)
let disambiguate_obj ?(fresh_instances=false) ~dbd ~aliases ~universe ~uri
if fresh_instances then CicNotationUtil.freshen_obj obj else obj
in
disambiguate_thing ~dbd ~context:[] ~metasenv:[] ~aliases ~universe ~uri
- ~pp_thing:CicNotationPp.pp_obj ~domain_of_thing:domain_of_obj
+ ~pp_thing:(CicNotationPp.pp_obj CicNotationPp.pp_term) ~domain_of_thing:domain_of_obj
~interpretate_thing:interpretate_obj ~refine_thing:refine_obj
(text,prefix_len,obj)
end
projects / helm.git / blobdiff