2 ||M|| This file is part of HELM, an Hypertextual, Electronic
3 ||A|| Library of Mathematics, developed at the Computer Science
4 ||T|| Department, University of Bologna, Italy.
6 ||T|| HELM is free software; you can redistribute it and/or
7 ||A|| modify it under the terms of the GNU General Public License
8 \ / version 2 or (at your option) any later version.
9 \ / This software is distributed as is, NO WARRANTY.
10 V_______________________________________________________________ *)
19 (* qualified identifier: uri, name, qualifiers *)
20 type qid = M.uri * M.id * M.id list
22 type context_node = qid option (* context node: None = root *)
25 path: M.id list; (* current section path *)
26 node: context_node; (* current context node *)
27 nodes: context_node list; (* context node list *)
28 line: int; (* line number *)
29 cover: string (* initial segment of URI hierarchy *)
32 type resolver = Local of int
35 let henv_size, hcnt_size = 7000, 4300 (* hash tables initial sizes *)
37 let henv = H.create henv_size (* optimized global environment *)
39 let hcnt = H.create hcnt_size (* optimized context *)
41 (* Internal functions *******************************************************)
43 let initial_status cover =
44 H.clear henv; H.clear hcnt; {
45 path = []; node = None; nodes = []; line = 1; cover = cover;
48 let id_of_name (id, _, _) = id
50 let mk_qid st id path =
51 let uripath = if st.cover = "" then path else st.cover :: path in
52 let str = String.concat "/" uripath in
53 let str = Filename.concat str id in
54 U.uri_of_string ("ld:/" ^ str ^ ".ld"), id, path
56 let uri_of_qid (uri, _, _) = uri
58 let complete_qid f st (id, is_local, qs) =
59 let f qs = f (mk_qid st id qs) in
60 let f path = C.list_rev_append f path ~tail:qs in
61 let rec skip f = function
62 | phd :: ptl, qshd :: _ when phd = qshd -> f ptl
63 | _ :: ptl, _ :: _ -> skip f (ptl, qs)
66 if is_local then f st.path else skip f (st.path, qs)
68 let relax_qid f st (_, id, path) =
69 let f path = f (mk_qid st id path) in
71 | _ :: tl -> C.list_rev f tl
76 let relax_opt_qid f st = function
78 | Some qid -> let f qid = f (Some qid) in relax_qid f st qid
80 let resolve_lref f st l lenv id =
81 let rec aux f i = function
83 | (name, _) :: _ when name = id -> f (Some (M.LRef (l, i)))
84 | _ :: tl -> aux f (succ i) tl
88 let resolve_lref_strict f st l lenv id =
91 | None -> assert false
93 resolve_lref f st l lenv id
95 let resolve_gref f st qid =
96 try let args = H.find henv (uri_of_qid qid) in f qid (Some args)
97 with Not_found -> f qid None
99 let resolve_gref_relaxed f st qid =
100 (* this is not tail recursive *)
101 let rec g qid = function
102 | None -> relax_qid (resolve_gref g st) st qid
103 | Some args -> f qid args
105 resolve_gref g st qid
107 let get_pars f st = function
109 | Some qid as node ->
110 try let pars = H.find hcnt (uri_of_qid qid) in f pars None
111 with Not_found -> f [] (Some node)
113 let get_pars_relaxed f st =
114 (* this is not tail recursive *)
115 let rec g pars = function
117 | Some node -> relax_opt_qid (get_pars g st) st node
119 get_pars g st st.node
121 (* this is not tail recursive on the GRef branch *)
122 let rec xlate_term f st lenv = function
126 let f vv tt = f (M.Appl (vv, tt)) in
127 let f vv = xlate_term (f vv) st lenv t in
128 xlate_term f st lenv v
129 | A.Abst (name, w, t) ->
130 let add name w lenv = (name, w) :: lenv in
131 let f ww tt = f (M.Abst (name, ww, tt)) in
132 let f ww = xlate_term (f ww) st (add name ww lenv) t in
133 xlate_term f st lenv w
134 | A.GRef (name, args) ->
135 let l = List.length lenv in
137 let map1 f = xlate_term f st lenv in
138 let map2 f (id, _) = resolve_lref_strict f st l lenv id in
140 let f args = f (M.GRef (l, uri_of_qid qid, args)) in
141 let f defs = C.list_rev_map_append f map2 defs ~tail in
142 C.list_sub_strict f defs args
144 C.list_map f map1 args
146 let g qid = resolve_gref_relaxed g st qid in
149 | None -> complete_qid g st name
151 resolve_lref f st l lenv (id_of_name name)
153 let xlate_entity err f st = function
154 | A.Section (Some (_, name)) ->
155 err {st with path = name :: st.path; nodes = st.node :: st.nodes}
157 begin match st.path, st.nodes with
158 | _ :: ptl, nhd :: ntl ->
159 err {st with path = ptl; node = nhd; nodes = ntl}
163 err {st with node = None}
164 | A.Context (Some name) ->
165 let f name = err {st with node = Some name} in
166 complete_qid f st name
167 | A.Block (name, w) ->
171 H.add hcnt (uri_of_qid qid) ((name, ww) :: pars);
172 err {st with node = Some qid}
174 xlate_term f st pars w
176 get_pars_relaxed f st
178 complete_qid f st (name, true, [])
179 | A.Decl (name, w) ->
183 H.add henv (uri_of_qid qid) pars;
184 let a = [Y.Mark st.line] in
185 let entry = pars, ww, None in
186 let entity = a, uri_of_qid qid, Y.Abst entry in
187 f {st with line = succ st.line} entity
189 xlate_term f st pars w
191 complete_qid f st (name, true, [])
193 get_pars_relaxed f st
194 | A.Def (name, w, trans, v) ->
198 H.add henv (uri_of_qid qid) pars;
199 let a = Y.Mark st.line :: if trans then [] else [Y.Priv] in
200 let entry = pars, ww, Some vv in
201 let entity = a, uri_of_qid qid, Y.Abbr entry in
202 f {st with line = succ st.line} entity
204 let f ww = xlate_term (f ww) st pars v in
205 xlate_term f st pars w
207 complete_qid f st (name, true, [])
209 get_pars_relaxed f st
211 (* Interface functions ******************************************************)
213 let initial_status ?(cover="") () =
216 let meta_of_aut = xlate_entity