← Back to branch summary

~ubuntu-branches/ubuntu/wily/coq-doc/wily

« back to all changes in this revision

Viewing changes to contrib/xml/proof2aproof.ml

  • Committer: Bazaar Package Importer
  • Author(s): Stéphane Glondu, Stéphane Glondu, Samuel Mimram
  • Date: 2010-01-07 22:50:39 UTC
  • mfrom: (1.2.2 upstream)
  • Revision ID: james.westby@ubuntu.com-20100107225039-n3cq82589u0qt0s2
Tags: 8.2pl1-1
http://bugs.debian.org/563669
http://bugs.debian.org/543545
[ Stéphane Glondu ]
* New upstream release (Closes: #563669)
  - remove patches
* Packaging overhaul:
  - use git, advertise it in Vcs-* fields of debian/control
  - use debhelper 7 and dh with override
  - use source format 3.0 (quilt)
* debian/control:
  - set Maintainer to d-o-m, set Uploaders to Sam and myself
  - add Homepage field
  - bump Standards-Version to 3.8.3
* Register PDF documentation into doc-base
* Add debian/watch
* Update debian/copyright

[ Samuel Mimram ]
* Change coq-doc's description to mention that it provides documentation in
  pdf format, not postscript, closes: #543545.

Show diffs side-by-side

added added

removed removed

Lines of Context:
contrib/xml/proof2aproof.ml
 
1
(************************************************************************)
 
2
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
 
3
(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
 
4
(*   \VV/  **************************************************************)
 
5
(*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
 
6
(*         *   University of Bologna                                    *)
 
7
(************************************************************************)
 
8
(*          This file is distributed under the terms of the             *)
 
9
(*           GNU Lesser General Public License Version 2.1              *)
 
10
(*                                                                      *)
 
11
(*                 Copyright (C) 2000-2004, HELM Team.                  *)
 
12
(*                       http://helm.cs.unibo.it                        *)
 
13
(************************************************************************)
 
14
 
 
15
(* Note: we can not use the Set module here because we _need_ physical *)
 
16
(* equality and there exists no comparison function compatible with    *)
 
17
(* physical equality.                                                  *)
 
18
 
 
19
module S =
 
20
 struct
 
21
  let empty = []
 
22
  let mem = List.memq
 
23
  let add x l = x::l
 
24
 end
 
25
;;
 
26
 
 
27
(* evar reduction that preserves some terms *)
 
28
let nf_evar sigma ~preserve =
 
29
 let module T = Term in
 
30
  let rec aux t =
 
31
   if preserve t then t else
 
32
    match T.kind_of_term t with
 
33
     | T.Rel _ | T.Meta _ | T.Var _ | T.Sort _ | T.Const _ | T.Ind _
 
34
     | T.Construct _ -> t
 
35
     | T.Cast (c1,k,c2) -> T.mkCast (aux c1, k, aux c2)
 
36
     | T.Prod (na,c1,c2) -> T.mkProd (na, aux c1, aux c2)
 
37
     | T.Lambda (na,t,c) -> T.mkLambda (na, aux t, aux c)
 
38
     | T.LetIn (na,b,t,c) -> T.mkLetIn (na, aux b, aux t, aux c)
 
39
     | T.App (c,l) ->
 
40
        let c' = aux c in
 
41
        let l' = Array.map aux l in
 
42
         (match T.kind_of_term c' with
 
43
             T.App (c'',l'') -> T.mkApp (c'', Array.append l'' l')
 
44
           | T.Cast (he,_,_) ->
 
45
              (match T.kind_of_term he with
 
46
                  T.App (c'',l'') -> T.mkApp (c'', Array.append l'' l')
 
47
                | _ -> T.mkApp (c', l')
 
48
              )
 
49
           | _ -> T.mkApp (c', l'))
 
50
     | T.Evar (e,l) when Evd.mem sigma e & Evd.is_defined sigma e ->
 
51
        aux (Evd.existential_value sigma (e,l))
 
52
     | T.Evar (e,l) -> T.mkEvar (e, Array.map aux l)
 
53
     | T.Case (ci,p,c,bl) -> T.mkCase (ci, aux p, aux c, Array.map aux bl)
 
54
     | T.Fix (ln,(lna,tl,bl)) ->
 
55
         T.mkFix (ln,(lna,Array.map aux tl,Array.map aux bl))
 
56
     | T.CoFix(ln,(lna,tl,bl)) ->
 
57
         T.mkCoFix (ln,(lna,Array.map aux tl,Array.map aux bl))
 
58
   in
 
59
    aux
 
60
;;
 
61
 
 
62
(* Unshares a proof-tree.                                                  *)
 
63
(* Warning: statuses, goals, prim_rules and tactic_exprs are not unshared! *)
 
64
let rec unshare_proof_tree =
 
65
 let module PT = Proof_type in
 
66
  function {PT.open_subgoals = status ; 
 
67
            PT.goal = goal ; 
 
68
            PT.ref = ref} ->
 
69
   let unshared_ref =
 
70
    match ref with
 
71
       None -> None
 
72
     | Some (rule,pfs) ->
 
73
        let unshared_rule =
 
74
         match rule with
 
75
             PT.Nested (cmpd, pf) ->
 
76
               PT.Nested (cmpd, unshare_proof_tree pf)
 
77
           | other -> other
 
78
        in
 
79
         Some (unshared_rule, List.map unshare_proof_tree pfs)
 
80
   in
 
81
    {PT.open_subgoals = status ; 
 
82
     PT.goal = goal ; 
 
83
     PT.ref = unshared_ref}
 
84
;;
 
85
 
 
86
module ProofTreeHash =
 
87
 Hashtbl.Make
 
88
  (struct
 
89
    type t = Proof_type.proof_tree
 
90
    let equal = (==)
 
91
    let hash = Hashtbl.hash
 
92
   end)
 
93
;;
 
94
 
 
95
 
 
96
let extract_open_proof sigma pf =
 
97
 let module PT = Proof_type in
 
98
 let module L = Logic in
 
99
  let evd = ref (Evd.create_evar_defs sigma) in
 
100
  let proof_tree_to_constr = ProofTreeHash.create 503 in
 
101
  let proof_tree_to_flattened_proof_tree = ProofTreeHash.create 503 in
 
102
  let unshared_constrs = ref S.empty in
 
103
  let rec proof_extractor vl node =
 
104
   let constr =
 
105
    match node with
 
106
       {PT.ref=Some(PT.Prim _,_)} as pf ->
 
107
        L.prim_extractor proof_extractor vl pf
 
108
          
 
109
     | {PT.ref=Some(PT.Nested (_,hidden_proof),spfl)} ->
 
110
         let sgl,v = Refiner.frontier hidden_proof in
 
111
         let flat_proof = v spfl in
 
112
         ProofTreeHash.add proof_tree_to_flattened_proof_tree node flat_proof ;
 
113
         proof_extractor vl flat_proof
 
114
          
 
115
     | {PT.ref=None;PT.goal=goal} ->
 
116
         let visible_rels =
 
117
           Util.map_succeed
 
118
             (fun id ->
 
119
                (* Section variables are in the [id] list but are not *)
 
120
                (* lambda abstracted in the term [vl]                 *)
 
121
                try let n = Logic.proof_variable_index id vl in (n,id)
 
122
                with Not_found -> failwith "caught")
 
123
(*CSC: the above function must be modified such that when it is found  *)
 
124
(*CSC: it becomes a Rel; otherwise a Var. Then it can be already used  *)
 
125
(*CSC: as the evar_instance. Ordering the instance becomes useless (it *)
 
126
(*CSC: will already be ordered.                                        *)
 
127
             (Termops.ids_of_named_context 
 
128
                (Environ.named_context_of_val goal.Evd.evar_hyps)) in
 
129
         let sorted_rels =
 
130
           Sort.list (fun (n1,_) (n2,_) -> n1 < n2 ) visible_rels in
 
131
         let context =
 
132
           let l = 
 
133
             List.map
 
134
               (fun (_,id) -> Sign.lookup_named id 
 
135
                   (Environ.named_context_of_val goal.Evd.evar_hyps))
 
136
               sorted_rels in
 
137
           Environ.val_of_named_context l
 
138
         in
 
139
(*CSC: the section variables in the right order must be added too *)
 
140
         let evar_instance = List.map (fun (n,_) -> Term.mkRel n) sorted_rels in
 
141
    (*     let env = Global.env_of_context context in *)
 
142
         let evd',evar =
 
143
           Evarutil.new_evar_instance context !evd goal.Evd.evar_concl
 
144
             evar_instance in
 
145
         evd := evd' ;
 
146
         evar
 
147
          
 
148
     | _ -> Util.anomaly "Bug : a case has been forgotten in proof_extractor"
 
149
   in
 
150
    let unsharedconstr =
 
151
     let evar_nf_constr =
 
152
      nf_evar (Evd.evars_of !evd)
 
153
        ~preserve:(function e -> S.mem e !unshared_constrs) constr
 
154
     in
 
155
      Unshare.unshare
 
156
       ~already_unshared:(function e -> S.mem e !unshared_constrs)
 
157
       evar_nf_constr
 
158
    in
 
159
(*CSC: debugging stuff to be removed *)
 
160
if ProofTreeHash.mem proof_tree_to_constr node then
 
161
 Pp.ppnl (Pp.(++) (Pp.str "#DUPLICATE INSERTION: ")
 
162
 (Tactic_printer.print_proof (Evd.evars_of !evd) [] node)) ;
 
163
     ProofTreeHash.add proof_tree_to_constr node unsharedconstr ;
 
164
     unshared_constrs := S.add unsharedconstr !unshared_constrs ;
 
165
     unsharedconstr
 
166
  in
 
167
  let unshared_pf = unshare_proof_tree pf in
 
168
  let pfterm = proof_extractor [] unshared_pf in
 
169
   (pfterm, Evd.evars_of !evd, proof_tree_to_constr, proof_tree_to_flattened_proof_tree,
 
170
    unshared_pf)
 
171
;;
 
172
 
 
173
let extract_open_pftreestate pts =
 
174
  extract_open_proof (Refiner.evc_of_pftreestate pts)
 
175
   (Tacmach.proof_of_pftreestate pts)
 
176
;;