helm/ocaml/cic/cicUtil.ml

   1 (* Copyright (C) 2004, HELM Team.
   2  *
   3  * This file is part of HELM, an Hypertextual, Electronic
   4  * Library of Mathematics, developed at the Computer Science
   5  * Department, University of Bologna, Italy.
   6  *
   7  * HELM is free software; you can redistribute it and/or
   8  * modify it under the terms of the GNU General Public License
   9  * as published by the Free Software Foundation; either version 2
  10  * of the License, or (at your option) any later version.
  11  *
  12  * HELM is distributed in the hope that it will be useful,
  13  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  14  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15  * GNU General Public License for more details.
  16  *
  17  * You should have received a copy of the GNU General Public License
  18  * along with HELM; if not, write to the Free Software
  19  * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
  20  * MA  02111-1307, USA.
  21  *
  22  * For details, see the HELM World-Wide-Web page,
  23  * http://helm.cs.unibo.it/
  24  *)
  25
  26 exception Meta_not_found of int
  27 exception Subst_not_found of int
  28
  29
  30 let lookup_meta index metasenv =
  31   try
  32     List.find (fun (index', _, _) -> index = index') metasenv
  33   with Not_found -> raise (Meta_not_found index)
  34
  35 let lookup_subst n subst =
  36   try
  37     List.assoc n subst
  38   with Not_found -> raise (Subst_not_found n)
  39
  40 let exists_meta index = List.exists (fun (index', _, _) -> (index = index'))
  41
  42 (* clean_up_meta take a substitution, a metasenv a meta_inex and a local
  43 context l and clean up l with respect to the hidden hipothesis in the
  44 canonical context *)
  45
  46 let clean_up_local_context subst metasenv n l =
  47   let cc =
  48     (try
  49        let (cc,_) = lookup_subst n subst in cc
  50      with Subst_not_found _ ->
  51        try
  52          let (_,cc,_) = lookup_meta n metasenv in cc
  53        with Meta_not_found _ -> assert false) in
  54   (try
  55      List.map2
  56        (fun t1 t2 ->
  57           match t1,t2 with
  58               None , _ -> None
  59             | _ , t -> t) cc l
  60    with
  61        Invalid_argument _ -> assert false)
  62
  63 let is_closed =
  64  let module C = Cic in
  65  let rec is_closed k =
  66   function
  67       C.Rel m when m > k -> false
  68     | C.Rel m -> true
  69     | C.Meta (_,l) ->
  70        List.fold_left
  71         (fun i t -> i && (match t with None -> true | Some t -> is_closed k t)
  72         ) true l
  73     | C.Sort _ -> true
  74     | C.Implicit _ -> assert false
  75     | C.Cast (te,ty) -> is_closed k te && is_closed k ty
  76     | C.Prod (name,so,dest) -> is_closed k so && is_closed (k+1) dest
  77     | C.Lambda (_,so,dest) -> is_closed k so && is_closed (k+1) dest
  78     | C.LetIn (_,so,dest) -> is_closed k so && is_closed (k+1) dest
  79     | C.Appl l ->
  80        List.fold_right (fun x i -> i && is_closed k x) l true
  81     | C.Var (_,exp_named_subst)
  82     | C.Const (_,exp_named_subst)
  83     | C.MutInd (_,_,exp_named_subst)
  84     | C.MutConstruct (_,_,_,exp_named_subst) ->
  85        List.fold_right (fun (_,x) i -> i && is_closed k x)
  86         exp_named_subst true
  87     | C.MutCase (_,_,out,te,pl) ->
  88        is_closed k out && is_closed k te &&
  89         List.fold_right (fun x i -> i && is_closed k x) pl true
  90     | C.Fix (_,fl) ->
  91        let len = List.length fl in
  92         let k_plus_len = k + len in
  93          List.fold_right
  94           (fun (_,_,ty,bo) i -> i && is_closed k ty && is_closed k_plus_len bo
  95           ) fl true
  96     | C.CoFix (_,fl) ->
  97        let len = List.length fl in
  98         let k_plus_len = k + len in
  99          List.fold_right
 100           (fun (_,ty,bo) i -> i && is_closed k ty && is_closed k_plus_len bo
 101           ) fl true
 102 in
 103  is_closed 0
 104 ;;
 105
 106 (* CPS iterators on Cic.term ************************************************)
 107
 108 let rec visit_l visit_t map f r = function
 109    | []        -> f r
 110    | h :: tail ->
 111       let f r = visit_l visit_t map f r tail in
 112       visit_t f r (map h)
 113
 114 let meta_closed t =
 115    let rec visit_t f r = function
 116       | Cic.Meta _                     -> raise Exit
 117       | Cic.Implicit _
 118       | Cic.Sort _
 119       | Cic.Rel _                      -> f r
 120       | Cic.Cast (t, u)
 121       | Cic.Prod (_, t, u)
 122       | Cic.Lambda (_, t, u)
 123       | Cic.LetIn (_, t, u)            ->
 124          let f r = visit_t f r u in visit_t f r t
 125       | Cic.Appl tl                    ->
 126          visit_l visit_t (fun x -> x) f r tl
 127       | Cic.Fix (_, tl)                ->
 128          let f r = visit_l visit_t (fun (_, _, _, u) -> u) f r tl in
 129          visit_l visit_t (fun (_, _, t, _) -> t) f r tl
 130       | Cic.CoFix (_, tl)              ->
 131          let f r = visit_l visit_t (fun (_, _, u) -> u) f r tl in
 132          visit_l visit_t (fun (_, t, _) -> t) f r tl
 133       | Cic.Var (k, tl)
 134       | Cic.Const (k, tl)
 135       | Cic.MutInd (k, _, tl)
 136       | Cic.MutConstruct (k, _, _, tl) ->
 137          visit_l visit_t (fun (_, u) -> u) f r tl
 138       | Cic.MutCase (_, _, t, u, tl)   ->
 139          let f r = visit_l visit_t (fun u -> u) f r tl in
 140          let f r = visit_t f r u in
 141          visit_t f r t
 142    in
 143    try visit_t (fun x -> x) () t; false with Exit -> true
 144
 145 let xpointer_RE = Str.regexp "\\([^#]+\\)#xpointer(\\(.*\\))"
 146 let slash_RE = Str.regexp "/"
 147
 148 let term_of_uri s =
 149   let uri = UriManager.uri_of_string s in
 150   try
 151     (if String.sub s (String.length s - 4) 4 = ".con" then
 152       Cic.Const (uri, [])
 153     else if String.sub s (String.length s - 4) 4 = ".var" then
 154       Cic.Var (uri, [])
 155     else if not (Str.string_match xpointer_RE s 0) then
 156       raise (UriManager.IllFormedUri s)
 157     else
 158       let (baseuri,xpointer) = (Str.matched_group 1 s, Str.matched_group 2 s) in
 159       let baseuri = UriManager.uri_of_string baseuri in
 160       (match Str.split slash_RE xpointer with
 161       | [_; tyno] -> Cic.MutInd (baseuri, int_of_string tyno - 1, [])
 162       | [_; tyno; consno] ->
 163           Cic.MutConstruct
 164             (baseuri, int_of_string tyno - 1, int_of_string consno, [])
 165       | _ -> raise Exit))
 166   with
 167   | Exit
 168   | Failure _
 169   | Not_found -> raise (UriManager.IllFormedUri s)
 170