(* $Id$ *)
-module C = Cic
+module C = Cic
+module UM = UriManager
exception Meta_not_found of int
exception Subst_not_found of int
| C.Cast (te,ty) -> is_closed k te && is_closed k ty
| C.Prod (name,so,dest) -> is_closed k so && is_closed (k+1) dest
| C.Lambda (_,so,dest) -> is_closed k so && is_closed (k+1) dest
- | C.LetIn (_,so,dest) -> is_closed k so && is_closed (k+1) dest
+ | C.LetIn (_,so,ty,dest) ->
+ is_closed k so && is_closed k ty && is_closed (k+1) dest
| C.Appl l ->
List.fold_right (fun x i -> i && is_closed k x) l true
| C.Var (_,exp_named_subst)
| C.Cast (te,ty) -> is_meta_closed te && is_meta_closed ty
| C.Prod (name,so,dest) -> is_meta_closed so && is_meta_closed dest
| C.Lambda (_,so,dest) -> is_meta_closed so && is_meta_closed dest
- | C.LetIn (_,so,dest) -> is_meta_closed so && is_meta_closed dest
+ | C.LetIn (_,so,ty,dest) ->
+ is_meta_closed so &&
+ is_meta_closed ty &&
+ is_meta_closed dest
| C.Appl l ->
not (List.exists (fun x -> not (is_meta_closed x)) l)
| C.Var (_,exp_named_subst)
let is_generated obj = List.exists ((=) `Generated) (attributes_of_obj obj)
-let arity_of_composed_coercion obj =
- let attrs = attributes_of_obj obj in
- try
- let tag=List.find (function `Class (`Coercion _) -> true|_->false) attrs in
- match tag with
- | `Class (`Coercion n) -> n
- | _-> assert false
- with Not_found -> 0
-;;
-
let projections_of_record obj uri =
let attrs = attributes_of_obj obj in
try
| C.ACast (id,_,_)
| C.AProd (id,_,_,_)
| C.ALambda (id,_,_,_)
- | C.ALetIn (id,_,_,_)
+ | C.ALetIn (id,_,_,_,_)
| C.AAppl (id,_)
| C.AConst (id,_,_)
| C.AMutInd (id,_,_,_)
| C.Cast (te,ty) -> C.Cast (rehash_term te, rehash_term ty)
| C.Prod (n,s,t) -> C.Prod (n, rehash_term s, rehash_term t)
| C.Lambda (n,s,t) -> C.Lambda (n, rehash_term s, rehash_term t)
- | C.LetIn (n,s,t) -> C.LetIn (n, rehash_term s, rehash_term t)
+ | C.LetIn (n,s,ty,t) ->
+ C.LetIn (n, rehash_term s, rehash_term ty, rehash_term t)
| C.Appl l -> C.Appl (List.map rehash_term l)
| C.Const (uri,exp_named_subst) ->
let uri' = recons uri in
| Some (name,C.Decl t) ->
Some (name,C.Decl (rehash_term t))
| Some (name,C.Def (bo,ty)) ->
- let ty' =
- match ty with
- None -> None
- | Some ty'' -> Some (rehash_term ty'')
- in
- Some (name,C.Def (rehash_term bo, ty'))) hyps,
+ Some (name,C.Def (rehash_term bo, rehash_term ty))) hyps,
rehash_term ty))
conjs
in
List.flatten (List.map (fun (u, t) -> metas_of_term t) ens)
| C.Cast (s, t)
| C.Prod (_, s, t)
- | C.Lambda (_, s, t)
- | C.LetIn (_, s, t) -> (metas_of_term s) @ (metas_of_term t)
+ | C.Lambda (_, s, t) -> (metas_of_term s) @ (metas_of_term t)
+ | C.LetIn (_, s, ty, t) ->
+ (metas_of_term s) @ (metas_of_term ty) @ (metas_of_term t)
| C.Appl l -> List.flatten (List.map metas_of_term l)
| C.MutCase (uri, i, s, t, l) ->
(metas_of_term s) @ (metas_of_term t) @
S.empty ens
| C.Cast (s, t)
| C.Prod (_, s, t)
- | C.Lambda (_, s, t)
- | C.LetIn (_, s, t) -> S.union (metas_of_term_set s) (metas_of_term_set t)
+ | C.Lambda (_, s, t) -> S.union (metas_of_term_set s) (metas_of_term_set t)
+ | C.LetIn (_, s, ty, t) ->
+ S.union (metas_of_term_set s)
+ (S.union (metas_of_term_set ty) (metas_of_term_set t))
| C.Appl l ->
List.fold_left
(fun s t -> S.union s (metas_of_term_set t))
aux s s' && aux t t'
| C.Lambda (_,s,t), C.Lambda (_,s',t') ->
aux s s' && aux t t'
- | C.LetIn (_,s,t), C.LetIn(_,s',t') ->
- aux s s' && aux t t'
+ | C.LetIn (_,s,ty,t), C.LetIn(_,s',ty',t') ->
+ aux s s' && aux ty ty' && aux t t'
| C.Appl l, C.Appl l' when List.length l = List.length l' ->
(try
List.fold_left2
in
aux
-let is_sober t =
- let rec sober_term g = function
- | C.Rel _
+let is_sober c t =
+ let rec sober_term c g = function
+ | C.Rel i ->
+ if i <= 0 then fun b -> false else g
| C.Sort _
| C.Implicit _ -> g
| C.Const (_, xnss)
| C.Var (_, xnss)
| C.MutConstruct (_, _, _, xnss)
- | C.MutInd (_, _, xnss) -> sober_xnss g xnss
- | C.Meta (_, xss) -> sober_xss g xss
- | C.LetIn (_, v, t)
+ | C.MutInd (_, _, xnss) -> sober_xnss c g xnss
+ | C.Meta (_, xss) -> sober_xss c g xss
| C.Lambda (_, v, t)
| C.Prod (_, v, t)
- | C.Cast (t, v) -> sober_term (sober_term g t) v
+ | C.Cast (t, v) ->
+ sober_term c (sober_term c g t) v
+ | C.LetIn (_, v, ty, t) ->
+ sober_term c (sober_term c (sober_term c g t) ty) v
| C.Appl []
- | C.Appl [_] -> fun b -> false
- | C.Appl ts -> sober_terms g ts
+ | C.Appl [_]
+ | C.Appl (C.Appl _ :: _) -> fun b -> false
+ | C.Appl ts -> sober_terms c g ts
| C.MutCase (_, _, t, v, ts) ->
- sober_terms (sober_term (sober_term g t) v) ts
- | C.Fix (_, ifs) -> sober_ifs g ifs
- | C.CoFix (_, cifs) -> sober_cifs g cifs
- and sober_terms g = List.fold_left sober_term g
- and sober_xnss g =
- let map g (_, t) = sober_term g t in
+ sober_terms c (sober_term c (sober_term c g t) v) ts
+ | C.Fix (_, ifs) -> sober_ifs c g ifs
+ | C.CoFix (_, cifs) -> sober_cifs c g cifs
+ and sober_terms c g = List.fold_left (sober_term c) g
+ and sober_xnss c g =
+ let map g (_, t) = sober_term c g t in
List.fold_left map g
- and sober_xss g =
+ and sober_xss c g =
let map g = function
| None -> g
- | Some t -> sober_term g t
+ | Some t -> sober_term c g t
in
List.fold_left map g
- and sober_ifs g =
- let map g (_, _, t, v) = sober_term (sober_term g t) v in
+ and sober_ifs c g =
+ let map g (_, _, t, v) = sober_term c (sober_term c g t) v in
List.fold_left map g
- and sober_cifs g =
- let map g (_, t, v) = sober_term (sober_term g t) v in
+ and sober_cifs c g =
+ let map g (_, t, v) = sober_term c (sober_term c g t) v in
List.fold_left map g
in
- sober_term (fun b -> b) t true
+ sober_term c (fun b -> b) t true
+
+(* raw cic prettyprinter ****************************************************)
+
+let xiter out so ss sc map l =
+ let rec aux = function
+ | hd :: tl when tl <> [] -> map hd; out ss; aux tl
+ | hd :: tl -> map hd; aux tl
+ | [] -> ()
+ in
+ out so; aux l; out sc
+
+let abst s w = Some (s, C.Decl w)
+
+let abbr s v w = Some (s, C.Def (v, w))
+
+let pp_sort out = function
+ | C.Type _ -> out "*Type"
+ | C.Prop -> out "*Prop"
+ | C.CProp _ -> out "*CProp"
+ | C.Set -> out "*Set"
+
+let pp_name out = function
+ | C.Name s -> out s
+ | C.Anonymous -> out "_"
+
+let pp_rel out c i =
+ try match List.nth c (pred i) with
+ | None -> out (Printf.sprintf "%u[?]" i)
+ | Some (s, _) -> out (Printf.sprintf "%u[" i); pp_name out s; out "]"
+ with Failure "nth" -> out (Printf.sprintf "%u[%i]" i (List.length c - i))
+
+let pp_implicit out = function
+ | None -> out "?"
+ | Some `Closed -> out "?[Closed]"
+ | Some `Type -> out "?[Type]"
+ | Some `Hole -> out "?[Hole]"
+ | Some `Vector -> out "?[...]"
+
+let pp_uri out a =
+ out (Printf.sprintf "%s<%s>" (UM.name_of_uri a) (UM.string_of_uri a))
+
+let rec pp_term out e c = function
+ | C.Sort h -> pp_sort out h
+ | C.Rel i -> pp_rel out c i
+ | C.Implicit x -> pp_implicit out x
+ | C.Meta (i, iss) ->
+ let map = function None -> out "_" | Some v -> pp_term out e c v in
+ out (Printf.sprintf "?%u" i); xiter out "[" "; " "]" map iss
+ | C.Var (a, xss) ->
+ pp_uri out a; pp_xss out e c xss
+ | C.Const (a, xss) ->
+ pp_uri out a; pp_xss out e c xss
+ | C.MutInd (a, m, xss) ->
+ pp_uri out a; out (Printf.sprintf "/%u" m);
+ pp_xss out e c xss
+ | C.MutConstruct (a, m, n, xss) ->
+ pp_uri out a; out (Printf.sprintf "/%u/%u" m n);
+ pp_xss out e c xss
+ | C.Cast (v, w) ->
+ out "type "; pp_term out e c w; out " contains "; pp_term out e c v
+ | C.Appl vs ->
+ xiter out "(" " @ " ")" (pp_term out e c) vs
+ | C.MutCase (a, m, w, v, vs) ->
+ out "match "; pp_term out e c v;
+ out " of "; pp_uri out a; out (Printf.sprintf "/%u" m);
+ out " to "; pp_term out e c w;
+ xiter out " cases " " | " "" (pp_term out e c) vs
+ | C.Prod (s, w, t) ->
+ out "forall "; pp_name out s; out " of "; pp_term out e c w;
+ out " in "; pp_term out e (abst s w :: c) t
+ | C.Lambda (s, w, t) ->
+ out "fun "; pp_name out s; out " of "; pp_term out e c w;
+ out " in "; pp_term out e (abst s w :: c) t
+ | C.LetIn (s, v, w, t) ->
+ out "let "; pp_name out s;
+ out " def "; pp_term out e c v; out " of "; pp_term out e c w;
+ out " in "; pp_term out e (abbr s v w :: c) t
+ | C.Fix (i, fs) ->
+ let map c (s, _, w, v) = abbr (C.Name s) v w :: c in
+ let c' = List.fold_left map c fs in
+ let map (s, i, w, v) =
+ out (Printf.sprintf "%s[%u] def " s i); pp_term out e c' v;
+ out " of "; pp_term out e c w;
+ in
+ xiter out "let rec " " and " " in " map fs; pp_rel out c' (succ i)
+ | C.CoFix (i, fs) ->
+ let map c (s, w, v) = abbr (C.Name s) v w :: c in
+ let c' = List.fold_left map c fs in
+ let map (s, w, v) =
+ out s; pp_term out e c' v;
+ out " of "; pp_term out e c w;
+ in
+ xiter out "let corec " " and " " in " map fs; pp_rel out c' (succ i)
+
+and pp_xss out e c xss =
+ let map (a, v) = pp_uri out a; out " <- "; pp_term out e c v in
+ xiter out "[" "; " "]" map xss
+
+let pp_int out i =
+ out (Printf.sprintf "%u" i)
+
+let pp_attrs out attrs =
+ let map = function
+ | _ -> ()
+ in
+ xiter out "[" "; " "] " map attrs
+
+let pp_pars out pars =
+ xiter out " (" ", " ")\n" (pp_uri out) pars
+
+let pp_point out point =
+ if point then out "ind " else out "coind "
+
+let pp_constructor out (s, w) =
+ out s; out " of "; pp_term out [] [] w
+
+let pp_definition out (s, point, w, ts) =
+ out "let "; pp_point out point; out s; out " of "; pp_term out [] [] w;
+ xiter out "\ndef " "\nor " "" (pp_constructor out) ts
+
+let pp_obj out = function
+ | C.Constant (s, None, u, pars, attrs) ->
+ out "fun "; pp_attrs out attrs; out s; pp_pars out pars;
+ out " of "; pp_term out [] [] u
+ | C.Constant (s, Some t, u, pars, attrs) ->
+ out "let "; pp_attrs out attrs; out s; pp_pars out pars;
+ out " def "; pp_term out [] [] t; out " of "; pp_term out [] [] u
+ | C.Variable (s, None, u, pars, attrs) ->
+ out "local fun "; pp_attrs out attrs; out s; pp_pars out pars;
+ out " of "; pp_term out [] [] u
+ | C.Variable (s, Some t, u, pars, attrs) ->
+ out "local let "; pp_attrs out attrs; out s; pp_pars out pars;
+ out " def "; pp_term out [] [] t; out " of "; pp_term out [] [] u
+ | C.InductiveDefinition (us, pars, lpsno, attrs) ->
+ out "Inductive "; pp_attrs out attrs; pp_int out lpsno; pp_pars out pars;
+ xiter out "" "\n" "" (pp_definition out) us
+ | C.CurrentProof (s, e, t, u, pars, attrs) ->
+ out "Current Proof"
+
projects / helm.git / blobdiff