X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Fsoftware%2Fcomponents%2Fgrafite_engine%2FgrafiteEngine.ml;h=ec9f3866fdab4bbffab2ce894ab17e937b809cef;hb=8049c166a37789d7a1b1ca1c3a1174712bbf87ba;hp=0904cf33119b99ff7183b998af6d1edbd95f01cb;hpb=e869500069d11aadd7bbe8afddcdd9044d0b56a7;p=helm.git

diff --git a/helm/software/components/grafite_engine/grafiteEngine.ml b/helm/software/components/grafite_engine/grafiteEngine.ml
index 0904cf331..ec9f3866f 100644
--- a/helm/software/components/grafite_engine/grafiteEngine.ml
+++ b/helm/software/components/grafite_engine/grafiteEngine.ml
@@ -33,6 +33,7 @@ exception IncludedFileNotCompiled of string * string
 exception Macro of
  GrafiteAst.loc *
   (Cic.context -> GrafiteTypes.status * (Cic.term,Cic.lazy_term) GrafiteAst.macro)
+exception NMacro of GrafiteAst.loc * GrafiteAst.nmacro
 
 type 'a disambiguator_input = string * int * 'a
 
@@ -40,6 +41,11 @@ type options = {
   do_heavy_checks: bool ; 
 }
 
+let concat_nuris uris nuris =
+   match uris,nuris with
+   | `New uris, `New nuris -> `New (nuris@uris)
+   | _ -> assert false
+;;
 (** create a ProofEngineTypes.mk_fresh_name_type function which uses given
   * names as long as they are available, then it fallbacks to name generation
   * using FreshNamesGenerator module *)
@@ -495,253 +501,6 @@ let eval_unification_hint status t n =
   status,`New []
 ;;
 
-let product f l1 l2 =
-  List.fold_left
-    (fun acc x ->
-      List.fold_left 
-        (fun acc y ->
-           f x y :: acc)
-        acc l2)
-    [] l1  
-;;
-
-let pos_in_list x l =
-      match 
-        HExtlib.list_findopt (fun y i -> if y = x then Some i else None) l
-      with
-      | Some i -> i
-      | None -> assert false
-;;
-
-let pos_of x t = 
-  match t with
-  | NCic.Appl l -> pos_in_list x l
-  | _ -> assert false
-;;
-
-let rec count_prod = function
-  | NCic.Prod (_,_,x) -> 1 + count_prod x
-  | _ -> 0
-;;
-
-let term_at i t =
-  match t with
-  | NCic.Appl l -> 
-      (match 
-        HExtlib.list_findopt (fun y j -> if i+1=j then Some y else None) l
-      with
-      | Some i -> i
-      | None -> assert false)
-  | _ -> assert false
-;;
-
-let src_tgt_of_ty_cpos_arity ty cpos arity =
-  let pis = count_prod ty in
-  let tpos = pis - arity in
-  let rec pi_nth i j = function
-    | NCic.Prod (_,s,_) when i = j -> s
-    | NCic.Prod (_,_,t) -> pi_nth (i+1) j t
-    | t -> assert (i = j); t
-  in
-  let rec cleanup_prod = function
-    | NCic.Prod (_,_,t) -> NCic.Prod ("_",NCic.Implicit `Type, cleanup_prod t)
-    | _ -> NCic.Implicit `Type
-  in
-  let rec pi_tail i j = function
-    | NCic.Prod (_,_,_) as t when i = j -> cleanup_prod t
-    | NCic.Prod (_,_,t) -> pi_tail (i+1) j t
-    | t -> assert (i = j); t
-  in
-  let mask t =
-    let rec aux () = function
-      | NCic.Meta _ 
-      | NCic.Implicit _ as x -> x
-      | NCic.Rel _ -> NCic.Implicit `Type
-      | t -> NCicUtils.map (fun _ () -> ()) () aux t
-    in
-     aux () t
-  in 
-  mask (pi_nth 0 cpos ty), 
-  mask (pi_tail 0 tpos ty)
-;;
-
-let close_in_context t metasenv = 
-  let rec aux m_subst subst ctx = function
-   | (i,(tag,[],ty)) :: tl ->
-        let name = "x" ^ string_of_int (List.length ctx) in
-        let subst = (i,(tag,[],NCic.Rel (List.length tl+1),ty))::subst in
-        let ty = NCicUntrusted.apply_subst (m_subst (List.length ctx)) ctx ty in
-        let m_subst m = 
-          (i,(tag,[],NCic.Rel (m-List.length ctx),ty))::(m_subst m)
-        in
-        NCic.Lambda (name, ty, aux m_subst subst ((name,NCic.Decl ty)::ctx) tl)
-   | [] -> 
-           (* STRONG ASSUMPTION: 
-                since metas occurring in t have an empty context,
-                the substitution i build makes sense (i.e, the Rel
-                I pun in the subst will not be lifted by subst_meta *)
-           NCicUntrusted.apply_subst subst ctx
-             (NCicSubstitution.lift (List.length ctx) t)
-   | _ -> assert false
-  in
-  aux (fun _ -> []) [] [] metasenv
-;;
-
-let toposort metasenv = 
-  let module T = HTopoSort.Make(
-    struct type t = int * NCic.conjecture let compare (i,_) (j,_) = i-j end) 
-  in
-  let deps (_,(_,_,t)) =
-    List.filter (fun (j,_) -> 
-      List.mem j (NCicUntrusted.metas_of_term [] [] t)) metasenv
-  in
-  T.topological_sort metasenv deps
-;;
-
-let basic_eval_ncoercion (name,t,s,d,p,a) status =
-  let to_s = 
-    NCicCoercion.look_for_coercion status [] [] [] (NCic.Implicit `Type) s
-  in
-  let from_d = 
-    NCicCoercion.look_for_coercion status [] [] [] d (NCic.Implicit `Type)
-  in
-  let status = NCicCoercion.index_coercion status t s d a p in
-  let c =
-    List.find 
-     (function (_,NCic.Appl (x::_),_,_) -> x = t | _ -> assert false) 
-      (NCicCoercion.look_for_coercion status [] [] [] s d)
-  in
-  let composites = 
-    let to_s_o_c = 
-      product (fun (m1,t1,_,j) (mc,c,_,i) -> m1@mc,c,[i,t1],j,a) 
-        to_s [c]
-    in
-    let c_o_from_d = 
-      product (fun (mc,c,_,j) (m1,t1,ty,i) -> m1@mc,t1,[i,c],j,count_prod ty) 
-        [c] from_d
-    in
-    let to_s_o_c_o_from_d =
-      product (fun (m1,t1,_,j) (m,t,upl,i,a)-> 
-       m@m1,t,(i,t1)::upl,j,a)
-       to_s c_o_from_d
-    in
-    to_s_o_c @ c_o_from_d @ to_s_o_c_o_from_d
-  in
-  let composites =
-    HExtlib.filter_map
-     (fun (metasenv, bo, upl, p, arity) ->
-        try
-         let metasenv, subst = 
-           List.fold_left 
-            (fun (metasenv,subst) (a,b) ->
-                NCicUnification.unify status metasenv subst [] a b)
-            (metasenv,[]) upl
-         in
-         let bo = NCicUntrusted.apply_subst subst [] bo in
-         let metasenv = toposort metasenv in
-         let bo = close_in_context bo metasenv in
-         let pos = 
-           match p with 
-           | NCic.Meta (p,_) -> pos_in_list p (List.map fst metasenv) 
-           | _ -> assert false
-         in
-         let ty = NCicTypeChecker.typeof ~metasenv:[] ~subst:[] [] bo in
-         let src,tgt = src_tgt_of_ty_cpos_arity ty pos arity in
-(*
-         prerr_endline (
-           NCicPp.ppterm ~metasenv:[] ~subst:[] ~context:[] bo ^ " : " ^
-           NCicPp.ppterm ~metasenv:[] ~subst:[] ~context:[] ty ^ " as " ^
-           NCicPp.ppterm ~metasenv:[] ~subst:[] ~context:[] src ^ " ===> " ^
-           NCicPp.ppterm ~metasenv:[] ~subst:[] ~context:[] tgt ^
-           " cpos=" ^ string_of_int pos ^ " arity=" ^ string_of_int arity);
-*)
-         Some (bo,src,tgt,arity,pos)
-       with 
-       | NCicTypeChecker.TypeCheckerFailure _
-       | NCicUnification.UnificationFailure _ 
-       | NCicUnification.Uncertain _ -> None
-     ) composites
-  in
-  List.fold_left 
-    (fun st (t,s,d,a,p) -> NCicCoercion.index_coercion st t s d a p) 
-    status composites
-;;
-
-let inject_ncoercion =
- let basic_eval_ncoercion (name,t,s,d,p,a) ~refresh_uri_in_universe
-  ~refresh_uri_in_term
- =
-  let t = refresh_uri_in_term t in
-  let s = refresh_uri_in_term s in
-  let d = refresh_uri_in_term d in
-   basic_eval_ncoercion (name,t,s,d,p,a)
- in
-  NRstatus.Serializer.register "ncoercion" basic_eval_ncoercion
-;;
-
-let src_tgt_cpos_arity_of_ty_id_src_tgt status ty id src tgt =
-  let status, src, cpos = 
-    let rec aux cpos ctx = function
-      | NCic.Prod (name,ty,bo) ->
-         if name <> id then aux (cpos+1) ((name,NCic.Decl ty)::ctx) bo
-         else
-           (try 
-            let metasenv,subst,status,src =
-              GrafiteDisambiguate.disambiguate_nterm 
-                None status ctx [] [] ("",0,src) in
-            let src = NCicUntrusted.apply_subst subst [] src in
-            (* CHECK that the declared pattern matches the abstraction *)
-            let _ = NCicUnification.unify status metasenv subst ctx ty src in
-            status, src, cpos
-           with 
-           | NCicUnification.UnificationFailure _
-           | NCicUnification.Uncertain _
-           | MultiPassDisambiguator.DisambiguationError _ ->
-               raise (GrafiteTypes.Command_error "bad source pattern"))
-      | _ -> assert false
-    in
-      aux 0 [] ty
-  in
-  let status, tgt, arity = 
-    let metasenv,subst,status,tgt =
-      GrafiteDisambiguate.disambiguate_nterm 
-        None status [] [] [] ("",0,tgt) in
-    let tgt = NCicUntrusted.apply_subst subst [] tgt in
-    (* CHECK che sia unificabile mancante *)
-    let rec count_prod = function
-      | NCic.Prod (_,_,x) -> 1 + count_prod x
-      | _ -> 0
-    in
-     status, tgt, count_prod tgt
-  in
-  status, src, tgt, cpos, arity
-;;
-
-let basic_eval_and_inject_ncoercion infos status =
- let status = basic_eval_ncoercion infos status in
- let dump = inject_ncoercion infos::status#dump in
-  status#set_dump dump
-;;
-
-let eval_ncoercion status name t ty (id,src) tgt = 
-
- let metasenv,subst,status,ty =
-  GrafiteDisambiguate.disambiguate_nterm None status [] [] [] ("",0,ty) in
- assert (metasenv=[]);
- let ty = NCicUntrusted.apply_subst subst [] ty in
- let metasenv,subst,status,t =
-  GrafiteDisambiguate.disambiguate_nterm (Some ty) status [] [] [] ("",0,t) in
- assert (metasenv=[]);
- let t = NCicUntrusted.apply_subst subst [] t in
-
- let status, src, tgt, cpos, arity = 
-   src_tgt_cpos_arity_of_ty_id_src_tgt status ty id src tgt in
- let status =
-  basic_eval_and_inject_ncoercion (name,t,src,tgt,cpos,arity) status
- in
-  status,`New []
-;;
-
 let basic_eval_add_constraint (s,u1,u2) status =
  NCicLibrary.add_constraint status s u1 u2
 ;;
@@ -899,6 +658,10 @@ let eval_ng_tac tac =
   | GrafiteAst.NChange (_loc, pat, ww) -> 
       NTactics.change_tac 
        ~where:(text,prefix_len,pat) ~with_what:(text,prefix_len,ww) 
+  | GrafiteAst.NConstructor (_loc,num,args) -> 
+     NTactics.constructor_tac 
+       ?num ~args:(List.map (fun x -> text,prefix_len,x) args)
+  | GrafiteAst.NCut (_loc, t) -> NTactics.cut_tac (text,prefix_len,t) 
   | GrafiteAst.NDot _ -> NTactics.dot_tac 
   | GrafiteAst.NElim (_loc, what, where) ->
       NTactics.elim_tac 
@@ -909,6 +672,7 @@ let eval_ng_tac tac =
       NTactics.generalize_tac ~where:(text,prefix_len,where)
   | GrafiteAst.NId _ -> (fun x -> x)
   | GrafiteAst.NIntro (_loc,n) -> NTactics.intro_tac n
+  | GrafiteAst.NLApply (_loc, t) -> NTactics.lapply_tac (text,prefix_len,t) 
   | GrafiteAst.NLetIn (_loc,where,what,name) ->
       NTactics.letin_tac ~where:(text,prefix_len,where) 
         ~what:(text,prefix_len,what) name
@@ -948,7 +712,7 @@ let rec eval_ncommand opts status (text,prefix_len,cmd) =
   match cmd with
   | GrafiteAst.UnificationHint (loc, t, n) -> eval_unification_hint status t n
   | GrafiteAst.NCoercion (loc, name, t, ty, source, target) ->
-      eval_ncoercion status name t ty source target
+      NCicCoercDeclaration.eval_ncoercion status name t ty source target
   | GrafiteAst.NQed loc ->
      if status#ng_mode <> `ProofMode then
       raise (GrafiteTypes.Command_error "Not in proof mode")
@@ -1008,9 +772,7 @@ let rec eval_ncommand opts status (text,prefix_len,cmd) =
                  eval_ncommand opts status
                   ("",0,GrafiteAst.NObj (HExtlib.dummy_floc,boxml))
                 in
-                 match uris,nuris with
-                    `New uris, `New nuris -> status,`New (nuris@uris)
-                  | _ -> assert false
+                status, concat_nuris uris nuris
                with
                 NCicTypeChecker.TypeCheckerFailure msg
                  when Lazy.force msg =
@@ -1026,18 +788,21 @@ let rec eval_ncommand opts status (text,prefix_len,cmd) =
                  (fun (name,is_coercion,arity) ->
                    if is_coercion then Some(name,leftno,arity) else None) fields
             | _ -> [] in
-           let status =
+           let status,uris =
             List.fold_left
-             (fun status (name,cpos,arity) ->
+             (fun (status,uris) (name,cpos,arity) ->
                let metasenv,subst,status,t =
                 GrafiteDisambiguate.disambiguate_nterm None status [] [] []
                  ("",0,CicNotationPt.Ident (name,None)) in
                assert (metasenv = [] && subst = []);
-               let ty = NCicTypeChecker.typeof ~subst ~metasenv [] t in
-               let src,tgt = src_tgt_of_ty_cpos_arity ty cpos arity in
-                basic_eval_and_inject_ncoercion (name,t,src,tgt,cpos,arity)
-                 status
-             ) status coercions
+               let status, nuris = 
+                 NCicCoercDeclaration.
+                   basic_eval_and_record_ncoercion_from_t_cpos_arity 
+                    status (name,t,cpos,arity)
+               in
+               let uris = concat_nuris nuris uris in
+               status, uris) 
+             (status,uris) coercions
            in
             status,uris
           with
@@ -1332,6 +1097,8 @@ let rec eval_command = {ec_go = fun ~disambiguate_command opts status
       eval_ncommand opts status (text,prefix_len,cmd)
   | GrafiteAst.Macro (loc, macro) ->
      raise (Macro (loc,disambiguate_macro status (text,prefix_len,macro)))
+  | GrafiteAst.NMacro (loc, macro) ->
+     raise (NMacro (loc,macro))
 
 } and eval_from_moo = {efm_go = fun status fname ->
   let ast_of_cmd cmd =