uri: (Cic.id, string) Hashtbl.t;
}
-exception No_match
-
-module OrderedInt =
- struct
- type t = int
- let compare (x1:t) (x2:t) = Pervasives.compare x2 x1 (* reverse order *)
- end
-
-module IntSet = Set.Make (OrderedInt)
-
-let int_set_of_int_list l =
- List.fold_left (fun acc i -> IntSet.add i acc) IntSet.empty l
-
let warning s = prerr_endline ("CicNotation WARNING: " ^ s)
-module type PATTERN =
- sig
- type pattern_t
- val compatible : pattern_t -> pattern_t -> bool
- end
-
-module Patterns (P: PATTERN) =
+(* module Pattern32 =
struct
- type row_t = P.pattern_t list * pattern_id
- type t = row_t list
-
- let empty = []
-
- let first_column t = List.map (fun (patterns, _) -> List.hd patterns) t
- let pattern_ids t = List.map snd t
-
- let partition t pidl =
- let partitions = Hashtbl.create 11 in
- let add pid row = Hashtbl.add partitions pid row in
- (try
- List.iter2 add pidl t
- with Invalid_argument _ -> assert false);
- let pidset = int_set_of_int_list pidl in
- IntSet.fold
- (fun pid acc ->
- match Hashtbl.find_all partitions pid with
- | [] -> acc
- | patterns -> (pid, List.rev patterns) :: acc)
- pidset []
-
- let are_empty t = fst (List.hd t) = []
- (* if first row has an empty list of patterns, then others will as well *)
-
- (* return 2 lists of rows, first one containing homogeneous rows according
- * to "compatible" below *)
- let horizontal_split t =
- let ap, first_row, t' =
- match t with
- | [] -> assert false
- | ([], _) :: _ ->
- assert false (* are_empty should have been invoked in advance *)
- | ((hd :: _ , _) as row) :: tl -> hd, row, tl
- in
- let rec aux prev_t = function
- | [] -> List.rev prev_t, []
- | ([], _) :: _ -> assert false
- | (((hd :: _), _) as row) :: tl when P.compatible ap hd ->
- aux (row :: prev_t) tl
- | t -> List.rev prev_t, t
- in
- aux [first_row] t'
-
- (* return 2 lists, first one representing first column, second one
- * representing rows stripped of the first element *)
- let vertical_split t =
- let l =
- List.map
- (function
- | (hd :: tl, pid) -> hd, (tl, pid)
- | _ -> assert false)
- t
- in
- List.split l
+ type pattern_t = CicNotationPt.cic_appl_pattern
+ let compatible ap1 ap2 =
+ match ap1, ap2 with
+ | CicNotationPt.UriPattern _, CicNotationPt.UriPattern _
+ | CicNotationPt.ArgPattern _, CicNotationPt.ArgPattern _
+ | CicNotationPt.ApplPattern _, CicNotationPt.ApplPattern _ -> true
+ | _ -> false
end
-module Patterns21 = Patterns (CicNotationTag)
-
-module Patterns32 =
- struct
- type row_t = CicNotationPt.cic_appl_pattern list * pattern_id
- type t = row_t list
-
- let empty = []
-
- let first_column t = List.map (fun (patterns, _) -> List.hd patterns) t
- let pattern_ids t = List.map snd t
-
- let partition t pidl =
- let partitions = Hashtbl.create 11 in
- let add pid row = Hashtbl.add partitions pid row in
- (try
- List.iter2 add pidl t
- with Invalid_argument _ -> assert false);
- let pidset = int_set_of_int_list pidl in
- IntSet.fold
- (fun pid acc ->
- match Hashtbl.find_all partitions pid with
- | [] -> acc
- | patterns -> (pid, List.rev patterns) :: acc)
- pidset []
-
- let are_empty t = fst (List.hd t) = []
- (* if first row has an empty list of patterns, then others will as well *)
-
- (* return 2 lists of rows, first one containing homogeneous rows according
- * to "compatible" below *)
- let horizontal_split t =
- let compatible ap1 ap2 =
- match ap1, ap2 with
- | CicNotationPt.UriPattern _, CicNotationPt.UriPattern _
- | CicNotationPt.ArgPattern _, CicNotationPt.ArgPattern _
- | CicNotationPt.ApplPattern _, CicNotationPt.ApplPattern _ -> true
- | _ -> false
- in
- let ap =
- match t with
- | [] -> assert false
- | ([], _) :: _ ->
- assert false (* are_empty should have been invoked in advance *)
- | (hd :: _ , _) :: _ -> hd
- in
- let rec aux prev_t = function
- | [] -> List.rev prev_t, []
- | ([], _) :: _ -> assert false
- | (((hd :: _), _) as row) :: tl when compatible ap hd ->
- aux (row :: prev_t) tl
- | t -> List.rev prev_t, t
- in
- aux [] t
-
- (* return 2 lists, first one representing first column, second one
- * representing rows stripped of the first element *)
- let vertical_split t =
- let l =
- List.map
- (function
- | (hd :: tl, pid) -> hd, (tl, pid)
- | _ -> assert false)
- t
- in
- List.split l
- end
+module Patterns32 = Patterns (Pattern32) *)
(* acic -> ast auxiliary function s *)
(* persistent state *)
let level1_patterns21 = Hashtbl.create 211
-let level2_patterns32 = Hashtbl.create 211
+(* let level2_patterns32 = Hashtbl.create 211 *)
-let (compiled21: (CicNotationPt.term -> CicNotationPt.term) option ref) =
- ref None
-let (compiled32: (term_info -> Cic.annterm -> CicNotationPt.term) option ref) =
+let (compiled21: (CicNotationPt.term -> (CicNotationEnv.t * pattern_id) option)
+option ref) =
ref None
+(* let (compiled32: (term_info -> Cic.annterm -> CicNotationPt.term) option ref) =
+ ref None *)
-let pattern21_matrix = ref Patterns21.empty
-let pattern32_matrix = ref Patterns32.empty
+let pattern21_matrix = ref []
+(* let pattern32_matrix = ref Patterns32.empty *)
let get_compiled21 () =
match !compiled21 with
| None -> assert false
| Some f -> f
-let get_compiled32 () =
+(* let get_compiled32 () =
match !compiled32 with
| None -> assert false
- | Some f -> f
+ | Some f -> f *)
let set_compiled21 f = compiled21 := Some f
-let set_compiled32 f = compiled32 := Some f
+(* let set_compiled32 f = compiled32 := Some f *)
(* "envl" is a list of triples:
* <name environment, term environment, pattern id>, where
end))
(* compiler from level 3 to level 2 *)
-let compiler32 (t: Patterns32.t) success_k fail_k =
- let rec aux t k = (* k is a continuation *)
+(* let compiler32 (t: Patterns32.t) success_k fail_k =
+ let rec aux t k = |+ k is a continuation +|
if t = [] then
k
else if Patterns32.are_empty t then begin
(match t with
| _::_::_ ->
- (* XXX optimization possible here: throw away all except one of the
- * rules which lead to ambiguity *)
+ |+ XXX optimization possible here: throw away all except one of the
+ * rules which lead to ambiguity +|
warning "ambiguous interpretation"
| _ -> ());
return_closure success_k
| _ -> assert false)
t'
in
- (* arity partitioning *)
+ |+ arity partitioning +|
let clusters = Patterns32.partition t' pidl in
- let ks = (* k continuation list *)
+ let ks = |+ k continuation list +|
List.map
(fun (len, cluster) ->
let cluster' =
- List.map (* add args as patterns heads *)
+ List.map |+ add args as patterns heads +|
(function
| (Ast.ApplPattern args) :: tl, pid ->
- (* let's throw away "teste di cluster" *)
+ |+ let's throw away "teste di cluster" +|
args @ tl, pid
| _ -> assert false)
cluster
matcher term_info [annterm] (List.map (fun (_, pid) -> [], [], pid) t)
with No_match -> fail_k term_info annterm)
-let return_closure21 success_k =
- (fun terms envl ->
- prerr_endline "return_closure21";
- match terms with
- | [] ->
- (try
- success_k (List.hd envl)
- with Failure _ -> assert false)
- | _ -> assert false)
-
-let variable_closure21 vars k =
- (fun terms envl ->
- prerr_endline "variable_closure21";
- match terms with
- | hd :: tl ->
- let envl' =
- List.map2
- (fun (name, ty) (env, pid) ->
- (name, (ty, CicNotationEnv.value_of_term hd)) :: env, pid)
- vars envl
- in
- k tl envl'
- | _ -> assert false)
-
-let constructor_closure21 ks k =
- (fun terms envl ->
- prerr_endline "constructor_closure21";
- (match terms with
- | p :: tl ->
- prerr_endline (sprintf "on term %s" (CicNotationPp.pp_term p));
- (try
- let tag, subterms = CicNotationTag.get_tag p in
- let k' = List.assoc tag ks in
- k' (subterms @ tl) envl
- with Not_found -> k terms envl)
- | [] -> assert false))
-
-let compiler21 (t: Patterns21.t) success_k fail_k =
- let rec aux t k =
- if t = [] then
- k
- else if Patterns21.are_empty t then begin
- (match t with
- | _::_::_ ->
- (* XXX optimization possible here: throw away all except one of the
- * rules which lead to ambiguity *)
- warning "ambiguous notation"
- | _ -> ());
- return_closure21 success_k
- end else
- match Patterns21.horizontal_split t with
- | t', [] ->
- (match t' with
- | []
- | ([], _) :: _ -> assert false
- | (Ast.Variable _ :: _, _) :: _ ->
- let first_column, t'' = Patterns21.vertical_split t' in
- let vars =
- List.map
- (function
- | Ast.Variable v -> CicNotationEnv.declaration_of_var v
- | _ -> assert false)
- first_column
- in
- variable_closure21 vars (aux t'' k)
- | _ ->
- let pidl =
- List.map
- (function
- | p :: _, _ -> fst (CicNotationTag.get_tag p)
- | [], _ -> assert false)
- t'
- in
- let clusters = Patterns21.partition t' pidl in
- let ks =
- List.map
- (fun (pid, cluster) ->
- let cluster' =
- List.map (* add args as patterns heads *)
- (function
- | p :: tl, pid ->
- let _, subpatterns = CicNotationTag.get_tag p in
- subpatterns @ tl, pid
- | _ -> assert false)
- cluster
- in
- pid, aux cluster' k)
- clusters
- in
- constructor_closure21 ks k)
- | t', tl -> aux t' (aux tl k)
- in
- let matcher = aux t (fun _ _ -> raise No_match) in
- (fun ast ->
- try
- matcher [ast] (List.map (fun (_, pid) -> [], pid) t)
- with No_match -> fail_k ast)
-
-let ast_of_acic1 term_info annterm = (get_compiled32 ()) term_info annterm
-
-let pp_ast1 term = (get_compiled21 ()) term
+let ast_of_acic1 term_info annterm = (get_compiled32 ()) term_info annterm *)
let instantiate21 env pid =
prerr_endline "instantiate21";
and subst_layout l = CicNotationUtil.visit_layout subst l in
subst l1
-let instantiate32 term_info name_env term_env pid =
+let rec pp_ast1 term =
+ let rec pp_value = function
+ | CicNotationEnv.NumValue _ as v -> v
+ | CicNotationEnv.StringValue _ as v -> v
+ | CicNotationEnv.TermValue t -> CicNotationEnv.TermValue (pp_ast1 t)
+ | CicNotationEnv.OptValue None as v -> v
+ | CicNotationEnv.OptValue (Some v) ->
+ CicNotationEnv.OptValue (Some (pp_value v))
+ | CicNotationEnv.ListValue vl ->
+ CicNotationEnv.ListValue (List.map pp_value vl)
+ in
+ let ast_env_of_env env =
+ List.map (fun (var, (ty, value)) -> (var, (ty, pp_value value))) env
+ in
+ match (get_compiled21 ()) term with
+ | None -> pp_ast0 term pp_ast1
+ | Some (env, pid) -> instantiate21 (ast_env_of_env env) pid
+
+(* let instantiate32 term_info name_env term_env pid =
let symbol, args =
try
Hashtbl.find level2_patterns32 pid
let rec instantiate_arg = function
| Ast.IdentArg name ->
(try List.assoc name term_env with Not_found -> assert false)
- | Ast.EtaArg (None, _) -> assert false (* TODO *)
+ | Ast.EtaArg (None, _) -> assert false |+ TODO +|
| Ast.EtaArg (Some name, arg) ->
let (name', ty_opt) =
try List.assoc name name_env with Not_found -> assert false
pid
in
let compiled32 = compiler32 t success_k fail_k in
- set_compiled32 compiled32
+ set_compiled32 compiled32 *)
let load_patterns21 t =
- let rec pp_value = function
- | CicNotationEnv.NumValue _ as v -> v
- | CicNotationEnv.StringValue _ as v -> v
- | CicNotationEnv.TermValue t -> CicNotationEnv.TermValue (pp_ast1 t)
- | CicNotationEnv.OptValue None as v -> v
- | CicNotationEnv.OptValue (Some v) ->
- CicNotationEnv.OptValue (Some (pp_value v))
- | CicNotationEnv.ListValue vl ->
- CicNotationEnv.ListValue (List.map pp_value vl)
- in
- let ast_env_of_env env =
- List.map (fun (var, (ty, value)) -> (var, (ty, pp_value value))) env
- in
- let fail_k term = pp_ast0 term pp_ast1 in
- let success_k (env, pid) = instantiate21 (ast_env_of_env env) pid in
- let compiled21 = compiler21 t success_k fail_k in
- set_compiled21 compiled21
+ set_compiled21 (CicNotationMatcher.T21.compiler t)
-let ast_of_acic id_to_sort annterm =
+(* let ast_of_acic id_to_sort annterm =
let term_info = { sort = id_to_sort; uri = Hashtbl.create 211 } in
let ast = ast_of_acic1 term_info annterm in
- ast, term_info.uri
+ ast, term_info.uri *)
let pp_ast term = pp_ast1 term
incr counter;
!counter
-let add_interpretation (symbol, args) appl_pattern =
+(* let add_interpretation (symbol, args) appl_pattern =
let id = fresh_id () in
Hashtbl.add level2_patterns32 id (symbol, args);
pattern32_matrix := ([appl_pattern], id) :: !pattern32_matrix;
load_patterns32 !pattern32_matrix;
- id
+ id *)
let add_pretty_printer ?precedence ?associativity l2 l1 =
let id = fresh_id () in
let l2' = CicNotationUtil.strip_attributes l2 in
Hashtbl.add level1_patterns21 id (precedence, associativity, l1);
- pattern21_matrix := ([l2'], id) :: !pattern21_matrix;
+ pattern21_matrix := (l2', id) :: !pattern21_matrix;
load_patterns21 !pattern21_matrix;
id
exception Interpretation_not_found
exception Pretty_printer_not_found
-let remove_interpretation id =
+(* let remove_interpretation id =
(try
Hashtbl.remove level2_patterns32 id;
with Not_found -> raise Interpretation_not_found);
pattern32_matrix := List.filter (fun (_, id') -> id <> id') !pattern32_matrix;
- load_patterns32 !pattern32_matrix
+ load_patterns32 !pattern32_matrix *)
let remove_pretty_printer id =
(try
let _ =
load_patterns21 [];
- load_patterns32 []
+(* load_patterns32 [] *)
projects / helm.git / blobdiff