diff options
120 files changed, 2466 insertions, 2366 deletions
@@ -46,8 +46,8 @@ LOCALINCLUDES=-I config -I tools -I scripts -I lib -I kernel -I library \ MLINCLUDES=$(LOCALINCLUDES) -I $(CAMLP4LIB) -BYTEFLAGS=-rectypes $(MLINCLUDES) $(CAMLDEBUG) -OPTFLAGS=-rectypes $(MLINCLUDES) $(CAMLTIMEPROF) +BYTEFLAGS=$(MLINCLUDES) $(CAMLDEBUG) +OPTFLAGS=$(MLINCLUDES) $(CAMLTIMEPROF) OCAMLDEP=ocamldep DEPFLAGS=$(LOCALINCLUDES) @@ -571,11 +571,11 @@ $(GALLINA): $(GALLINACMO) beforedepend:: tools/gallina_lexer.ml -$(COQMAKEFILE): tools/coq_makefile.ml - $(OCAMLC) $(BYTEFLAGS) -custom -o $@ tools/coq_makefile.ml +$(COQMAKEFILE): tools/coq_makefile.cmo + $(OCAMLC) $(BYTEFLAGS) -custom -o $@ tools/coq_makefile.cmo -$(COQTEX): tools/coq-tex.ml - $(OCAMLC) $(BYTEFLAGS) -custom -o $@ str.cma tools/coq-tex.ml +$(COQTEX): tools/coq-tex.cmo + $(OCAMLC) $(BYTEFLAGS) -custom -o $@ str.cma tools/coq-tex.cmo COQVO2XMLCMO=$(CONFIG) toplevel/usage.cmo tools/coq_vo2xml.cmo @@ -761,6 +761,62 @@ ML4FILES += toplevel/mltop.ml4 clean:: rm -f toplevel/mltop.byteml toplevel/mltop.optml +# files compiled with camlp4 because of streams syntax + +lib/pp.cmo: lib/pp.ml + $(OCAMLC) -pp camlp4o $(BYTEFLAGS) -c $< + +lib/pp.cmx: lib/pp.ml + $(OCAMLOPT) -pp camlp4o $(OPTFLAGS) -c $< + +kernel/term.cmo: kernel/term.ml + $(OCAMLC) -rectypes $(BYTEFLAGS) -c $< + +kernel/term.cmx: kernel/term.ml + $(OCAMLOPT) -rectypes $(OPTFLAGS) -c $< + +library/nametab.cmo: library/nametab.ml + $(OCAMLC) -rectypes $(BYTEFLAGS) -c $< + +library/nametab.cmx: library/nametab.ml + $(OCAMLOPT) -rectypes $(OPTFLAGS) -c $< + +contrib/xml/xml.cmo: contrib/xml/xml.ml + $(OCAMLC) -pp camlp4o $(BYTEFLAGS) -c $< + +contrib/xml/xml.cmx: contrib/xml/xml.ml + $(OCAMLOPT) -pp camlp4o $(OPTFLAGS) -c $< + +contrib/xml/xmlcommand.cmo: contrib/xml/xmlcommand.ml + $(OCAMLC) -pp camlp4o $(BYTEFLAGS) -c $< + +contrib/xml/xmlcommand.cmx: contrib/xml/xmlcommand.ml + $(OCAMLOPT) -pp camlp4o $(OPTFLAGS) -c $< + +contrib/interface/dad.cmo: contrib/interface/dad.ml + $(OCAMLC) -pp camlp4o $(BYTEFLAGS) -c $< + +contrib/interface/dad.cmx: contrib/interface/dad.ml + $(OCAMLOPT) -pp camlp4o $(OPTFLAGS) -c $< + +contrib/interface/line_parser.cmo: contrib/interface/line_parser.ml + $(OCAMLC) -pp camlp4o $(BYTEFLAGS) -c $< + +contrib/interface/line_parser.cmx: contrib/interface/line_parser.ml + $(OCAMLOPT) -pp camlp4o $(OPTFLAGS) -c $< + +tools/coq_makefile.cmo: tools/coq_makefile.ml + $(OCAMLC) -pp camlp4o $(BYTEFLAGS) -c $< + +tools/coq_makefile.cmx: tools/coq_makefile.ml + $(OCAMLOPT) -pp camlp4o $(OPTFLAGS) -c $< + +tools/coq-tex.cmo: tools/coq-tex.ml + $(OCAMLC) -pp camlp4o $(BYTEFLAGS) -c $< + +tools/coq-tex.cmx: tools/coq-tex.ml + $(OCAMLOPT) -pp camlp4o $(OPTFLAGS) -c $< + ########################################################################### # Default rules ########################################################################### diff --git a/contrib/correctness/pcicenv.ml b/contrib/correctness/pcicenv.ml index 4663b3e37..63c176217 100644 --- a/contrib/correctness/pcicenv.ml +++ b/contrib/correctness/pcicenv.ml @@ -27,7 +27,7 @@ let modify_sign id t s = fold_named_context (fun ((x,b,ty) as d) sign -> if x=id then add_named_decl (x,b,t) sign else add_named_decl d sign) - s empty_named_context + s ~init:empty_named_context let add_sign (id,t) s = try diff --git a/contrib/correctness/peffect.ml b/contrib/correctness/peffect.ml index 1db31269b..c6e1636c6 100644 --- a/contrib/correctness/peffect.ml +++ b/contrib/correctness/peffect.ml @@ -143,17 +143,17 @@ open Util open Himsg let pp (r,w) = - hOV 0 [< if r<>[] then - [< 'sTR"reads "; - prlist_with_sep (fun () -> [< 'sTR","; 'sPC >]) pr_id r >] - else [< >]; - 'sPC; + hov 0 (if r<>[] then + (str"reads " ++ + prlist_with_sep (fun () -> (str"," ++ spc ())) pr_id r) + else (mt ()) ++ + spc () ++ if w<>[] then - [< 'sTR"writes "; - prlist_with_sep (fun ()-> [< 'sTR","; 'sPC >]) pr_id w >] - else [< >] - >] + (str"writes " ++ + prlist_with_sep (fun ()-> (str"," ++ spc ())) pr_id w) + else (mt ()) +) let ppr e = - pP (pp e) + Pp.pp (pp e) diff --git a/contrib/correctness/penv.ml b/contrib/correctness/penv.ml index c3cc1ec64..9ac7bee8e 100644 --- a/contrib/correctness/penv.ml +++ b/contrib/correctness/penv.ml @@ -223,7 +223,7 @@ let register id id' = let (v,p) = Idmap.find id !edited in let _ = add_global id' v (Some p) in Options.if_verbose - mSGNL (hOV 0 [< 'sTR"Program "; pr_id id'; 'sPC; 'sTR"is defined" >]); + msgnl (hov 0 (str"Program " ++ pr_id id' ++ spc () ++ str"is defined")); edited := Idmap.remove id !edited with Not_found -> () diff --git a/contrib/correctness/perror.ml b/contrib/correctness/perror.ml index 17c673a54..19b4db992 100644 --- a/contrib/correctness/perror.ml +++ b/contrib/correctness/perror.ml @@ -30,38 +30,38 @@ let raise_with_loc = function let unbound_variable id loc = raise_with_loc loc (UserError ("Perror.unbound_variable", - (hOV 0 [<'sTR"Unbound variable"; 'sPC; pr_id id; 'fNL >]))) + (hov 0 (str"Unbound variable" ++ spc () ++ pr_id id ++ fnl ())))) let unbound_reference id loc = raise_with_loc loc (UserError ("Perror.unbound_reference", - (hOV 0 [<'sTR"Unbound reference"; 'sPC; pr_id id; 'fNL >]))) + (hov 0 (str"Unbound reference" ++ spc () ++ pr_id id ++ fnl ())))) let clash id loc = raise_with_loc loc (UserError ("Perror.clash", - (hOV 0 [< 'sTR"Clash with previous constant"; 'sPC; - 'sTR(string_of_id id); 'fNL >]))) + (hov 0 (str"Clash with previous constant" ++ spc () ++ + str(string_of_id id) ++ fnl ())))) let not_defined id = raise (UserError ("Perror.not_defined", - (hOV 0 [< 'sTR"The object"; 'sPC; pr_id id; 'sPC; - 'sTR"is not defined"; 'fNL >]))) + (hov 0 (str"The object" ++ spc () ++ pr_id id ++ spc () ++ + str"is not defined" ++ fnl ())))) let check_for_reference loc id = function Ref _ -> () | _ -> Stdpp.raise_with_loc loc (UserError ("Perror.check_for_reference", - hOV 0 [< pr_id id; 'sPC; - 'sTR"is not a reference" >])) + hov 0 (pr_id id ++ spc () ++ + str"is not a reference"))) let check_for_array loc id = function Array _ -> () | _ -> Stdpp.raise_with_loc loc (UserError ("Perror.check_for_array", - hOV 0 [< pr_id id; 'sPC; - 'sTR"is not an array" >])) + hov 0 (pr_id id ++ spc () ++ + str"is not an array"))) let is_constant_type s = function TypePure c -> @@ -75,56 +75,56 @@ let check_for_index_type loc v = if not is_index then Stdpp.raise_with_loc loc (UserError ("Perror.check_for_index", - hOV 0 [< 'sTR"This expression is an index"; 'sPC; - 'sTR"and should have type int (Z)" >])) + hov 0 (str"This expression is an index" ++ spc () ++ + str"and should have type int (Z)"))) let check_no_effect loc ef = if not (Peffect.get_writes ef = []) then Stdpp.raise_with_loc loc (UserError ("Perror.check_no_effect", - hOV 0 [< 'sTR"A boolean should not have side effects" - >])) + hov 0 (str"A boolean should not have side effects" +))) let should_be_boolean loc = Stdpp.raise_with_loc loc (UserError ("Perror.should_be_boolean", - hOV 0 [< 'sTR"This expression is a test:" ; 'sPC; - 'sTR"it should have type bool" >])) + hov 0 (str"This expression is a test:" ++ spc () ++ + str"it should have type bool"))) let test_should_be_annotated loc = Stdpp.raise_with_loc loc (UserError ("Perror.test_should_be_annotated", - hOV 0 [< 'sTR"This test should be annotated" >])) + hov 0 (str"This test should be annotated"))) let if_branches loc = Stdpp.raise_with_loc loc (UserError ("Perror.if_branches", - hOV 0 [< 'sTR"The two branches of an `if' expression" ; 'sPC; - 'sTR"should have the same type" >])) + hov 0 (str"The two branches of an `if' expression" ++ spc () ++ + str"should have the same type"))) let check_for_not_mutable loc v = if is_mutable v then Stdpp.raise_with_loc loc (UserError ("Perror.check_for_not_mutable", - hOV 0 [< 'sTR"This expression cannot be a mutable" >])) + hov 0 (str"This expression cannot be a mutable"))) let check_for_pure_type loc v = if not (is_pure v) then Stdpp.raise_with_loc loc (UserError ("Perror.check_for_pure_type", - hOV 0 [< 'sTR"This expression must be pure"; 'sPC; - 'sTR"(neither a mutable nor a function)" >])) + hov 0 (str"This expression must be pure" ++ spc () ++ + str"(neither a mutable nor a function)"))) let check_for_let_ref loc v = if not (is_pure v) then Stdpp.raise_with_loc loc (UserError ("Perror.check_for_let_ref", - hOV 0 [< 'sTR"References can only be bound in pure terms">])) + hov 0 (str"References can only be bound in pure terms"))) let informative loc s = Stdpp.raise_with_loc loc (UserError ("Perror.variant_informative", - hOV 0 [< 'sTR s; 'sPC; 'sTR"must be informative" >])) + hov 0 (str s ++ spc () ++ str"must be informative"))) let variant_informative loc = informative loc "Variant" let should_be_informative loc = informative loc "This term" @@ -132,41 +132,41 @@ let should_be_informative loc = informative loc "This term" let app_of_non_function loc = Stdpp.raise_with_loc loc (UserError ("Perror.app_of_non_function", - hOV 0 [< 'sTR"This term cannot be applied"; 'sPC; - 'sTR"(either it is not a function"; 'sPC; - 'sTR"or it is applied to non pure arguments)" >])) + hov 0 (str"This term cannot be applied" ++ spc () ++ + str"(either it is not a function" ++ spc () ++ + str"or it is applied to non pure arguments)"))) let partial_app loc = Stdpp.raise_with_loc loc (UserError ("Perror.partial_app", - hOV 0 [< 'sTR"This function does not have"; - 'sPC; 'sTR"the right number of arguments" >])) + hov 0 (str"This function does not have" ++ + spc () ++ str"the right number of arguments"))) let expected_type loc s = Stdpp.raise_with_loc loc (UserError ("Perror.expected_type", - hOV 0 [< 'sTR"Argument is expected to have type"; 'sPC; s >])) + hov 0 (str"Argument is expected to have type" ++ spc () ++ s))) let expects_a_type id loc = Stdpp.raise_with_loc loc (UserError ("Perror.expects_a_type", - hOV 0 [< 'sTR"The argument "; pr_id id; 'sPC; - 'sTR"in this application is supposed to be a type" >])) + hov 0 (str"The argument " ++ pr_id id ++ spc () ++ + str"in this application is supposed to be a type"))) let expects_a_term id = raise (UserError ("Perror.expects_a_type", - hOV 0 [< 'sTR"The argument "; pr_id id; 'sPC; - 'sTR"in this application is supposed to be a term" >])) + hov 0 (str"The argument " ++ pr_id id ++ spc () ++ + str"in this application is supposed to be a term"))) let should_be_a_variable loc = Stdpp.raise_with_loc loc (UserError ("Perror.should_be_a_variable", - hOV 0 [< 'sTR"Argument should be a variable" >])) + hov 0 (str"Argument should be a variable"))) let should_be_a_reference loc = Stdpp.raise_with_loc loc (UserError ("Perror.should_be_a_reference", - hOV 0 [< 'sTR"Argument of function should be a reference" >])) + hov 0 (str"Argument of function should be a reference"))) diff --git a/contrib/correctness/pextract.ml b/contrib/correctness/pextract.ml index a097ac1b5..47fc9929f 100644 --- a/contrib/correctness/pextract.ml +++ b/contrib/correctness/pextract.ml @@ -42,18 +42,18 @@ let access = ConstRef sp_access let has_array = ref false let pp_conversions () = - [< 'sTR"\ + (str"\ let rec int_of_pos = function XH -> 1 | XI p -> 2 * (int_of_pos p) + 1 | XO p -> 2 * (int_of_pos p) -;; + ++ ++ let int_of_z = function ZERO -> 0 | POS p -> int_of_pos p | NEG p -> -(int_of_pos p) -;; + ++ ++ " >] (* '"' *) (* collect all section-path in a CIC constant *) @@ -61,7 +61,7 @@ let int_of_z = function let spset_of_cci env c = let spl = Fw_env.collect (extraction env c) in let sps = List.fold_left (fun e x -> SpSet.add x e) SpSet.empty spl in - has_array := !has_array or (SpSet.mem sp_access sps); + has_array := !has_array or (SpSet.mem sp_access sps) ++ SpSet.remove sp_access sps @@ -81,10 +81,10 @@ let collect env = | Acc x -> add_id env s x | Aff (x,e1) -> add_id env (collect_rec env s e1) x | TabAcc (_,x,e1) -> - has_array := true; + has_array := true ++ add_id env (collect_rec env s e1) x | TabAff (_,x,e1,e2) -> - has_array := true; + has_array := true ++ add_id env (collect_rec env (collect_rec env s e1) e2) x | Seq bl -> List.fold_left (fun s st -> match st with @@ -144,17 +144,17 @@ module Ocaml_ren = Ocaml.OCaml_renaming let rename_global id = let id' = Ocaml_ren.rename_global_term !Fwtoml.globals (Name id) in - Fwtoml.add_global_renaming (id,id'); + Fwtoml.add_global_renaming (id,id') ++ id' -type rename_struct = { rn_map : identifier IdMap.t; +type rename_struct = { rn_map : identifier IdMap.t ++ rn_avoid : identifier list } -let rn_empty = { rn_map = IdMap.empty; rn_avoid = [] } +let rn_empty = { rn_map = IdMap.empty ++ rn_avoid = [] } let rename_local rn id = let id' = Ocaml_ren.rename_term (!Fwtoml.globals@rn.rn_avoid) (Name id) in - { rn_map = IdMap.add id id' rn.rn_map; rn_avoid = id' :: rn.rn_avoid }, + { rn_map = IdMap.add id id' rn.rn_map ++ rn_avoid = id' :: rn.rn_avoid }, id' let get_local_name rn id = IdMap.find id rn.rn_map @@ -177,7 +177,7 @@ let rec rename_binders rn = function *) let putpar par s = - if par then [< 'sTR"("; s; 'sTR")" >] else s + if par then (str"(" ++ s ++ str")") else s let is_ref env id = try @@ -188,21 +188,21 @@ let is_ref env id = let rec pp_constr env rn = function | VAR id -> if is_ref env id then - [< 'sTR"!"; pID (get_name env rn id) >] + (str"!" ++ pID (get_name env rn id)) else pID (get_name env rn id) | DOPN((Const _|MutInd _|MutConstruct _) as oper, _) -> pID (Fwtoml.name_of_oper oper) | DOPN(AppL,v) -> if Array.length v = 0 then - [< >] + (mt ()) else begin match v.(0) with DOPN(Const sp,_) when sp = sp_access -> - [< pp_constr env rn v.(3); - 'sTR".(int_of_z "; pp_constr env rn v.(4); 'sTR")" >] + (pp_constr env rn v.(3) ++ + str".(int_of_z " ++ pp_constr env rn v.(4) ++ str")") | _ -> - hOV 2 (putpar true (prvect_with_sep (fun () -> [< 'sPC >]) + hov 2 (putpar true (prvect_with_sep (fun () -> (spc ())) (pp_constr env rn) v)) end | DOP2(Cast,c,_) -> pp_constr env rn c @@ -219,95 +219,95 @@ let collect_lambda = collect [] let pr_binding rn = - prlist_with_sep (fun () -> [< >]) + prlist_with_sep (fun () -> (mt ())) (function | (id,(Untyped | BindType _)) -> - [< 'sTR" "; pID (get_local_name rn id) >] - | (id,BindSet) -> [< >]) + (str" " ++ pID (get_local_name rn id)) + | (id,BindSet) -> (mt ())) let pp_prog id = let rec pp_d env rn par = function | Var x -> pID (get_name env rn x) - | Acc x -> [< 'sTR"!"; pID (get_name env rn x) >] - | Aff (x,e1) -> [< pID (get_name env rn x); - 'sTR" := "; hOV 0 (pp env rn false e1) >] + | Acc x -> (str"!" ++ pID (get_name env rn x)) + | Aff (x,e1) -> (pID (get_name env rn x) ++ + str" := " ++ hov 0 (pp env rn false e1)) | TabAcc (_,x,e1) -> - [< pID (get_name env rn x); - 'sTR".(int_of_z "; hOV 0 (pp env rn true e1); 'sTR")" >] + (pID (get_name env rn x) ++ + str".(int_of_z " ++ hov 0 (pp env rn true e1) ++ str")") | TabAff (_,x,e1,e2) -> - [< pID (get_name env rn x); - 'sTR".(int_of_z "; hOV 0 (pp env rn true e1); 'sTR")"; - 'sTR" <-"; 'sPC; hOV 2 (pp env rn false e2) >] + (pID (get_name env rn x) ++ + str".(int_of_z " ++ hov 0 (pp env rn true e1) ++ str")" ++ + str" <-" ++ spc () ++ hov 2 (pp env rn false e2)) | Seq bl -> - [< 'sTR"begin"; 'fNL; - 'sTR" "; hOV 0 [< pp_block env rn bl; >]; 'fNL; - 'sTR"end" >] + (str"begin" ++ fnl () ++ + str" " ++ hov 0 (pp_block env rn bl ++) ++ fnl () ++ + str"end") | If (e1,e2,e3) -> - putpar par [< 'sTR"if "; (pp env rn false e1); - 'sTR" then"; 'fNL; - 'sTR" "; hOV 0 (pp env rn false e2); 'fNL; - 'sTR"else"; 'fNL; - 'sTR" "; hOV 0 (pp env rn false e3) >] + putpar par (str"if " ++ (pp env rn false e1) ++ + str" then" ++ fnl () ++ + str" " ++ hov 0 (pp env rn false e2) ++ fnl () ++ + str"else" ++ fnl () ++ + str" " ++ hov 0 (pp env rn false e3)) (* optimisations : then begin .... end else begin ... end *) | While (b,inv,_,bl) -> - [< 'sTR"while "; (pp env rn false b); 'sTR" do"; 'fNL; - 'sTR" "; - hOV 0 [< (match inv with - None -> [< >] - | Some c -> [< 'sTR"(* invariant: "; pTERM c.a_value ; - 'sTR" *)"; 'fNL >]); - pp_block env rn bl; >]; 'fNL; - 'sTR"done"; >] + (str"while " ++ (pp env rn false b) ++ str" do" ++ fnl () ++ + str" " ++ + hov 0 ((match inv with + None -> (mt ()) + | Some c -> (str"(* invariant: " ++ pTERM c.a_value ++ + str" *)" ++ fnl ())) ++ + pp_block env rn bl ++) ++ fnl () ++ + str"done" ++) | Lam (bl,e) -> let env' = traverse_binders env bl in let rn' = rename_binders rn bl in putpar par - (hOV 2 [< 'sTR"fun"; pr_binding rn' bl; 'sTR" ->"; - 'sPC; pp env' rn' false e >]) - | SApp ((Var id)::_, [e1; e2]) + (hov 2 (str"fun" ++ pr_binding rn' bl ++ str" ->" ++ + spc () ++ pp env' rn' false e)) + | SApp ((Var id)::_, [e1 ++ e2]) when id = connective_and or id = connective_or -> let conn = if id = connective_and then "&" else "or" in putpar par - (hOV 0 [< pp env rn true e1; 'sPC; 'sTR conn; 'sPC; - pp env rn true e2 >]) + (hov 0 (pp env rn true e1 ++ spc () ++ str conn ++ spc () ++ + pp env rn true e2)) | SApp ((Var id)::_, [e]) when id = connective_not -> putpar par - (hOV 0 [< 'sTR"not"; 'sPC; pp env rn true e >]) + (hov 0 (str"not" ++ spc () ++ pp env rn true e)) | SApp _ -> invalid_arg "Prog_extract.pp_prog (SApp)" | App(e1,[]) -> - hOV 0 (pp env rn false e1) + hov 0 (pp env rn false e1) | App (e1,l) -> putpar true - (hOV 2 [< pp env rn true e1; + (hov 2 (pp env rn true e1 ++ prlist (function - Term p -> [< 'sPC; pp env rn true p >] - | Refarg x -> [< 'sPC; pID (get_name env rn x) >] - | Type _ -> [< >]) - l >]) + Term p -> (spc () ++ pp env rn true p) + | Refarg x -> (spc () ++ pID (get_name env rn x)) + | Type _ -> (mt ())) + l)) | LetRef (x,e1,e2) -> let (_,v),_,_,_ = e1.info.kappa in let env' = add (x,Ref v) env in let rn',x' = rename_local rn x in putpar par - (hOV 0 [< 'sTR"let "; pID x'; 'sTR" = ref "; pp env rn false e1; - 'sTR" in"; 'fNL; pp env' rn' false e2 >]) + (hov 0 (str"let " ++ pID x' ++ str" = ref " ++ pp env rn false e1 ++ + str" in" ++ fnl () ++ pp env' rn' false e2)) | LetIn (x,e1,e2) -> let (_,v),_,_,_ = e1.info.kappa in let env' = add (x,v) env in let rn',x' = rename_local rn x in putpar par - (hOV 0 [< 'sTR"let "; pID x'; 'sTR" = "; pp env rn false e1; - 'sTR" in"; 'fNL; pp env' rn' false e2 >]) + (hov 0 (str"let " ++ pID x' ++ str" = " ++ pp env rn false e1 ++ + str" in" ++ fnl () ++ pp env' rn' false e2)) | LetRec (f,bl,_,_,e) -> let env' = traverse_binders env bl in let rn' = rename_binders rn bl in let env'' = add (f,make_arrow bl e.info.kappa) env' in let rn'',f' = rename_local rn' f in putpar par - (hOV 0 [< 'sTR"let rec "; pID f'; pr_binding rn' bl; 'sTR" ="; 'fNL; - 'sTR" "; hOV 0 [< pp env'' rn'' false e >]; 'fNL; - 'sTR"in "; pID f' >]) + (hov 0 (str"let rec " ++ pID f' ++ pr_binding rn' bl ++ str" =" ++ fnl () ++ + str" " ++ hov 0 (pp env'' rn'' false e) ++ fnl () ++ + str"in " ++ pID f')) | Debug (_,e1) -> pp env rn par e1 | PPoint (_,d) -> pp_d env rn par d | Expression c -> @@ -317,21 +317,21 @@ let pp_prog id = let bl = map_succeed (function Statement p -> p | _ -> failwith "caught") bl in - prlist_with_sep (fun () -> [< 'sTR";"; 'fNL >]) - (fun p -> hOV 0 (pp env rn false p)) bl + prlist_with_sep (fun () -> (str";" ++ fnl ())) + (fun p -> hov 0 (pp env rn false p)) bl and pp env rn par p = - [< pp_d env rn par p.desc >] + (pp_d env rn par p.desc) and pp_mut v c = match v with | Ref _ -> - [< 'sTR"ref "; pp_constr empty rn_empty (extraction empty c) >] + (str"ref " ++ pp_constr empty rn_empty (extraction empty c)) | Array (n,_) -> - [< 'sTR"Array.create "; 'cUT; + (str"Array.create " ++ cut () ++ putpar true - [< 'sTR"int_of_z "; - pp_constr empty rn_empty (extraction empty n) >]; - 'sTR" "; pp_constr empty rn_empty (extraction empty c) >] + (str"int_of_z " ++ + pp_constr empty rn_empty (extraction empty n)) ++ + str" " ++ pp_constr empty rn_empty (extraction empty c)) | _ -> invalid_arg "pp_mut" in let v = lookup_global id in @@ -339,23 +339,23 @@ let pp_prog id = if is_mutable v then try let c = find_init id in - hOV 0 [< 'sTR"let "; pID id'; 'sTR" = "; pp_mut v c >] + hov 0 (str"let " ++ pID id' ++ str" = " ++ pp_mut v c) with Not_found -> errorlabstrm "Prog_extract.pp_prog" - [< 'sTR"The variable "; pID id; - 'sTR" must be initialized first !" >] + (str"The variable " ++ pID id ++ + str" must be initialized first !") else match find_pgm id with | None -> errorlabstrm "Prog_extract.pp_prog" - [< 'sTR"The program "; pID id; - 'sTR" must be realized first !" >] + (str"The program " ++ pID id ++ + str" must be realized first !") | Some p -> let bl,p = collect_lambda p in let rn = rename_binders rn_empty bl in let env = traverse_binders empty bl in - hOV 0 [< 'sTR"let "; pID id'; pr_binding rn bl; 'sTR" ="; 'fNL; - 'sTR" "; hOV 2 (pp env rn false p) >] + hov 0 (str"let " ++ pID id' ++ pr_binding rn bl ++ str" =" ++ fnl () ++ + str" " ++ hov 2 (pp env rn false p)) (* extraction des programmes impératifs/fonctionnels vers ocaml *) @@ -375,7 +375,7 @@ let import sp = match repr_path sp with | _ -> () let pp_ocaml file prm = - has_array := false; + has_array := false ++ (* on separe objects Coq et programmes *) let cic,pgms = List.fold_left @@ -404,7 +404,7 @@ let pp_ocaml file prm = in let cic' = SpSet.fold - (fun sp cic -> import sp; IdSet.add (basename sp) cic) + (fun sp cic -> import sp ++ IdSet.add (basename sp) cic) spl cic in (cic',IdSet.union pgms pgms',id::pl) @@ -414,23 +414,23 @@ let pp_ocaml file prm = in let cic = IdSet.elements cic in (* on pretty-print *) - let prm' = { needed = cic; expand = prm.expand; - expansion = prm.expansion; exact = prm.exact } + let prm' = { needed = cic ++ expand = prm.expand ++ + expansion = prm.expansion ++ exact = prm.exact } in - let strm = [< Ocaml.OCaml_pp_file.pp_recursive prm'; - 'fNL; 'fNL; - if !has_array then pp_conversions() else [< >]; - prlist (fun p -> [< pp_prog p; 'fNL; 'sTR";;"; 'fNL; 'fNL >]) + let strm = (Ocaml.OCaml_pp_file.pp_recursive prm' ++ + fnl () ++ fnl () ++ + if !has_array then pp_conversions() else (mt ()) ++ + prlist (fun p -> (pp_prog p ++ fnl () ++ str";;" ++ fnl () ++ fnl ())) pgms - >] +) in (* puis on ecrit dans le fichier *) let chan = open_trapping_failure open_out file ".ml" in let ft = with_output_to chan in begin - try pP_with ft strm ; pp_flush_with ft () - with e -> pp_flush_with ft () ; close_out chan; raise e - end; + try pP_with ft strm ++ pp_flush_with ft () + with e -> pp_flush_with ft () ++ close_out chan ++ raise e + end ++ close_out chan @@ -450,10 +450,10 @@ let initialize id com = initialize id c else errorlabstrm "Prog_extract.initialize" - [< 'sTR"Not the expected type for the mutable "; pID id >] + (str"Not the expected type for the mutable " ++ pID id) with Not_found -> errorlabstrm "Prog_extract.initialize" - [< pr_id id; 'sTR" is not a mutable" >] + (pr_id id ++ str" is not a mutable") (* grammaire *) @@ -467,6 +467,6 @@ let _ = vinterp_add "IMPERATIVEEXTRACTION" let _ = vinterp_add "INITIALIZE" (function - | [VARG_IDENTIFIER id ; VARG_COMMAND com] -> + | [VARG_IDENTIFIER id ++ VARG_COMMAND com] -> (fun () -> initialize id com) | _ -> assert false) diff --git a/contrib/correctness/pmisc.ml b/contrib/correctness/pmisc.ml index 6d04befe2..36e4f0dc9 100644 --- a/contrib/correctness/pmisc.ml +++ b/contrib/correctness/pmisc.ml @@ -22,7 +22,7 @@ let debug = ref false let deb_mess s = if !debug then begin - mSGNL s; pp_flush() + msgnl s; pp_flush() end let list_of_some = function diff --git a/contrib/correctness/prename.ml b/contrib/correctness/prename.ml index 122ff16ab..aa068f19c 100644 --- a/contrib/correctness/prename.ml +++ b/contrib/correctness/prename.ml @@ -111,8 +111,8 @@ let var_at_date r d id = find (until d r) id with Not_found -> raise (UserError ("Renamings.var_at_date", - hOV 0 [< 'sTR"Variable "; pr_id id; 'sTR" is unknown"; 'sPC; - 'sTR"at date "; 'sTR d >])) + hov 0 (str"Variable " ++ pr_id id ++ str" is unknown" ++ spc () ++ + str"at date " ++ str d))) let vars_at_date r d ids = let r' = until d r in List.map (fun id -> id,find r' id) ids @@ -125,15 +125,15 @@ open Util open Himsg let pp r = - hOV 2 (prlist_with_sep (fun () -> [< 'fNL >]) + hov 2 (prlist_with_sep (fun () -> (fnl ())) (fun (d,l) -> - [< 'sTR d; 'sTR": "; - prlist_with_sep (fun () -> [< 'sPC >]) + (str d ++ str": " ++ + prlist_with_sep (fun () -> (spc ())) (fun (id,id') -> - [< 'sTR"("; pr_id id; 'sTR","; pr_id id'; 'sTR")" >]) - l >]) + (str"(" ++ pr_id id ++ str"," ++ pr_id id' ++ str")")) + l)) r.levels) let ppr e = - pP (pp e) + Pp.pp (pp e) diff --git a/contrib/correctness/psyntax.ml4 b/contrib/correctness/psyntax.ml4 index 6b487348a..361791414 100644 --- a/contrib/correctness/psyntax.ml4 +++ b/contrib/correctness/psyntax.ml4 @@ -490,12 +490,12 @@ open Declare let is_assumed global ids = if List.length ids = 1 then - mSGNL [< 'sTR (if global then "A global variable " else ""); - pr_id (List.hd ids); 'sTR " is assumed" >] + msgnl (str (if global then "A global variable " else "") ++ + pr_id (List.hd ids) ++ str " is assumed") else - mSGNL [< 'sTR (if global then "Some global variables " else ""); - prlist_with_sep (fun () -> [< 'sTR ", " >]) pr_id ids; - 'sTR " are assumed" >] + msgnl (str (if global then "Some global variables " else "") ++ + prlist_with_sep (fun () -> (str ", ")) pr_id ids ++ + str " are assumed") let add = vinterp_add @@ -521,10 +521,10 @@ let _ = (fun () -> fold_all (fun (id,v) _ -> - mSGNL [< pr_id id; 'sTR " : "; - hOV 2 (match v with TypeV v -> pp_type_v v - | Set -> [< 'sTR "Set" >]); - 'fNL >]) + msgnl (pr_id id ++ str " : " ++ + hov 2 (match v with TypeV v -> pp_type_v v + | Set -> (str "Set")) ++ + fnl ())) Penv.empty ()) | _ -> assert false) @@ -539,7 +539,7 @@ let _ = List.iter (fun id -> if Penv.is_global id then Util.errorlabstrm "PROGVARIABLE" - [< 'sTR"Clash with previous constant "; pr_id id >]) + (str"Clash with previous constant " ++ pr_id id)) ids; let v = out_typev d in Pdb.check_type_v (all_refs ()) v; @@ -575,13 +575,13 @@ GEXTEND Gram | IDENT "Correctness"; s = IDENT; p = Programs.program; "." -> let d = Ast.dynamic (in_prog p) in - let str = Ast.str s in + let str = Ast.string s in <:ast< (CORRECTNESS $str (VERNACDYN $d)) >> | IDENT "Correctness"; s = IDENT; p = Programs.program; ";"; tac = Tactic.tactic; "." -> let d = Ast.dynamic (in_prog p) in - let str = Ast.str s in + let str = Ast.string s in <:ast< (CORRECTNESS $str (VERNACDYN $d) (TACTIC $tac)) >> ] ]; Pcoq.Vernac_.command: [ [ IDENT "Debug"; IDENT "on"; "." -> <:ast< (PROGDEBUGON) >> diff --git a/contrib/correctness/ptactic.ml b/contrib/correctness/ptactic.ml index 011c3c7e8..e8f10fc89 100644 --- a/contrib/correctness/ptactic.ml +++ b/contrib/correctness/ptactic.ml @@ -37,7 +37,7 @@ let coqast_of_prog p = let p = Pdb.db_prog p in (* 2. typage avec effets *) - deb_mess [< 'sTR"Ptyping.states: Typing with effects..."; 'fNL >]; + deb_mess (str"Ptyping.states: Typing with effects..." ++ fnl ()); let env = Penv.empty in let ren = initial_renaming env in let p = Ptyping.states ren env p in @@ -54,20 +54,20 @@ let coqast_of_prog p = (* 4b. traduction terme (terme intermédiaire de type cc_term) *) deb_mess - [< 'fNL; 'sTR"Mlize.trad: Translation program -> cc_term..."; 'fNL >]; + (fnl () ++ str"Mlize.trad: Translation program -> cc_term..." ++ fnl ()); let cc = Pmlize.trans ren p in let cc = Pred.red cc in deb_mess (Putil.pp_cc_term cc); (* 5. traduction en constr *) deb_mess - [< 'fNL; 'sTR"Pcic.constr_of_prog: Translation cc_term -> rawconstr..."; - 'fNL >]; + (fnl () ++ str"Pcic.constr_of_prog: Translation cc_term -> rawconstr..." ++ + fnl ()); let r = Pcic.rawconstr_of_prog cc in deb_mess (Printer.pr_rawterm r); (* 6. résolution implicites *) - deb_mess [< 'fNL; 'sTR"Resolution implicits (? => Meta(n))..."; 'fNL >]; + deb_mess (fnl () ++ str"Resolution implicits (? => Meta(n))..." ++ fnl ()); let oc = understand_gen_tcc Evd.empty (Global.env()) [] [] None r in deb_mess (Printer.prterm (snd oc)); @@ -227,9 +227,9 @@ let correctness s p opttac = start_proof id Declare.NeverDischarge sign cty; Penv.new_edited id (v,p); if !debug then show_open_subgoals(); - deb_mess [< 'sTR"Pred.red_cci: Reduction..."; 'fNL >]; + deb_mess (str"Pred.red_cci: Reduction..." ++ fnl ()); let oc = reduce_open_constr oc in - deb_mess [< 'sTR"AFTER REDUCTION:"; 'fNL >]; + deb_mess (str"AFTER REDUCTION:" ++ fnl ()); deb_mess (Printer.prterm (snd oc)); let tac = (tclTHEN (Refine.refine_tac oc) automatic) in let tac = match opttac with diff --git a/contrib/correctness/ptyping.ml b/contrib/correctness/ptyping.ml index 2e95f840f..a6f7a0ae9 100644 --- a/contrib/correctness/ptyping.ml +++ b/contrib/correctness/ptyping.ml @@ -529,7 +529,7 @@ let rec states_desc ren env loc = function if s_e.info.kappa = c then s_e else begin - if !verbose_fix then begin mSGNL (pp_type_c s_e.info.kappa) end ; + if !verbose_fix then begin msgnl (pp_type_c s_e.info.kappa) end ; state_rec s_e.info.kappa end in diff --git a/contrib/correctness/putil.ml b/contrib/correctness/putil.ml index 5e454a252..dbb903ab1 100644 --- a/contrib/correctness/putil.ml +++ b/contrib/correctness/putil.ml @@ -235,70 +235,70 @@ open Util open Printer let pp_pre = function - [] -> [< >] + [] -> (mt ()) | l -> - hOV 0 [< 'sTR"pre "; - prlist_with_sep (fun () -> [< 'sPC >]) - (fun x -> prterm x.p_value) l >] + hov 0 (str"pre " ++ + prlist_with_sep (fun () -> (spc ())) + (fun x -> prterm x.p_value) l) let pp_post = function - None -> [< >] - | Some c -> hOV 0 [< 'sTR"post "; prterm c.a_value >] + None -> (mt ()) + | Some c -> hov 0 (str"post " ++ prterm c.a_value) let rec pp_type_v = function - Ref v -> hOV 0 [< pp_type_v v; 'sPC; 'sTR"ref" >] - | Array (cc,v) -> hOV 0 [< 'sTR"array "; prterm cc; 'sTR" of "; pp_type_v v >] + Ref v -> hov 0 (pp_type_v v ++ spc () ++ str"ref") + | Array (cc,v) -> hov 0 (str"array " ++ prterm cc ++ str" of " ++ pp_type_v v) | Arrow (b,c) -> - hOV 0 [< prlist_with_sep (fun () -> [< >]) pp_binder b; - pp_type_c c >] + hov 0 (prlist_with_sep (fun () -> (mt ())) pp_binder b ++ + pp_type_c c) | TypePure c -> prterm c and pp_type_c ((id,v),e,p,q) = - hOV 0 [< 'sTR"returns "; pr_id id; 'sTR":"; pp_type_v v; 'sPC; - Peffect.pp e; 'sPC; pp_pre p; 'sPC; pp_post q ; - 'sPC; 'sTR"end" >] + hov 0 (str"returns " ++ pr_id id ++ str":" ++ pp_type_v v ++ spc () ++ + Peffect.pp e ++ spc () ++ pp_pre p ++ spc () ++ pp_post q ++ + spc () ++ str"end") and pp_binder = function - id,BindType v -> [< 'sTR"("; pr_id id; 'sTR":"; pp_type_v v; 'sTR")" >] - | id,BindSet -> [< 'sTR"("; pr_id id; 'sTR":Set)" >] - | id,Untyped -> [< 'sTR"("; pr_id id; 'sTR")" >] + id,BindType v -> (str"(" ++ pr_id id ++ str":" ++ pp_type_v v ++ str")") + | id,BindSet -> (str"(" ++ pr_id id ++ str":Set)") + | id,Untyped -> (str"(" ++ pr_id id ++ str")") (* pretty-print of cc-terms (intermediate terms) *) let rec pp_cc_term = function CC_var id -> pr_id id | CC_letin (_,_,bl,c,c1) -> - hOV 0 [< hOV 2 [< 'sTR"let "; - prlist_with_sep (fun () -> [< 'sTR"," >]) - (fun (id,_) -> pr_id id) bl; - 'sTR" ="; 'sPC; - pp_cc_term c; - 'sTR " in">]; - 'fNL; - pp_cc_term c1 >] + hov 0 (hov 2 (str"let " ++ + prlist_with_sep (fun () -> (str",")) + (fun (id,_) -> pr_id id) bl ++ + str" =" ++ spc () ++ + pp_cc_term c ++ + str " in") ++ + fnl () ++ + pp_cc_term c1) | CC_lam (bl,c) -> - hOV 2 [< prlist (fun (id,_) -> [< 'sTR"["; pr_id id; 'sTR"]" >]) bl; - 'cUT; - pp_cc_term c >] + hov 2 (prlist (fun (id,_) -> (str"[" ++ pr_id id ++ str"]")) bl ++ + cut () ++ + pp_cc_term c) | CC_app (f,args) -> - hOV 2 [< 'sTR"("; - pp_cc_term f; 'sPC; - prlist_with_sep (fun () -> [< 'sPC >]) pp_cc_term args; - 'sTR")" >] + hov 2 (str"(" ++ + pp_cc_term f ++ spc () ++ + prlist_with_sep (fun () -> (spc ())) pp_cc_term args ++ + str")") | CC_tuple (_,_,cl) -> - hOV 2 [< 'sTR"("; - prlist_with_sep (fun () -> [< 'sTR","; 'cUT >]) - pp_cc_term cl; - 'sTR")" >] + hov 2 (str"(" ++ + prlist_with_sep (fun () -> (str"," ++ cut ())) + pp_cc_term cl ++ + str")") | CC_case (_,b,[e1;e2]) -> - hOV 0 [< 'sTR"if "; pp_cc_term b; 'sTR" then"; 'fNL; - 'sTR" "; hOV 0 (pp_cc_term e1); 'fNL; - 'sTR"else"; 'fNL; - 'sTR" "; hOV 0 (pp_cc_term e2) >] + hov 0 (str"if " ++ pp_cc_term b ++ str" then" ++ fnl () ++ + str" " ++ hov 0 (pp_cc_term e1) ++ fnl () ++ + str"else" ++ fnl () ++ + str" " ++ hov 0 (pp_cc_term e2)) | CC_case _ -> - hOV 0 [< 'sTR"<Case: not yet implemented>" >] + hov 0 (str"<Case: not yet implemented>") | CC_expr c -> - hOV 0 (prterm c) + hov 0 (prterm c) | CC_hole c -> - [< 'sTR"(?::"; prterm c; 'sTR")" >] + (str"(?::" ++ prterm c ++ str")") diff --git a/contrib/extraction/common.ml b/contrib/extraction/common.ml index 9b111bbf4..9467986ef 100644 --- a/contrib/extraction/common.ml +++ b/contrib/extraction/common.ml @@ -45,8 +45,8 @@ let long_module r = try dirpath_prefix d with _ -> errorlabstrm "long_module_message" - [< 'sTR "Can't find the module of"; 'sPC; - Printer.pr_global r >] + (str "Can't find the module of" ++ spc () ++ + Printer.pr_global r) in check_module d' in check_module (dirpath (sp_of_r r)) @@ -210,10 +210,10 @@ let extract_to_file f prm decls = in let cout = open_out f in let ft = Pp_control.with_output_to cout in - if decls <> [] then pP_with ft (hV 0 (preamble prm)); + if decls <> [] then pp_with ft (hv 0 (preamble prm)); begin try - List.iter (fun d -> mSGNL_with ft (pp_decl d)) decls + List.iter (fun d -> msgnl_with ft (pp_decl d)) decls with e -> pp_flush_with ft (); close_out cout; raise e end; diff --git a/contrib/extraction/extract_env.ml b/contrib/extraction/extract_env.ml index 8ce82a45b..ce367c1c2 100644 --- a/contrib/extraction/extract_env.ml +++ b/contrib/extraction/extract_env.ml @@ -32,16 +32,16 @@ let module_of_id m = locate_loaded_library (make_short_qualid m) with Not_found -> errorlabstrm "module_message" - [< 'sTR "Module"; 'sPC;pr_id m; 'sPC; 'sTR "not found." >] + (str "Module" ++ spc () ++ pr_id m ++ spc () ++ str "not found.") (*s Module name clash verification. *) let clash_error sn n1 n2 = errorlabstrm "clash_module_message" - [< 'sTR ("There are two Coq modules with ML name " ^ sn ^" :"); - 'fNL ; 'sTR (" "^(string_of_dirpath n1)) ; - 'fNL ; 'sTR (" "^(string_of_dirpath n2)) ; - 'fNL ; 'sTR "This is not allowed in ML. Please do some renaming first." >] + (str ("There are two Coq modules with ML name " ^ sn ^" :") ++ + fnl () ++ str (" "^(string_of_dirpath n1)) ++ + fnl () ++ str (" "^(string_of_dirpath n2)) ++ + fnl () ++ str "This is not allowed in ML. Please do some renaming first.") let check_r m sm r = let rm = String.capitalize (string_of_id (short_module r)) in @@ -205,8 +205,8 @@ let local_optimize refs = optimize prm (decl_of_refs refs) let print_user_extract r = - mSGNL [< 'sTR "User defined extraction:"; - 'sPC; 'sTR (find_ml_extraction r) ; 'fNL>] + msgnl (str "User defined extraction:" ++ + spc () ++ str (find_ml_extraction r) ++ fnl ()) let decl_in_r r0 = function | Dglob (r,_) -> r = r0 @@ -220,7 +220,7 @@ let extract_reference r = print_user_extract r else let d = list_last (local_optimize [r]) in - mSGNL (ToplevelPp.pp_decl + msgnl (ToplevelPp.pp_decl (if (decl_in_r r d) || d = Dtype([],true) || d = Dtype([],false) then d else List.find (decl_in_r r) (local_optimize [r]))) @@ -239,8 +239,8 @@ let _ = (* Otherwise, output the ML type or expression *) | _ -> match extract_constr (Global.env()) c with - | Emltype (t,_,_) -> mSGNL (ToplevelPp.pp_type t) - | Emlterm a -> mSGNL (ToplevelPp.pp_ast (normalize a))) + | Emltype (t,_,_) -> msgnl (ToplevelPp.pp_type t) + | Emlterm a -> msgnl (ToplevelPp.pp_ast (normalize a))) | _ -> assert false) (*s Recursive extraction in the Coq toplevel. The vernacular command is @@ -255,7 +255,7 @@ let _ = let rl = List.filter (fun x -> not (is_ml_extraction x)) rl in let dl = local_optimize rl in List.iter print_user_extract ml_rl ; - List.iter (fun d -> mSGNL (ToplevelPp.pp_decl d)) dl) + List.iter (fun d -> msgnl (ToplevelPp.pp_decl d)) dl) (*s Extraction to a file (necessarily recursive). The vernacular command is \verb!Extraction "file"! [qualid1] ... [qualidn]. diff --git a/contrib/extraction/extraction.ml b/contrib/extraction/extraction.ml index 132367de9..b9a43fd04 100644 --- a/contrib/extraction/extraction.ml +++ b/contrib/extraction/extraction.ml @@ -244,12 +244,12 @@ let decompose_lam_eta n env c = let axiom_message sp = errorlabstrm "axiom_message" - [< 'sTR "You must specify an extraction for axiom"; 'sPC; - pr_sp sp; 'sPC; 'sTR "first" >] + (str "You must specify an extraction for axiom" ++ spc () ++ + pr_sp sp ++ spc () ++ str "first") let section_message () = errorlabstrm "section_message" - [< 'sTR "You can't extract within a section. Close it and try again" >] + (str "You can't extract within a section. Close it and try again") (*s Tables to keep the extraction of inductive types and constructors. *) @@ -421,8 +421,8 @@ and extract_type_app env (r,sc,vlc) vl args = let args = if diff > 0 then begin (* This can (normally) only happen when r is a flexible type. We discard the remaining arguments *) - (*i wARN (hOV 0 [< 'sTR ("Discarding " ^ - (string_of_int diff) ^ " type(s) argument(s).") >]); i*) + (*i wARN (hov 0 (str ("Discarding " ^ + (string_of_int diff) ^ " type(s) argument(s)."))); i*) list_firstn (List.length sc) args end else args in let nargs = List.length args in diff --git a/contrib/extraction/haskell.ml b/contrib/extraction/haskell.ml index 8d5cf6ebe..499503f17 100644 --- a/contrib/extraction/haskell.ml +++ b/contrib/extraction/haskell.ml @@ -36,11 +36,11 @@ let preamble prm = | None -> "Main" | Some m -> String.capitalize (string_of_id m) in - [< 'sTR "module "; 'sTR m; 'sTR " where"; 'fNL; 'fNL; - 'sTR "type Prop = ()"; 'fNL; - 'sTR "prop = ()"; 'fNL; 'fNL; - 'sTR "type Arity = ()"; 'fNL; - 'sTR "arity = ()"; 'fNL; 'fNL >] + (str "module " ++ str m ++ str " where" ++ fnl () ++ fnl () ++ + str "type Prop = ()" ++ fnl () ++ + str "prop = ()" ++ fnl () ++ fnl () ++ + str "type Arity = ()" ++ fnl () ++ + str "arity = ()" ++ fnl () ++ fnl ()) (*s The pretty-printing functor. *) @@ -65,23 +65,23 @@ let rec pp_type par t = | [] -> assert false | [t] -> pp_rec par t | t::l -> - [< open_par par; - pp_rec false t; 'sPC; - prlist_with_sep (fun () -> [< 'sPC >]) (pp_type true) l; - close_par par >]) + (open_par par ++ + pp_rec false t ++ spc () ++ + prlist_with_sep (fun () -> (spc ())) (pp_type true) l ++ + close_par par)) | Tarr (t1,t2) -> - [< open_par par; pp_rec true t1; 'sPC; 'sTR "->"; 'sPC; - pp_rec false t2; close_par par >] + (open_par par ++ pp_rec true t1 ++ spc () ++ str "->" ++ spc () ++ + pp_rec false t2 ++ close_par par) | Tglob r -> pp_type_global r | Texn s -> - [< string ("() -- " ^ s) ; 'fNL >] + (string ("() -- " ^ s) ++ fnl ()) | Tprop -> string "Prop" | Tarity -> string "Arity" in - hOV 0 (pp_rec par t) + hov 0 (pp_rec par t) (*s Pretty-printing of expressions. [par] indicates whether parentheses are needed or not. [env] is the list of names for the @@ -96,9 +96,9 @@ let expr_needs_par = function let rec pp_expr par env args = let apply st = match args with | [] -> st - | _ -> hOV 2 [< open_par par; st; 'sPC; - prlist_with_sep (fun () -> [< 'sPC >]) (fun s -> s) args; - close_par par >] + | _ -> hov 2 (open_par par ++ st ++ spc () ++ + prlist_with_sep (fun () -> (spc ())) (fun s -> s) args ++ + close_par par) in function | MLrel n -> @@ -109,155 +109,155 @@ let rec pp_expr par env args = | MLlam _ as a -> let fl,a' = collect_lams a in let fl,env' = push_vars fl env in - let st = [< pp_abst (List.rev fl); pp_expr false env' [] a' >] in + let st = (pp_abst (List.rev fl) ++ pp_expr false env' [] a') in if args = [] then - [< open_par par; st; close_par par >] + (open_par par ++ st ++ close_par par) else - apply [< 'sTR "("; st; 'sTR ")" >] + apply (str "(" ++ st ++ str ")") | MLletin (id,a1,a2) -> let id',env' = push_vars [id] env in let par' = par || args <> [] in let par2 = not par' && expr_needs_par a2 in apply - (hOV 0 [< open_par par'; - hOV 2 [< 'sTR "let "; pr_id (List.hd id'); 'sTR " ="; 'sPC; - pp_expr false env [] a1; 'sPC; 'sTR "in" >]; - 'sPC; - pp_expr par2 env' [] a2; - close_par par' >]) + (hov 0 (open_par par' ++ + hov 2 (str "let " ++ pr_id (List.hd id') ++ str " =" ++ spc () ++ + pp_expr false env [] a1 ++ spc () ++ str "in") ++ + spc () ++ + pp_expr par2 env' [] a2 ++ + close_par par')) | MLglob r -> apply (pp_global r) | MLcons (r,[]) -> pp_global r | MLcons (r,[a]) -> - [< open_par par; pp_global r; 'sPC; - pp_expr true env [] a; close_par par >] + (open_par par ++ pp_global r ++ spc () ++ + pp_expr true env [] a ++ close_par par) | MLcons (r,args') -> - [< open_par par; pp_global r; 'sPC; - prlist_with_sep (fun () -> [< 'sPC >]) (pp_expr true env []) args'; - close_par par >] + (open_par par ++ pp_global r ++ spc () ++ + prlist_with_sep (fun () -> (spc ())) (pp_expr true env []) args' ++ + close_par par) | MLcase (t, pv) -> apply - [< if args <> [] then [< 'sTR "(" >] else open_par par; - v 0 [< 'sTR "case "; pp_expr false env [] t; 'sTR " of"; - 'fNL; 'sTR " "; pp_pat env pv >]; - if args <> [] then [< 'sTR ")" >] else close_par par >] + (if args <> [] then (str "(") else open_par par ++ + v 0 (str "case " ++ pp_expr false env [] t ++ str " of" ++ + fnl () ++ str " " ++ pp_pat env pv) ++ + if args <> [] then (str ")") else close_par par) | MLfix (i,ids,defs) -> let ids',env' = push_vars (List.rev (Array.to_list ids)) env in pp_fix par env' (Some i) (Array.of_list (List.rev ids'),defs) args - | MLexn str -> - [< open_par par; 'sTR "error"; 'sPC; 'qS str; close_par par >] + | MLexn s -> + (open_par par ++ str "error" ++ spc () ++ qs s ++ close_par par) | MLprop -> string "prop" | MLarity -> string "arity" | MLcast (a,t) -> - [< open_par true; pp_expr false env args a; 'sPC; 'sTR "::"; 'sPC; - pp_type false t; close_par true >] + (open_par true ++ pp_expr false env args a ++ spc () ++ str "::" ++ spc () ++ + pp_type false t ++ close_par true) | MLmagic a -> - [< open_par true; 'sTR "Obj.magic"; 'sPC; - pp_expr false env args a; close_par true >] + (open_par true ++ str "Obj.magic" ++ spc () ++ + pp_expr false env args a ++ close_par true) and pp_pat env pv = let pp_one_pat (name,ids,t) = let ids,env' = push_vars (List.rev ids) env in let par = expr_needs_par t in - hOV 2 [< pp_global name; + hov 2 (pp_global name ++ begin match ids with - | [] -> [< >] - | _ -> [< 'sTR " "; + | [] -> (mt ()) + | _ -> (str " " ++ prlist_with_sep - (fun () -> [< 'sPC >]) pr_id (List.rev ids) >] - end; - 'sTR " ->"; 'sPC; pp_expr par env' [] t >] + (fun () -> (spc ())) pr_id (List.rev ids)) + end ++ + str " ->" ++ spc () ++ pp_expr par env' [] t) in - [< prvect_with_sep (fun () -> [< 'fNL; 'sTR " " >]) pp_one_pat pv >] + (prvect_with_sep (fun () -> (fnl () ++ str " ")) pp_one_pat pv) (*s names of the functions ([ids]) are already pushed in [env], and passed here just for convenience. *) and pp_fix par env in_p (ids,bl) args = - [< open_par par; - v 0 [< 'sTR "let { " ; + (open_par par ++ + v 0 (str "let { " ++ prvect_with_sep - (fun () -> [< 'sTR "; "; 'fNL >]) + (fun () -> (str "; " ++ fnl ())) (fun (fi,ti) -> pp_function env (pr_id fi) ti) - (array_map2 (fun id b -> (id,b)) ids bl); - 'sTR " }";'fNL; + (array_map2 (fun id b -> (id,b)) ids bl) ++ + str " }" ++fnl () ++ match in_p with | Some j -> - hOV 2 [< 'sTR "in "; pr_id ids.(j); + hov 2 (str "in " ++ pr_id ids.(j) ++ if args <> [] then - [< 'sTR " "; - prlist_with_sep (fun () -> [<'sTR " ">]) - (fun s -> s) args >] + (str " " ++ + prlist_with_sep (fun () -> (str " ")) + (fun s -> s) args) else - [< >] >] + (mt ())) | None -> - [< >] >]; - close_par par >] + (mt ())) ++ + close_par par) and pp_function env f t = let bl,t' = collect_lams t in let bl,env' = push_vars bl env in - [< f; pr_binding (List.rev bl); - 'sTR " ="; 'fNL; 'sTR " "; - hOV 2 (pp_expr false env' [] t') >] + (f ++ pr_binding (List.rev bl) ++ + str " =" ++ fnl () ++ str " " ++ + hov 2 (pp_expr false env' [] t')) -let pp_ast a = hOV 0 (pp_expr false (empty_env ()) [] a) +let pp_ast a = hov 0 (pp_expr false (empty_env ()) [] a) (*s Pretty-printing of inductive types declaration. *) let pp_one_inductive (pl,name,cl) = let pp_constructor (id,l) = - [< pp_global id; + (pp_global id ++ match l with - | [] -> [< >] - | _ -> [< 'sTR " " ; + | [] -> (mt ()) + | _ -> (str " " ++ prlist_with_sep - (fun () -> [< 'sTR " " >]) (pp_type true) l >] >] + (fun () -> (str " ")) (pp_type true) l)) in - [< 'sTR (if cl = [] then "type " else "data "); - pp_type_global name; 'sTR " "; - prlist_with_sep (fun () -> [< 'sTR " " >]) pr_lower_id pl; - if pl = [] then [< >] else [< 'sTR " " >]; - [< v 0 [< 'sTR "= "; - prlist_with_sep (fun () -> [< 'fNL; 'sTR " | " >]) - pp_constructor cl >] >] >] + (str (if cl = [] then "type " else "data ") ++ + pp_type_global name ++ str " " ++ + prlist_with_sep (fun () -> (str " ")) pr_lower_id pl ++ + if pl = [] then (mt ()) else (str " ") ++ + (v 0 (str "= " ++ + prlist_with_sep (fun () -> (fnl () ++ str " | ")) + pp_constructor cl))) let pp_inductive il = - [< prlist_with_sep (fun () -> [< 'fNL >]) pp_one_inductive il; 'fNL >] + (prlist_with_sep (fun () -> (fnl ())) pp_one_inductive il ++ fnl ()) (*s Pretty-printing of a declaration. *) let pp_decl = function | Dtype ([], _) -> - [< >] + (mt ()) | Dtype (i, _) -> - hOV 0 (pp_inductive i) + hov 0 (pp_inductive i) | Dabbrev (r, l, t) -> - hOV 0 [< 'sTR "type "; pp_type_global r; 'sPC; - prlist_with_sep (fun () -> [< 'sTR " " >]) pr_lower_id l; - if l <> [] then [< 'sTR " " >] else [< >]; 'sTR "="; 'sPC; - pp_type false t; 'fNL >] + hov 0 (str "type " ++ pp_type_global r ++ spc () ++ + prlist_with_sep (fun () -> (str " ")) pr_lower_id l ++ + if l <> [] then (str " ") else (mt ()) ++ str "=" ++ spc () ++ + pp_type false t ++ fnl ()) | Dglob (r, MLfix (i,ids,defs)) -> let env = empty_env () in let ids',env' = push_vars (List.rev (Array.to_list ids)) env in - [< prlist_with_sep (fun () -> [< 'fNL >]) + (prlist_with_sep (fun () -> (fnl ())) (fun (fi,ti) -> pp_function env' (pr_id fi) ti) - (List.combine (List.rev ids') (Array.to_list defs)); - 'fNL; + (List.combine (List.rev ids') (Array.to_list defs)) ++ + fnl () ++ let id = rename_global r in let idi = List.nth (List.rev ids') i in if id <> idi then - [< 'fNL; pr_id id; 'sTR " = "; pr_id idi; 'fNL >] + (fnl () ++ pr_id id ++ str " = " ++ pr_id idi ++ fnl ()) else - [< >] >] + (mt ())) | Dglob (r, a) -> - hOV 0 [< pp_function (empty_env ()) (pp_global r) a; 'fNL >] + hov 0 (pp_function (empty_env ()) (pp_global r) a ++ fnl ()) | Dcustom (r,s) -> - hOV 0 [< pp_global r; 'sTR " ="; - 'sPC; 'sTR s; 'fNL >] + hov 0 (pp_global r ++ str " =" ++ + spc () ++ str s ++ fnl ()) let pp_type = pp_type false diff --git a/contrib/extraction/mlutil.ml b/contrib/extraction/mlutil.ml index 32ad5053b..53408461f 100644 --- a/contrib/extraction/mlutil.ml +++ b/contrib/extraction/mlutil.ml @@ -581,15 +581,15 @@ let subst_glob_decl r m = function | d -> d let warning_expansion r = - wARN (hOV 0 [< 'sTR "The constant"; 'sPC; - Printer.pr_global r; -(*i 'sTR (" of size "^ (string_of_int (ml_size t))); i*) - 'sPC; 'sTR "is expanded." >]) + warn (hov 0 (str "The constant" ++ spc () ++ + Printer.pr_global r ++ +(*i str (" of size "^ (string_of_int (ml_size t))) ++ i*) + spc () ++ str "is expanded.")) let warning_expansion_must r = - wARN (hOV 0 [< 'sTR "The constant"; 'sPC; - Printer.pr_global r; - 'sPC; 'sTR "must be expanded." >]) + warn (hov 0 (str "The constant" ++ spc () ++ + Printer.pr_global r ++ + spc () ++ str "must be expanded.")) let print_ml_decl prm (r,_) = not (to_inline r) || List.mem r prm.to_appear diff --git a/contrib/extraction/ocaml.ml b/contrib/extraction/ocaml.ml index 778683646..36ccff88d 100644 --- a/contrib/extraction/ocaml.ml +++ b/contrib/extraction/ocaml.ml @@ -29,11 +29,11 @@ let rec collapse_type_app = function | (Tapp l1) :: l2 -> collapse_type_app (l1 @ l2) | l -> l -let string s = [< 'sTR s >] +let string s = (str s) -let open_par = function true -> string "(" | false -> [< >] +let open_par = function true -> string "(" | false -> (mt ()) -let close_par = function true -> string ")" | false -> [< >] +let close_par = function true -> string ")" | false -> (mt ()) let pp_tvar id = let s = string_of_id id in @@ -42,32 +42,32 @@ let pp_tvar id = else string ("' "^s) let pp_tuple f = function - | [] -> [< >] + | [] -> (mt ()) | [x] -> f x - | l -> [< 'sTR "("; - prlist_with_sep (fun () -> [< 'sTR ","; 'sPC >]) f l; - 'sTR ")" >] + | l -> (str "(" ++ + prlist_with_sep (fun () -> (str "," ++ spc ())) f l ++ + str ")") let pp_boxed_tuple f = function - | [] -> [< >] + | [] -> (mt ()) | [x] -> f x - | l -> [< 'sTR "("; - hOV 0 [< prlist_with_sep (fun () -> [< 'sTR ","; 'sPC >]) f l; - 'sTR ")" >] >] + | l -> (str "(" ++ + hov 0 (prlist_with_sep (fun () -> (str "," ++ spc ())) f l ++ + str ")")) let pp_abst = function - | [] -> [< >] - | l -> [< 'sTR "fun "; - prlist_with_sep (fun () -> [< 'sTR " " >]) pr_id l; - 'sTR " ->"; 'sPC >] + | [] -> (mt ()) + | l -> (str "fun " ++ + prlist_with_sep (fun () -> (str " ")) pr_id l ++ + str " ->" ++ spc ()) let pr_binding = function - | [] -> [< >] - | l -> [< 'sTR " "; prlist_with_sep (fun () -> [< 'sTR " " >]) pr_id l >] + | [] -> (mt ()) + | l -> (str " " ++ prlist_with_sep (fun () -> (str " ")) pr_id l) -let space_if = function true -> [< 'sTR " " >] | false -> [< >] +let space_if = function true -> (str " ") | false -> (mt ()) -let sec_space_if = function true -> [< 'sPC >] | false -> [< >] +let sec_space_if = function true -> (spc ()) | false -> (mt ()) (*s Generic renaming issues. *) @@ -114,10 +114,10 @@ let keywords = Idset.empty let preamble _ = - [< 'sTR "type prop = unit"; 'fNL; - 'sTR "let prop = ()"; 'fNL; 'fNL; - 'sTR "type arity = unit"; 'fNL; - 'sTR "let arity = ()"; 'fNL; 'fNL >] + (str "type prop = unit" ++ fnl () ++ + str "let prop = ()" ++ fnl () ++ fnl () ++ + str "type arity = unit" ++ fnl () ++ + str "let arity = ()" ++ fnl () ++ fnl ()) (*s The pretty-printing functor. *) @@ -140,12 +140,12 @@ let rec pp_type par t = (match collapse_type_app l with | [] -> assert false | [t] -> pp_rec par t - | t::l -> [< pp_tuple (pp_rec false) l; - sec_space_if (l <>[]); - pp_rec false t >]) + | t::l -> (pp_tuple (pp_rec false) l ++ + sec_space_if (l <>[]) ++ + pp_rec false t)) | Tarr (t1,t2) -> - [< open_par par; pp_rec true t1; 'sPC; 'sTR "->"; 'sPC; - pp_rec false t2; close_par par >] + (open_par par ++ pp_rec true t1 ++ spc () ++ str "->" ++ spc () ++ + pp_rec false t2 ++ close_par par) | Tglob r -> pp_type_global r | Texn s -> @@ -155,7 +155,7 @@ let rec pp_type par t = | Tarity -> string "arity" in - hOV 0 (pp_rec par t) + hov 0 (pp_rec par t) (*s Pretty-printing of expressions. [par] indicates whether parentheses are needed or not. [env] is the list of names for the @@ -171,9 +171,9 @@ let rec pp_expr par env args = let par' = args <> [] || par in let apply st = match args with | [] -> st - | _ -> hOV 2 [< open_par par; st; 'sPC; - prlist_with_sep (fun () -> [< 'sPC >]) (fun s -> s) args; - close_par par >] + | _ -> hov 2 (open_par par ++ st ++ spc () ++ + prlist_with_sep (fun () -> (spc ())) (fun s -> s) args ++ + close_par par) in function | MLrel n -> @@ -184,94 +184,94 @@ let rec pp_expr par env args = | MLlam _ as a -> let fl,a' = collect_lams a in let fl,env' = push_vars fl env in - let st = [< pp_abst (List.rev fl); pp_expr false env' [] a' >] in - [< open_par par'; st; close_par par' >] + let st = (pp_abst (List.rev fl) ++ pp_expr false env' [] a') in + (open_par par' ++ st ++ close_par par') | MLletin (id,a1,a2) -> let id',env' = push_vars [id] env in let par2 = not par' && expr_needs_par a2 in apply - (hOV 0 [< open_par par'; - hOV 2 [< 'sTR "let "; pr_id (List.hd id'); 'sTR " ="; 'sPC; - pp_expr false env [] a1; 'sPC; 'sTR "in" >]; - 'sPC; - pp_expr par2 env' [] a2; - close_par par' >]) + (hov 0 (open_par par' ++ + hov 2 (str "let " ++ pr_id (List.hd id') ++ str " =" ++ spc () ++ + pp_expr false env [] a1 ++ spc () ++ str "in") ++ + spc () ++ + pp_expr par2 env' [] a2 ++ + close_par par')) | MLglob r -> apply (pp_global r) | MLcons (r,[]) -> pp_global r | MLcons (r,[a]) -> - [< open_par par; pp_global r; 'sPC; - pp_expr true env [] a; close_par par >] + (open_par par ++ pp_global r ++ spc () ++ + pp_expr true env [] a ++ close_par par) | MLcons (r,args') -> - [< open_par par; pp_global r; 'sPC; - pp_tuple (pp_expr true env []) args'; close_par par >] + (open_par par ++ pp_global r ++ spc () ++ + pp_tuple (pp_expr true env []) args' ++ close_par par) | MLcase (t,[|x|])-> apply - (hOV 0 [< open_par par'; 'sTR "let "; + (hov 0 (open_par par' ++ str "let " ++ pp_one_pat - [< 'sTR " ="; 'sPC; - pp_expr false env [] t; 'sPC; 'sTR "in" >] - env x; - close_par par' >]) + (str " =" ++ spc () ++ + pp_expr false env [] t ++ spc () ++ str "in") + env x ++ + close_par par')) | MLcase (t, pv) -> apply - [< open_par par'; - v 0 [< 'sTR "match "; pp_expr false env [] t; 'sTR " with"; - 'fNL; 'sTR " "; pp_pat env pv >]; - close_par par' >] + (open_par par' ++ + v 0 (str "match " ++ pp_expr false env [] t ++ str " with" ++ + fnl () ++ str " " ++ pp_pat env pv) ++ + close_par par') | MLfix (i,ids,defs) -> let ids',env' = push_vars (List.rev (Array.to_list ids)) env in pp_fix par env' (Some i) (Array.of_list (List.rev ids'),defs) args - | MLexn str -> - [< open_par par; 'sTR "assert false"; 'sPC; - 'sTR ("(* "^str^" *)"); close_par par >] + | MLexn s -> + (open_par par ++ str "assert false" ++ spc () ++ + str ("(* "^s^" *)") ++ close_par par) | MLprop -> string "prop" | MLarity -> string "arity" | MLcast (a,t) -> - [< open_par true; pp_expr false env args a; 'sPC; 'sTR ":"; 'sPC; - pp_type false t; close_par true >] + (open_par true ++ pp_expr false env args a ++ spc () ++ str ":" ++ spc () ++ + pp_type false t ++ close_par true) | MLmagic a -> - [< open_par true; 'sTR "Obj.magic"; 'sPC; - pp_expr false env args a; close_par true >] + (open_par true ++ str "Obj.magic" ++ spc () ++ + pp_expr false env args a ++ close_par true) and pp_one_pat s env (r,ids,t) = let ids,env' = push_vars (List.rev ids) env in let par = expr_needs_par t in - [< pp_global r; - if ids = [] then [< >] - else [< 'sTR " "; pp_boxed_tuple pr_id (List.rev ids) >]; - s; 'sPC; pp_expr par env' [] t >] + (pp_global r ++ + if ids = [] then (mt ()) + else (str " " ++ pp_boxed_tuple pr_id (List.rev ids)) ++ + s ++ spc () ++ pp_expr par env' [] t) and pp_pat env pv = - [< prvect_with_sep (fun () -> [< 'fNL; 'sTR "| " >]) - (fun x -> hOV 2 (pp_one_pat (string " ->") env x)) pv >] + (prvect_with_sep (fun () -> (fnl () ++ str "| ")) + (fun x -> hov 2 (pp_one_pat (string " ->") env x)) pv) (*s names of the functions ([ids]) are already pushed in [env], and passed here just for convenience. *) and pp_fix par env in_p (ids,bl) args = - [< open_par par; - v 0 [< 'sTR "let rec " ; + (open_par par ++ + v 0 (str "let rec " ++ prvect_with_sep - (fun () -> [< 'fNL; 'sTR "and " >]) + (fun () -> (fnl () ++ str "and ")) (fun (fi,ti) -> pp_function env (pr_id fi) ti) - (array_map2 (fun id b -> (id,b)) ids bl); - 'fNL; + (array_map2 (fun id b -> (id,b)) ids bl) ++ + fnl () ++ match in_p with | Some j -> - hOV 2 [< 'sTR "in "; pr_id (ids.(j)); + hov 2 (str "in " ++ pr_id (ids.(j)) ++ if args <> [] then - [< 'sTR " "; - prlist_with_sep (fun () -> [<'sTR " ">]) - (fun s -> s) args >] + (str " " ++ + prlist_with_sep (fun () -> (str " ")) + (fun s -> s) args) else - [< >] >] + (mt ())) | None -> - [< >] >]; - close_par par >] + (mt ())) ++ + close_par par) and pp_function env f t = let bl,t' = collect_lams t in @@ -283,77 +283,77 @@ and pp_function env f t = match t' with | MLcase(MLrel 1,pv) -> if is_function pv then - [< f; pr_binding (List.rev (List.tl bl)) ; - 'sTR " = function"; 'fNL; - v 0 [< 'sTR " "; pp_pat env' pv >] >] + (f ++ pr_binding (List.rev (List.tl bl)) ++ + str " = function" ++ fnl () ++ + v 0 (str " " ++ pp_pat env' pv)) else - [< f; pr_binding (List.rev bl); - 'sTR " = match "; - pr_id (List.hd bl); 'sTR " with"; 'fNL; - v 0 [< 'sTR " "; pp_pat env' pv >] >] + (f ++ pr_binding (List.rev bl) ++ + str " = match " ++ + pr_id (List.hd bl) ++ str " with" ++ fnl () ++ + v 0 (str " " ++ pp_pat env' pv)) - | _ -> [< f; pr_binding (List.rev bl); - 'sTR " ="; 'fNL; 'sTR " "; - hOV 2 (pp_expr false env' [] t') >] + | _ -> (f ++ pr_binding (List.rev bl) ++ + str " =" ++ fnl () ++ str " " ++ + hov 2 (pp_expr false env' [] t')) -let pp_ast a = hOV 0 (pp_expr false (empty_env ()) [] a) +let pp_ast a = hov 0 (pp_expr false (empty_env ()) [] a) (*s Pretty-printing of inductive types declaration. *) let pp_parameters l = - [< pp_tuple pp_tvar l; space_if (l<>[]) >] + (pp_tuple pp_tvar l ++ space_if (l<>[])) let pp_one_inductive (pl,name,cl) = let pp_constructor (id,l) = - [< pp_global id; + (pp_global id ++ match l with - | [] -> [< >] - | _ -> [< 'sTR " of " ; + | [] -> (mt ()) + | _ -> (str " of " ++ prlist_with_sep - (fun () -> [< 'sPC ; 'sTR "* " >]) (pp_type true) l >] >] + (fun () -> (spc () ++ str "* ")) (pp_type true) l)) in - [< pp_parameters pl; pp_type_global name; 'sTR " ="; - [< 'fNL; - v 0 [< 'sTR " "; - prlist_with_sep (fun () -> [< 'fNL; 'sTR " | " >]) - (fun c -> hOV 2 (pp_constructor c)) cl >] >] >] + (pp_parameters pl ++ pp_type_global name ++ str " =" ++ + (fnl () ++ + v 0 (str " " ++ + prlist_with_sep (fun () -> (fnl () ++ str " | ")) + (fun c -> hov 2 (pp_constructor c)) cl))) let pp_inductive il = - [< 'sTR "type "; - prlist_with_sep (fun () -> [< 'fNL; 'sTR "and " >]) pp_one_inductive il; - 'fNL >] + (str "type " ++ + prlist_with_sep (fun () -> (fnl () ++ str "and ")) pp_one_inductive il ++ + fnl ()) (*s Pretty-printing of a declaration. *) let warning_coinductive r = - wARN (hOV 0 - [< 'sTR "You are trying to extract the CoInductive definition"; 'sPC; - Printer.pr_global r; 'sPC; 'sTR "in Ocaml."; 'sPC; - 'sTR "This is in general NOT a good idea,"; 'sPC; - 'sTR "since Ocaml is not lazy."; 'sPC; - 'sTR "You should consider using Haskell instead." >]) + warn (hov 0 + (str "You are trying to extract the CoInductive definition" ++ spc () ++ + Printer.pr_global r ++ spc () ++ str "in Ocaml." ++ spc () ++ + str "This is in general NOT a good idea," ++ spc () ++ + str "since Ocaml is not lazy." ++ spc () ++ + str "You should consider using Haskell instead.")) let pp_decl = function | Dtype ([], _) -> - if P.toplevel then hOV 0 [< 'sTR " prop (* Logic inductive *)"; 'fNL >] - else [< >] + if P.toplevel then hov 0 (str " prop (* Logic inductive *)" ++ fnl ()) + else (mt ()) | Dtype ((_,r,_)::_ as i, cofix) -> if cofix && (not P.toplevel) then if_verbose warning_coinductive r; - hOV 0 (pp_inductive i) + hov 0 (pp_inductive i) | Dabbrev (r, l, t) -> - hOV 0 [< 'sTR "type"; 'sPC; pp_parameters l; - pp_type_global r; 'sPC; 'sTR "="; 'sPC; - pp_type false t; 'fNL >] + hov 0 (str "type" ++ spc () ++ pp_parameters l ++ + pp_type_global r ++ spc () ++ str "=" ++ spc () ++ + pp_type false t ++ fnl ()) | Dglob (r, MLfix (_,[|_|],[|def|])) -> let id = rename_global r in let env' = [id], P.globals() in - [< hOV 2 (pp_fix false env' None ([|id|],[|def|]) []) >] + (hov 2 (pp_fix false env' None ([|id|],[|def|]) [])) | Dglob (r, a) -> - hOV 0 [< 'sTR "let "; - pp_function (empty_env ()) (pp_global r) a; 'fNL >] + hov 0 (str "let " ++ + pp_function (empty_env ()) (pp_global r) a ++ fnl ()) | Dcustom (r,s) -> - hOV 0 [< 'sTR "let "; pp_global r; - 'sTR " ="; 'sPC; 'sTR s; 'fNL >] + hov 0 (str "let " ++ pp_global r ++ + str " =" ++ spc () ++ str s ++ fnl ()) let pp_type = pp_type false diff --git a/contrib/extraction/table.ml b/contrib/extraction/table.ml index 8c8138fd0..a45490f20 100644 --- a/contrib/extraction/table.ml +++ b/contrib/extraction/table.ml @@ -64,7 +64,7 @@ let is_constant r = match r with let check_constant r = if (is_constant r) then r else errorlabstrm "extract_constant" - [< Printer.pr_global r; 'sPC; 'sTR "is not a constant" >] + (Printer.pr_global r ++ spc () ++ str "is not a constant") let string_of_varg = function | VARG_IDENTIFIER id -> string_of_id id @@ -73,7 +73,7 @@ let string_of_varg = function let no_such_reference q = errorlabstrm "reference_of_varg" - [< Nametab.pr_qualid q; 'sTR ": no such reference" >] + (Nametab.pr_qualid q ++ str ": no such reference") let reference_of_varg = function | VARG_QUALID q -> @@ -135,14 +135,14 @@ let _ = let print_inline () = let (i,n)= !inline_table in let i'= Refset.filter is_constant i in - mSG - [< 'sTR "Extraction Inline:"; 'fNL; + msg + (str "Extraction Inline:" ++ fnl () ++ Refset.fold - (fun r p -> [< p; 'sTR " " ; Printer.pr_global r ; 'fNL >]) i' [<>]; - 'sTR "Extraction NoInline:"; 'fNL; + (fun r p -> (p ++ str " " ++ Printer.pr_global r ++ fnl ())) i' (mt ()) ++ + str "Extraction NoInline:" ++ fnl () ++ Refset.fold - (fun r p -> [< p; 'sTR " " ; Printer.pr_global r ; 'fNL >]) n [<>] - >] + (fun r p -> (p ++ str " " ++ Printer.pr_global r ++ fnl ())) n (mt ()) +) let _ = vinterp_add "PrintExtractionInline" (fun _ -> print_inline) @@ -237,7 +237,7 @@ let extract_inductive r (id2,l2) = match r with add_anonymous_leaf (in_ml_extraction (r,s))) l2 | _ -> errorlabstrm "extract_inductive" - [< Printer.pr_global r; 'sPC; 'sTR "is not an inductive type" >] + (Printer.pr_global r ++ spc () ++ str "is not an inductive type") let _ = vinterp_add "ExtractInductive" diff --git a/contrib/interface/centaur.ml b/contrib/interface/centaur.ml index eae99993f..00db51adf 100644 --- a/contrib/interface/centaur.ml +++ b/contrib/interface/centaur.ml @@ -54,11 +54,11 @@ set_flags := (function () -> (g_nat_syntax_flag := true; ()) else ());; -let guarded_force_eval_stream s = +let guarded_force_eval_stream (s : std_ppcmds) = let l = ref [] in let f elt = l:= elt :: !l in (try Stream.iter f s with - | _ -> f (sTR "error guarded_force_eval_stream")); + | _ -> f (Stream.next (str "error guarded_force_eval_stream"))); Stream.of_list (List.rev !l);; @@ -67,7 +67,7 @@ let rec string_of_path p = | i::p -> (string_of_int i)^" "^ (string_of_path p) ;; let print_path p = - output_results_nl [< 'sTR "Path:"; 'sTR (string_of_path p)>] + output_results_nl (str "Path:" ++ str (string_of_path p)) ;; let kill_proof_node index = @@ -83,7 +83,8 @@ let kill_proof_node index = (*Message functions, the text of these messages is recognized by the protocols *) (*of CtCoq *) let ctf_header message_name request_id = - [< 'fNL; 'sTR "message"; 'fNL; 'sTR message_name; 'fNL; 'iNT request_id; 'fNL >];; + fnl () ++ str "message" ++ fnl () ++ str message_name ++ fnl () ++ + int request_id ++ fnl ();; let ctf_acknowledge_command request_id command_count opt_exn = let goal_count, goal_index = @@ -94,14 +95,14 @@ let ctf_acknowledge_command request_id command_count opt_exn = g_count, (min g_count !current_goal_index) else (0, 0) in - [< ctf_header "acknowledge" request_id; - 'iNT command_count; 'fNL; - 'iNT goal_count; 'fNL; - 'iNT goal_index; 'fNL; - 'sTR !current_proof_name; 'fNL; - (match opt_exn with - Some e -> Errors.explain_exn e - | None -> [< >]); 'fNL; 'sTR "E-n-d---M-e-s-s-a-g-e"; 'fNL >];; + (ctf_header "acknowledge" request_id ++ + int command_count ++ fnl () ++ + int goal_count ++ fnl () ++ + int goal_index ++ fnl () ++ + str !current_proof_name ++ fnl () ++ + (match opt_exn with + Some e -> Errors.explain_exn e + | None -> mt ()) ++ fnl () ++ str "E-n-d---M-e-s-s-a-g-e" ++ fnl ());; let ctf_undoResults = ctf_header "undo_results";; @@ -116,35 +117,37 @@ let ctf_Location = ctf_header "location";; let ctf_StateMessage = ctf_header "state";; let ctf_PathGoalMessage () = - [< 'fNL; 'sTR "message"; 'fNL; 'sTR "single_goal"; 'fNL >];; + fnl () ++ str "message" ++ fnl () ++ str "single_goal" ++ fnl ();; let ctf_GoalReqIdMessage = ctf_header "single_goal_state";; let ctf_NewStateMessage = ctf_header "fresh_state";; -let ctf_SavedMessage () = [< 'fNL; 'sTR "message"; 'fNL; 'sTR "saved"; 'fNL >];; +let ctf_SavedMessage () = fnl () ++ str "message" ++ fnl () ++ str "saved" ++ fnl ();; let ctf_KilledMessage req_id ngoals = - [< ctf_header "killed" req_id; 'iNT ngoals; 'fNL >];; + ctf_header "killed" req_id ++ int ngoals ++ fnl ();; let ctf_AbortedAllMessage () = - [< 'fNL; 'sTR "message"; 'fNL; 'sTR "aborted_all"; 'fNL >];; + fnl () ++ str "message" ++ fnl () ++ str "aborted_all" ++ fnl ();; let ctf_AbortedMessage request_id na = - [< 'fNL; 'sTR "message"; 'fNL; 'sTR "aborted_proof"; 'fNL; 'iNT request_id; 'fNL; - 'sTR na; 'fNL; 'sTR "E-n-d---M-e-s-s-a-g-e"; 'fNL >];; + fnl () ++ str "message" ++ fnl () ++ str "aborted_proof" ++ fnl () ++ + int request_id ++ fnl () ++ + str na ++ fnl () ++ str "E-n-d---M-e-s-s-a-g-e" ++ fnl ();; let ctf_UserErrorMessage request_id stream = - let stream = guarded_force_eval_stream stream in - [< 'fNL; 'sTR "message"; 'fNL; 'sTR "user_error"; 'fNL; 'iNT request_id; 'fNL; - stream; 'fNL; 'sTR "E-n-d---M-e-s-s-a-g-e"; 'fNL >];; + let stream = guarded_force_eval_stream stream in + fnl () ++ str "message" ++ fnl () ++ str "user_error" ++ fnl () ++ + int request_id ++ fnl () ++ + stream ++ fnl () ++ str "E-n-d---M-e-s-s-a-g-e" ++ fnl ();; let ctf_ResetInitialMessage () = - [< 'fNL; 'sTR "message"; 'fNL; 'sTR "reset_initial"; 'fNL >];; + fnl () ++ str "message" ++ fnl () ++ str "reset_initial" ++ fnl ();; -let ctf_ResetIdentMessage request_id str = - [< 'fNL; 'sTR "message"; 'fNL; 'sTR "reset_ident"; 'fNL; 'iNT request_id; 'fNL; - 'sTR str; 'fNL; 'sTR "E-n-d---M-e-s-s-a-g-e"; 'fNL >];; +let ctf_ResetIdentMessage request_id s = + fnl () ++ str "message" ++ fnl () ++ str "reset_ident" ++ fnl () ++ int request_id ++ fnl () ++ + str s ++ fnl () ++ str "E-n-d---M-e-s-s-a-g-e" ++ fnl ();; type vtp_tree = | P_rl of ct_RULE_LIST @@ -175,7 +178,7 @@ let break_happened = ref false;; let output_results stream vtp_tree = let _ = Sys.signal Sys.sigint (Sys.Signal_handle(fun i -> (break_happened := true;()))) in - mSG stream; + msg stream; match vtp_tree with Some t -> print_tree t | None -> ();; @@ -184,7 +187,7 @@ let output_results_nl stream = let _ = Sys.signal Sys.sigint (Sys.Signal_handle(fun i -> break_happened := true;())) in - mSGNL stream;; + msgnl stream;; let rearm_break () = @@ -216,7 +219,7 @@ let show_nth n = try let pf = proof_of_pftreestate (get_pftreestate()) in if (!text_proof_flag<>"off") then -(* errorlabstrm "debug" [< 'sTR "text printing unplugged" >]*) +(* errorlabstrm "debug" [< str "text printing unplugged" >]*) (if n=0 then output_results (ctf_TextMessage !global_request_id) (Some (P_text (show_proof !text_proof_flag []))) @@ -255,14 +258,14 @@ let add_search (global_reference:global_reference) assumptions cstr = CT_coerce_ID_to_FORMULA( CT_ident ("Error printing" ^ id_string))) in ctv_SEARCH_LIST:= ast::!ctv_SEARCH_LIST - with e -> mSGNL [< 'sTR "add_search raised an exception" >]; raise e;; + with e -> msgnl (str "add_search raised an exception"); raise e;; let make_error_stream node_string = - [< 'sTR "The syntax of "; 'sTR node_string; - 'sTR " is inconsistent with the vernac interpreter entry" >];; + str "The syntax of " ++ str node_string ++ + str " is inconsistent with the vernac interpreter entry";; let ctf_EmptyGoalMessage id = - [< 'fNL; 'sTR "Empty Goal is a no-op. Fun oh fun."; 'fNL >];; + fnl () ++ str "Empty Goal is a no-op. Fun oh fun." ++ fnl ();; let print_check (ast, judg) = @@ -271,15 +274,17 @@ let print_check (ast, judg) = (try translate_constr (Global.env()) value with UserError(f,str) -> raise(UserError(f, - [< Ast.print_ast - (ast_of_constr true (Global.env()) value); - 'fNL; str >]))) in + Ast.print_ast + (ast_of_constr true (Global.env()) value) ++ + fnl () ++ str))) + in let type_ct_ast = (try translate_constr (Global.env()) typ with UserError(f,str) -> - raise(UserError(f, [< Ast.print_ast (ast_of_constr true (Global.env()) - value); - 'fNL; str >]))) in + raise(UserError(f, Ast.print_ast (ast_of_constr true (Global.env()) + value) ++ + fnl () ++ str))) + in ((ctf_SearchResults !global_request_id), (Some (P_pl (CT_premises_list @@ -318,16 +323,16 @@ let globcv = function let pbp_tac_pcoq = pbp_tac (function x -> output_results - [< 'fNL; 'sTR "message"; 'fNL; 'sTR "pbp_results"; 'fNL; - 'iNT !global_request_id; 'fNL>] - (Some (P_t(xlate_tactic x))));; + (fnl () ++ str "message" ++ fnl () ++ str "pbp_results" ++ fnl () ++ + int !global_request_id ++ fnl ()) + (Some (P_t(xlate_tactic x))));; let dad_tac_pcoq = dad_tac(function x -> output_results - [< 'fNL; 'sTR "message"; 'fNL; 'sTR "pbp_results"; 'fNL; - 'iNT !global_request_id; 'fNL >] + (fnl () ++ str "message" ++ fnl () ++ str "pbp_results" ++ fnl () ++ + int !global_request_id ++ fnl ()) (Some (P_t(xlate_tactic x))));; let search_output_results () = @@ -346,8 +351,8 @@ let debug_tac2_pcoq = function try let result = report_error ast the_goal the_ast the_path [] g in (errorlabstrm "DEBUG TACTIC" - [< 'sTR "no error here "; 'fNL; pr_goal (sig_it g); - 'fNL; 'sTR "the tactic is"; 'fNL ; Printer.gentacpr ast >]; + (str "no error here " ++ fnl () ++ pr_goal (sig_it g) ++ + fnl () ++ str "the tactic is" ++ fnl () ++ Printer.gentacpr ast); result) with e -> @@ -481,9 +486,9 @@ let command_changes = [ begin if kind = "LETTOP" && not(refining ()) then errorlabstrm "StartProof" - [< 'sTR - "Let declarations can only be used in proof editing mode" - >]; + (str + "Let declarations can only be used in proof editing mode" + ); let str = (string_of_id s) in start_proof_com (Some s) stre c; History.start_proof str; @@ -563,7 +568,7 @@ let command_changes = [ (function () -> errorlabstrm "Begin Silent" - [< 'sTR "not available in Centaur mode" >]) + (str "not available in Centaur mode")) | _ -> errorlabstrm "BeginSilent" (make_error_stream "BeginSilent"))); ("EndSilent", @@ -572,7 +577,7 @@ let command_changes = [ (function () -> errorlabstrm "End Silent" - [< 'sTR "not available in Centaur mode" >]) + (str "not available in Centaur mode")) | _ -> errorlabstrm "EndSilent" (make_error_stream "EndSilent"))); ("ABORT", @@ -633,7 +638,7 @@ let command_changes = [ (function () -> let results = xlate_vernac_list (Ctast.ast_to_ct (name_to_ast qid)) in output_results - [<'fNL; 'sTR "message"; 'fNL; 'sTR "PRINT_VALUE"; 'fNL >] + (fnl () ++ str "message" ++ fnl () ++ str "PRINT_VALUE" ++ fnl ()) (Some (P_cl results))) | _ -> errorlabstrm "PrintId" (make_error_stream "PrintId"))); @@ -646,7 +651,7 @@ let command_changes = [ match kind with | "CHECK" -> print_check | "PRINTTYPE" -> - errorlabstrm "PrintType" [< 'sTR "Not yet supported in CtCoq" >] + errorlabstrm "PrintType" (str "Not yet supported in CtCoq") | _ -> errorlabstrm "CHECK" (make_error_stream "CHECK") in (function () -> let a,b = f (c, judgment_of_rawconstr evmap env c) in @@ -692,8 +697,8 @@ let command_changes = [ (fun () -> let results = dad_rule_names() in output_results - [< 'fNL; 'sTR "message"; 'fNL; 'sTR "dad_rule_names"; 'fNL; - 'iNT !global_request_id; 'fNL >] + (fnl () ++ str "message" ++ fnl () ++ str "dad_rule_names" ++ fnl () ++ + int !global_request_id ++ fnl ()) (Some (P_ids (CT_id_list (List.map (fun s -> CT_ident s) results))))) diff --git a/contrib/interface/dad.ml b/contrib/interface/dad.ml index 7f2ea95a4..ce3817404 100644 --- a/contrib/interface/dad.ml +++ b/contrib/interface/dad.ml @@ -254,7 +254,7 @@ vinterp_add "AddDadRule" let pr = match decompose_path (p1, p2) with pr, _, _ -> pr in (add_dad_rule name (Ctast.ast_to_ct pat) p1 p2 (List.length pr) pr (Ctast.ast_to_ct com))) | _ -> errorlabstrm "AddDadRule1" - [< 'sTR "AddDadRule2">]); + [< str "AddDadRule2">]); add_dad_rule "distributivity-inv" (Node(zz,"APPLIST",[Nvar(zz,"mult");Node(zz,"APPLIST",[Nvar(zz,"plus");Node(zz,"META",[Num(zz,4)]);Node(zz,"META",[Num(zz,3)])]);Node(zz,"META",[Num(zz,2)])])) [2; 2] diff --git a/contrib/interface/debug_tac.ml b/contrib/interface/debug_tac.ml index b7542fa74..80d9d7201 100644 --- a/contrib/interface/debug_tac.ml +++ b/contrib/interface/debug_tac.ml @@ -183,7 +183,7 @@ and checked_thens: report_holder -> Coqast.t -> Coqast.t list -> tactic = | Recursive_fail tr -> Tree_fail tr | Fail -> Failed 1 | _ -> errorlabstrm "check_thens" - [< 'sTR "this case should not happen in check_thens">]):: + (str "this case should not happen in check_thens")):: !report_holder); result) @@ -297,8 +297,8 @@ let rec reconstruct_success_tac ast = | _ -> errorlabstrm "this error case should not happen on an unknown tactic" - [< 'sTR "error in reconstruction with "; 'fNL; - (gentacpr ast) >]);; + (str "error in reconstruction with " ++ fnl () ++ + (gentacpr ast)));; let rec path_to_first_error = function @@ -332,15 +332,16 @@ let debug_tac = function let clean_ast = expand_tactic ast in let report_tree = try List.hd !report with - Failure "hd" -> (mSGNL [< 'sTR "report is empty" >]; Failed 1) in + Failure "hd" -> (msgnl (str "report is empty"); Failed 1) in let success_tac = reconstruct_success_tac clean_ast report_tree in let compact_success_tac = flatten_then success_tac in - mSGNL [< 'fNL; 'sTR "========= Successful tactic ============="; - 'fNL; - gentacpr compact_success_tac; 'fNL; - 'sTR "========= End of successful tactic ============">]; + msgnl (fnl () ++ + str "========= Successful tactic =============" ++ + fnl () ++ + gentacpr compact_success_tac ++ fnl () ++ + str "========= End of successful tactic ============"); result) | _ -> error "wrong arguments for debug_tac";; @@ -427,10 +428,9 @@ let rec report_error with e -> if !the_count > 1 then - mSGNL - [< 'sTR "in branch no "; 'iNT !the_count; - 'sTR " after tactic "; - gentacpr a >]; + msgnl + (str "in branch no " ++ int !the_count ++ + str " after tactic " ++ gentacpr a); raise e) | Node(_, "TACTICLIST", a::b::c::tl) -> report_error (ope("TACTICLIST", (ope("TACTICLIST", [a;b]))::c::tl)) @@ -458,16 +458,16 @@ let descr_first_error = function let the_path = ref ([] : int list) in try let result = report_error ast the_goal the_ast the_path [] g in - mSGNL [< 'sTR "no Error here" >]; + msgnl (str "no Error here"); result with e -> - (mSGNL [< 'sTR "Execution of this tactic raised message " ; 'fNL; - 'fNL; Errors.explain_exn e; 'fNL; - 'fNL; 'sTR "on goal" ; 'fNL; - pr_goal (sig_it (strip_some !the_goal)); 'fNL; - 'sTR "faulty tactic is"; 'fNL; 'fNL; - gentacpr (flatten_then !the_ast); 'fNL >]; + (msgnl (str "Execution of this tactic raised message " ++ fnl () ++ + fnl () ++ Errors.explain_exn e ++ fnl () ++ + fnl () ++ str "on goal" ++ fnl () ++ + pr_goal (sig_it (strip_some !the_goal)) ++ fnl () ++ + str "faulty tactic is" ++ fnl () ++ fnl () ++ + gentacpr (flatten_then !the_ast) ++ fnl ()); tclIDTAC g)) | _ -> error "wrong arguments for descr_first_error";; diff --git a/contrib/interface/name_to_ast.ml b/contrib/interface/name_to_ast.ml index e96106368..a7d5644f0 100644 --- a/contrib/interface/name_to_ast.ml +++ b/contrib/interface/name_to_ast.ml @@ -56,8 +56,8 @@ let impl_args_to_string = function let implicit_args_id_to_ast_list id l ast_list = (match impl_args_to_string l with None -> ast_list - | Some(s) -> (str("For " ^ (string_of_id id))):: - (str s):: + | Some(s) -> (string ("For " ^ (string_of_id id))):: + (string s):: ast_list);; (* This function construct an ast to enumerate the implicit positions for an @@ -125,7 +125,7 @@ let mutual_to_ast_list sp mib = Array.fold_right (fun mi (n,l) -> (n+1, (convert_one_inductive sp n)::l)) mipv (0, []) in (ope("MUTUALINDUCTIVE", - [str (if mib.mind_finite then "Inductive" else "CoInductive"); + [string (if mib.mind_finite then "Inductive" else "CoInductive"); ope("VERNACARGLIST", ast_list)]):: (implicit_args_to_ast_list sp mipv));; @@ -135,11 +135,11 @@ let constr_to_ast v = let implicits_to_ast_list implicits = (match (impl_args_to_string implicits) with None -> [] - | Some s -> [ope("COMMENT", [str s])]);; + | Some s -> [ope("COMMENT", [string s])]);; let make_variable_ast name typ implicits = (ope("VARIABLE", - [str "VARIABLE"; + [string "VARIABLE"; ope("BINDERLIST", [ope("BINDER", [(constr_to_ast (body_of_type typ)); @@ -148,7 +148,7 @@ let make_variable_ast name typ implicits = let make_definition_ast name c typ implicits = (ope("DEFINITION", - [str "DEFINITION"; + [string "DEFINITION"; nvar name; ope("COMMAND", [ope("CAST", @@ -193,8 +193,8 @@ let leaf_entry_to_ast_list (sp,lobj) = | (_, "INDUCTIVE") -> inductive_to_ast_list sp | (_, s) -> errorlabstrm - "print" [< 'sTR ("printing of unrecognized object " ^ - s ^ " has been required") >];; + "print" (str ("printing of unrecognized object " ^ + s ^ " has been required"));; @@ -232,10 +232,11 @@ let name_to_ast (qid:Nametab.qualid) = try let sp = Syntax_def.locate_syntactic_definition qid in errorlabstrm "print" - [< 'sTR "printing of syntax definitions not implemented" >] + (str "printing of syntax definitions not implemented") with Not_found -> errorlabstrm "print" - [< Nametab.pr_qualid qid; - 'sPC; 'sTR "not a defined object" >] in - ope("vernac_list", l);; + (Nametab.pr_qualid qid ++ + spc () ++ str "not a defined object") + in + ope("vernac_list", l);; diff --git a/contrib/interface/parse.ml b/contrib/interface/parse.ml index 6b2e38873..fad5c1e34 100644 --- a/contrib/interface/parse.ml +++ b/contrib/interface/parse.ml @@ -2,10 +2,10 @@ open Util;; open System;; -open Pp;; - open Ctast;; +open Pp;; + open Library;; open Ascent;; @@ -43,15 +43,15 @@ let print_parse_results n msg = flush stdout;; let ctf_SyntaxErrorMessage reqid pps = - [< 'fNL; 'sTR "message"; 'fNL; 'sTR "syntax_error"; 'fNL; 'iNT reqid; 'fNL; - pps; 'fNL; 'sTR "E-n-d---M-e-s-s-a-g-e"; 'fNL >];; + (fnl () ++ str "message" ++ fnl () ++ str "syntax_error" ++ fnl () ++ int reqid ++ fnl () ++ + pps ++ fnl () ++ str "E-n-d---M-e-s-s-a-g-e" ++ fnl ());; let ctf_SyntaxWarningMessage reqid pps = - [< 'fNL; 'sTR "message"; 'fNL; 'sTR "syntax_warning"; 'fNL; 'iNT reqid; 'fNL; - pps; 'fNL; 'sTR "E-n-d---M-e-s-s-a-g-e"; 'fNL >];; + (fnl () ++ str "message" ++ fnl () ++ str "syntax_warning" ++ fnl () ++ int reqid ++ fnl () ++ + pps ++ fnl () ++ str "E-n-d---M-e-s-s-a-g-e" ++ fnl ());; let ctf_FileErrorMessage reqid pps = - [< 'fNL; 'sTR "message"; 'fNL; 'sTR "file_error"; 'fNL; 'iNT reqid; 'fNL; - pps; 'fNL; 'sTR "E-n-d---M-e-s-s-a-g-e"; 'fNL >];; + (fnl () ++ str "message" ++ fnl () ++ str "file_error" ++ fnl () ++ int reqid ++ fnl () ++ + pps ++ fnl () ++ str "E-n-d---M-e-s-s-a-g-e" ++ fnl ());; (*In the code for CoqV6.2, the require_module call is encapsulated in a function "without_mes_ambig". Here I have supposed that this @@ -60,7 +60,7 @@ let try_require_module import specif name fname = try Library.require_module (if specif = "UNSPECIFIED" then None else Some (specif = "SPECIFICATION")) (Nametab.make_short_qualid (Names.id_of_string name)) fname (import = "IMPORT") with - | e -> mSGNL [< 'sTR "Reinterning of "; 'sTR name; 'sTR " failed" >];; + | e -> msgnl (str "Reinterning of " ++ str name ++ str " failed");; let execute_when_necessary ast = (match ast with @@ -79,11 +79,12 @@ let execute_when_necessary ast = | _ -> ()); ast;; let parse_to_dot = - let rec dot = parser - [< '("", ".") >] -> () - | [< '("EOI", "") >] -> raise End_of_file - | [< '_; s >] -> dot s - in Gram.Entry.of_parser "Coqtoplevel.dot" dot;; + let rec dot st = match Stream.next st with + | ("", ".") -> () + | ("EOI", "") -> raise End_of_file + | _ -> dot st + in + Gram.Entry.of_parser "Coqtoplevel.dot" dot;; let rec discard_to_dot stream = try Gram.Entry.parse parse_to_dot (Gram.parsable stream) with @@ -149,11 +150,11 @@ let parse_command_list reqid stream string_list = with | (Stdpp.Exc_located(l, Stream.Error txt)) as e -> begin - mSGNL (ctf_SyntaxWarningMessage reqid (Errors.explain_exn e)); + msgnl (ctf_SyntaxWarningMessage reqid (Errors.explain_exn e)); try discard_to_dot stream; - mSGNL [< 'sTR "debug"; 'fNL; 'iNT this_pos; 'fNL; 'iNT - (Stream.count stream) >]; + msgnl (str "debug" ++ fnl () ++ int this_pos ++ fnl () ++ int + (Stream.count stream)); Some( Node(l, "PARSING_ERROR", List.map Ctast.str (get_substring_list string_list this_pos @@ -175,7 +176,7 @@ let parse_command_list reqid stream string_list = | None -> [] in match parse_whole_stream () with | first_one::tail -> (P_cl (CT_command_list(first_one, tail))) - | [] -> raise (UserError ("parse_string", [< 'sTR "empty text." >]));; + | [] -> raise (UserError ("parse_string", (str "empty text.")));; (*When parsing a string using a phylum, the string is first transformed into a Coq Ast using the regular Coq parser, then it is transformed into @@ -215,12 +216,12 @@ let parse_string_action reqid phylum char_stream string_list = with | Stdpp.Exc_located(l,Match_failure(_,_,_)) -> flush_until_end_of_stream char_stream; - mSGNL (ctf_SyntaxErrorMessage reqid + msgnl (ctf_SyntaxErrorMessage reqid (Errors.explain_exn (Stdpp.Exc_located(l,Stream.Error "match failure")))) | e -> flush_until_end_of_stream char_stream; - mSGNL (ctf_SyntaxErrorMessage reqid (Errors.explain_exn e));; + msgnl (ctf_SyntaxErrorMessage reqid (Errors.explain_exn e));; let quiet_parse_string_action char_stream = @@ -247,10 +248,10 @@ let parse_file_action reqid file_name = this_ast with | Stdpp.Exc_located(l,Stream.Error txt ) -> - mSGNL (ctf_SyntaxWarningMessage reqid - [< 'sTR "Error with file"; 'sPC; 'sTR file_name; 'fNL; + msgnl (ctf_SyntaxWarningMessage reqid + (str "Error with file" ++ spc () ++ str file_name ++ fnl () ++ Errors.explain_exn - (Stdpp.Exc_located(l,Stream.Error txt)) >]); + (Stdpp.Exc_located(l,Stream.Error txt)))); let rec discard_to_dot () = try Gram.Entry.parse parse_to_dot (Gram.parsable stream) with Stdpp.Exc_located(_,Token.Error _) -> discard_to_dot() @@ -276,18 +277,18 @@ let parse_file_action reqid file_name = | first_one :: tail -> print_parse_results reqid (P_cl (CT_command_list (first_one, tail))) - | [] -> raise (UserError ("parse_file_action", [< 'sTR "empty file." >])) + | [] -> raise (UserError ("parse_file_action", (str "empty file."))) with | Stdpp.Exc_located(l,Match_failure(_,_,_)) -> - mSGNL + msgnl (ctf_SyntaxErrorMessage reqid - [< 'sTR "Error with file"; 'sPC; 'sTR file_name; 'fNL; - Errors.explain_exn (Stdpp.Exc_located(l,Stream.Error "match failure")) >]) + (str "Error with file" ++ spc () ++ str file_name ++ fnl () ++ + Errors.explain_exn (Stdpp.Exc_located(l,Stream.Error "match failure")))) | e -> - mSGNL + msgnl (ctf_SyntaxErrorMessage reqid - [< 'sTR "Error with file"; 'sPC; 'sTR file_name; 'fNL; - Errors.explain_exn e >]);; + (str "Error with file" ++ spc () ++ str file_name ++ fnl () ++ + Errors.explain_exn e));; (* This function is taken from Mltop.add_path *) @@ -297,7 +298,7 @@ let add_path dir coq_dirpath = Library.add_load_path_entry (dir,coq_dirpath) end else - wARNING [< 'sTR ("Cannot open " ^ dir) >] + msg_warning (str ("Cannot open " ^ dir)) let convert_string d = try Names.id_of_string d @@ -315,7 +316,7 @@ let add_rec_path dir coq_dirpath = List.iter Library.add_load_path_entry dirs end else - wARNING [< 'sTR ("Cannot open " ^ dir) >];; + msg_warning (str ("Cannot open " ^ dir));; let add_path_action reqid string_arg = let directory_name = glob string_arg in @@ -325,30 +326,30 @@ let add_path_action reqid string_arg = end;; let print_version_action () = - mSGNL [< >]; - mSGNL [< 'sTR "$Id$" >];; + msgnl (mt ()); + msgnl (str "$Id$");; let load_syntax_action reqid module_name = - mSG [< 'sTR "loading "; 'sTR module_name; 'sTR "... " >]; + msg (str "loading " ++ str module_name ++ str "... "); try (let qid = Nametab.make_short_qualid (Names.id_of_string module_name) in read_module qid; - mSG [< 'sTR "opening... ">]; + msg (str "opening... "); let fullname = Nametab.locate_loaded_library qid in import_module fullname; - mSGNL [< 'sTR "done"; 'fNL >]; + msgnl (str "done" ++ fnl ()); ()) with | UserError (label, pp_stream) -> (*This one may be necessary to make sure that the message won't be indented *) - mSGNL [< >]; - mSGNL - [< 'fNL; 'sTR "error while loading syntax module "; 'sTR module_name; - 'sTR ": "; 'sTR label; 'fNL; pp_stream >] + msgnl (mt ()); + msgnl + (fnl () ++ str "error while loading syntax module " ++ str module_name ++ + str ": " ++ str label ++ fnl () ++ pp_stream) | e -> - mSGNL [< >]; - mSGNL - [< 'fNL; 'sTR "message"; 'fNL; 'sTR "load_error"; 'fNL; 'iNT reqid; 'fNL >]; + msgnl (mt ()); + msgnl + (fnl () ++ str "message" ++ fnl () ++ str "load_error" ++ fnl () ++ int reqid ++ fnl ()); ();; let coqparser_loop inchan = @@ -370,12 +371,12 @@ Libobject.relax true; if Sys.file_exists coqdir then coqdir else - (mSGNL [< 'sTR "could not find the value of COQDIR" >]; exit 1) in + (msgnl (str "could not find the value of COQDIR"); exit 1) in begin add_rec_path (Filename.concat coqdir "theories") (Names.make_dirpath [Nameops.coq_root]); add_path (Filename.concat coqdir "tactics") (Names.make_dirpath [Nameops.coq_root]); add_rec_path (Filename.concat coqdir "contrib") (Names.make_dirpath [Nameops.coq_root]); - List.iter (fun a -> mSGNL [< 'sTR a >]) (get_load_path()) + List.iter (fun a -> msgnl (str a)) (get_load_path()) end; (try (match create_entry (get_univ "nat") "number" ETast with @@ -387,10 +388,10 @@ Libobject.relax true; (fun s loc -> Node((0,0),"XTRA",[Str((0,0),"omega_integer_for_ctcoq"); Num((0,0),int_of_string s)]))]] - | _ -> mSGNL [< 'sTR "unpredicted behavior of Grammar.extend" >]) + | _ -> msgnl (str "unpredicted behavior of Grammar.extend")) with - e -> mSGNL [< 'sTR "could not add a parser for numbers" >]); + e -> msgnl (str "could not add a parser for numbers")); (let vernacrc = try Sys.getenv "VERNACRC" @@ -406,28 +407,28 @@ Libobject.relax true; with | End_of_file -> () | e -> - (mSGNL (Errors.explain_exn e); - mSGNL [< 'sTR "could not load the VERNACRC file" >]); + (msgnl (Errors.explain_exn e); + msgnl (str "could not load the VERNACRC file")); try - mSGNL [< 'sTR vernacrc >] + msgnl (str vernacrc) with e -> ()); (try let user_vernacrc = try Some(Sys.getenv "USERVERNACRC") with | Not_found as e -> - mSGNL [< 'sTR "no .vernacrc file" >]; None in + msgnl (str "no .vernacrc file"); None in (match user_vernacrc with Some f -> coqparser_loop (open_in f) | None -> ()) with | End_of_file -> () | e -> - mSGNL (Errors.explain_exn e); - mSGNL [< 'sTR "error in your .vernacrc file" >]); -mSGNL [< 'sTR "Starting Centaur Specialized Parser Loop" >]; + msgnl (Errors.explain_exn e); + msgnl (str "error in your .vernacrc file")); +msgnl (str "Starting Centaur Specialized Parser Loop"); try coqparser_loop stdin with | End_of_file -> () - | e -> mSGNL(Errors.explain_exn e)) + | e -> msgnl(Errors.explain_exn e)) diff --git a/contrib/interface/showproof.ml b/contrib/interface/showproof.ml index 5bfad2f52..c23394e8c 100644 --- a/contrib/interface/showproof.ml +++ b/contrib/interface/showproof.ml @@ -1806,7 +1806,7 @@ let show_proof lang gpath = ;; let show_nproof path = - pP (sp_print (sph [spi; show_proof "fr" path]));; + pp (sp_print (sph [spi; show_proof "fr" path]));; vinterp_add "ShowNaturalProof" (fun _ -> diff --git a/contrib/interface/showproof_ct.ml b/contrib/interface/showproof_ct.ml index e3bca2243..b689620e3 100644 --- a/contrib/interface/showproof_ct.ml +++ b/contrib/interface/showproof_ct.ml @@ -120,31 +120,31 @@ let sphv l = let rec prlist_with_sep f g l = match l with - [] -> hOV 0 [< >] - |x::l1 -> hOV 0 [< (g x); (f ()); (prlist_with_sep f g l1)>] + [] -> hov 0 (mt ()) + |x::l1 -> hov 0 ((g x) ++ (f ()) ++ (prlist_with_sep f g l1)) ;; let rec sp_print x = match x with - CT_coerce_ID_to_TEXT (CT_ident s) - -> (match s with - "\n" -> [< 'fNL >] - | "Retour chariot pour Show proof" -> [< 'fNL >] - |_ -> [< 'sTR s >]) - | CT_text_formula f -> [< prterm (Hashtbl.find ct_FORMULA_constr f) >] - | CT_text_op [CT_coerce_ID_to_TEXT (CT_ident "to_prove"); - CT_text_path (CT_signed_int_list p); - CT_coerce_ID_to_TEXT (CT_ident "goal"); - g] -> + | CT_coerce_ID_to_TEXT (CT_ident s) + -> (match s with + | "\n" -> fnl () + | "Retour chariot pour Show proof" -> fnl () + |_ -> str s) + | CT_text_formula f -> prterm (Hashtbl.find ct_FORMULA_constr f) + | CT_text_op [CT_coerce_ID_to_TEXT (CT_ident "to_prove"); + CT_text_path (CT_signed_int_list p); + CT_coerce_ID_to_TEXT (CT_ident "goal"); + g] -> let p=(List.map (fun y -> match y with (CT_coerce_INT_to_SIGNED_INT (CT_int x)) -> x | _ -> raise (Failure "sp_print")) p) in - h 0 [< 'sTR "<b>"; sp_print g; 'sTR "</b>">] + h 0 (str "<b>" ++ sp_print g ++ str "</b>") | CT_text_op [CT_coerce_ID_to_TEXT (CT_ident "uselemma"); CT_coerce_ID_to_TEXT (CT_ident intro); l;g] -> - h 0 [< 'sTR ("<i>("^intro^" "); sp_print l; 'sTR ")</i>"; sp_print g>] + h 0 (str ("<i>("^intro^" ") ++ sp_print l ++ str ")</i>" ++ sp_print g) | CT_text_op [CT_coerce_ID_to_TEXT (CT_ident "hyp"); CT_text_path (CT_signed_int_list p); CT_coerce_ID_to_TEXT (CT_ident hyp); @@ -153,7 +153,7 @@ let rec sp_print x = (CT_coerce_INT_to_SIGNED_INT (CT_int x)) -> x | _ -> raise (Failure "sp_print")) p) in - h 0 [< 'sTR hyp>] + h 0 (str hyp) | CT_text_op [CT_coerce_ID_to_TEXT (CT_ident "hyp_with_type"); CT_text_path (CT_signed_int_list p); @@ -163,23 +163,23 @@ let rec sp_print x = (CT_coerce_INT_to_SIGNED_INT (CT_int x)) -> x | _ -> raise (Failure "sp_print")) p) in - h 0 [< sp_print g; 'sPC; 'sTR "<i>("; 'sTR hyp;'sTR ")</i>">] + h 0 (sp_print g ++ spc () ++ str "<i>(" ++ str hyp ++ str ")</i>") | CT_text_h l -> - h 0 [< prlist_with_sep (fun () -> [< >]) - (fun y -> sp_print y) l>] + h 0 (prlist_with_sep (fun () -> mt ()) + (fun y -> sp_print y) l) | CT_text_v l -> - v 0 [< prlist_with_sep (fun () -> [< >]) - (fun y -> sp_print y) l>] + v 0 (prlist_with_sep (fun () -> mt ()) + (fun y -> sp_print y) l) | CT_text_hv l -> - h 0 [< prlist_with_sep (fun () -> [<>]) - (fun y -> sp_print y) l>] + h 0 (prlist_with_sep (fun () -> mt ()) + (fun y -> sp_print y) l) | CT_text_op [CT_coerce_ID_to_TEXT (CT_ident "shrink"); CT_text_op [CT_coerce_ID_to_TEXT (CT_ident info); t]] -> - h 0 [< 'sTR ("("^info^": "); sp_print t ;'sTR ")" >] + h 0 (str ("("^info^": ") ++ sp_print t ++ str ")") | CT_text_op [CT_coerce_ID_to_TEXT (CT_ident "root_of_text_proof"); t]-> sp_print t - | _ -> [< 'sTR "..." >] + | _ -> str "..." ;; diff --git a/contrib/interface/translate.ml b/contrib/interface/translate.ml index 75cd7db38..c691ff912 100644 --- a/contrib/interface/translate.ml +++ b/contrib/interface/translate.ml @@ -56,12 +56,12 @@ let dbize_sp = | Invalid_argument _ | Failure _ -> anomaly_loc (loc, "Translate.dbize_sp (taken from Astterm)", - [< 'sTR "malformed section-path" >]) + [< str "malformed section-path" >]) end | ast -> anomaly_loc (Ast.loc ast, "Translate.dbize_sp (taken from Astterm)", - [< 'sTR "not a section-path" >]);; + [< str "not a section-path" >]);; *) (* dead code: @@ -120,8 +120,9 @@ let translate_sign env = fold_named_context (fun env (id,v,c) l -> (CT_premise(CT_ident(string_of_id id), translate_constr env c))::l) - env [] in - CT_premises_list l;; + env ~init:[] + in + CT_premises_list l;; (* the function rev_and_compact performs two operations: 1- it reverses the list of integers given as argument diff --git a/contrib/omega/coq_omega.ml b/contrib/omega/coq_omega.ml index 8e1d90489..729b3278d 100644 --- a/contrib/omega/coq_omega.ml +++ b/contrib/omega/coq_omega.ml @@ -86,7 +86,7 @@ let make_clenv_binding_apply wc (c,t) lbind = clenv_match_args lbind clause else errorlabstrm "make_clenv_bindings" - [<'sTR "Cannot mix bindings and free associations">] + (str "Cannot mix bindings and free associations") let resolve_with_bindings_tac (c,lbind) gl = let (wc,kONT) = startWalk gl in @@ -107,13 +107,13 @@ let reduce_to_mind gl t = let t' = pf_nf_betaiota gl (pf_one_step_reduce gl t) in elimrec t' l with e when catchable_exception e -> errorlabstrm "tactics__reduce_to_mind" - [< 'sTR"Not an inductive product" >]) + (str"Not an inductive product")) | (Case _,_) -> (try let t' = pf_nf_betaiota gl (pf_one_step_reduce gl t) in elimrec t' l with e when catchable_exception e -> errorlabstrm "tactics__reduce_to_mind" - [< 'sTR"Not an inductive product" >]) + (str"Not an inductive product")) | (Cast (c,_),[]) -> elimrec c l | (Prod (n,ty,t'),[]) -> let ty' = Retyping.get_assumption_of (Global.env()) Evd.empty ty in @@ -487,7 +487,7 @@ let context operation path (t : constr) = | ((P_TYPE :: p), LetIn (n,b,t,c)) -> (mkLetIn (n,b,loop i p t,c)) | (p, _) -> - pPNL [<Printer.prterm t>]; + ppnl (Printer.prterm t); failwith ("abstract_path " ^ string_of_int(List.length p)) in loop 1 path t @@ -508,7 +508,7 @@ let occurence path (t : constr) = | ((P_TYPE :: p), Lambda (n,term,c)) -> loop p term | ((P_TYPE :: p), LetIn (n,b,term,c)) -> loop p term | (p, _) -> - pPNL [<Printer.prterm t>]; + ppnl (Printer.prterm t); failwith ("occurence " ^ string_of_int(List.length p)) in loop path t @@ -1658,8 +1658,8 @@ let rec decidability gl t = | Kapp("Z",[]) -> mkApp (Lazy.force coq_dec_eq, [| t1;t2 |]) | Kapp("nat",[]) -> mkApp (Lazy.force coq_dec_eq_nat, [| t1;t2 |]) | _ -> errorlabstrm "decidability" - [< 'sTR "Omega: Can't solve a goal with equality on "; - Printer.prterm typ >] + (str "Omega: Can't solve a goal with equality on " ++ + Printer.prterm typ) end | Kapp("Zne",[t1;t2]) -> mkApp (Lazy.force coq_dec_Zne, [| t1;t2 |]) | Kapp("Zle",[t1;t2]) -> mkApp (Lazy.force coq_dec_Zle, [| t1;t2 |]) diff --git a/contrib/ring/ring.ml b/contrib/ring/ring.ml index 97258c506..83ed2ad14 100644 --- a/contrib/ring/ring.ml +++ b/contrib/ring/ring.ml @@ -215,9 +215,9 @@ let guess_theory a = theories_map_find a with Not_found -> errorlabstrm "Ring" - [< 'sTR "No Declared Ring Theory for "; - prterm a; 'fNL; - 'sTR "Use Add [Semi] Ring to declare it">] + (str "No Declared Ring Theory for " ++ + prterm a ++ fnl () ++ + str "Use Add [Semi] Ring to declare it") (* Looks up an option *) @@ -229,8 +229,8 @@ let unbox = function let add_theory want_ring want_abstract want_setoid a aequiv asetth amorph aplus amult aone azero aopp aeq t cset = if theories_map_mem a then errorlabstrm "Add Semi Ring" - [< 'sTR "A (Semi-)(Setoid-)Ring Structure is already declared for "; - prterm a >]; + (str "A (Semi-)(Setoid-)Ring Structure is already declared for " ++ + prterm a); let env = Global.env () in if (want_ring & want_setoid & (not (is_conv env Evd.empty (Typing.type_of env Evd.empty t) @@ -238,24 +238,24 @@ let add_theory want_ring want_abstract want_setoid a aequiv asetth amorph aplus [| a; (unbox aequiv); aplus; amult; aone; azero; (unbox aopp); aeq|])))) & (not (is_conv env Evd.empty (Typing.type_of env Evd.empty (unbox asetth)) (mkLApp (coq_Setoid_Theory, [| a; (unbox aequiv) |]))))) then - errorlabstrm "addring" [< 'sTR "Not a valid Setoid-Ring theory" >]; + errorlabstrm "addring" (str "Not a valid Setoid-Ring theory"); if (not want_ring & want_setoid & (not (is_conv env Evd.empty (Typing.type_of env Evd.empty t) (mkLApp (coq_Semi_Setoid_Ring_Theory, [| a; (unbox aequiv); aplus; amult; aone; azero; aeq|])))) & (not (is_conv env Evd.empty (Typing.type_of env Evd.empty (unbox asetth)) (mkLApp (coq_Setoid_Theory, [| a; (unbox aequiv) |]))))) then - errorlabstrm "addring" [< 'sTR "Not a valid Semi-Setoid-Ring theory" >]; + errorlabstrm "addring" (str "Not a valid Semi-Setoid-Ring theory"); if (want_ring & not want_setoid & not (is_conv env Evd.empty (Typing.type_of env Evd.empty t) (mkLApp (coq_Ring_Theory, [| a; aplus; amult; aone; azero; (unbox aopp); aeq |])))) then - errorlabstrm "addring" [< 'sTR "Not a valid Ring theory" >]; + errorlabstrm "addring" (str "Not a valid Ring theory"); if (not want_ring & not want_setoid & not (is_conv env Evd.empty (Typing.type_of env Evd.empty t) (mkLApp (coq_Semi_Ring_Theory, [| a; aplus; amult; aone; azero; aeq |])))) then - errorlabstrm "addring" [< 'sTR "Not a valid Semi-Ring theory" >]; + errorlabstrm "addring" (str "Not a valid Semi-Ring theory"); Lib.add_anonymous_leaf (theory_to_obj (a, { th_ring = want_ring; @@ -931,7 +931,7 @@ let polynom lc gl = (fun c1 -> not (pf_conv_x gl t (pf_type_of gl c1))) args then errorlabstrm "Ring :" - [< 'sTR" All terms must have the same type" >]; + (str" All terms must have the same type"); (tclTHEN (raw_polynom th None args) (guess_eq_tac th)) gl | _ -> (match match_with_equiv (pf_concl gl) with | Some (equiv, c1::args) -> @@ -941,10 +941,10 @@ let polynom lc gl = (fun c2 -> not (pf_conv_x gl t (pf_type_of gl c2))) args then errorlabstrm "Ring :" - [< 'sTR" All terms must have the same type" >]; + (str" All terms must have the same type"); (tclTHEN (raw_polynom th None args) (guess_equiv_tac th)) gl | _ -> errorlabstrm "polynom :" - [< 'sTR" This goal is not an equality nor a setoid equivalence" >])) + (str" This goal is not an equality nor a setoid equivalence"))) (* Elsewhere, guess the theory, check that all terms have the same type and apply raw_polynom *) | c :: lc' -> @@ -954,7 +954,7 @@ let polynom lc gl = (fun c1 -> not (pf_conv_x gl t (pf_type_of gl c1))) lc' then errorlabstrm "Ring :" - [< 'sTR" All terms must have the same type" >]; + (str" All terms must have the same type"); (tclTHEN (raw_polynom th None lc) polynom_unfold_tac) gl let dyn_polynom ltacargs gl = diff --git a/contrib/romega/refl_omega.ml b/contrib/romega/refl_omega.ml index 791a2fafa..0ec692633 100644 --- a/contrib/romega/refl_omega.ml +++ b/contrib/romega/refl_omega.ml @@ -513,7 +513,7 @@ let replay_history env_hyp = in loop env_hyp let show_goal gl = - if !debug then Pp.pPNL (Tacmach.pr_gls gl); Tacticals.tclIDTAC gl + if !debug then Pp.ppnl (Tacmach.pr_gls gl); Tacticals.tclIDTAC gl (* Cette fonction prépare le rejeu puis l'appelle : \begin{itemize} @@ -569,9 +569,9 @@ let prepare_and_play env tac_hyps trace_solution = mkApp(Lazy.force coq_interp_sequent, [| env_reified; l_reified_terms |]) in let reified_trace_solution = replay_history l_e trace_solution in if !debug then begin - Pp.pPNL [< Printer.prterm reified>]; - Pp.pPNL [< Printer.prterm l_reified_tac_norms>]; - Pp.pPNL [< Printer.prterm reified_trace_solution>]; + Pp.ppnl (Printer.prterm reified); + Pp.ppnl (Printer.prterm l_reified_tac_norms); + Pp.ppnl (Printer.prterm reified_trace_solution); end; Tactics.generalize l_generalized >> Tactics.change_in_concl reified >> diff --git a/dev/db_printers.ml b/dev/db_printers.ml index 1384a77f5..c7857e968 100644 --- a/dev/db_printers.ml +++ b/dev/db_printers.ml @@ -8,7 +8,7 @@ open Pp open Names -let pP s = pP (hOV 0 s) +let pP s = pP (hov 0 s) let prid id = Format.print_string (string_of_id id) let prsp sp = Format.print_string (string_of_path sp) diff --git a/dev/top_printers.ml b/dev/top_printers.ml index 9a8670aeb..ebdf4715d 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -27,59 +27,59 @@ open Errors let _ = Termast.print_evar_arguments := true -let pP s = pP (hOV 0 s) +let pP s = pp (hov 0 s) -let prast c = pP(print_ast c) +let prast c = pp(print_ast c) -let prastpat c = pP(print_astpat c) -let prastpatl c = pP(print_astlpat c) -let ppterm = (fun x -> pP(prterm x)) -let pprawterm = (fun x -> pP(pr_rawterm x)) -let pppattern = (fun x -> pP(pr_pattern x)) -let pptype = (fun x -> pP(prtype x)) +let prastpat c = pp(print_astpat c) +let prastpatl c = pp(print_astlpat c) +let ppterm = (fun x -> pp(prterm x)) +let pprawterm = (fun x -> pp(pr_rawterm x)) +let pppattern = (fun x -> pp(pr_pattern x)) +let pptype = (fun x -> pp(prtype x)) -let prid id = pP [< pr_id id >] +let prid id = pp (pr_id id) let prconst (sp,j) = - pP [< 'sTR"#"; pr_sp sp; 'sTR"="; prterm j.uj_val >] + pp (str"#" ++ pr_sp sp ++ str"=" ++ prterm j.uj_val) let prvar ((id,a)) = - pP [< 'sTR"#" ; pr_id id ; 'sTR":" ; prterm a >] + pp (str"#" ++ pr_id id ++ str":" ++ prterm a) let genprj f j = - let (c,t) = Termast.with_casts f j in [< c; 'sTR " : "; t >] + let (c,t) = Termast.with_casts f j in (c ++ str " : " ++ t) -let prj j = pP (genprj prjudge j) +let prj j = pp (genprj prjudge j) -let prsp sp = pP[< pr_sp sp >] +let prsp sp = pp(pr_sp sp) -let prqualid qid = pP[< Nametab.pr_qualid qid >] +let prqualid qid = pp(Nametab.pr_qualid qid) -let prgoal g = pP(prgl g) +let prgoal g = pp(prgl g) -let prsigmagoal g = pP(prgl (sig_it g)) +let prsigmagoal g = pp(prgl (sig_it g)) -let prgls gls = pP(pr_gls gls) +let prgls gls = pp(pr_gls gls) -let prglls glls = pP(pr_glls glls) +let prglls glls = pp(pr_glls glls) -let pproof p = pP(print_proof Evd.empty empty_named_context p) +let pproof p = pp(print_proof Evd.empty empty_named_context p) -let prevd evd = pP(pr_decls evd) +let prevd evd = pp(pr_decls evd) -let prevc evc = pP(pr_evc evc) +let prevc evc = pp(pr_evc evc) -let prwc wc = pP(pr_evc wc) +let prwc wc = pp(pr_evc wc) -let prclenv clenv = pP(pr_clenv clenv) +let prclenv clenv = pp(pr_clenv clenv) -let print_uni u = (pP (pr_uni u)) +let print_uni u = (pp (pr_uni u)) -let pp_universes u = pP [< 'sTR"[" ; pr_universes u ; 'sTR"]" >] +let pp_universes u = pp (str"[" ++ pr_universes u ++ str"]") -let ppenv e = pP (pr_rel_context e (rel_context e)) +let ppenv e = pp (pr_rel_context e (rel_context e)) -let pptac = (fun x -> pP(gentacpr x)) +let pptac = (fun x -> pp(gentacpr x)) let cnt = ref 0 @@ -132,7 +132,7 @@ let constr_display csr = | Prop(Pos) -> "Prop(Pos)" | Prop(Null) -> "Prop(Null)" | Type u -> - incr cnt; pP [< 'sTR "with "; 'iNT !cnt; pr_uni u; 'fNL >]; + incr cnt; pp (str "with " ++ int !cnt ++ pr_uni u ++ fnl ()); "Type("^(string_of_int !cnt)^")" and name_display = function @@ -140,7 +140,7 @@ let constr_display csr = | Anonymous -> "Anonymous" in - mSG [<'sTR (term_display csr);'fNL>] + msg (str (term_display csr) ++fnl ()) open Format;; @@ -237,7 +237,7 @@ let print_pure_constr csr = | Prop(Pos) -> print_string "Set" | Prop(Null) -> print_string "Prop" | Type u -> open_hbox(); - print_string "Type("; pP (pr_uni u); print_string ")"; close_box() + print_string "Type("; pp (pr_uni u); print_string ")"; close_box() and name_display = function | Name id -> print_string (string_of_id id) diff --git a/kernel/closure.ml b/kernel/closure.ml index 56ef7cafb..7cac9e596 100644 --- a/kernel/closure.ml +++ b/kernel/closure.ml @@ -32,9 +32,9 @@ let reset () = beta := 0; delta := 0; zeta := 0; evar := 0; iota := 0; prune := 0 let stop() = - mSGNL [< 'sTR"[Reds: beta=";'iNT !beta; 'sTR" delta="; 'iNT !delta; - 'sTR" zeta="; 'iNT !zeta; 'sTR" evar="; 'iNT !evar; - 'sTR" iota="; 'iNT !iota; 'sTR" prune="; 'iNT !prune; 'sTR"]" >] + msgnl (str "[Reds: beta=" ++ int !beta ++ str" delta=" ++ int !delta ++ + str" zeta=" ++ int !zeta ++ str" evar=" ++ int !evar ++ + str" iota=" ++ int !iota ++ str" prune=" ++ int !prune ++ str"]") let incr_cnt red cnt = if red then begin @@ -383,7 +383,7 @@ let defined_rels flags env = match b with | None -> (i+1, subs) | Some body -> (i+1, (i,body) :: subs)) - env (0,[]) + env ~init:(0,[]) (* else (0,[])*) let create mk_cl flgs env = diff --git a/kernel/cooking.ml b/kernel/cooking.ml index 3b901a1ac..0313d4d46 100644 --- a/kernel/cooking.ml +++ b/kernel/cooking.ml @@ -36,13 +36,13 @@ type recipe = { let failure () = anomalylabstrm "generic__modify_opers" - [< 'sTR"An oper which was never supposed to appear has just appeared" ; - 'sPC ; 'sTR"Either this is in system code, and you need to" ; 'sPC; - 'sTR"report this error," ; 'sPC ; - 'sTR"Or you are using a user-written tactic which calls" ; 'sPC ; - 'sTR"generic__modify_opers, in which case the user-written code" ; - 'sPC ; 'sTR"is broken - this function is an internal system" ; - 'sPC ; 'sTR"for internal system use only" >] + (str"An oper which was never supposed to appear has just appeared" ++ + spc () ++ str"Either this is in system code, and you need to" ++ spc () ++ + str"report this error," ++ spc () ++ + str"Or you are using a user-written tactic which calls" ++ spc () ++ + str"generic__modify_opers, in which case the user-written code" ++ + spc () ++ str"is broken - this function is an internal system" ++ + spc () ++ str"for internal system use only") let modify_opers replfun (constl,indl,cstrl) = let rec substrec c = @@ -101,11 +101,11 @@ let expmod_constr modlist c = let expfun (sp,cb) = if cb.const_opaque then errorlabstrm "expmod_constr" - [< 'sTR"Cannot unfold the value of "; - 'sTR(string_of_path sp); 'sPC; - 'sTR"You cannot declare local lemmas as being opaque"; 'sPC; - 'sTR"and then require that theorems which use them"; 'sPC; - 'sTR"be transparent" >]; + (str"Cannot unfold the value of " ++ + str(string_of_path sp) ++ spc () ++ + str"You cannot declare local lemmas as being opaque" ++ spc () ++ + str"and then require that theorems which use them" ++ spc () ++ + str"be transparent"); match cb.const_body with | Some body -> body | None -> assert false diff --git a/kernel/environ.ml b/kernel/environ.ml index e03d489c7..0d341aabc 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -82,13 +82,13 @@ let reset_rel_context env = let fold_named_context f env ~init = snd (Sign.fold_named_context (fun d (env,e) -> (push_named_decl d env, f env d e)) - (named_context env) (reset_context env,init)) + (named_context env) ~init:(reset_context env,init)) -let fold_named_context_reverse f a env = - Sign.fold_named_context_reverse f a (named_context env) +let fold_named_context_reverse f ~init env = + Sign.fold_named_context_reverse f ~init:init (named_context env) let push_rel d = rel_context_app (add_rel_decl d) -let push_rel_context ctxt = fold_rel_context push_rel ctxt +let push_rel_context ctxt x = fold_rel_context push_rel ctxt ~init:x let push_rel_assum (id,ty) = push_rel (id,None,ty) let push_rec_types (lna,typarray,_) env = @@ -100,7 +100,7 @@ let push_rec_types (lna,typarray,_) env = let fold_rel_context f env ~init = snd (fold_rel_context (fun d (env,e) -> (push_rel d env, f env d e)) - (rel_context env) (reset_rel_context env,init)) + (rel_context env) ~init:(reset_rel_context env,init)) let set_universes g env = if env.env_universes == g then env else { env with env_universes = g } diff --git a/kernel/inductive.ml b/kernel/inductive.ml index 218edd3a4..395ec95de 100644 --- a/kernel/inductive.ml +++ b/kernel/inductive.ml @@ -97,7 +97,8 @@ let instantiate_params t args sign = | (Some b,_,LetIn(_,_,_,t)) -> (largs, (substl subs b)::subs, t) | _ -> fail()) sign - (args,[],t) in + ~init:(args,[],t) + in if rem_args <> [] then fail(); type_app (substl subs) ty @@ -190,8 +191,9 @@ let local_rels ctxt = match copt with None -> (mkRel n :: rels, n+1) | Some _ -> (rels, n+1)) - ([],1) - ctxt in + ~init:([],1) + ctxt + in rels let build_dependent_constructor cs = diff --git a/kernel/sign.ml b/kernel/sign.ml index 83474f122..20bd1e03a 100644 --- a/kernel/sign.ml +++ b/kernel/sign.ml @@ -40,8 +40,8 @@ let instance_from_named_context sign = | [] -> [] in Array.of_list (inst_rec sign) -let fold_named_context = List.fold_right -let fold_named_context_reverse = List.fold_left +let fold_named_context f l ~init = List.fold_right f l init +let fold_named_context_reverse f ~init l = List.fold_left f init l (*s Signatures of ordered section variables *) type section_context = named_context @@ -66,8 +66,8 @@ let lookup_rel n sign = let rel_context_length = List.length -let fold_rel_context = List.fold_right -let fold_rel_context_reverse = List.fold_left +let fold_rel_context f l ~init:x = List.fold_right f l x +let fold_rel_context_reverse f ~init:x l = List.fold_left f x l (* Push named declarations on top of a rel context *) (* Bizarre. Should be avoided. *) diff --git a/kernel/term.ml b/kernel/term.ml index 8c7d7ccd0..16524ea46 100644 --- a/kernel/term.ml +++ b/kernel/term.ml @@ -1020,7 +1020,7 @@ let rec to_lambda n prod = match kind_of_term prod with | Prod (na,ty,bd) -> mkLambda (na,ty,to_lambda (n-1) bd) | Cast (c,_) -> to_lambda n c - | _ -> errorlabstrm "to_lambda" [<>] + | _ -> errorlabstrm "to_lambda" (mt ()) let rec to_prod n lam = if n=0 then @@ -1029,7 +1029,7 @@ let rec to_prod n lam = match kind_of_term lam with | Lambda (na,ty,bd) -> mkProd (na,ty,to_prod (n-1) bd) | Cast (c,_) -> to_prod n c - | _ -> errorlabstrm "to_prod" [<>] + | _ -> errorlabstrm "to_prod" (mt ()) (* pseudo-reduction rule: * [prod_app s (Prod(_,B)) N --> B[N] @@ -1040,7 +1040,7 @@ let prod_app t n = | Prod (_,_,b) -> subst1 n b | _ -> errorlabstrm "prod_app" - [< 'sTR"Needed a product, but didn't find one" ; 'fNL >] + (str"Needed a product, but didn't find one" ++ fnl ()) (* prod_appvect T [| a1 ; ... ; an |] -> (T a1 ... an) *) diff --git a/kernel/typeops.ml b/kernel/typeops.ml index 6556b0c76..ce62acdf8 100644 --- a/kernel/typeops.ml +++ b/kernel/typeops.ml @@ -103,7 +103,7 @@ let rec check_hyps_inclusion env sign = if not (eq_constr ty2 ty1) then error "types do not match") sign - () + ~init:() let check_args env c hyps = diff --git a/kernel/univ.ml b/kernel/univ.ml index 99dd2ee36..c5b998380 100644 --- a/kernel/univ.ml +++ b/kernel/univ.ml @@ -49,23 +49,25 @@ let string_of_univ = function ((List.map string_of_univ_level gel)@ (List.map (fun u -> "("^(string_of_univ_level u)^")+1") gtl)))^")" -let pr_uni_level u = [< 'sTR (string_of_univ_level u) >] +let pr_uni_level u = str (string_of_univ_level u) let pr_uni = function - | Variable u -> pr_uni_level u + | Variable u -> + pr_uni_level u | Max (gel,gtl) -> - [< 'sTR "max("; - prlist_with_sep pr_coma pr_uni_level gel; - if gel <> [] & gtl <> [] then pr_coma () else [< >]; - prlist_with_sep pr_coma - (fun x -> [< 'sTR "("; pr_uni_level x; 'sTR")+1" >]) gtl; - 'sTR ")" >] + str "max(" ++ + prlist_with_sep pr_coma pr_uni_level gel ++ + if gel <> [] & gtl <> [] then pr_coma () else mt () ++ + prlist_with_sep pr_coma + (fun x -> str "(" ++ pr_uni_level x ++ str ")+1") gtl ++ + str ")" (* Returns a fresh universe, juste above u. Does not create new universes for Type_0 (the sort of Prop and Set). Used to type the sort u. *) let super = function - | Variable u -> Max ([],[u]) + | Variable u -> + Max ([],[u]) | Max _ -> anomaly ("Cannot take the successor of a non variable universes:\n"^ "you are probably typing a type already known to be the type\n"^ @@ -125,7 +127,7 @@ let repr g u = let a = try UniverseMap.find u g with Not_found -> anomalylabstrm "Univ.repr" - [< 'sTR"Universe "; pr_uni_level u; 'sTR" undefined" >] + (str"Universe " ++ pr_uni_level u ++ str" undefined") in match a with | Equiv(_,v) -> repr_rec v @@ -405,13 +407,12 @@ let num_edges g = let pr_arc = function | Canonical {univ=u; gt=gt; ge=ge} -> - hOV 2 - [< pr_uni_level u; 'sPC; - prlist_with_sep pr_spc (fun v -> [< 'sTR">"; pr_uni_level v >]) gt; - prlist_with_sep pr_spc (fun v -> [< 'sTR">="; pr_uni_level v >]) ge - >] + hov 2 + (pr_uni_level u ++ spc () ++ + prlist_with_sep pr_spc (fun v -> str ">" ++ pr_uni_level v) gt ++ + prlist_with_sep pr_spc (fun v -> str ">=" ++ pr_uni_level v) ge) | Equiv (u,v) -> - [< pr_uni_level u ; 'sTR"=" ; pr_uni_level v >] + pr_uni_level u ++ str "=" ++ pr_uni_level v let pr_universes g = let graph = UniverseMap.fold (fun k a l -> (k,a)::l) g [] in diff --git a/lib/edit.ml b/lib/edit.ml index ca41a0436..04a382a58 100644 --- a/lib/edit.ml +++ b/lib/edit.ml @@ -83,20 +83,20 @@ let undo e n = | Some d -> let (bs,_) = Hashtbl.find e.buf d in if Bstack.depth bs <= n then - errorlabstrm "Edit.undo" [< 'sTR"Undo stack would be exhausted" >]; + errorlabstrm "Edit.undo" (str"Undo stack would be exhausted"); repeat n (fun () -> let _ = Bstack.pop bs in ()) () let create e (d,b,c,udepth) = if Hashtbl.mem e.buf d then errorlabstrm "Edit.create" - [< 'sTR"Already editing something of that name" >]; + (str"Already editing something of that name"); let bs = Bstack.create udepth in Bstack.push bs b; Hashtbl.add e.buf d (bs,c) let delete e d = if not(Hashtbl.mem e.buf d) then - errorlabstrm "Edit.delete" [< 'sTR"No such editor" >]; + errorlabstrm "Edit.delete" (str"No such editor"); Hashtbl.remove e.buf d; e.last_focused_stk <- (list_except d e.last_focused_stk); match e.focus with @@ -48,7 +48,10 @@ type 'a ppdir_token = | Ppdir_print_newline | Ppdir_print_flush -type std_ppcmds = (int*string) ppcmd_token Stream.t +type ppcmd = (int*string) ppcmd_token + +type std_ppcmds = ppcmd Stream.t + type 'a ppdirs = 'a ppdir_token Stream.t (* Compute length of an UTF-8 encoded string @@ -88,41 +91,43 @@ let utf8_length s = !cnt (* formatting commands *) -let sTR s = Ppcmd_print (utf8_length s,s) -let sTRas (i,s) = Ppcmd_print (i,s) -let bRK (a,b) = Ppcmd_print_break (a,b) -let tBRK (a,b) = Ppcmd_print_tbreak (a,b) -let tAB = Ppcmd_set_tab -let fNL = Ppcmd_force_newline -let pifB = Ppcmd_print_if_broken -let wS n = Ppcmd_white_space n +let str s = [< 'Ppcmd_print (utf8_length s,s) >] +let stras (i,s) = [< 'Ppcmd_print (i,s) >] +let brk (a,b) = [< 'Ppcmd_print_break (a,b) >] +let tbrk (a,b) = [< 'Ppcmd_print_tbreak (a,b) >] +let tab () = [< 'Ppcmd_set_tab >] +let fnl () = [< 'Ppcmd_force_newline >] +let pifb () = [< 'Ppcmd_print_if_broken >] +let ws n = [< 'Ppcmd_white_space n >] (* derived commands *) -let sPC = Ppcmd_print_break (1,0) -let cUT = Ppcmd_print_break (0,0) -let aLIGN = Ppcmd_print_break (0,0) -let iNT n = sTR (string_of_int n) -let rEAL r = sTR (string_of_float r) -let bOOL b = sTR (string_of_bool b) -let qSTRING s = sTR ("\""^(String.escaped s)^"\"") -let qS = qSTRING +let spc () = [< 'Ppcmd_print_break (1,0) >] +let cut () = [< 'Ppcmd_print_break (0,0) >] +let align () = [< 'Ppcmd_print_break (0,0) >] +let int n = str (string_of_int n) +let real r = str (string_of_float r) +let bool b = str (string_of_bool b) +let qstring s = str ("\""^(String.escaped s)^"\"") +let qs = qstring +let mt () = [< >] (* boxing commands *) let h n s = [< 'Ppcmd_box(Pp_hbox n,s) >] let v n s = [< 'Ppcmd_box(Pp_vbox n,s) >] -let hV n s = [< 'Ppcmd_box(Pp_hvbox n,s) >] -let hOV n s = [< 'Ppcmd_box(Pp_hovbox n,s) >] +let hv n s = [< 'Ppcmd_box(Pp_hvbox n,s) >] +let hov n s = [< 'Ppcmd_box(Pp_hovbox n,s) >] let t s = [< 'Ppcmd_box(Pp_tbox,s) >] (* Opening and closing of boxes *) -let hB n = Ppcmd_open_box(Pp_hbox n) -let vB n = Ppcmd_open_box(Pp_vbox n) -let hVB n = Ppcmd_open_box(Pp_hvbox n) -let hOVB n = Ppcmd_open_box(Pp_hovbox n) -let tB = Ppcmd_open_box Pp_tbox -let cLOSE = Ppcmd_close_box -let tCLOSE = Ppcmd_close_tbox +let hb n = [< 'Ppcmd_open_box(Pp_hbox n) >] +let vb n = [< 'Ppcmd_open_box(Pp_vbox n) >] +let hvb n = [< 'Ppcmd_open_box(Pp_hvbox n) >] +let hovb n = [< 'Ppcmd_open_box(Pp_hovbox n) >] +let tb () = [< 'Ppcmd_open_box Pp_tbox >] +let close () = [< 'Ppcmd_close_box >] +let tclose () = [< 'Ppcmd_close_tbox >] +let (++) = Stream.iapp (* pretty printing functions *) let pp_dirs ft = @@ -167,51 +172,51 @@ let pp_dirs ft = let pp_std_dirs = pp_dirs std_ft let pp_err_dirs = pp_dirs err_ft -let pPCMDS x = Ppdir_ppcmds x +let ppcmds x = Ppdir_ppcmds x (* pretty printing functions WITHOUT FLUSH *) -let pP_with ft strm = - pp_dirs ft [< 'pPCMDS strm >] +let pp_with ft strm = + pp_dirs ft [< 'Ppdir_ppcmds strm >] -let pPNL_with ft strm = - pp_dirs ft [< 'pPCMDS [< strm ; 'Ppcmd_force_newline >] >] +let ppnl_with ft strm = + pp_dirs ft [< 'Ppdir_ppcmds [< strm ; 'Ppcmd_force_newline >] >] let warning_with ft string = - pPNL_with ft [< 'sTR"Warning: " ; 'sTR string >] + ppnl_with ft [< str "Warning: " ; str string >] -let wARN_with ft pps = - pPNL_with ft [< 'sTR"Warning: " ; pps >] +let warn_with ft pps = + ppnl_with ft [< str "Warning: " ; pps >] let pp_flush_with ft = Format.pp_print_flush ft (* pretty printing functions WITH FLUSH *) -let mSG_with ft strm = - pp_dirs ft [< 'pPCMDS strm ; 'Ppdir_print_flush >] +let msg_with ft strm = + pp_dirs ft [< 'Ppdir_ppcmds strm ; 'Ppdir_print_flush >] -let mSGNL_with ft strm = - pp_dirs ft [< 'pPCMDS strm ; 'Ppdir_print_newline >] +let msgnl_with ft strm = + pp_dirs ft [< 'Ppdir_ppcmds strm ; 'Ppdir_print_newline >] -let wARNING_with ft strm= - pp_dirs ft [<'pPCMDS ([<'sTR "Warning: "; strm>]); 'Ppdir_print_newline>] +let msg_warning_with ft strm= + pp_dirs ft [< 'Ppdir_ppcmds [< str "Warning: "; strm>]; + 'Ppdir_print_newline >] (* pretty printing functions WITHOUT FLUSH *) -let pP = pP_with std_ft -let pPNL = pPNL_with std_ft -let pPERR = pP_with err_ft -let pPERRNL = pPNL_with err_ft -let message s = pPNL [< 'sTR s >] +let pp = pp_with std_ft +let ppnl = ppnl_with std_ft +let pperr = pp_with err_ft +let pperrnl = ppnl_with err_ft +let message s = ppnl (str s) let warning = warning_with std_ft -let wARN = wARN_with std_ft +let warn = warn_with std_ft let pp_flush = Format.pp_print_flush std_ft let flush_all() = flush stderr; flush stdout; pp_flush() (* pretty printing functions WITH FLUSH *) -let mSG = mSG_with std_ft -let mSGNL = mSGNL_with std_ft -let mSGERR = mSG_with err_ft -let mSGERRNL = mSGNL_with err_ft -let wARNING = wARNING_with std_ft - +let msg = msg_with std_ft +let msgnl = msgnl_with std_ft +let msgerr = msg_with err_ft +let msgerrnl = msgnl_with err_ft +let msg_warning = msg_warning_with std_ft diff --git a/lib/pp.mli b/lib/pp.mli index d0730044c..c23100b2f 100644 --- a/lib/pp.mli +++ b/lib/pp.mli @@ -14,62 +14,67 @@ open Pp_control (* Pretty-printers. *) -type 'a ppcmd_token +type ppcmd -type std_ppcmds = (int*string) ppcmd_token Stream.t +type std_ppcmds = ppcmd Stream.t (*s Formatting commands. *) -val sTR : string -> (int*string) ppcmd_token -val sTRas : int * string -> (int*string) ppcmd_token -val bRK : int * int -> 'a ppcmd_token -val tBRK : int * int -> 'a ppcmd_token -val tAB : 'a ppcmd_token -val fNL : 'a ppcmd_token -val pifB : 'a ppcmd_token -val wS : int -> 'a ppcmd_token +val str : string -> std_ppcmds +val stras : int * string -> std_ppcmds +val brk : int * int -> std_ppcmds +val tbrk : int * int -> std_ppcmds +val tab : unit -> std_ppcmds +val fnl : unit -> std_ppcmds +val pifb : unit -> std_ppcmds +val ws : int -> std_ppcmds +val mt : unit -> std_ppcmds + +(*s Concatenation. *) + +val (++) : std_ppcmds -> std_ppcmds -> std_ppcmds (*s Derived commands. *) -val sPC : 'a ppcmd_token -val cUT : 'a ppcmd_token -val aLIGN : 'a ppcmd_token -val iNT : int -> (int*string) ppcmd_token -val rEAL : float -> (int * string) ppcmd_token -val bOOL : bool -> (int * string) ppcmd_token -val qSTRING : string -> (int * string) ppcmd_token -val qS : string -> (int * string) ppcmd_token +val spc : unit -> std_ppcmds +val cut : unit -> std_ppcmds +val align : unit -> std_ppcmds +val int : int -> std_ppcmds +val real : float -> std_ppcmds +val bool : bool -> std_ppcmds +val qstring : string -> std_ppcmds +val qs : string -> std_ppcmds (*s Boxing commands. *) val h : int -> std_ppcmds -> std_ppcmds val v : int -> std_ppcmds -> std_ppcmds -val hV : int -> std_ppcmds -> std_ppcmds -val hOV : int -> std_ppcmds -> std_ppcmds +val hv : int -> std_ppcmds -> std_ppcmds +val hov : int -> std_ppcmds -> std_ppcmds val t : std_ppcmds -> std_ppcmds (*s Opening and closing of boxes. *) -val hB : int -> 'a ppcmd_token -val vB : int -> 'a ppcmd_token -val hVB : int -> 'a ppcmd_token -val hOVB : int -> 'a ppcmd_token -val tB : 'a ppcmd_token -val cLOSE : 'a ppcmd_token -val tCLOSE : 'a ppcmd_token +val hb : int -> std_ppcmds +val vb : int -> std_ppcmds +val hvb : int -> std_ppcmds +val hovb : int -> std_ppcmds +val tb : unit -> std_ppcmds +val close : unit -> std_ppcmds +val tclose : unit -> std_ppcmds (*s Pretty-printing functions \emph{without flush}. *) -val pP_with : Format.formatter -> std_ppcmds -> unit -val pPNL_with : Format.formatter -> std_ppcmds -> unit +val pp_with : Format.formatter -> std_ppcmds -> unit +val ppnl_with : Format.formatter -> std_ppcmds -> unit val warning_with : Format.formatter -> string -> unit -val wARN_with : Format.formatter -> std_ppcmds -> unit +val warn_with : Format.formatter -> std_ppcmds -> unit val pp_flush_with : Format.formatter -> unit -> unit (*s Pretty-printing functions \emph{with flush}. *) -val mSG_with : Format.formatter -> std_ppcmds -> unit -val mSGNL_with : Format.formatter -> std_ppcmds -> unit +val msg_with : Format.formatter -> std_ppcmds -> unit +val msgnl_with : Format.formatter -> std_ppcmds -> unit (*s The following functions are instances of the previous ones on @@ -77,21 +82,20 @@ val mSGNL_with : Format.formatter -> std_ppcmds -> unit (*s Pretty-printing functions \emph{without flush} on [stdout] and [stderr]. *) -val pP : std_ppcmds -> unit -val pPNL : std_ppcmds -> unit -val pPERR : std_ppcmds -> unit -val pPERRNL : std_ppcmds -> unit +val pp : std_ppcmds -> unit +val ppnl : std_ppcmds -> unit +val pperr : std_ppcmds -> unit +val pperrnl : std_ppcmds -> unit val message : string -> unit (* = pPNL *) val warning : string -> unit -val wARN : std_ppcmds -> unit +val warn : std_ppcmds -> unit val pp_flush : unit -> unit val flush_all: unit -> unit (*s Pretty-printing functions \emph{with flush} on [stdout] and [stderr]. *) -val mSG : std_ppcmds -> unit -val mSGNL : std_ppcmds -> unit -val mSGERR : std_ppcmds -> unit -val mSGERRNL : std_ppcmds -> unit -val wARNING : std_ppcmds -> unit - +val msg : std_ppcmds -> unit +val msgnl : std_ppcmds -> unit +val msgerr : std_ppcmds -> unit +val msgerrnl : std_ppcmds -> unit +val msg_warning : std_ppcmds -> unit diff --git a/lib/system.ml b/lib/system.ml index 81dda51f9..37a102d40 100644 --- a/lib/system.ml +++ b/lib/system.ml @@ -22,7 +22,7 @@ type load_path = physical_path list let exists_dir dir = try let _ = opendir dir in true with Unix_error _ -> false -let all_subdirs root = +let all_subdirs ~unix_path:root = let l = ref [] in let add f rel = l := (f, rel) :: !l in let rec traverse dir rel = @@ -85,8 +85,8 @@ let find_file_in_path paths name = search_in_path paths name with Not_found -> errorlabstrm "System.find_file_in_path" - (hOV 0 [< 'sTR"Can't find file" ; 'sPC ; 'sTR name ; 'sPC ; - 'sTR"on loadpath" >]) + (hov 0 (str "Can't find file" ++ spc () ++ str name ++ spc () ++ + str "on loadpath")) let is_in_path lpath filename = try @@ -106,8 +106,8 @@ let open_trapping_failure open_fun name suffix = let try_remove f = try Sys.remove f - with _ -> mSGNL [< 'sTR"Warning: " ; 'sTR"Could not remove file " ; - 'sTR f ; 'sTR" which is corrupted!" >] + with _ -> msgnl (str"Warning: " ++ str"Could not remove file " ++ + str f ++ str" which is corrupted!" ) let marshal_out ch v = Marshal.to_channel ch v [] let marshal_in ch = @@ -169,9 +169,9 @@ let get_time () = let time_difference (t1,_,_) (t2,_,_) = t2 -. t1 let fmt_time_difference (startreal,ustart,sstart) (stopreal,ustop,sstop) = - [< 'rEAL(stopreal -. startreal); 'sTR" secs "; - 'sTR"("; - 'rEAL((-.) ustop ustart); 'sTR"u"; - 'sTR","; - 'rEAL((-.) sstop sstart); 'sTR"s"; - 'sTR")" >] + real (stopreal -. startreal) ++ str " secs " ++ + str "(" ++ + real ((-.) ustop ustart) ++ str "u" ++ + str "," ++ + real ((-.) sstop sstart) ++ str "s" ++ + str ")" diff --git a/lib/util.ml b/lib/util.ml index 30e64307d..5a02ffaef 100644 --- a/lib/util.ml +++ b/lib/util.ml @@ -13,11 +13,11 @@ open Pp (* Errors *) exception Anomaly of string * std_ppcmds (* System errors *) -let anomaly string = raise (Anomaly(string,[< 'sTR string >])) +let anomaly string = raise (Anomaly(string, str string)) let anomalylabstrm string pps = raise (Anomaly(string,pps)) exception UserError of string * std_ppcmds (* User errors *) -let error string = raise (UserError(string,[< 'sTR string >])) +let error string = raise (UserError(string, str string)) let errorlabstrm l pps = raise (UserError(l,pps)) (* raising located exceptions *) @@ -498,26 +498,26 @@ let map_succeed f = (* Pretty-printing *) -let pr_spc () = [< 'sPC >];; -let pr_fnl () = [< 'fNL >];; -let pr_int n = [< 'iNT n >];; -let pr_str s = [< 'sTR s >];; -let pr_coma () = [< 'sTR","; 'sPC >];; +let pr_spc = spc +let pr_fnl = fnl +let pr_int = int +let pr_str = str +let pr_coma () = str "," ++ spc () let rec prlist elem l = match l with - | [] -> [< >] - | h::t -> let e = elem h and r = prlist elem t in [< e; r >] + | [] -> mt () + | h::t -> Stream.lapp (fun () -> elem h) (prlist elem t) let rec prlist_with_sep sep elem l = match l with - | [] -> [< >] + | [] -> mt () | [h] -> elem h | h::t -> let e = elem h and s = sep() and r = prlist_with_sep sep elem t in - [< e; s; r >] + e ++ s ++ r let pr_vertical_list pr = function - | [] -> [< 'sTR "none"; 'fNL >] - | l -> [< 'fNL; 'sTR " "; hOV 0 (prlist_with_sep pr_fnl pr l); 'fNL >] + | [] -> str "none" ++ fnl () + | l -> fnl () ++ str " " ++ hov 0 (prlist_with_sep pr_fnl pr l) ++ fnl () let prvecti elem v = let n = Array.length v in @@ -525,9 +525,9 @@ let prvecti elem v = if i = 0 then elem 0 v.(0) else - let r = pr (i-1) and e = elem i v.(i) in [< r; e >] + let r = pr (i-1) and e = elem i v.(i) in r ++ e in - if n=0 then [< >] else pr (n - 1) + if n = 0 then mt () else pr (n - 1) let prvect_with_sep sep elem v = let rec pr n = @@ -535,10 +535,10 @@ let prvect_with_sep sep elem v = elem v.(0) else let r = pr (n-1) and s = sep() and e = elem v.(n) in - [< r; s; e >] + r ++ s ++ e in let n = Array.length v in - if n = 0 then [< >] else pr (n - 1) + if n = 0 then mt () else pr (n - 1) (*s Size of ocaml values. *) diff --git a/lib/util.mli b/lib/util.mli index 7bd7d71c4..60504d9cf 100644 --- a/lib/util.mli +++ b/lib/util.mli @@ -168,12 +168,12 @@ val pr_int : int -> std_ppcmds val pr_str : string -> std_ppcmds val pr_coma : unit -> std_ppcmds -val prlist : ('a -> 'b Stream.t) -> 'a list -> 'b Stream.t -val prvecti : (int -> 'a -> 'b Stream.t) -> 'a array -> 'b Stream.t +val prlist : ('a -> std_ppcmds) -> 'a list -> std_ppcmds +val prvecti : (int -> 'a -> std_ppcmds) -> 'a array -> std_ppcmds val prlist_with_sep : - (unit -> 'a Stream.t) -> ('b -> 'a Stream.t) -> 'b list -> 'a Stream.t + (unit -> std_ppcmds) -> ('b -> std_ppcmds) -> 'b list -> std_ppcmds val prvect_with_sep : - (unit -> 'a Stream.t) -> ('b -> 'a Stream.t) -> 'b array -> 'a Stream.t + (unit -> std_ppcmds) -> ('b -> std_ppcmds) -> 'b array -> std_ppcmds val pr_vertical_list : ('b -> std_ppcmds) -> 'b list -> std_ppcmds (*s Size of an ocaml value (in words, bytes and kilobytes). *) diff --git a/library/declare.ml b/library/declare.ml index c87ec0d34..2b86f8954 100644 --- a/library/declare.ml +++ b/library/declare.ml @@ -84,17 +84,17 @@ let _ = Summary.declare_summary "VARIABLE" Summary.init_function = (fun () -> vartab := Idmap.empty); Summary.survive_section = false } -let cache_variable (sp,(id,(p,d,str))) = +let cache_variable (sp,(id,(p,d,strength))) = (* Constr raisonne sur les noms courts *) if Idmap.mem id !vartab then - errorlabstrm "cache_variable" [< pr_id id; 'sTR " already exists" >]; + errorlabstrm "cache_variable" (pr_id id ++ str " already exists"); let cst = match d with (* Fails if not well-typed *) | SectionLocalAssum ty -> Global.push_named_assum (id,ty) | SectionLocalDef (c,t) -> Global.push_named_def (id,c,t) in let (_,bd,ty) = Global.lookup_named id in let vd = (bd,ty,cst) in Nametab.push 0 (restrict_path 0 sp) (VarRef id); - vartab := Idmap.add id (p,vd,str) !vartab + vartab := Idmap.add id (p,vd,strength) !vartab let (in_variable, out_variable) = let od = { @@ -125,7 +125,7 @@ let _ = Summary.declare_summary "CONSTANT" let cache_constant (sp,(cdt,stre)) = (if Nametab.exists_cci sp then let (_,id) = repr_path sp in - errorlabstrm "cache_constant" [< pr_id id; 'sTR " already exists" >]); + errorlabstrm "cache_constant" (pr_id id ++ str " already exists")); Global.add_constant sp cdt; (match stre with | DischargeAt (dp,n) when not (is_dirpath_prefix_of dp (Lib.cwd ())) -> @@ -143,7 +143,7 @@ let cache_constant (sp,(cdt,stre)) = let load_constant (sp,(ce,stre)) = (if Nametab.exists_cci sp then let (_,id) = repr_path sp in - errorlabstrm "cache_constant" [< pr_id id; 'sTR " already exists" >]); + errorlabstrm "cache_constant" (pr_id id ++ str " already exists")); csttab := Spmap.add sp stre !csttab; Nametab.push (depth_of_strength stre + 1) sp (ConstRef sp) @@ -206,7 +206,7 @@ let inductive_names sp mie = let check_exists_inductive (sp,_) = if Nametab.exists_cci sp then let (_,id) = repr_path sp in - errorlabstrm "cache_inductive" [< pr_id id; 'sTR " already exists" >] + errorlabstrm "cache_inductive" (pr_id id ++ str " already exists") let cache_inductive (sp,mie) = let names = inductive_names sp mie in diff --git a/library/goptions.ml b/library/goptions.ml index 95336c35e..f919b12e8 100644 --- a/library/goptions.ml +++ b/library/goptions.ml @@ -109,10 +109,11 @@ module MakeTable = (fun c -> t := MySet.remove c !t)) let print_table table_name printer table = - mSG ([< 'sTR table_name ; (hOV 0 - (if MySet.is_empty table then [< 'sTR "None" ; 'fNL >] - else MySet.fold - (fun a b -> [< printer a; 'sPC; b >]) table [<>])) >]) + msg (str table_name ++ + (hov 0 + (if MySet.is_empty table then str "None" ++ fnl () + else MySet.fold + (fun a b -> printer a ++ spc () ++ b) table (mt ())))) class table_of_A () = object @@ -123,7 +124,7 @@ module MakeTable = method remove x = remove_option (A.encode x) method mem x = let answer = MySet.mem (A.encode x) !t in - mSG [< 'sTR (A.member_message x answer) >] + msg (str (A.member_message x answer)) method print = print_table A.title A.printer !t end @@ -152,7 +153,7 @@ struct let table = string_table let encode x = x let check = A.check - let printer s = [< 'sTR s >] + let printer s = (str s) let key = A.key let title = A.title let member_message = A.member_message @@ -298,10 +299,10 @@ let set_string_option_value = set_option_value let msg_option_value (name,v) = match v with - | BoolValue true -> [< 'sTR "true" >] - | BoolValue false -> [< 'sTR "false" >] - | IntValue n -> [< 'iNT n >] - | StringValue s -> [< 'sTR s >] + | BoolValue true -> str "true" + | BoolValue false -> str "false" + | IntValue n -> int n + | StringValue s -> str s | IdentValue r -> pr_global_env (Global.env()) r let print_option_value key = @@ -309,35 +310,41 @@ let print_option_value key = let s = read () in match s with | BoolValue b -> - mSG [< 'sTR("The "^name^" mode is "^(if b then "on" else "off"));'fNL>] + msg (str ("The "^name^" mode is "^(if b then "on" else "off")) ++ + fnl ()) | _ -> - mSG [< 'sTR ("Current value of "^name^" is "); - msg_option_value (name,s); 'fNL >] + msg (str ("Current value of "^name^" is ") ++ + msg_option_value (name,s) ++ fnl ()) let print_tables () = - mSG - [< 'sTR "Synchronous options:"; 'fNL; + msg + (str "Synchronous options:" ++ fnl () ++ OptionMap.fold (fun key (name,(sync,read,write)) p -> - if sync then [< p; 'sTR (" "^(nickname key)^": "); - msg_option_value (name,read()); 'fNL >] - else [< p >]) - !value_tab [<>]; - 'sTR "Asynchronous options:"; 'fNL; + if sync then + p ++ str (" "^(nickname key)^": ") ++ + msg_option_value (name,read()) ++ fnl () + else + p) + !value_tab (mt ()) ++ + str "Asynchronous options:" ++ fnl () ++ OptionMap.fold (fun key (name,(sync,read,write)) p -> - if sync then [< p >] - else [< p; 'sTR (" "^(nickname key)^": "); - msg_option_value (name,read()); 'fNL >]) - !value_tab [<>]; - 'sTR "Tables:"; 'fNL; + if sync then + p + else + p ++ str (" "^(nickname key)^": ") ++ + msg_option_value (name,read()) ++ fnl ()) + !value_tab (mt ()) ++ + str "Tables:" ++ fnl () ++ List.fold_right - (fun (nickkey,_) p -> [< p; 'sTR (" "^nickkey); 'fNL >]) - !string_table [<>]; + (fun (nickkey,_) p -> p ++ str (" "^nickkey) ++ fnl ()) + !string_table (mt ()) ++ List.fold_right - (fun (nickkey,_) p -> [< p; 'sTR (" "^nickkey); 'fNL >]) - !ident_table [<>]; - 'fNL; - >] + (fun (nickkey,_) p -> p ++ str (" "^nickkey) ++ fnl ()) + !ident_table (mt ()) ++ + fnl () + ) + diff --git a/library/lib.ml b/library/lib.ml index f989ce988..8eaba772e 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -147,7 +147,7 @@ let open_section id = let dir = extend_dirpath !path_prefix id in let sp = make_path id in if Nametab.exists_section dir then - errorlabstrm "open_section" [< pr_id id; 'sTR " already exists" >]; + errorlabstrm "open_section" (pr_id id ++ str " already exists"); let sum = freeze_summaries() in add_entry sp (OpenedSection (dir, sum)); (*Pushed for the lifetime of the section: removed by unfrozing the summary*) @@ -176,7 +176,7 @@ let export_segment seg = (* Restore lib_stk and summaries as before the section opening, and add a ClosedSection object. *) -let close_section export id = +let close_section ~export id = let sp,dir,fs = try match find_entry_p is_opened_section with | sp,OpenedSection (dir,fs) -> diff --git a/library/library.ml b/library/library.ml index 970c2f6bf..5dc120c23 100644 --- a/library/library.ml +++ b/library/library.ml @@ -246,9 +246,9 @@ let with_magic_number_check f a = try f a with System.Bad_magic_number fname -> errorlabstrm "load_module_from" - [< 'sTR"file "; 'sTR fname; 'sPC; 'sTR"has bad magic number."; - 'sPC; 'sTR"It is corrupted"; 'sPC; - 'sTR"or was compiled with another version of Coq." >] + (str"file " ++ str fname ++ spc () ++ str"has bad magic number." ++ + spc () ++ str"It is corrupted" ++ spc () ++ + str"or was compiled with another version of Coq.") let rec load_module = function | (LibLoaded, dir, _) -> @@ -264,9 +264,9 @@ let rec load_module = function close_in ch; if dir <> md.md_name then errorlabstrm "load_module" - [< 'sTR ("The file " ^ f ^ " contains module"); 'sPC; - pr_dirpath md.md_name; 'sPC; 'sTR "and not module"; 'sPC; - pr_dirpath dir >]; + (str ("The file " ^ f ^ " contains module") ++ spc () ++ + pr_dirpath md.md_name ++ spc () ++ str "and not module" ++ spc () ++ + pr_dirpath dir); compunit_cache := Stringmap.add f (md, digest) !compunit_cache; (md, digest) in intern_module digest f md @@ -301,11 +301,11 @@ and load_absolute_module_from dir = | LibUnmappedDir -> let prefix, dir = fst (split_dirpath dir), string_of_dirpath dir in errorlabstrm "load_module" - [< 'sTR ("Cannot load "^dir^":"); 'sPC; - 'sTR "no physical path bound to"; 'sPC; pr_dirpath prefix; 'fNL >] + (str ("Cannot load "^dir^":") ++ spc () ++ + str "no physical path bound to" ++ spc () ++ pr_dirpath prefix ++ fnl ()) | LibNotFound -> errorlabstrm "load_module" - [< 'sTR"Cannot find module "; pr_dirpath dir; 'sTR" in loadpath">] + (str"Cannot find module " ++ pr_dirpath dir ++ str" in loadpath") | e -> raise e let locate_qualified_library qid = @@ -336,19 +336,19 @@ let try_locate_qualified_library qid = | LibUnmappedDir -> let prefix, id = repr_qualid qid in errorlabstrm "load_module" - [< 'sTR ("Cannot load "^(string_of_id id)^":"); 'sPC; - 'sTR "no physical path bound to"; 'sPC; pr_dirpath prefix; 'fNL >] + (str ("Cannot load "^(string_of_id id)^":") ++ spc () ++ + str "no physical path bound to" ++ spc () ++ pr_dirpath prefix ++ fnl ()) | LibNotFound -> errorlabstrm "load_module" - [< 'sTR"Cannot find module "; pr_qualid qid; 'sTR" in loadpath">] + (str"Cannot find module " ++ pr_qualid qid ++ str" in loadpath") | _ -> assert false let check_module_short_name f dir = function | Some id when id <> snd (split_dirpath dir) -> errorlabstrm "load_module" - [< 'sTR ("The file " ^ f ^ " contains module"); 'sPC; - pr_dirpath dir; 'sPC; 'sTR "and not module"; 'sPC; - pr_id id >] + (str ("The file " ^ f ^ " contains module") ++ spc () ++ + pr_dirpath dir ++ spc () ++ str "and not module" ++ spc () ++ + pr_id id) | _ -> () let locate_by_filename_only id f = @@ -473,10 +473,10 @@ let iter_all_segments insec f = let fmt_modules_state () = let opened = opened_modules () and loaded = loaded_modules () in - [< 'sTR "Imported (open) Modules: " ; - prlist_with_sep pr_spc pr_dirpath opened ; 'fNL ; - 'sTR "Loaded Modules: "; - prlist_with_sep pr_spc pr_dirpath loaded ; 'fNL >] + (str "Imported (open) Modules: " ++ + prlist_with_sep pr_spc pr_dirpath opened ++ fnl () ++ + str "Loaded Modules: " ++ + prlist_with_sep pr_spc pr_dirpath loaded ++ fnl ()) (*s Display the memory use of a module. *) @@ -484,6 +484,6 @@ open Printf let mem s = let m = find_module s in - h 0 [< 'sTR (sprintf "%dk (cenv = %dk / seg = %dk)" + h 0 (str (sprintf "%dk (cenv = %dk / seg = %dk)" (size_kb m) (size_kb m.module_compiled_env) - (size_kb m.module_declarations)) >] + (size_kb m.module_declarations))) diff --git a/library/nameops.ml b/library/nameops.ml index c748f5a55..ecbe07e77 100644 --- a/library/nameops.ml +++ b/library/nameops.ml @@ -17,7 +17,7 @@ open Term (* Identifiers *) -let pr_id id = [< 'sTR (string_of_id id) >] +let pr_id id = (str (string_of_id id)) let wildcard = id_of_string "_" @@ -145,7 +145,7 @@ let next_name_away name l = (**********************************************) -let pr_dirpath sl = [< 'sTR (string_of_dirpath sl) >] +let pr_dirpath sl = (str (string_of_dirpath sl)) (* Operations on dirpaths *) let empty_dirpath = make_dirpath [] @@ -234,4 +234,4 @@ let path_of_string s = | Invalid_argument _ -> invalid_arg "path_of_string" (* Section paths *) -let pr_sp sp = [< 'sTR (string_of_path sp) >] +let pr_sp sp = (str (string_of_path sp)) diff --git a/library/nametab.ml b/library/nametab.ml index f70d672f8..99524bde1 100755 --- a/library/nametab.ml +++ b/library/nametab.ml @@ -157,7 +157,7 @@ let push_long_names_libpath = push_modidtree the_libtab possibly limited visibility, i.e. Theorem, Lemma, Definition, Axiom, Parameter but also Remark and Fact) *) -let push_cci n sp ref = +let push_cci ~visibility:n sp ref = let dir, s = repr_path sp in (* We push partially qualified name (with at least one prefix) *) push_long_names_ccipath n dir s (TrueGlobal ref) @@ -297,7 +297,7 @@ let pr_global_env env ref = paresseusement : il faut forcer l'évaluation pour capturer l'éventuelle levée d'une exception (le cas échoit dans le debugger) *) let s = string_of_qualid (shortest_qualid_of_global env ref) in - [< 'sTR s >] + (str s) (********************************************************************) diff --git a/library/summary.ml b/library/summary.ml index c315e0cd2..210a1a81b 100644 --- a/library/summary.ml +++ b/library/summary.ml @@ -34,7 +34,7 @@ let declare_summary sumname sdecl = in if Hashtbl.mem summaries sumname then anomalylabstrm "Summary.declare_summary" - [< 'sTR "Cannot declare a summary twice: " ; 'sTR sumname >]; + (str "Cannot declare a summary twice: " ++ str sumname); Hashtbl.add summaries sumname ddecl type frozen = Dyn.t Stringmap.t diff --git a/parsing/ast.ml b/parsing/ast.ml index 1830e45e9..ac5c149e4 100755 --- a/parsing/ast.ml +++ b/parsing/ast.ml @@ -37,7 +37,7 @@ let slam(idl,b) = Slam(dummy_loc,idl,b) let ide s = Id(dummy_loc,s) let nvar s = Nvar(dummy_loc,s) let num n = Num(dummy_loc,n) -let str s = Str(dummy_loc,s) +let string s = Str(dummy_loc,s) let path sl = Path(dummy_loc,sl) let dynamic d = Dynamic(dummy_loc,d) @@ -102,63 +102,67 @@ type env = (string * v) list (* Pretty-printing *) let rec print_ast ast = match ast with - | Num(_,n) -> [< 'iNT n >] - | Str(_,s) -> [< 'qS s >] - | Path(_,sl) -> [< 'sTR(string_of_path sl) >] - | Id (_,s) -> [< 'sTR"{" ; 'sTR s ; 'sTR"}" >] - | Nvar(_,s) -> [< 'sTR(string_of_id s) >] - | Nmeta(_,s) -> [< 'sTR s >] + | Num(_,n) -> int n + | Str(_,s) -> qs s + | Path(_,sl) -> str (string_of_path sl) + | Id (_,s) -> str "{" ++ str s ++ str "}" + | Nvar(_,s) -> str (string_of_id s) + | Nmeta(_,s) -> str s | Node(_,op,l) -> - hOV 3 [< 'sTR"(" ; 'sTR op ; 'sPC ; print_astl l; 'sTR")" >] - | Slam(_,None,ast) -> hOV 1 [< 'sTR"[<>]"; print_ast ast >] + hov 3 (str "(" ++ str op ++ spc () ++ print_astl l ++ str ")") + | Slam(_,None,ast) -> hov 1 (str "[<>]" ++ print_ast ast) | Slam(_,Some x,ast) -> - hOV 1 - [< 'sTR"["; 'sTR(string_of_id x); 'sTR"]"; 'cUT; print_ast ast >] - | Smetalam(_,id,ast) -> hOV 1 [< 'sTR id; print_ast ast >] + hov 1 + (str "[" ++ str (string_of_id x) ++ str "]" ++ cut () ++ + print_ast ast) + | Smetalam(_,id,ast) -> hov 1 (str id ++ print_ast ast) | Dynamic(_,d) -> - hOV 0 [< 'sTR"<dynamic: "; 'sTR(Dyn.tag d); 'sTR">" >] + hov 0 (str "<dynamic: " ++ str (Dyn.tag d) ++ str ">") and print_astl astl = prlist_with_sep pr_spc print_ast astl let print_ast_cast = function - | Tany -> [< >] - | Tvar -> [< 'sTR":var" >] - | Tid -> [< 'sTR":id" >] - | Tstr -> [< 'sTR":str" >] - | Tpath -> [< 'sTR":path" >] - | Tnum -> [< 'sTR":num" >] - | Tlist -> [< 'sTR":list" >] + | Tany -> (mt ()) + | Tvar -> (str":var") + | Tid -> (str":id") + | Tstr -> (str":str") + | Tpath -> (str":path") + | Tnum -> (str":num") + | Tlist -> (str":list") let rec print_astpat = function - | Pquote ast -> [< 'sTR"'"; print_ast ast >] - | Pmeta(s,tk) -> [< 'sTR s; print_ast_cast tk >] + | Pquote ast -> + str"'" ++ print_ast ast + | Pmeta(s,tk) -> + str s ++ print_ast_cast tk | Pmeta_slam(s,b) -> - hOV 1 [< 'sTR"["; 'sTR s; 'sTR"]"; 'cUT; print_astpat b >] + hov 1 (str "[" ++ str s ++ str"]" ++ cut () ++ print_astpat b) | Pnode(op,al) -> - hOV 2 [< 'sTR"(" ; 'sTR op; 'sPC; print_astlpat al; 'sTR")" >] - | Pslam(None,b) -> hOV 1 [< 'sTR"[<>]"; 'cUT; print_astpat b >] + hov 2 (str"(" ++ str op ++ spc () ++ print_astlpat al ++ str")" ) + | Pslam(None,b) -> + hov 1 (str"[<" ++ cut () ++ print_astpat b) | Pslam(Some id,b) -> - hOV 1 - [< 'sTR"["; 'sTR(string_of_id id); 'sTR"]"; 'cUT; print_astpat b >] + hov 1 + (str"[" ++ str(string_of_id id) ++ str"]" ++ cut () ++ print_astpat b) and print_astlpat = function - | Pnil -> [< >] - | Pcons(h,Pnil) -> hOV 1 [< print_astpat h >] - | Pcons(h,t) -> hOV 1 [< print_astpat h; 'sPC; print_astlpat t >] - | Plmeta(s) -> [< 'sTR"| "; 'sTR s >] + | Pnil -> (mt ()) + | Pcons(h,Pnil) -> hov 1 (print_astpat h) + | Pcons(h,t) -> hov 1 (print_astpat h ++ spc () ++ print_astlpat t) + | Plmeta(s) -> (str"| " ++ str s) let print_val = function | Vast a -> print_ast a | Vastlist al -> - hOV 1 [< 'sTR"["; prlist_with_sep pr_spc print_ast al; 'sTR"]" >] + hov 1 (str"[" ++ prlist_with_sep pr_spc print_ast al ++ str"]") (* Ast values environments *) let grammar_type_error (loc,s) = - anomaly_loc (loc,s,[< 'sTR"grammar type error: "; 'sTR s >]) + anomaly_loc (loc,s,(str"grammar type error: " ++ str s)) (* Coercions enforced by the user *) @@ -172,7 +176,7 @@ let check_cast loc a k = | (Tnum, Num _) -> () | (Tlist, _) -> grammar_type_error (loc,"Ast.cast_val") | _ -> user_err_loc (loc,"Ast.cast_val", - [< 'sTR"cast _"; print_ast_cast k; 'sTR"failed" >]) + (str"cast _" ++ print_ast_cast k ++ str"failed")) let rec coerce_to_var = function | Nvar(_,id) as var -> var @@ -181,7 +185,7 @@ let rec coerce_to_var = function | Node(_,"QUALIDARG",[Nvar(_,id) as var]) -> var | ast -> user_err_loc (loc ast,"Ast.coerce_to_var", - [< 'sTR"This expression should be a simple identifier" >]) + (str"This expression should be a simple identifier")) let coerce_to_id a = match coerce_to_var a with | Nvar (_,id) -> id @@ -194,7 +198,7 @@ let env_assoc_value loc v env = with Not_found -> anomaly_loc (loc,"Ast.env_assoc_value", - [< 'sTR"metavariable "; 'sTR v; 'sTR" is unbound." >]) + (str"metavariable " ++ str v ++ str" is unbound.")) let env_assoc_list sigma (loc,v) = match env_assoc_value loc v sigma with @@ -252,12 +256,12 @@ let type_of_meta env loc pv = List.assoc pv env with Not_found -> user_err_loc (loc,"Ast.type_of_meta", - [< 'sTR"variable "; 'sTR pv; 'sTR" is unbound" >]) + (str"variable " ++ str pv ++ str" is unbound")) let check_ast_meta env loc pv = if (type_of_meta env loc pv) <> ETast then user_err_loc (loc,"Ast.check_ast_meta", - [< 'sTR"variable "; 'sTR pv; 'sTR" is a List" >]) + (str"variable " ++ str pv ++ str" is a List")) let rec val_of_ast env ast = match ast with @@ -277,7 +281,7 @@ let rec val_of_ast env ast = | Slam(_,os,b) -> Pslam(os, val_of_ast env b) | Node(loc,op,_) when isMeta op -> user_err_loc(loc,"Ast.val_of_ast", - [< 'sTR"no metavariable in operator position." >]) + (str"no metavariable in operator position.")) | Node(_,op,args) -> Pnode(op, vall_of_astl env args) | Dynamic(loc,_) -> invalid_arg_loc(loc,"val_of_ast: dynamic") @@ -292,8 +296,8 @@ and vall_of_astl env astl = Pcons(Pmeta(pv,Tlist), vall_of_astl env asttl) else user_err_loc (loc,"Ast.vall_of_astl", - [< 'sTR"variable "; 'sTR pv; - 'sTR" is not a List" >]) + (str"variable " ++ str pv ++ + str" is not a List")) | ast::asttl -> Pcons (val_of_ast env ast, vall_of_astl env asttl) | [] -> Pnil @@ -449,8 +453,8 @@ let bind_patvar env loc v etyp = else user_err_loc (loc,"Ast.bind_patvar", - [< 'sTR"variable "; 'sTR v; - 'sTR" is bound several times with different types" >]) + (str"variable " ++ str v ++ + str" is bound several times with different types")) with Not_found -> if v="$_" then env else (v,etyp)::env @@ -493,7 +497,7 @@ let rec pat_of_ast env ast = (Pslam(os,pb), env') | Node(loc,op,_) when isMeta op -> user_err_loc(loc,"Ast.pat_of_ast", - [< 'sTR"no metavariable in operator position." >]) + (str"no metavariable in operator position.")) | Node(_,op,args) -> let (pargs, env') = patl_of_astl env args in (Pnode(op,pargs), env') @@ -521,28 +525,29 @@ let to_pat env ast = (* Ast with cases and metavariables *) let print_sig = function - | [] -> [< >] + | [] -> + mt () | sigma -> - [< 'sTR"with constraints :"; 'bRK(1,1); - v 0 (prlist_with_sep pr_spc - (fun (x,v) -> [< 'sTR x; 'sTR" = "; hOV 0 (print_val v) >]) - sigma) >] + str"with constraints :" ++ brk(1,1) ++ + v 0 (prlist_with_sep pr_spc + (fun (x,v) -> str x ++ str" = " ++ hov 0 (print_val v)) + sigma) let case_failed loc sigma e pats = user_err_loc (loc,"Ast.eval_act", - [< 'sTR"Grammar case failure. The ast"; 'sPC; print_ast e; - 'sPC; 'sTR"does not match any of the patterns :"; - 'bRK(1,1); v 0 (prlist_with_sep pr_spc print_astpat pats); 'fNL; - print_sig sigma >]) + str"Grammar case failure. The ast" ++ spc () ++ print_ast e ++ + spc () ++ str"does not match any of the patterns :" ++ + brk(1,1) ++ v 0 (prlist_with_sep pr_spc print_astpat pats) ++ fnl () ++ + print_sig sigma) let caselist_failed loc sigma el pats = user_err_loc (loc,"Ast.eval_act", - [< 'sTR"Grammar case failure. The ast list"; 'bRK(1,1); print_astl el; - 'sPC; 'sTR"does not match any of the patterns :"; - 'bRK(1,1); v 0 (prlist_with_sep pr_spc print_astlpat pats); 'fNL; - print_sig sigma >]) + str"Grammar case failure. The ast list" ++ brk(1,1) ++ print_astl el ++ + spc () ++ str"does not match any of the patterns :" ++ + brk(1,1) ++ v 0 (prlist_with_sep pr_spc print_astlpat pats) ++ fnl () ++ + print_sig sigma) let rec eval_act dloc sigma act = match act with @@ -593,7 +598,7 @@ and case vars etyp ast = (apl,aa) | _ -> user_err_loc (loca,"Ast.case", - [< 'sTR"case pattern for an ast should be a single ast" >])) + (str"case pattern for an ast should be a single ast"))) | _ -> invalid_arg_loc (loc ast,"Ast.case") and caselist vars etyp ast = diff --git a/parsing/ast.mli b/parsing/ast.mli index d3e0ee4ab..fae49ac34 100755 --- a/parsing/ast.mli +++ b/parsing/ast.mli @@ -25,7 +25,7 @@ val slam : identifier option * Coqast.t -> Coqast.t val nvar : identifier -> Coqast.t val ide : string -> Coqast.t val num : int -> Coqast.t -val str : string -> Coqast.t +val string : string -> Coqast.t val path : section_path -> Coqast.t val dynamic : Dyn.t -> Coqast.t diff --git a/parsing/astterm.ml b/parsing/astterm.ml index b471059f4..e2baa7b77 100644 --- a/parsing/astterm.ml +++ b/parsing/astterm.ml @@ -34,28 +34,28 @@ let from_list l = List.fold_right Idset.add l Idset.empty (* when an head ident is not a constructor in pattern *) let mssg_hd_is_not_constructor s = - [< 'sTR "The symbol "; pr_id s; 'sTR " should be a constructor" >] + (str "The symbol " ++ pr_id s ++ str " should be a constructor") (* checking linearity of a list of ids in patterns *) let non_linearl_mssg id = - [< 'sTR "The variable " ; 'sTR(string_of_id id); - 'sTR " is bound several times in pattern" >] + (str "The variable " ++ str(string_of_id id) ++ + str " is bound several times in pattern") let error_capture_loc loc s = user_err_loc (loc,"ast_to_rawconstr", - [< 'sTR "The variable "; pr_id s; 'sTR " occurs in its type" >]) + (str "The variable " ++ pr_id s ++ str " occurs in its type")) let error_expl_impl_loc loc = user_err_loc (loc,"ast_to_rawconstr", - [< 'sTR "Found an explicitely given implicit argument but was expecting"; - 'fNL; 'sTR "a regular one" >]) + (str "Found an explicitely given implicit argument but was expecting" ++ + fnl () ++ str "a regular one")) let error_metavar_loc loc = user_err_loc (loc,"ast_to_rawconstr", - [< 'sTR "Metavariable numbers must be positive" >]) + (str "Metavariable numbers must be positive")) let rec has_duplicate = function | [] -> None @@ -70,17 +70,17 @@ let check_linearity lhs ids = | None -> () let mal_formed_mssg () = - [<'sTR "malformed macro of multiple case" >] + (str "malformed macro of multiple case") (* determines if some pattern variable starts with uppercase *) let warning_uppercase loc uplid = (* Comment afficher loc ?? *) let vars = prlist_with_sep - (fun () -> [< 'sTR ", " >]) (* We avoid 'sPC, else it breaks the line *) - (fun v -> [< 'sTR (string_of_id v) >]) uplid in + (fun () -> (str ", ")) (* We avoid spc (), else it breaks the line *) + (fun v -> (str (string_of_id v))) uplid in let (s1,s2) = if List.length uplid = 1 then (" ","s ") else ("s "," ") in - wARN [<'sTR ("the variable"^s1); vars; - 'sTR (" start"^s2^"with an upper case letter in pattern") >] + warn (str ("the variable"^s1) ++ vars ++ + str (" start"^s2^"with an upper case letter in pattern")) let is_uppercase_var v = match (string_of_id v).[0] with @@ -96,8 +96,8 @@ let check_uppercase loc ids = (* check that the number of pattern matches the number of matched args *) let mssg_number_of_patterns n pl = - [< 'sTR"Expecting ";'iNT n ; 'sTR" pattern(s) but found "; - 'iNT (List.length pl); 'sTR" in " >] + str"Expecting " ++ int n ++ str" pattern(s) but found " ++ + int (List.length pl) ++ str" in " let check_number_of_pattern loc n l = if n<>(List.length l) then @@ -115,9 +115,9 @@ let ast_to_sp = function section_path sp with Invalid_argument _ | Failure _ -> anomaly_loc(loc,"Astterm.ast_to_sp", - [< 'sTR"ill-formed section-path" >])) + (str"ill-formed section-path"))) | ast -> anomaly_loc(Ast.loc ast,"Astterm.ast_to_sp", - [< 'sTR"not a section-path" >]) + (str"not a section-path")) let is_underscore id = (id = wildcard) @@ -126,7 +126,7 @@ let name_of_nvar s = let ident_of_nvar loc s = if is_underscore s then - user_err_loc (loc,"ident_of_nvar", [< 'sTR "Unexpected wildcard" >]) + user_err_loc (loc,"ident_of_nvar", (str "Unexpected wildcard")) else s let interp_qualid p = @@ -190,8 +190,8 @@ let maybe_constructor env = function | Node(loc,("CONST"|"EVAR"|"MUTIND"|"SYNCONST" as key), l) -> user_err_loc (loc,"ast_to_pattern", - [< 'sTR "Found a pattern involving global references which are not constructors" - >]) + (str "Found a pattern involving global references which are not constructors" +)) | _ -> anomaly "ast_to_pattern: badly-formed ast for Cases pattern" @@ -214,7 +214,7 @@ let ast_to_global loc c = | ("SYNCONST", [sp]) -> Syntax_def.search_syntactic_definition (ast_to_sp sp), [] | _ -> anomaly_loc (loc,"ast_to_global", - [< 'sTR "Bad ast for this global a reference">]) + (str "Bad ast for this global a reference")) (* let ref_from_constr c = match kind_of_term c with @@ -338,12 +338,12 @@ let rec ast_to_cofix = function (fi::lf, astA::lA, astT::lt) | _ -> anomaly "CFDECL is expected" -let error_fixname_unbound str is_cofix loc name = +let error_fixname_unbound s is_cofix loc name = user_err_loc (loc,"ast_to (COFIX)", - [< 'sTR "The name"; 'sPC ; pr_id name ; - 'sPC ; 'sTR "is not bound in the corresponding"; 'sPC ; - 'sTR ((if is_cofix then "co" else "")^"fixpoint definition") >]) + str "The name" ++ spc () ++ pr_id name ++ + spc () ++ str "is not bound in the corresponding" ++ spc () ++ + str ((if is_cofix then "co" else "")^"fixpoint definition")) (* let rec collapse_env n env = if n=0 then env else add_rel_decl (Anonymous,()) (collapse_env (n-1) (snd (uncons_rel_env env))) @@ -458,7 +458,7 @@ let ast_to_rawconstr sigma env allow_soapp lvar = | Node(loc,"SQUASH",_) -> user_err_loc(loc,"ast_to_rawconstr", - [< 'sTR "Ill-formed specification" >]) + (str "Ill-formed specification")) | Node(loc,opn,tl) -> anomaly ("ast_to_rawconstr found operator "^opn^" with "^ @@ -664,10 +664,10 @@ let constrOut = function if (Dyn.tag d) = "constr" then constr_out d else - anomalylabstrm "constrOut" [<'sTR "Dynamic tag should be constr">] + anomalylabstrm "constrOut" (str "Dynamic tag should be constr") | ast -> anomalylabstrm "constrOut" - [<'sTR "Not a Dynamic ast: "; print_ast ast>] + (str "Not a Dynamic ast: " ++ print_ast ast) let interp_constr sigma env c = understand sigma env (interp_rawconstr sigma env c) @@ -688,13 +688,13 @@ let interp_sort = function | Node(loc,"PROP", []) -> Prop Null | Node(loc,"SET", []) -> Prop Pos | Node(loc,"TYPE", _) -> new_Type_sort () - | a -> user_err_loc (Ast.loc a,"interp_sort", [< 'sTR "Not a sort" >]) + | a -> user_err_loc (Ast.loc a,"interp_sort", (str "Not a sort")) let interp_elimination_sort = function | Node(loc,"PROP", []) -> InProp | Node(loc,"SET", []) -> InSet | Node(loc,"TYPE", _) -> InType - | a -> user_err_loc (Ast.loc a,"interp_sort", [< 'sTR "Not a sort" >]) + | a -> user_err_loc (Ast.loc a,"interp_sort", (str "Not a sort")) let judgment_of_rawconstr sigma env c = understand_judgment sigma env (interp_rawconstr sigma env c) diff --git a/parsing/egrammar.ml b/parsing/egrammar.ml index aa9ab17aa..fb3039c0e 100644 --- a/parsing/egrammar.ml +++ b/parsing/egrammar.ml @@ -25,11 +25,11 @@ let (grammar_state : grammar_command list ref) = ref [] let specify_name name e = match e with | UserError(lab,strm) -> - UserError(lab, [< 'sTR"during interpretation of grammar rule "; - 'sTR name; 'sTR","; 'sPC; strm >]) + UserError(lab, (str"during interpretation of grammar rule " ++ + str name ++ str"," ++ spc () ++ strm)) | Anomaly(lab,strm) -> - Anomaly(lab, [< 'sTR"during interpretation of grammar rule "; - 'sTR name; 'sTR","; 'sPC; strm >]) + Anomaly(lab, (str"during interpretation of grammar rule " ++ + str name ++ str"," ++ spc () ++ strm)) | Failure s -> Failure("during interpretation of grammar rule "^name^", "^s) | e -> e diff --git a/parsing/esyntax.ml b/parsing/esyntax.ml index 28be50723..2b801d03e 100644 --- a/parsing/esyntax.ml +++ b/parsing/esyntax.ml @@ -141,7 +141,7 @@ let _ = Ppprim.add ("token",token_printer) (* A primitive printer to do "print as" (to specify a length for a string) *) let print_as_printer stdpr = function - | Node (_, "AS", [Num(_,n); Str(_,s)]) -> [< 'sTRas (n,s) >] + | Node (_, "AS", [Num(_,n); Str(_,s)]) -> (stras (n,s)) | ast -> stdpr ast let _ = Ppprim.add ("print_as",print_as_printer) @@ -165,11 +165,11 @@ let print_syntax_entry whatfor sub_pr env se = | None -> token_printer (sub_pr whatfor (Some(rule_prec,reln))) in printer (Ast.pat_sub Ast.dummy_loc env e) - | RO s -> [< 'sTR s >] - | UNP_TAB -> [< 'tAB >] - | UNP_FNL -> [< 'fNL >] - | UNP_BRK(n1,n2) -> [< 'bRK(n1,n2) >] - | UNP_TBRK(n1,n2) -> [< 'tBRK(n1,n2) >] + | RO s -> str s + | UNP_TAB -> tab () + | UNP_FNL -> fnl () + | UNP_BRK(n1,n2) -> brk(n1,n2) + | UNP_TBRK(n1,n2) -> tbrk(n1,n2) | UNP_BOX (b,sub) -> ppcmd_of_box b (prlist print_hunk sub) in prlist print_hunk se.syn_hunks @@ -191,11 +191,11 @@ let genprint dflt whatfor inhprec ast = if no_paren then printed_gt else - [< 'sTR"(" ; printed_gt; 'sTR")" >] + (str"(" ++ printed_gt ++ str")") | None -> dflt gt (* No rule found *) in try rec_pr whatfor inhprec ast with - | Failure _ -> [< 'sTR"<PP failure: "; dflt ast; 'sTR">" >] - | Not_found -> [< 'sTR"<PP search failure: "; dflt ast; 'sTR">" >] + | Failure _ -> (str"<PP failure: " ++ dflt ast ++ str">") + | Not_found -> (str"<PP search failure: " ++ dflt ast ++ str">") diff --git a/parsing/extend.ml4 b/parsing/extend.ml4 index 2c74daa86..e54ac11bb 100644 --- a/parsing/extend.ml4 +++ b/parsing/extend.ml4 @@ -107,7 +107,7 @@ let nterm univ ast = try get_entry u n with UserError _ -> - user_err_loc(loc ast,"Externd.nterm", [< 'sTR"unknown grammar entry" >]) + user_err_loc(loc ast,"Externd.nterm", str"unknown grammar entry") in (nont, type_of_entry e) @@ -163,7 +163,7 @@ let gram_define_entry univ = function try create_entry univ nt etyp with Failure s -> - user_err_loc (ntl,"gram_define_entry",[< 'sTR s >]) + user_err_loc (ntl,"gram_define_entry", str s) in (nt, etyp, assoc, rl) | ast -> invalid_arg_loc (Ast.loc ast, "gram_define_entry") @@ -218,8 +218,8 @@ type unparsing_hunk = let ppcmd_of_box = function | PpHB n -> h n - | PpHOVB n -> hOV n - | PpHVB n -> hV n + | PpHOVB n -> hov n + | PpHVB n -> hv n | PpVB n -> v n | PpTB -> t diff --git a/parsing/g_ltac.ml4 b/parsing/g_ltac.ml4 index dc69dca1a..9c008d34d 100644 --- a/parsing/g_ltac.ml4 +++ b/parsing/g_ltac.ml4 @@ -31,14 +31,14 @@ GEXTEND Gram (match c with | Coqast.Node(_,"COMMAND",[csr]) -> <:ast< (LETTOPCLAUSE $id (CONSTR $csr)) >> - | _ -> errorlabstrm "Gram.let_clause" [<'sTR "Not a COMMAND">]) + | _ -> errorlabstrm "Gram.let_clause" (str "Not a COMMAND")) | id = identarg; ":"; c = constrarg; ":="; te = tactic_expr -> <:ast< (LETCUTCLAUSE $id $c $te) >> | id = identarg; ":"; c = constrarg -> (match c with | Coqast.Node(_,"COMMAND",[csr]) -> <:ast< (LETTOPCLAUSE $id (CONSTR $csr)) >> - | _ -> errorlabstrm "Gram.let_clause" [<'sTR "Not a COMMAND">]) ] ] + | _ -> errorlabstrm "Gram.let_clause" (str "Not a COMMAND")) ] ] ; rec_clause: [ [ name = identarg; it = LIST1 input_fun; "->"; body = tactic_atom -> @@ -51,7 +51,7 @@ GEXTEND Gram [Coqast.Node(_,"QUALID",[Coqast.Nvar(_,_) as s])]) -> <:ast< (SUBTERM $s $pc) >> | _ -> - errorlabstrm "Gram.match_pattern" [<'sTR "Not a correct SUBTERM">]) + errorlabstrm "Gram.match_pattern" (str "Not a correct SUBTERM")) | "["; pc = constrarg; "]" -> <:ast< (SUBTERM $pc) >> | pc = constrarg -> <:ast< (TERM $pc) >> ] ] ; @@ -117,7 +117,7 @@ GEXTEND Gram (match llc with | [Coqast.Node(_,"LETTOPCLAUSE",[id;c])] -> <:ast< (TheoremProof "LETTOP" $id $c $tb) >> - | _ -> errorlabstrm "Gram.tactic_atom" [<'sTR "Not a LETTOPCLAUSE">]) + | _ -> errorlabstrm "Gram.tactic_atom" (str "Not a LETTOPCLAUSE")) | IDENT "Match"; IDENT "Context"; IDENT "With"; mrl = match_context_list -> <:ast< (MATCHCONTEXT ($LIST $mrl)) >> | IDENT "Match"; com = constrarg; IDENT "With"; mrl = match_list -> diff --git a/parsing/g_minicoq.ml4 b/parsing/g_minicoq.ml4 index 9faf6d877..8c5df17a7 100644 --- a/parsing/g_minicoq.ml4 +++ b/parsing/g_minicoq.ml4 @@ -125,11 +125,11 @@ let print_univers = ref false let print_casts = ref false let print_type u = - if !print_univers then [< 'sTR "Type"; pr_uni u >] - else [< 'sTR "Type" >] + if !print_univers then (str "Type" ++ pr_uni u) + else (str "Type") let print_name = function - | Anonymous -> [< 'sTR "_" >] + | Anonymous -> (str "_") | Name id -> pr_id id let print_rel bv n = print_name (List.nth bv (pred n)) @@ -145,33 +145,33 @@ let rename bv = function let rec pp bv t = match kind_of_term t with - | Sort (Prop Pos) -> [< 'sTR "Set" >] - | Sort (Prop Null) -> [< 'sTR "Prop" >] + | Sort (Prop Pos) -> (str "Set") + | Sort (Prop Null) -> (str "Prop") | Sort (Type u) -> print_type u | Lambda (na, t, c) -> - [< 'sTR"["; print_name na; 'sTR":"; pp bv t; 'sTR"]"; pp (na::bv) c >] + (str"[" ++ print_name na ++ str":" ++ pp bv t ++ str"]" ++ pp (na::bv) c) | Prod (Anonymous, t, c) -> - [< pp bv t; 'sTR"->"; pp (Anonymous::bv) c >] + (pp bv t ++ str"->" ++ pp (Anonymous::bv) c) | Prod (na, t, c) -> - [< 'sTR"("; print_name na; 'sTR":"; pp bv t; 'sTR")"; pp (na::bv) c >] + (str"(" ++ print_name na ++ str":" ++ pp bv t ++ str")" ++ pp (na::bv) c) | Cast (c, t) -> if !print_casts then - [< 'sTR"("; pp bv c; 'sTR"::"; pp bv t; 'sTR")" >] + (str"(" ++ pp bv c ++ str"::" ++ pp bv t ++ str")") else pp bv c | App(h, v) -> - [< 'sTR"("; pp bv h; 'sPC; - prvect_with_sep (fun () -> [< 'sPC >]) (pp bv) v; 'sTR")" >] + (str"(" ++ pp bv h ++ spc () ++ + prvect_with_sep (fun () -> (spc ())) (pp bv) v ++ str")") | Const (sp, _) -> - [< 'sTR"Const "; pr_id (basename sp) >] + (str"Const " ++ pr_id (basename sp)) | Ind ((sp,i), _) -> - [< 'sTR"Ind "; pr_id (basename sp); 'sTR" "; 'iNT i >] + (str"Ind " ++ pr_id (basename sp) ++ str" " ++ int i) | Construct (((sp,i),j), _) -> - [< 'sTR"Construct "; pr_id (basename sp); 'sTR" "; 'iNT i; - 'sTR" "; 'iNT j >] + (str"Construct " ++ pr_id (basename sp) ++ str" " ++ int i ++ + str" " ++ int j) | Var id -> pr_id id | Rel n -> print_rel bv n - | _ -> [< 'sTR"<???>" >] + | _ -> (str"<???>") let pr_term _ ctx = pp (fold_rel_context (fun _ (n,_,_) l -> n::l) ctx []) diff --git a/parsing/g_natsyntax.ml b/parsing/g_natsyntax.ml index 6b67c1c0a..9a97f4b06 100644 --- a/parsing/g_natsyntax.ml +++ b/parsing/g_natsyntax.ml @@ -84,7 +84,7 @@ let replace_S p = (* Prints not p, but the SUCCESSOR of p !!!!! *) let nat_printer std_pr p = match (int_of_nat p) with - | Some i -> [< 'sTR (string_of_int i) >] + | Some i -> (str (string_of_int i)) | None -> std_pr (replace_S p) let _ = Esyntax.Ppprim.add ("nat_printer", nat_printer) diff --git a/parsing/g_proofs.ml4 b/parsing/g_proofs.ml4 index fdd29feee..5e8d853ee 100644 --- a/parsing/g_proofs.ml4 +++ b/parsing/g_proofs.ml4 @@ -112,7 +112,7 @@ GEXTEND Gram | Coqast.Node(_,"RECCLAUSE",nme::[bd]) -> <:ast<(TACDEF $nme (AST $bd))>> | _ -> - anomalylabstrm "Gram.vernac" [<'sTR "Not a correct RECCLAUSE">]) + anomalylabstrm "Gram.vernac" (str "Not a correct RECCLAUSE")) | IDENT "Recursive"; deftok; "Definition"; vc=vrec_clause; "And"; vcl=LIST1 vrec_clause SEP "And" -> let nvcl= @@ -123,8 +123,10 @@ GEXTEND Gram | Coqast.Node(_,"RECCLAUSE",nme::[bd]) -> nme::<:ast<(AST $bd)>>::b | _ -> - anomalylabstrm "Gram.vernac" [<'sTR - "Not a correct RECCLAUSE">]) (vc::vcl) [] in + anomalylabstrm "Gram.vernac" + (str "Not a correct RECCLAUSE")) + (vc::vcl) [] + in <:ast<(TACDEF ($LIST $nvcl))>> (* Hints for Auto and EAuto *) diff --git a/parsing/g_rsyntax.ml b/parsing/g_rsyntax.ml index ff42bc01d..41fe0df2a 100644 --- a/parsing/g_rsyntax.ml +++ b/parsing/g_rsyntax.ml @@ -71,13 +71,13 @@ let replace_plus p = let r_printer std_pr p = let (_,ast1,astp,_) = get_r_sign dummy_loc in match (int_of_r p) with - | Some i -> [< 'sTR (string_of_int (i+1)) >] + | Some i -> (str (string_of_int (i+1))) | None -> std_pr (replace_plus p) let r_printer_outside std_pr p = let (_,ast1,astp,_) = get_r_sign dummy_loc in match (int_of_r p) with - | Some i -> [< 'sTR "``"; 'sTR (string_of_int (i+1)); 'sTR "``" >] + | Some i -> (str "``" ++ str (string_of_int (i+1)) ++ str "``") | None -> std_pr (replace_plus p) let _ = Esyntax.Ppprim.add ("r_printer", r_printer) diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4 index 5cbfd4954..b58dc654d 100644 --- a/parsing/g_tactic.ml4 +++ b/parsing/g_tactic.ml4 @@ -369,7 +369,7 @@ GEXTEND Gram | (false, _) -> <:ast< (CALL $id ($LIST $l)) >> | _ -> Util.user_err_loc (loc, "G_tactic.meta_tactic", - [< 'sTR"Cannot apply arguments to a meta-tactic." >]) + (str"Cannot apply arguments to a meta-tactic.")) ] *)] ; tactic: diff --git a/parsing/g_zsyntax.ml b/parsing/g_zsyntax.ml index 8b94b4fd7..f6a836942 100644 --- a/parsing/g_zsyntax.ml +++ b/parsing/g_zsyntax.ml @@ -117,9 +117,9 @@ let inside_printer posneg std_pr p = match (int_array_option_of_pos astxI astxO astxH p) with | Some n -> if posneg then - [< 'sTR (string_of_int_array n) >] + (str (string_of_int_array n)) else - [< 'sTR "(-"; 'sTR (string_of_int_array n); 'sTR ")" >] + (str "(-" ++ str (string_of_int_array n) ++ str ")") | None -> let c = if posneg then myvar0 else myvar1 in std_pr (ope("ZEXPR",[ope("APPLIST",[c; p])])) @@ -129,12 +129,12 @@ let outside_printer posneg std_pr p = match (int_array_option_of_pos astxI astxO astxH p) with | Some n -> if posneg then - [< 'sTR "`"; 'sTR (string_of_int_array n); 'sTR "`">] + (str "`" ++ str (string_of_int_array n) ++ str "`") else - [< 'sTR "`-"; 'sTR (string_of_int_array n); 'sTR "`" >] + (str "`-" ++ str (string_of_int_array n) ++ str "`") | None -> let c = if posneg then myvar0 else myvar1 in - [< 'sTR "("; std_pr (ope("APPLIST",[c; p])); 'sTR ")" >] + (str "(" ++ std_pr (ope("APPLIST", [c; p])) ++ str ")") (* Declare pretty-printers for integers *) let _ = Esyntax.Ppprim.add ("positive_printer", (outside_printer true)) diff --git a/parsing/pcoq.ml4 b/parsing/pcoq.ml4 index 540e1fab0..ffa82f034 100644 --- a/parsing/pcoq.ml4 +++ b/parsing/pcoq.ml4 @@ -73,8 +73,7 @@ module Gram = :: !camlp4_state; G.extend e pos rls let delete_rule e pil = - errorlabstrm "Pcoq.delete_rule" - [< 'sTR "GDELETE_RULE forbidden." >] + errorlabstrm "Pcoq.delete_rule" (str "GDELETE_RULE forbidden.") end @@ -192,7 +191,7 @@ let get_entry (u, utab) s = Hashtbl.find utab s with Not_found -> errorlabstrm "Pcoq.get_entry" - [< 'sTR"unknown grammar entry "; 'sTR u; 'sTR":"; 'sTR s >] + (str "unknown grammar entry " ++ str u ++ str ":" ++ str s) let new_entry etyp (u, utab) s = let ename = u ^ ":" ^ s in diff --git a/parsing/prettyp.ml b/parsing/prettyp.ml index 4ee232915..41a4a6b5a 100644 --- a/parsing/prettyp.ml +++ b/parsing/prettyp.ml @@ -32,18 +32,18 @@ let print_basename sp = pr_global (ConstRef sp) let print_closed_sections = ref false let print_typed_value_in_env env (trm,typ) = - [< prterm_env env trm ; 'fNL ; - 'sTR " : "; prtype_env env typ ; 'fNL >] + (prterm_env env trm ++ fnl () ++ + str " : " ++ prtype_env env typ ++ fnl ()) let print_typed_value x = print_typed_value_in_env (Global.env ()) x let print_impl_args = function - | [] -> [<>] - | [i] -> [< 'sTR"Position ["; 'iNT i; 'sTR"] is implicit" >] + | [] -> mt () + | [i] -> str"Position [" ++ int i ++ str"] is implicit" | l -> - [< 'sTR"Positions ["; - prlist_with_sep (fun () -> [< 'sTR";" >]) (fun i -> [< 'iNT i >]) l; - 'sTR"] are implicit" >] + str"Positions [" ++ + prlist_with_sep (fun () -> str " ++") (fun i -> int i) l ++ + str"] are implicit" (* To be improved; the type should be used to provide the types in the abstractions. This should be done recursively inside prterm, so that @@ -53,13 +53,13 @@ let print_impl_args = function let print_named_def name body typ = let pbody = prterm body in let ptyp = prtype typ in - [< 'sTR "*** ["; 'sTR name ; 'sTR " "; - hOV 0 [< 'sTR ":="; 'bRK (1,2); pbody; 'sPC; - 'sTR ":"; 'bRK (1,2); ptyp >]; - 'sTR "]"; 'fNL >] + (str "*** [" ++ str name ++ str " " ++ + hov 0 (str ":=" ++ brk (1,2) ++ pbody ++ spc () ++ + str ":" ++ brk (1,2) ++ ptyp) ++ + str "]" ++ fnl ()) let print_named_assum name typ = - [< 'sTR "*** [" ; 'sTR name ; 'sTR " : "; prtype typ; 'sTR "]"; 'fNL >] + (str "*** [" ++ str name ++ str " : " ++ prtype typ ++ str "]" ++ fnl ()) let print_named_decl (id,c,typ) = let s = string_of_id id in @@ -72,35 +72,36 @@ let assumptions_for_print lna = let implicit_args_id id l = if l = [] then - [<>] + (mt ()) else - [< 'sTR"For "; pr_id id; 'sTR": "; print_impl_args l ; 'fNL >] + (str"For " ++ pr_id id ++ str": " ++ print_impl_args l ++ fnl ()) let implicit_args_msg sp mipv = - [< prvecti + (prvecti (fun i mip -> let imps = inductive_implicits_list (sp,i) in - [< (implicit_args_id mip.mind_typename imps); + ((implicit_args_id mip.mind_typename imps) ++ prvecti (fun j idc -> let imps = constructor_implicits_list ((sp,i),succ j) in (implicit_args_id idc imps)) mip.mind_consnames - >]) - mipv >] +)) + mipv) let print_params env params = if List.length params = 0 then - [<>] + (mt ()) else - [< 'sTR "["; pr_rel_context env params; 'sTR "]"; 'bRK(1,2) >] + (str "[" ++ pr_rel_context env params ++ str "]" ++ brk(1,2)) let print_constructors envpar names types = let pc = - [< prvect_with_sep (fun () -> [<'bRK(1,0); 'sTR "| " >]) - (fun (id,c) -> [< pr_id id; 'sTR " : "; prterm_env envpar c >]) - (array_map2 (fun n t -> (n,t)) names types) >] - in hV 0 [< 'sTR " "; pc >] + prvect_with_sep (fun () -> brk(1,0) ++ str "| ") + (fun (id,c) -> pr_id id ++ str " : " ++ prterm_env envpar c) + (array_map2 (fun n t -> (n,t)) names types) + in + hv 0 (str " " ++ pc) let build_inductive sp tyi = let (mib,mip) = Global.lookup_inductive (sp,tyi) in @@ -116,11 +117,11 @@ let print_one_inductive sp tyi = let (ref, params, arity, cstrnames, cstrtypes) = build_inductive sp tyi in let env = Global.env () in let envpar = push_rel_context params env in - (hOV 0 - [< (hOV 0 - [< pr_global (IndRef (sp,tyi)) ; 'bRK(1,2); print_params env params; - 'sTR ": "; prterm_env envpar arity; 'sTR " :=" >]); - 'bRK(1,2); print_constructors envpar cstrnames cstrtypes >]) + (hov 0 + ((hov 0 + (pr_global (IndRef (sp,tyi)) ++ brk(1,2) ++ print_params env params ++ + str ": " ++ prterm_env envpar arity ++ str " :=")) ++ + brk(1,2) ++ print_constructors envpar cstrnames cstrtypes)) let print_mutual sp = let (mib,mip) = Global.lookup_inductive (sp,0) in @@ -131,13 +132,13 @@ let print_mutual sp = if mib.mind_finite then "Inductive " else "CoInductive " in let env = Global.env () in let envpar = push_rel_context params env in - (hOV 0 [< - 'sTR sfinite ; - pr_global (IndRef (sp,0)); 'bRK(1,2); - print_params env params; 'bRK(1,5); - 'sTR": "; prterm_env envpar arity; 'sTR" :="; - 'bRK(0,4); print_constructors envpar cstrnames cstrtypes; 'fNL; - implicit_args_msg sp mib.mind_packets >] ) + (hov 0 ( + str sfinite ++ + pr_global (IndRef (sp,0)) ++ brk(1,2) ++ + print_params env params ++ brk(1,5) ++ + str": " ++ prterm_env envpar arity ++ str" :=" ++ + brk(0,4) ++ print_constructors envpar cstrnames cstrtypes ++ fnl () ++ + implicit_args_msg sp mib.mind_packets) ) (* Mutual [co]inductive definitions *) else let _,(mipli,miplc) = @@ -147,24 +148,24 @@ let print_mutual sp = mipv (0,([],[])) in let strind = - if mipli = [] then [<>] - else [< 'sTR "Inductive"; 'bRK(1,4); + if mipli = [] then (mt ()) + else (str "Inductive" ++ brk(1,4) ++ (prlist_with_sep - (fun () -> [< 'fNL; 'sTR" with"; 'bRK(1,4) >]) - (print_one_inductive sp) mipli); 'fNL >] + (fun () -> (fnl () ++ str" with" ++ brk(1,4))) + (print_one_inductive sp) mipli) ++ fnl ()) and strcoind = - if miplc = [] then [<>] - else [< 'sTR "CoInductive"; 'bRK(1,4); + if miplc = [] then (mt ()) + else (str "CoInductive" ++ brk(1,4) ++ (prlist_with_sep - (fun () -> [<'fNL; 'sTR " with"; 'bRK(1,4) >]) - (print_one_inductive sp) miplc); 'fNL >] + (fun () -> (fnl () ++ str " with" ++ brk(1,4))) + (print_one_inductive sp) miplc) ++ fnl ()) in - (hV 0 [< 'sTR"Mutual " ; - if mib.mind_finite then - [< strind; strcoind >] - else - [<strcoind; strind>]; - implicit_args_msg sp mipv >]) + (hv 0 (str"Mutual " ++ + (if mib.mind_finite then + strind ++ strcoind + else + strcoind ++ strind) ++ + implicit_args_msg sp mipv)) (* let env = Global.env () in @@ -177,24 +178,24 @@ let print_mutual sp = let arities = Array.map (fun mip -> (Name mip.mind_typename, None, mip.mind_nf_arity)) mipv in let env_ar = push_rels lpars env in let pr_constructor (id,c) = - [< pr_id id; 'sTR " : "; prterm_env env_ar c >] in + (pr_id id ++ str " : " ++ prterm_env env_ar c) in let print_constructors mis = let (_,lC) = mis_type_mconstructs mis in let lidC = array_map2 (fun id c -> (id, snd (decomp_n_prod env evd nparams c))) (mis_consnames mis) lC in let plidC = - prvect_with_sep (fun () -> [<'bRK(0,0); 'sTR "| " >]) + prvect_with_sep (fun () -> (brk(0,0) ++ str "| ")) pr_constructor lidC in - hV 0 [< 'sTR " "; plidC >] + hV 0 (str " " ++ plidC) in let params = if nparams = 0 then - [<>] + (mt ()) else - [< 'sTR "["; pr_rel_context env lpars; 'sTR "]"; 'bRK(1,2) >] in + (str "[" ++ pr_rel_context env lpars ++ str "]" ++ brk(1,2)) in let print_oneind tyi = let mis = build_mis @@ -203,11 +204,11 @@ let print_mutual sp = mib in let (_,arity) = decomp_n_prod env evd nparams (body_of_type (mis_user_arity mis)) in - (hOV 0 - [< (hOV 0 - [< pr_global (IndRef (sp,tyi)) ; 'bRK(1,2); params; - 'sTR ": "; prterm_env env_ar arity; 'sTR " :=" >]); - 'bRK(1,2); print_constructors mis >]) + (hov 0 + ((hov 0 + (pr_global (IndRef (sp,tyi)) ++ brk(1,2) ++ params ++ + str ": " ++ prterm_env env_ar arity ++ str " :=")) ++ + brk(1,2) ++ print_constructors mis)) in let mis0 = build_mis @@ -218,14 +219,14 @@ let print_mutual sp = let (_,arity) = decomp_n_prod env evd nparams (body_of_type (mis_user_arity mis0)) in let sfinite = if mis_finite mis0 then "Inductive " else "CoInductive " in - (hOV 0 [< 'sTR sfinite ; pr_global (IndRef (sp,0)); + (hov 0 (str sfinite ++ pr_global (IndRef (sp,0)) ++ if nparams = 0 then - [<>] + (mt ()) else - [< 'sTR" ["; pr_rel_context env lpars; 'sTR "]">]; - 'bRK(1,5); 'sTR": "; prterm_env env_ar arity; 'sTR" :="; - 'bRK(0,4); print_constructors mis0; 'fNL; - implicit_args_msg sp mipv >] ) + (str" [" ++ pr_rel_context env lpars ++ str "]") ++ + brk(1,5) ++ str": " ++ prterm_env env_ar arity ++ str" :=" ++ + brk(0,4) ++ print_constructors mis0 ++ fnl () ++ + implicit_args_msg sp mipv) ) (* Mutual [co]inductive definitions *) else let _,(mipli,miplc) = @@ -235,63 +236,63 @@ let print_mutual sp = (0,([],[])) (Array.to_list mipv) in let strind = - if mipli = [] then [<>] - else [< 'sTR "Inductive"; 'bRK(1,4); + if mipli = [] then (mt ()) + else (str "Inductive" ++ brk(1,4) ++ (prlist_with_sep - (fun () -> [< 'fNL; 'sTR" with"; 'bRK(1,4) >]) + (fun () -> (fnl () ++ str" with" ++ brk(1,4))) print_oneind - (List.rev mipli)); 'fNL >] + (List.rev mipli)) ++ fnl ()) and strcoind = - if miplc = [] then [<>] - else [< 'sTR "CoInductive"; 'bRK(1,4); + if miplc = [] then (mt ()) + else (str "CoInductive" ++ brk(1,4) ++ (prlist_with_sep - (fun () -> [<'fNL; 'sTR " with"; 'bRK(1,4) >]) - print_oneind (List.rev miplc)); 'fNL >] + (fun () -> (fnl () ++ str " with" ++ brk(1,4))) + print_oneind (List.rev miplc)) ++ fnl ()) in - (hV 0 [< 'sTR"Mutual " ; + (hV 0 (str"Mutual " ++ if mis_finite mis0 then - [< strind; strcoind >] + (strind ++ strcoind) else - [<strcoind; strind>]; - implicit_args_msg sp mipv >]) + (strcoind ++ strind) ++ + implicit_args_msg sp mipv)) *) let print_section_variable sp = let (d,_) = get_variable sp in let l = implicits_of_var sp in - [< print_named_decl d; print_impl_args l; 'fNL >] + (print_named_decl d ++ print_impl_args l ++ fnl ()) let print_body = function | Some c -> prterm c - | None -> [< 'sTR"<no body>" >] + | None -> (str"<no body>") let print_typed_body (val_0,typ) = - [< print_body val_0; 'fNL; 'sTR " : "; prtype typ; 'fNL >] + (print_body val_0 ++ fnl () ++ str " : " ++ prtype typ ++ fnl ()) let print_constant with_values sep sp = let cb = Global.lookup_constant sp in let val_0 = cb.const_body in let typ = cb.const_type in let impls = constant_implicits_list sp in - hOV 0 [< (match val_0 with + hov 0 ((match val_0 with | None -> - [< 'sTR"*** [ "; - print_basename sp; - 'sTR " : "; 'cUT ; prtype typ ; 'sTR" ]"; 'fNL >] + (str"*** [ " ++ + print_basename sp ++ + str " : " ++ cut () ++ prtype typ ++ str" ]" ++ fnl ()) | _ -> - [< print_basename sp; - 'sTR sep; 'cUT ; + (print_basename sp ++ + str sep ++ cut () ++ if with_values then print_typed_body (val_0,typ) else - [< prtype typ ; 'fNL >] >]); - print_impl_args impls; 'fNL >] + (prtype typ ++ fnl ()))) ++ + print_impl_args impls ++ fnl ()) -let print_inductive sp = [< print_mutual sp; 'fNL >] +let print_inductive sp = (print_mutual sp ++ fnl ()) let print_syntactic_def sep sp = let id = basename sp in let c = Syntax_def.search_syntactic_definition sp in - [< 'sTR" Syntactif Definition "; pr_id id ; 'sTR sep; pr_rawterm c; 'fNL >] + (str" Syntactif Definition " ++ pr_id id ++ str sep ++ pr_rawterm c ++ fnl ()) let print_leaf_entry with_values sep (sp,lobj) = let tag = object_tag lobj in @@ -303,56 +304,56 @@ let print_leaf_entry with_values sep (sp,lobj) = | (_,"INDUCTIVE") -> print_inductive sp | (_,"AUTOHINT") -> -(* [< 'sTR" Hint Marker"; 'fNL >]*) - [< >] +(* (str" Hint Marker" ++ fnl ())*) + (mt ()) | (_,"GRAMMAR") -> -(* [< 'sTR" Grammar Marker"; 'fNL >]*) - [< >] +(* (str" Grammar Marker" ++ fnl ())*) + (mt ()) | (_,"SYNTAXCONSTANT") -> print_syntactic_def sep sp | (_,"PPSYNTAX") -> -(* [< 'sTR" Syntax Marker"; 'fNL >]*) - [< >] +(* (str" Syntax Marker" ++ fnl ())*) + (mt ()) | (_,"TOKEN") -> -(* [< 'sTR" Token Marker"; 'fNL >]*) - [< >] +(* (str" Token Marker" ++ fnl ())*) + (mt ()) | (_,"CLASS") -> -(* [< 'sTR" Class Marker"; 'fNL >]*) - [< >] +(* (str" Class Marker" ++ fnl ())*) + (mt ()) | (_,"COERCION") -> -(* [< 'sTR" Coercion Marker"; 'fNL >]*) - [< >] +(* (str" Coercion Marker" ++ fnl ())*) + (mt ()) | (_,"REQUIRE") -> -(* [< 'sTR" Require Marker"; 'fNL >]*) - [< >] - | (_,"END-SECTION") -> [< >] - | (_,"STRUCTURE") -> [< >] +(* (str" Require Marker" ++ fnl ())*) + (mt ()) + | (_,"END-SECTION") -> (mt ()) + | (_,"STRUCTURE") -> (mt ()) (* To deal with forgotten cases... *) - | (_,s) -> [< >] + | (_,s) -> (mt ()) (* | (_,s) -> - [< 'sTR(string_of_path sp); 'sTR" : "; - 'sTR"Unrecognized object "; 'sTR s; 'fNL >] + (str(string_of_path sp) ++ str" : " ++ + str"Unrecognized object " ++ str s ++ fnl ()) *) let rec print_library_entry with_values ent = let sep = if with_values then " = " else " : " in match ent with | (sp,Lib.Leaf lobj) -> - [< print_leaf_entry with_values sep (sp,lobj) >] + (print_leaf_entry with_values sep (sp,lobj)) | (sp,Lib.OpenedSection (dir,_)) -> - [< 'sTR " >>>>>>> Section "; pr_id (basename sp); 'fNL >] + (str " >>>>>>> Section " ++ pr_id (basename sp) ++ fnl ()) | (sp,Lib.ClosedSection _) -> - [< 'sTR " >>>>>>> Closed Section "; pr_id (basename sp); 'fNL >] + (str " >>>>>>> Closed Section " ++ pr_id (basename sp) ++ fnl ()) | (_,Lib.Module dir) -> - [< 'sTR " >>>>>>> Module "; pr_dirpath dir; 'fNL >] + (str " >>>>>>> Module " ++ pr_dirpath dir ++ fnl ()) | (_,Lib.FrozenState _) -> - [< >] + (mt ()) and print_context with_values = let rec prec = function - | h::rest -> [< prec rest ; print_library_entry with_values h >] - | [] -> [< >] + | h::rest -> (prec rest ++ print_library_entry with_values h) + | [] -> (mt ()) in prec @@ -405,7 +406,7 @@ let print_safe_judgment env j = let print_eval red_fun env {uj_val=trm;uj_type=typ} = let ntrm = red_fun env Evd.empty trm in - [< 'sTR " = "; print_judgment env {uj_val = ntrm; uj_type = typ} >] + (str " = " ++ print_judgment env {uj_val = ntrm; uj_type = typ}) let print_name qid = try @@ -431,14 +432,14 @@ let print_name qid = let dir,str = repr_qualid qid in if (repr_dirpath dir) <> [] then raise Not_found; let (_,c,typ) = Global.lookup_named str in - [< print_named_decl (str,c,typ) >] + (print_named_decl (str,c,typ)) with Not_found -> try let sp = Syntax_def.locate_syntactic_definition qid in print_syntactic_def " = " sp with Not_found -> errorlabstrm "print_name" - [< pr_qualid qid; 'sPC; 'sTR "not a defined object" >] + (pr_qualid qid ++ spc () ++ str "not a defined object") let print_opaque_name qid = let sigma = Evd.empty in @@ -464,17 +465,17 @@ let print_opaque_name qid = | _ -> assert false with Not_found -> - errorlabstrm "print_opaque" [< pr_qualid qid; 'sPC; 'sTR "not declared" >] + errorlabstrm "print_opaque" (pr_qualid qid ++ spc () ++ str "not declared") let print_local_context () = let env = Lib.contents_after None in let rec print_var_rec = function - | [] -> [< >] + | [] -> (mt ()) | (sp,Lib.Leaf lobj)::rest -> if "VARIABLE" = object_tag lobj then let (d,_) = get_variable (basename sp) in - [< print_var_rec rest; - print_named_decl d >] + (print_var_rec rest ++ + print_named_decl d) else print_var_rec rest | _::rest -> print_var_rec rest @@ -485,22 +486,22 @@ let print_local_context () = | "CONSTANT" | "PARAMETER" -> let {const_body=val_0;const_type=typ} = Global.lookup_constant sp in - [< print_last_const rest; - print_basename sp ;'sTR" = "; - print_typed_body (val_0,typ) >] + (print_last_const rest ++ + print_basename sp ++str" = " ++ + print_typed_body (val_0,typ)) | "INDUCTIVE" -> - [< print_last_const rest;print_mutual sp; 'fNL >] - | "VARIABLE" -> [< >] + (print_last_const rest ++print_mutual sp ++ fnl ()) + | "VARIABLE" -> (mt ()) | _ -> print_last_const rest) - | _ -> [< >] + | _ -> (mt ()) in - [< print_var_rec env; print_last_const env >] + (print_var_rec env ++ print_last_const env) let fprint_var name typ = - [< 'sTR ("*** [" ^ name ^ " :"); fprtype typ; 'sTR "]"; 'fNL >] + (str ("*** [" ^ name ^ " :") ++ fprtype typ ++ str "]" ++ fnl ()) let fprint_judge {uj_val=trm;uj_type=typ} = - [< fprterm trm; 'sTR" : " ; fprterm (body_of_type typ) >] + (fprterm trm ++ str" : " ++ fprterm (body_of_type typ)) let unfold_head_fconst = let rec unfrec k = match kind_of_term k with @@ -541,37 +542,37 @@ let print_index_coercion c = let print_class i = let cl,_ = class_info_from_index i in - [< 'sTR (string_of_class cl) >] + (str (string_of_class cl)) let print_path ((i,j),p) = - [< 'sTR"["; - prlist_with_sep (fun () -> [< 'sTR"; " >]) - (fun c -> print_index_coercion c) p; - 'sTR"] : "; print_class i; 'sTR" >-> "; - print_class j >] + (str"[" ++ + prlist_with_sep (fun () -> (str"; ")) + (fun c -> print_index_coercion c) p ++ + str"] : " ++ print_class i ++ str" >-> " ++ + print_class j) let _ = Classops.install_path_printer print_path let print_graph () = - [< prlist_with_sep pr_fnl print_path (inheritance_graph()) >] + (prlist_with_sep pr_fnl print_path (inheritance_graph())) let print_classes () = - [< prlist_with_sep pr_spc + (prlist_with_sep pr_spc (fun (_,(cl,x)) -> - [< 'sTR (string_of_class cl) - (*; 'sTR(string_of_strength x.cl_strength) *) >]) - (classes()) >] + (str (string_of_class cl) + (* ++ str(string_of_strength x.cl_strength) *))) + (classes())) let print_coercions () = - [< prlist_with_sep pr_spc - (fun (_,(_,v)) -> [< print_coercion_value v >]) (coercions()) >] + (prlist_with_sep pr_spc + (fun (_,(_,v)) -> (print_coercion_value v)) (coercions())) let index_of_class cl = try fst (class_info cl) with _ -> errorlabstrm "index_of_class" - [< 'sTR(string_of_class cl); 'sTR" is not a defined class" >] + (str(string_of_class cl) ++ str" is not a defined class") let print_path_between cls clt = let i = index_of_class cls in @@ -581,8 +582,8 @@ let print_path_between cls clt = lookup_path_between (i,j) with _ -> errorlabstrm "index_cl_of_id" - [< 'sTR"No path between ";'sTR(string_of_class cls); - 'sTR" and ";'sTR(string_of_class clt) >] + (str"No path between " ++str(string_of_class cls) ++ + str" and " ++str(string_of_class clt)) in print_path ((i,j),p) diff --git a/parsing/printer.ml b/parsing/printer.ml index 77d0f59a1..3076213e5 100644 --- a/parsing/printer.ml +++ b/parsing/printer.ml @@ -25,29 +25,29 @@ open Nametab let emacs_str s = if !Options.print_emacs then s else "" -let dfltpr ast = [< 'sTR"#GENTERM " ; print_ast ast >];; +let dfltpr ast = (str"#GENTERM " ++ print_ast ast);; let pr_global ref = pr_global_env (Global.env()) ref let global_const_name sp = try pr_global (ConstRef sp) with Not_found -> (* May happen in debug *) - [< 'sTR ("CONST("^(string_of_path sp)^")") >] + (str ("CONST("^(string_of_path sp)^")")) let global_ind_name (sp,tyi) = try pr_global (IndRef (sp,tyi)) with Not_found -> (* May happen in debug *) - [< 'sTR ("IND("^(string_of_path sp)^","^(string_of_int tyi)^")") >] + (str ("IND("^(string_of_path sp)^","^(string_of_int tyi)^")")) let global_constr_name ((sp,tyi),i) = try pr_global (ConstructRef ((sp,tyi),i)) with Not_found -> (* May happen in debug *) - [< 'sTR ("CONSTRUCT("^(string_of_path sp)^","^(string_of_int tyi) - ^","^(string_of_int i)^")") >] + (str ("CONSTRUCT("^(string_of_path sp)^","^(string_of_int tyi) + ^","^(string_of_int i)^")")) let globpr gt = match gt with - | Nvar(_,s) -> [< pr_id s >] - | Node(_,"EVAR", [Num (_,ev)]) -> [< 'sTR ("?" ^ (string_of_int ev)) >] + | Nvar(_,s) -> (pr_id s) + | Node(_,"EVAR", [Num (_,ev)]) -> (str ("?" ^ (string_of_int ev))) | Node(_,"CONST",[Path(_,sl)]) -> global_const_name (section_path sl) | Node(_,"MUTIND",[Path(_,sl); Num(_,tyi)]) -> @@ -55,16 +55,16 @@ let globpr gt = match gt with | Node(_,"MUTCONSTRUCT",[Path(_,sl); Num(_,tyi); Num(_,i)]) -> global_constr_name ((section_path sl, tyi), i) | Dynamic(_,d) -> - if (Dyn.tag d) = "constr" then [< 'sTR"<dynamic [constr]>" >] + if (Dyn.tag d) = "constr" then (str"<dynamic [constr]>") else dfltpr gt | gt -> dfltpr gt let wrap_exception = function Anomaly (s1,s2) -> - warning ("Anomaly ("^s1^")");pP s2; - [< 'sTR"<PP error: non-printable term>" >] + warning ("Anomaly ("^s1^")"); pp s2; + str"<PP error: non-printable term>" | Failure _ | UserError _ | Not_found -> - [< 'sTR"<PP error: non-printable term>" >] + str"<PP error: non-printable term>" | s -> raise s (* These are the names of the universes where the pp rules for constr and @@ -135,10 +135,10 @@ let rec gentacpr gt = Esyntax.genprint default_tacpr tactic_syntax_universe tactic_initial_prec gt and default_tacpr = function - | Nvar(_,s) -> [< pr_id s >] + | Nvar(_,s) -> (pr_id s) (* constr's may occur inside tac expressions ! *) - | Node(_,"EVAR", [Num (_,ev)]) -> [< 'sTR ("?" ^ (string_of_int ev)) >] + | Node(_,"EVAR", [Num (_,ev)]) -> (str ("?" ^ (string_of_int ev))) | Node(_,"CONST",[Path(_,sl)]) -> let sp = section_path sl in pr_global (ConstRef sp) @@ -150,39 +150,39 @@ and default_tacpr = function pr_global (ConstructRef ((sp,tyi),i)) (* This should be tactics *) - | Node(_,s,[]) -> [< 'sTR s >] + | Node(_,s,[]) -> (str s) | Node(_,s,ta) -> - [< 'sTR s; 'bRK(1,2); hOV 0 (prlist_with_sep pr_spc gentacpr ta) >] + (str s ++ brk(1,2) ++ hov 0 (prlist_with_sep pr_spc gentacpr ta)) | Dynamic(_,d) as gt -> let tg = Dyn.tag d in - if tg = "tactic" then [< 'sTR"<dynamic [tactic]>" >] - else if tg = "value" then [< 'sTR"<dynamic [value]>" >] - else if tg = "constr" then [< 'sTR"<dynamic [constr]>" >] + if tg = "tactic" then (str"<dynamic [tactic]>") + else if tg = "value" then (str"<dynamic [value]>") + else if tg = "constr" then (str"<dynamic [constr]>") else dfltpr gt | gt -> dfltpr gt let pr_var_decl env (id,c,typ) = let pbody = match c with - | None -> [< >] + | None -> (mt ()) | Some c -> (* Force evaluation *) let pb = prterm_env env c in - [< 'sTR" := "; pb >] in + (str" := " ++ pb) in let pt = prtype_env env typ in - let ptyp = [< 'sTR" : "; pt >] in - [< pr_id id ; hOV 0 [< pbody; ptyp >] >] + let ptyp = (str" : " ++ pt) in + (pr_id id ++ hov 0 (pbody ++ ptyp)) let pr_rel_decl env (na,c,typ) = let pbody = match c with - | None -> [< >] + | None -> (mt ()) | Some c -> (* Force evaluation *) let pb = prterm_env env c in - [< 'sTR":="; 'sPC; pb; 'sPC >] in + (str":=" ++ spc () ++ pb ++ spc ()) in let ptyp = prtype_env env typ in match na with - | Anonymous -> [< 'sTR"<>" ; 'sPC; pbody; 'sTR":"; 'sPC; ptyp >] - | Name id -> [< pr_id id ; 'sPC; pbody; 'sTR":"; 'sPC; ptyp >] + | Anonymous -> (str"<>" ++ spc () ++ pbody ++ str":" ++ spc () ++ ptyp) + | Name id -> (pr_id id ++ spc () ++ pbody ++ str":" ++ spc () ++ ptyp) (* Prints out an "env" in a nice format. We print out the @@ -191,18 +191,18 @@ let pr_rel_decl env (na,c,typ) = (* Prints a signature, all declarations on the same line if possible *) let pr_named_context_of env = - hV 0 [< (fold_named_context - (fun env d pps -> [< pps; 'wS 2; pr_var_decl env d >]) - env) [< >] >] + hv 0 (fold_named_context + (fun env d pps -> pps ++ ws 2 ++ pr_var_decl env d) + env ~init:(mt ())) let pr_rel_context env rel_context = let rec prec env = function - | [] -> [<>] + | [] -> (mt ()) | [b] -> pr_rel_decl env b | b::rest -> let pb = pr_rel_decl env b in let penvtl = prec (push_rel b env) rest in - [< pb; 'sTR";"; 'sPC; penvtl >] + (pb ++ str";" ++ spc () ++ penvtl) in prec env (List.rev rel_context) @@ -211,21 +211,21 @@ let pr_context_unlimited env = let sign_env = fold_named_context (fun env d pps -> - let pidt = pr_var_decl env d in [< pps; 'fNL; pidt >]) - env [< >] + let pidt = pr_var_decl env d in (pps ++ fnl () ++ pidt)) + env ~init:(mt ()) in let db_env = fold_rel_context (fun env d pps -> - let pnat = pr_rel_decl env d in [< pps; 'fNL; pnat >]) - env [< >] + let pnat = pr_rel_decl env d in (pps ++ fnl () ++ pnat)) + env ~init:(mt ()) in - [< sign_env; db_env >] + (sign_env ++ db_env) let pr_ne_context_of header env = if Environ.rel_context env = empty_rel_context & - Environ.named_context env = empty_named_context then [< >] - else let penv = pr_context_unlimited env in [< header; penv; 'fNL >] + Environ.named_context env = empty_named_context then (mt ()) + else let penv = pr_context_unlimited env in (header ++ penv ++ fnl ()) let pr_context_limit n env = let named_context = Environ.named_context env in @@ -238,25 +238,25 @@ let pr_context_limit n env = fold_named_context (fun env d (i,pps) -> if i < k then - (i+1, [< pps ;'sTR "." >]) + (i+1, (pps ++str ".")) else let pidt = pr_var_decl env d in - (i+1, [< pps ; 'fNL ; - 'sTR (emacs_str (String.make 1 (Char.chr 253))); - pidt >])) - env (0,[< >]) + (i+1, (pps ++ fnl () ++ + str (emacs_str (String.make 1 (Char.chr 253))) ++ + pidt))) + env ~init:(0,(mt ())) in let db_env = fold_rel_context (fun env d pps -> let pnat = pr_rel_decl env d in - [< pps; 'fNL; - 'sTR (emacs_str (String.make 1 (Char.chr 253))); - pnat >]) - env [< >] + (pps ++ fnl () ++ + str (emacs_str (String.make 1 (Char.chr 253))) ++ + pnat)) + env ~init:(mt ()) in - [< sign_env; db_env >] + (sign_env ++ db_env) let pr_context_of env = match Options.print_hyps_limit () with - | None -> hV 0 (pr_context_unlimited env) - | Some n -> hV 0 (pr_context_limit n env) + | None -> hv 0 (pr_context_unlimited env) + | Some n -> hv 0 (pr_context_limit n env) diff --git a/parsing/search.ml b/parsing/search.ml index a96567bf4..1d5619969 100644 --- a/parsing/search.ml +++ b/parsing/search.ml @@ -80,7 +80,7 @@ let crible (fn : global_reference -> env -> constr -> unit) ref = Library.iter_all_segments false crible_rec with Not_found -> errorlabstrm "search" - [< pr_global ref; 'sPC; 'sTR "not declared" >] + (pr_global ref ++ spc () ++ str "not declared") (* Fine Search. By Yves Bertot. *) @@ -101,7 +101,7 @@ let xor a b = (a or b) & (not (a & b)) let plain_display ref a c = let pc = prterm_env a c in let pr = pr_global ref in - mSG [< hOV 2 [< pr; 'sTR":"; 'sPC; pc >]; 'fNL>] + msg (hov 2 (pr ++ str":" ++ spc () ++ pc) ++ fnl ()) let filter_by_module (module_list:dir_path list) (accept:bool) (ref:global_reference) (env:env) _ = diff --git a/parsing/termast.ml b/parsing/termast.ml index fb9852f3b..f7affb5b1 100644 --- a/parsing/termast.ml +++ b/parsing/termast.ml @@ -278,7 +278,7 @@ and ast_of_eqn (_,ids,pl,c) = ope("EQN", (ast_of_raw c)::(List.map ast_of_cases_pattern pl)) and ast_of_rawopt = function - | None -> (str "SYNTH") + | None -> (string "SYNTH") | Some p -> ast_of_raw p and factorize_binder n oper na aty c = @@ -399,7 +399,7 @@ let rec ast_of_pattern env = function | PCoFix c -> ast_of_raw (Detyping.detype [] env (mkCoFix c)) and ast_of_patopt env = function - | None -> (str "SYNTH") + | None -> (string "SYNTH") | Some p -> ast_of_pattern env p and factorize_binder_pattern env n oper na aty c = diff --git a/pretyping/cases.ml b/pretyping/cases.ml index 3152478ab..7f6f05d11 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -176,7 +176,7 @@ let pred_case_ml_onebranch loc env sigma isrec indt (i,fj) = open Pp let mssg_may_need_inversion () = - [< 'sTR "This pattern-matching is not exhaustive.">] + str "This pattern-matching is not exhaustive." let mssg_this_case_cannot_occur () = "This pattern-matching is not exhaustive." diff --git a/pretyping/classops.ml b/pretyping/classops.ml index 77dff358b..952bb9822 100755 --- a/pretyping/classops.ml +++ b/pretyping/classops.ml @@ -257,7 +257,7 @@ let coercion_value i = (* pretty-print functions are now in Pretty *) (* rajouter une coercion dans le graphe *) -let path_printer = ref (fun _ -> [< 'sTR "<a class path>" >] +let path_printer = ref (fun _ -> str "<a class path>" : (int * int) * inheritance_path -> std_ppcmds) let install_path_printer f = path_printer := f @@ -265,8 +265,8 @@ let install_path_printer f = path_printer := f let print_path x = !path_printer x let message_ambig l = - [< 'sTR"Ambiguous paths:"; 'sPC; - prlist_with_sep pr_fnl (fun ijp -> print_path ijp) l >] + (str"Ambiguous paths:" ++ spc () ++ + prlist_with_sep pr_fnl (fun ijp -> print_path ijp) l) (* add_coercion_in_graph : coe_index * cl_index * cl_index -> unit coercion,source,target *) @@ -315,7 +315,7 @@ let add_coercion_in_graph (ic,source,target) = old_inheritance_graph end; if (!ambig_paths <> []) && is_verbose () && is_mes_ambig() then - pPNL (message_ambig !ambig_paths) + ppnl (message_ambig !ambig_paths) type coercion = (coe_typ * coe_info_typ) * cl_typ * cl_typ @@ -337,7 +337,7 @@ let (inCoercion,outCoercion) = cache_function = cache_coercion; export_function = (function x -> Some x) }) -let declare_coercion coef v stre isid cls clt ps = +let declare_coercion coef v stre ~isid ~src:cls ~target:clt ~params:ps = Lib.add_anonymous_leaf (inCoercion ((coef, diff --git a/pretyping/classops.mli b/pretyping/classops.mli index ecdce7543..3861d8d35 100644 --- a/pretyping/classops.mli +++ b/pretyping/classops.mli @@ -71,7 +71,7 @@ val strength_of_cl : cl_typ -> strength (*s [declare_coercion] adds a coercion in the graph of coercion paths *) val declare_coercion : - coe_typ -> value:unsafe_judgment -> strength:strength -> isid:bool -> + coe_typ -> unsafe_judgment -> strength -> isid:bool -> src:cl_typ -> target:cl_typ -> params:int -> unit (*s Access to coercions infos *) diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index b634b0443..111e5a514 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -32,8 +32,8 @@ let encode_inductive ref = | IndRef indsp -> indsp | _ -> errorlabstrm "indsp_of_id" - [< pr_global_env (Global.env()) ref; - 'sTR" is not an inductive type" >] in + (pr_global_env (Global.env()) ref ++ + str" is not an inductive type") in let (mib,mip) = Global.lookup_inductive indsp in let constr_lengths = Array.map List.length mip.mind_listrec in (indsp,constr_lengths) @@ -67,7 +67,7 @@ module PrintingCasesMake = let encode = encode_inductive let check (_,lc) = if not (Test.test lc) then - errorlabstrm "check_encode" [< 'sTR Test.error_message >] + errorlabstrm "check_encode" (str Test.error_message) let printer (ind,_) = pr_id (basename (path_of_inductive (Global.env()) ind)) let key = Goptions.SecondaryTable ("Printing",Test.field) diff --git a/pretyping/evarutil.ml b/pretyping/evarutil.ml index a56e87b2e..a53ecf535 100644 --- a/pretyping/evarutil.ml +++ b/pretyping/evarutil.ml @@ -308,8 +308,9 @@ let make_evar_instance_with_rel env = (fun env (id,b,_) l -> (* if b=None then *) mkVar id :: l (*else l*)) env ~init:[] in snd (fold_rel_context - (fun env (_,b,_) (i,l) -> (i-1, (*if b=None then *) mkRel i :: l (*else l*))) - env (n,vars)) + (fun env (_,b,_) (i,l) -> + (i-1, (*if b=None then *) mkRel i :: l (*else l*))) + env ~init:(n,vars)) let make_subst env args = snd (fold_named_context @@ -318,7 +319,7 @@ let make_subst env args = | (* None *) _ , a::rest -> (rest, (id,a)::l) (* | Some _, _ -> g*) | _ -> anomaly "Instance does not match its signature") - env (List.rev args,[])) + env ~init:(List.rev args,[])) (* [new_isevar] declares a new existential in an env env with type typ *) (* Converting the env into the sign of the evar to define *) @@ -335,7 +336,7 @@ let push_rel_context_to_named_context env = add_named_decl (id,option_app (substl subst) c, type_app (substl subst) t) sign)) - (rel_context env) ([],ids_of_named_context sign0,sign0) + (rel_context env) ~init:([],ids_of_named_context sign0,sign0) in (subst, reset_with_named_context sign env) let new_isevar isevars env typ = diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml index 3c5e17b09..392b4fc84 100644 --- a/pretyping/indrec.ml +++ b/pretyping/indrec.ml @@ -533,7 +533,7 @@ let declare_one_elimination ind = const_entry_type = None; const_entry_opaque = false }, NeverDischarge) in - Options.if_verbose pPNL [< 'sTR na; 'sTR " is defined" >] + Options.if_verbose ppnl (str na ++ str " is defined") in let env = Global.env () in let sigma = Evd.empty in @@ -575,9 +575,9 @@ let lookup_eliminator ind_sp s = try construct_reference env id with Not_found -> errorlabstrm "default_elim" - [< 'sTR "Cannot find the elimination combinator :"; - pr_id id; 'sPC; - 'sTR "The elimination of the inductive definition :"; - pr_id base; 'sPC; 'sTR "on sort "; - 'sPC; print_sort (new_sort_in_family s) ; - 'sTR " is probably not allowed" >] + (str "Cannot find the elimination combinator :" ++ + pr_id id ++ spc () ++ + str "The elimination of the inductive definition :" ++ + pr_id base ++ spc () ++ str "on sort " ++ + spc () ++ print_sort (new_sort_in_family s) ++ + str " is probably not allowed") diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index dee738a77..2971ba430 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -207,7 +207,7 @@ let rec pretype tycon env isevars lvar lmeta = function Not_found -> user_err_loc (loc,"pretype", - [< 'sTR "Metavariable "; 'iNT n; 'sTR" is unbound" >]) + str "Metavariable " ++ int n ++ str " is unbound") in inh_conv_coerce_to_tycon loc env isevars j tycon | RHole loc -> @@ -220,7 +220,7 @@ let rec pretype tycon env isevars lvar lmeta = function | Some loc -> user_err_loc (loc,"pretype", - [< 'sTR "Cannot infer a term for this placeholder" >]))) + (str "Cannot infer a term for this placeholder")))) | RRec (loc,fixkind,names,lar,vdef) -> let larj = @@ -420,7 +420,7 @@ let rec pretype tycon env isevars lvar lmeta = function j (*inh_conv_coerce_to_tycon loc env isevars j tycon*) else - user_err_loc (loc,"pretype",[< 'sTR "Not a constr tagged Dynamic" >]) + user_err_loc (loc,"pretype",(str "Not a constr tagged Dynamic")) (* [pretype_type valcon env isevars lvar lmeta c] coerces [c] into a type *) and pretype_type valcon env isevars lvar lmeta = function @@ -471,7 +471,7 @@ let check_evars fail_evar initial_sigma sigma c = if not (Evd.in_dom initial_sigma ev) then (if fail_evar then errorlabstrm "whd_ise" - [< 'sTR"There is an unknown subterm I cannot solve" >] + (str"There is an unknown subterm I cannot solve") else (* try to avoid duplication *) (if not (List.exists (fun (k',_) -> k=k') !metamap) then metamap := (k, existential_type sigma k) :: !metamap)) @@ -534,7 +534,7 @@ let understand_type sigma env c = let _,c = ise_infer_type_gen true sigma env [] [] c in c.utj_val -let understand_gen sigma env lvar lmeta exptyp c = +let understand_gen sigma env lvar lmeta ~expected_type:exptyp c = let _, c = ise_infer_gen true sigma env lvar lmeta exptyp c in c.uj_val diff --git a/pretyping/syntax_def.ml b/pretyping/syntax_def.ml index 381a40ee6..f13f31de0 100644 --- a/pretyping/syntax_def.ml +++ b/pretyping/syntax_def.ml @@ -33,7 +33,7 @@ let add_syntax_constant sp c = let cache_syntax_constant (sp,c) = if Nametab.exists_cci sp then errorlabstrm "cache_syntax_constant" - [< pr_id (basename sp); 'sTR " already exists" >]; + (pr_id (basename sp) ++ str " already exists"); add_syntax_constant sp c; Nametab.push_syntactic_definition sp; Nametab.push_short_name_syntactic_definition sp @@ -41,7 +41,7 @@ let cache_syntax_constant (sp,c) = let load_syntax_constant (sp,c) = if Nametab.exists_cci sp then errorlabstrm "cache_syntax_constant" - [< pr_id (basename sp); 'sTR " already exists" >]; + (pr_id (basename sp) ++ str " already exists"); add_syntax_constant sp c; Nametab.push_syntactic_definition sp diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index 6c38f6d9a..2f2f7e753 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -30,9 +30,9 @@ let set_transparent_const sp = let cb = Global.lookup_constant sp in if cb.const_body <> None & cb.const_opaque then errorlabstrm "set_transparent_const" - [< 'sTR "Cannot make"; 'sPC; - Nametab.pr_global_env (Global.env()) (Nametab.ConstRef sp); - 'sPC; 'sTR "transparent because it was declared opaque." >]; + (str "Cannot make" ++ spc () ++ + Nametab.pr_global_env (Global.env()) (Nametab.ConstRef sp) ++ + spc () ++ str "transparent because it was declared opaque."); Conv_oracle.set_transparent_const sp let set_opaque_var = Conv_oracle.set_opaque_var @@ -601,7 +601,7 @@ let rec substlin env name n ol c = with NotEvaluableConst _ -> errorlabstrm "substlin" - [< pr_sp const; 'sTR " is not a defined constant" >] + (pr_sp const ++ str " is not a defined constant") else ((n+1), ol, c) @@ -611,7 +611,7 @@ let rec substlin env name n ol c = | (_,Some c,_) -> (n+1, List.tl ol, c) | _ -> errorlabstrm "substlin" - [< pr_id id; 'sTR " is not a defined constant" >] + (pr_id id ++ str " is not a defined constant") else ((n+1), ol, c) @@ -829,14 +829,14 @@ let reduce_to_ind_gen allow_product env sigma t = elimrec (push_rel (n,None,t) env) t' ((n,None,ty)::l) else errorlabstrm "tactics__reduce_to_mind" - [< 'sTR"Not an inductive definition" >] + (str"Not an inductive definition") | _ -> (try let t' = nf_betaiota (one_step_reduce env sigma t) in elimrec env t' l with NotStepReducible -> errorlabstrm "tactics__reduce_to_mind" - [< 'sTR"Not an inductive product" >]) + (str"Not an inductive product")) in elimrec env t [] diff --git a/pretyping/termops.ml b/pretyping/termops.ml index 04cbd0d19..97e8f68cc 100644 --- a/pretyping/termops.ml +++ b/pretyping/termops.ml @@ -18,10 +18,10 @@ open Nametab open Sign let print_sort = function - | Prop Pos -> [< 'sTR "Set" >] - | Prop Null -> [< 'sTR "Prop" >] -(* | Type _ -> [< 'sTR "Type" >] *) - | Type u -> [< 'sTR "Type("; Univ.pr_uni u; 'sTR ")" >] + | Prop Pos -> (str "Set") + | Prop Null -> (str "Prop") +(* | Type _ -> (str "Type") *) + | Type u -> (str "Type(" ++ Univ.pr_uni u ++ str ")") let current_module = ref empty_dirpath @@ -41,10 +41,10 @@ let new_sort_in_family = function (* prod_it b [xn:Tn;..;x1:T1] = (x1:T1)..(xn:Tn)b *) -let prod_it = List.fold_left (fun c (n,t) -> mkProd (n, t, c)) +let prod_it ~init = List.fold_left (fun c (n,t) -> mkProd (n, t, c)) init (* lam_it b [xn:Tn;..;x1:T1] = [x1:T1]..[xn:Tn]b *) -let lam_it = List.fold_left (fun c (n,t) -> mkLambda (n, t, c)) +let lam_it ~init = List.fold_left (fun c (n,t) -> mkLambda (n, t, c)) init (* [Rel (n+m);...;Rel(n+1)] *) let rel_vect n m = Array.init m (fun i -> mkRel(n+m-i)) @@ -104,12 +104,17 @@ let mkProd_wo_LetIn (na,body,t) c = | None -> mkProd (na, body_of_type t, c) | Some b -> subst1 b c -let it_mkProd_wo_LetIn = List.fold_left (fun c d -> mkProd_wo_LetIn d c) -let it_mkProd_or_LetIn = List.fold_left (fun c d -> mkProd_or_LetIn d c) +let it_mkProd_wo_LetIn ~init = + List.fold_left (fun c d -> mkProd_wo_LetIn d c) init -let it_mkLambda_or_LetIn = List.fold_left (fun c d -> mkLambda_or_LetIn d c) +let it_mkProd_or_LetIn ~init = + List.fold_left (fun c d -> mkProd_or_LetIn d c) init -let it_named_context_quantifier f = List.fold_left (fun c d -> f d c) +let it_mkLambda_or_LetIn ~init = + List.fold_left (fun c d -> mkLambda_or_LetIn d c) init + +let it_named_context_quantifier f ~init = + List.fold_left (fun c d -> f d c) init let it_mkNamedProd_or_LetIn = it_named_context_quantifier mkNamedProd_or_LetIn let it_mkNamedLambda_or_LetIn = it_named_context_quantifier mkNamedLambda_or_LetIn @@ -469,7 +474,7 @@ let subst_term_occ locs c t = else let (nbocc,t') = subst_term_occ_gen locs 1 c t in if List.exists (fun o -> o >= nbocc or o <= -nbocc) locs then - errorlabstrm "subst_term_occ" [< 'sTR "Too few occurences" >]; + errorlabstrm "subst_term_occ" (str "Too few occurences"); t' let subst_term_occ_decl locs c (id,bodyopt,typ as d) = @@ -484,7 +489,7 @@ let subst_term_occ_decl locs c (id,bodyopt,typ as d) = let (nbocc,body') = subst_term_occ_gen locs 1 c body in let (nbocc',t') = subst_term_occ_gen locs nbocc c typ in if List.exists (fun o -> o >= nbocc' or o <= -nbocc') locs then - errorlabstrm "subst_term_occ_decl" [< 'sTR "Too few occurences" >]; + errorlabstrm "subst_term_occ_decl" (str "Too few occurences"); (id,Some body',t') @@ -709,7 +714,7 @@ let lift_rel_context n sign = in liftrec (rel_context_length sign) sign -let fold_named_context_both_sides = list_fold_right_and_left +let fold_named_context_both_sides f l ~init = list_fold_right_and_left f l init let rec mem_named_context id = function | (id',_,_) :: _ when id=id' -> true diff --git a/proofs/clenv.ml b/proofs/clenv.ml index d73264e92..1a2ebd32f 100644 --- a/proofs/clenv.ml +++ b/proofs/clenv.ml @@ -430,8 +430,8 @@ let clenv_assign mv rhs clenv = (* Streams are lazy, force evaluation of id to catch Not_found*) let id = Intmap.find mv clenv.namenv in errorlabstrm "clenv_assign" - [< 'sTR "An incompatible instantiation has already been found for "; - pr_id id >] + (str "An incompatible instantiation has already been found for " ++ + pr_id id) with Not_found -> anomaly "clenv_assign: non dependent metavar already assigned" else @@ -907,7 +907,7 @@ let clenv_lookup_name clenv id = match intmap_inv clenv.namenv id with | [] -> errorlabstrm "clenv_lookup_name" - [< 'sTR"No such bound variable "; pr_id id >] + (str"No such bound variable " ++ pr_id id) | [n] -> n | _ -> @@ -926,18 +926,18 @@ let clenv_match_args s clause = | Dep s -> if List.mem_assoc b t then errorlabstrm "clenv_match_args" - [< 'sTR "The variable "; pr_id s; - 'sTR " occurs more than once in binding" >] + (str "The variable " ++ pr_id s ++ + str " occurs more than once in binding") else clenv_lookup_name clause s | NoDep n -> if List.mem_assoc b t then errorlabstrm "clenv_match_args" - [< 'sTR "The position "; 'iNT n ; - 'sTR " occurs more than once in binding" >]; + (str "The position " ++ int n ++ + str " occurs more than once in binding"); (try List.nth mvs (n-1) with Failure "item" -> errorlabstrm "clenv_match_args" - [< 'sTR"No such binder" >]) + (str"No such binder")) | Com -> anomaly "No free term in clenv_match_args") in let k_typ = w_hnf_constr clause.hook (clenv_instance_type clause k) @@ -1092,7 +1092,7 @@ let make_clenv_binding_apply wc n (c,t) lbind = clenv_match_args lbind clause else errorlabstrm "make_clenv_bindings" - [<'sTR "Cannot mix bindings and free associations">] + (str "Cannot mix bindings and free associations") let make_clenv_binding wc (c,t) lbind = let largs = collect_com lbind in @@ -1105,7 +1105,7 @@ let make_clenv_binding wc (c,t) lbind = clenv_match_args lbind clause else errorlabstrm "make_clenv_bindings" - [<'sTR "Cannot mix bindings and free associations">] + (str "Cannot mix bindings and free associations") open Printer @@ -1113,15 +1113,15 @@ let pr_clenv clenv = let pr_name mv = try let id = Intmap.find mv clenv.namenv in - [< 'sTR"[" ; pr_id id ; 'sTR"]" >] - with Not_found -> [< >] + (str"[" ++ pr_id id ++ str"]") + with Not_found -> (mt ()) in let pr_meta_binding = function | (mv,Cltyp b) -> - hOV 0 [< 'iNT mv ; pr_name mv ; 'sTR " : " ; prterm b.rebus ; 'fNL >] + hov 0 (int mv ++ pr_name mv ++ str " : " ++ prterm b.rebus ++ fnl ()) | (mv,Clval(b,_)) -> - hOV 0 [< 'iNT mv ; pr_name mv ; 'sTR " := " ; prterm b.rebus ; 'fNL >] + hov 0 (int mv ++ pr_name mv ++ str " := " ++ prterm b.rebus ++ fnl ()) in - [< 'sTR"TEMPL: " ; prterm clenv.templval.rebus ; - 'sTR" : " ; prterm clenv.templtyp.rebus ; 'fNL ; - (prlist pr_meta_binding (intmap_to_list clenv.env)) >] + (str"TEMPL: " ++ prterm clenv.templval.rebus ++ + str" : " ++ prterm clenv.templtyp.rebus ++ fnl () ++ + (prlist pr_meta_binding (intmap_to_list clenv.env))) diff --git a/proofs/logic.ml b/proofs/logic.ml index 61edd06bf..ea524791a 100644 --- a/proofs/logic.ml +++ b/proofs/logic.ml @@ -180,8 +180,8 @@ and mk_casegoals sigma goal goalacc p c = let error_use_instantiate () = errorlabstrm "Logic.prim_refiner" - [< 'sTR"cannot intro when there are open metavars in the domain type"; - 'sPC; 'sTR"- use Instantiate" >] + (str"cannot intro when there are open metavars in the domain type" ++ + spc () ++ str"- use Instantiate") (* Auxiliary functions for primitive MOVE tactic * @@ -257,7 +257,7 @@ let apply_to_hyp2 env id f = found := true; f env d tail end else push_named_decl d env) - (named_context env) (reset_context env) + (named_context env) ~init:(reset_context env) in if (not !check) || !found then env' else error "No such assumption" @@ -363,7 +363,7 @@ let remove_hyp_body env sigma id = let b' = mkCast (b,t) in recheck_typability (Some id',id) env'' sigma b'); push_named_decl d env'') - tail env'); + tail ~init:env'); env') (* Primitive tactics are handled here *) @@ -667,67 +667,67 @@ open Printer let pr_prim_rule = function | {name=Intro;newids=[id]} -> - [< 'sTR"Intro " ; pr_id id >] + str"Intro " ++ pr_id id | {name=Intro_after;newids=[id]} -> - [< 'sTR"intro after " ; pr_id id >] + str"intro after " ++ pr_id id | {name=Intro_replacing;newids=[id]} -> - [< 'sTR"intro replacing " ; pr_id id >] + (str"intro replacing " ++ pr_id id) | {name=Cut b;terms=[t];newids=[id]} -> if b then - [< 'sTR"TrueCut "; prterm t >] + (str"TrueCut " ++ prterm t) else - [< 'sTR"Cut "; prterm t; 'sTR ";[Intro "; pr_id id; 'sTR "|Idtac]" >] + (str"Cut " ++ prterm t ++ str ";[Intro " ++ pr_id id ++ str "|Idtac]") | {name=FixRule;newids=[f];params=[Num(_,n)]} -> - [< 'sTR"Fix "; pr_id f; 'sTR"/"; 'iNT n>] + (str"Fix " ++ pr_id f ++ str"/" ++ int n) | {name=FixRule;newids=(f::lf);params=(Num(_,n))::ln;terms=lar} -> let rec print_mut = function (f::lf),((Num(_,n))::ln),(ar::lar) -> - [< pr_id f; 'sTR"/"; 'iNT n; 'sTR" : "; prterm ar; - print_mut (lf,ln,lar)>] - | _ -> [<>] in - [< 'sTR"Fix "; pr_id f; 'sTR"/"; 'iNT n; - 'sTR" with "; print_mut (lf,ln,lar) >] + pr_id f ++ str"/" ++ int n ++ str" : " ++ prterm ar ++ + print_mut (lf,ln,lar) + | _ -> (mt ()) in + (str"Fix " ++ pr_id f ++ str"/" ++ int n ++ + str" with " ++ print_mut (lf,ln,lar)) | {name=Cofix;newids=[f];terms=[]} -> - [< 'sTR"Cofix "; pr_id f >] + (str"Cofix " ++ pr_id f) | {name=Cofix;newids=(f::lf);terms=lar} -> let rec print_mut = function (f::lf),(ar::lar) -> - [< pr_id f; 'sTR" : "; prterm ar; print_mut (lf,lar)>] - | _ -> [<>] + (pr_id f ++ str" : " ++ prterm ar ++ print_mut (lf,lar)) + | _ -> (mt ()) in - [< 'sTR"Cofix "; pr_id f; 'sTR" with "; print_mut (lf,lar) >] + (str"Cofix " ++ pr_id f ++ str" with " ++ print_mut (lf,lar)) | {name=Refine;terms=[c]} -> - [< 'sTR(if occur_meta c then "Refine " else "Exact ") ; prterm c >] + (str(if occur_meta c then "Refine " else "Exact ") ++ prterm c) | {name=Convert_concl;terms=[c]} -> - [< 'sTR"Change " ; prterm c >] + (str"Change " ++ prterm c) | {name=Convert_hyp;hypspecs=[id];terms=[c]} -> - [< 'sTR"Change " ; prterm c ; 'sPC ; 'sTR"in " ; pr_id id >] + (str"Change " ++ prterm c ++ spc () ++ str"in " ++ pr_id id) | {name=Convert_defbody;hypspecs=[id];terms=[c]} -> - [< 'sTR"Change " ; prterm c ; 'sPC ; 'sTR"in " ; pr_id id >] + (str"Change " ++ prterm c ++ spc () ++ str"in " ++ pr_id id) | {name=Convert_deftype;hypspecs=[id];terms=[c]} -> - [< 'sTR"Change " ; prterm c ; 'sPC ; - 'sTR"in (Type of " ; pr_id id; 'sTR ")" >] + (str"Change " ++ prterm c ++ spc () ++ + str"in (Type of " ++ pr_id id ++ str ")") | {name=Thin;hypspecs=ids} -> - [< 'sTR"Clear " ; prlist_with_sep pr_spc pr_id ids >] + (str"Clear " ++ prlist_with_sep pr_spc pr_id ids) | {name=ThinBody;hypspecs=ids} -> - [< 'sTR"ClearBody " ; prlist_with_sep pr_spc pr_id ids >] + (str"ClearBody " ++ prlist_with_sep pr_spc pr_id ids) | {name=Move withdep;hypspecs=[id1;id2]} -> - [< 'sTR (if withdep then "Dependent " else ""); - 'sTR"Move " ; pr_id id1; 'sTR " after "; pr_id id2 >] + (str (if withdep then "Dependent " else "") ++ + str"Move " ++ pr_id id1 ++ str " after " ++ pr_id id2) | _ -> anomaly "pr_prim_rule: Unrecognized primitive rule" diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index b148c019a..610e99b9f 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -43,13 +43,13 @@ let get_all_proof_names () = Edit.dom proof_edits let msg_proofs use_resume = match Edit.dom proof_edits with - | [] -> [< 'sPC ; 'sTR"(No proof-editing in progress)." >] - | l -> [< 'sTR"." ; 'fNL ; 'sTR"Proofs currently edited:" ; 'sPC ; - (prlist_with_sep pr_spc pr_id (get_all_proof_names ())) ; - 'sTR"." ; - (if use_resume then [< 'fNL ; 'sTR"Use \"Resume\" first." >] - else [< >]) - >] + | [] -> (spc () ++ str"(No proof-editing in progress).") + | l -> (str"." ++ fnl () ++ str"Proofs currently edited:" ++ spc () ++ + (prlist_with_sep pr_spc pr_id (get_all_proof_names ())) ++ + str"." ++ + (if use_resume then (fnl () ++ str"Use \"Resume\" first.") + else (mt ())) +) let undo_default = 12 let undo_limit = ref undo_default @@ -61,7 +61,7 @@ let undo_limit = ref undo_default let get_state () = match Edit.read proof_edits with | None -> errorlabstrm "Pfedit.get_state" - [< 'sTR"No focused proof"; msg_proofs true >] + (str"No focused proof" ++ msg_proofs true) | Some(_,pfs,ts) -> (pfs,ts) let get_topstate () = snd(get_state()) @@ -79,7 +79,7 @@ let set_current_proof s = Edit.focus proof_edits s with Invalid_argument "Edit.focus" -> errorlabstrm "Pfedit.set_proof" - [< 'sTR"No such proof" ; (msg_proofs false) >] + (str"No such proof" ++ (msg_proofs false)) let resume_proof = set_current_proof @@ -88,12 +88,12 @@ let suspend_proof () = Edit.unfocus proof_edits with Invalid_argument "Edit.unfocus" -> errorlabstrm "Pfedit.suspend_current_proof" - [< 'sTR"No active proof" ; (msg_proofs true) >] + (str"No active proof" ++ (msg_proofs true)) let resume_last_proof () = match (Edit.last_focused proof_edits) with | None -> - errorlabstrm "resume_last" [< 'sTR"No proof-editing in progress." >] + errorlabstrm "resume_last" (str"No proof-editing in progress.") | Some p -> Edit.focus proof_edits p @@ -101,7 +101,7 @@ let get_current_proof_name () = match Edit.read proof_edits with | None -> errorlabstrm "Pfedit.get_proof" - [< 'sTR"No focused proof" ; msg_proofs true >] + (str"No focused proof" ++ msg_proofs true) | Some(na,_,_) -> na let add_proof (na,pfs,ts) = @@ -112,7 +112,7 @@ let delete_proof na = Edit.delete proof_edits na with (UserError ("Edit.delete",_)) -> errorlabstrm "Pfedit.delete_proof" - [< 'sTR"No such proof" ; msg_proofs false >] + (str"No such proof" ++ msg_proofs false) let init_proofs () = Edit.clear proof_edits @@ -121,7 +121,7 @@ let mutate f = Edit.mutate proof_edits (fun _ pfs -> f pfs) with Invalid_argument "Edit.mutate" -> errorlabstrm "Pfedit.mutate" - [< 'sTR"No focused proof" ; msg_proofs true >] + (str"No focused proof" ++ msg_proofs true) let start (na,ts) = let pfs = mk_pftreestate ts.top_goal in @@ -131,7 +131,7 @@ let restart_proof () = match Edit.read proof_edits with | None -> errorlabstrm "Pfedit.restart" - [< 'sTR"No focused proof to restart" ; msg_proofs true >] + (str"No focused proof to restart" ++ msg_proofs true) | Some(na,_,ts) -> delete_proof na; start (na,ts); @@ -166,7 +166,7 @@ let undo n = subtree - this solution only works properly if undoing one step *) if subtree_solved() then Edit.undo proof_edits 1 with (Invalid_argument "Edit.undo") -> - errorlabstrm "Pfedit.undo" [< 'sTR"No focused proof"; msg_proofs true >] + errorlabstrm "Pfedit.undo" (str"No focused proof" ++ msg_proofs true) (*********************************************************************) (* Proof cooking *) @@ -193,8 +193,8 @@ let refining () = [] <> (Edit.dom proof_edits) let check_no_pending_proofs () = if refining () then errorlabstrm "check_no_pending_proofs" - [< 'sTR"Proof editing in progress" ; (msg_proofs false) ; - 'sTR"Use \"Abort All\" first or complete proof(s)." >] + (str"Proof editing in progress" ++ (msg_proofs false) ++ + str"Use \"Abort All\" first or complete proof(s).") let delete_current_proof () = delete_proof (get_current_proof_name ()) diff --git a/proofs/proof_trees.ml b/proofs/proof_trees.ml index af106b1c4..8e2a9b0ea 100644 --- a/proofs/proof_trees.ml +++ b/proofs/proof_trees.ml @@ -116,36 +116,36 @@ let pr_goal g = let env = evar_env g in let penv = pr_context_of env in let pc = prterm_env_at_top env g.evar_concl in - [< 'sTR" "; hV 0 [< penv; 'fNL; - 'sTR (emacs_str (String.make 1 (Char.chr 253))) ; - 'sTR "============================"; 'fNL ; - 'sTR" " ; pc>]; 'fNL>] + str" " ++ hv 0 (penv ++ fnl () ++ + str (emacs_str (String.make 1 (Char.chr 253))) ++ + str "============================" ++ fnl () ++ + str" " ++ pc) ++ fnl () let pr_concl n g = let env = evar_env g in let pc = prterm_env_at_top env g.evar_concl in - [< 'sTR (emacs_str (String.make 1 (Char.chr 253))) ; - 'sTR "subgoal ";'iNT n;'sTR " is:";'cUT;'sTR" " ; pc >] + str (emacs_str (String.make 1 (Char.chr 253))) ++ + str "subgoal " ++ int n ++ str " is:" ++ cut () ++ str" " ++ pc (* print the subgoals but write Subtree proved! even in case some existential variables remain unsolved, pr_subgoals_existential is a safer version of pr_subgoals *) let pr_subgoals = function - | [] -> [< 'sTR"Subtree proved!" ; 'fNL >] + | [] -> (str"Subtree proved!" ++ fnl ()) | [g] -> - let pg = pr_goal g in v 0 [< 'sTR ("1 "^"subgoal");'cUT; pg >] + let pg = pr_goal g in v 0 (str ("1 "^"subgoal") ++cut () ++ pg) | g1::rest -> let rec pr_rec n = function - | [] -> [< >] + | [] -> (mt ()) | g::rest -> let pg = pr_concl n g in let prest = pr_rec (n+1) rest in - [< 'cUT; pg; prest >] + (cut () ++ pg ++ prest) in let pg1 = pr_goal g1 in let pgr = pr_rec 2 rest in - v 0 [< 'iNT(List.length rest+1) ; 'sTR" subgoals" ;'cUT; pg1; pgr >] + v 0 (int(List.length rest+1) ++ str" subgoals" ++ cut () ++ pg1 ++ pgr) let pr_subgoal n = let rec prrec p = function @@ -153,7 +153,7 @@ let pr_subgoal n = | g::rest -> if p = 1 then let pg = pr_goal g in - v 0 [< 'sTR "subgoal ";'iNT n;'sTR " is:"; 'cUT; pg >] + v 0 (str "subgoal " ++ int n ++ str " is:" ++ cut () ++ pg) else prrec (p-1) rest in @@ -165,85 +165,85 @@ let pr_seq evd = in let pdcl = pr_named_context_of env in let pcl = prterm_env_at_top env cl in - hOV 0 [< pdcl ; 'sPC ; hOV 0 [< 'sTR"|- " ; pcl >] >] + hov 0 (pdcl ++ spc () ++ hov 0 (str"|- " ++ pcl)) let prgl gl = let pgl = pr_seq gl in - [< 'sTR"[" ; pgl ; 'sTR"]" ; 'sPC >] + (str"[" ++ pgl ++ str"]" ++ spc ()) let pr_evgl gl = let phyps = pr_idl (ids_of_named_context gl.evar_hyps) in let pc = prterm gl.evar_concl in - hOV 0 [< 'sTR"[" ; phyps; 'sPC; 'sTR"|- " ; pc; 'sTR"]" >] + hov 0 (str"[" ++ phyps ++ spc () ++ str"|- " ++ pc ++ str"]") let pr_evgl_sign gl = let ps = pr_named_context_of (evar_env gl) in let pc = prterm gl.evar_concl in - hOV 0 [< 'sTR"[" ; ps; 'sPC; 'sTR"|- " ; pc; 'sTR"]" >] + hov 0 (str"[" ++ ps ++ spc () ++ str"|- " ++ pc ++ str"]") (* evd.evgoal.lc seems to be printed twice *) let pr_decl evd = let pevgl = pr_evgl evd in let pb = match evd.evar_body with - | Evar_empty -> [< 'fNL >] - | Evar_defined c -> let pc = prterm c in [< 'sTR" => " ; pc; 'fNL >] + | Evar_empty -> (fnl ()) + | Evar_defined c -> let pc = prterm c in (str" => " ++ pc ++ fnl ()) in - h 0 [< pevgl; pb >] + h 0 (pevgl ++ pb) let pr_evd evd = prlist_with_sep pr_fnl (fun (ev,evd) -> let pe = pr_decl evd in - h 0 [< pr_id (id_of_existential ev) ; 'sTR"==" ; pe >]) + h 0 (pr_id (id_of_existential ev) ++ str"==" ++ pe)) (Evd.to_list evd) let pr_decls decls = pr_evd decls let pr_evc evc = let pe = pr_evd evc.sigma in - [< pe >] + (pe) let pr_evars = prlist_with_sep pr_fnl (fun (ev,evd) -> let pegl = pr_evgl_sign evd in - [< pr_id (id_of_existential ev); 'sTR " : "; pegl >]) + (pr_id (id_of_existential ev) ++ str " : " ++ pegl)) (* Print an enumerated list of existential variables *) let rec pr_evars_int i = function - | [] -> [< >] + | [] -> (mt ()) | (ev,evd)::rest -> let pegl = pr_evgl_sign evd in let pei = pr_evars_int (i+1) rest in - [< (hOV 0 [< 'sTR "Existential "; 'iNT i; 'sTR " ="; 'sPC; - pr_id (id_of_existential ev) ; 'sTR " : "; pegl >]); - 'fNL ; pei >] + (hov 0 (str "Existential " ++ int i ++ str " =" ++ spc () ++ + pr_id (id_of_existential ev) ++ str " : " ++ pegl)) ++ + fnl () ++ pei let pr_subgoals_existential sigma = function | [] -> let exl = Evd.non_instantiated sigma in if exl = [] then - [< 'sTR"Subtree proved!" ; 'fNL >] + (str"Subtree proved!" ++ fnl ()) else let pei = pr_evars_int 1 exl in - [< 'sTR "No more subgoals but non-instantiated existential "; - 'sTR "variables :" ;'fNL; (hOV 0 pei) >] + (str "No more subgoals but non-instantiated existential " ++ + str "variables :" ++fnl () ++ (hov 0 pei)) | [g] -> let pg = pr_goal g in - v 0 [< 'sTR ("1 "^"subgoal");'cUT; pg >] + v 0 (str ("1 "^"subgoal") ++cut () ++ pg) | g1::rest -> let rec pr_rec n = function - | [] -> [< >] + | [] -> (mt ()) | g::rest -> let pc = pr_concl n g in let prest = pr_rec (n+1) rest in - [< 'cUT; pc; prest >] + (cut () ++ pc ++ prest) in let pg1 = pr_goal g1 in let prest = pr_rec 2 rest in - v 0 [< 'iNT(List.length rest+1) ; 'sTR" subgoals" ;'cUT; pg1; prest; - 'fNL >] + v 0 (int(List.length rest+1) ++ str" subgoals" ++ cut () + ++ pg1 ++ prest ++ fnl ()) open Ast open Termast @@ -308,7 +308,7 @@ let ast_of_cvt_redexp = function let ast_of_cvt_arg = function | Identifier id -> nvar id | Qualid qid -> ast_of_qualid qid - | Quoted_string s -> str s + | Quoted_string s -> string s | Integer n -> num n | Command c -> ope ("COMMAND",[c]) | Constr c -> @@ -316,8 +316,8 @@ let ast_of_cvt_arg = function | OpenConstr (_,c) -> ope ("COMMAND",[ast_of_constr false (Global.env ()) c]) | Constr_context _ -> - anomalylabstrm "ast_of_cvt_arg" [<'sTR - "Constr_context argument could not be used">] + anomalylabstrm "ast_of_cvt_arg" (str + "Constr_context argument could not be used") | Clause idl -> let transl = function | InHyp id -> ope ("INHYP", [nvar id]) diff --git a/proofs/refiner.ml b/proofs/refiner.ml index a645cf0f0..6806cf2b6 100644 --- a/proofs/refiner.ml +++ b/proofs/refiner.ml @@ -91,7 +91,7 @@ let rec frontier p = p' else errorlabstrm "Refiner.frontier" - [< 'sTR"frontier was handed back a ill-formed proof." >])) + (str"frontier was handed back a ill-formed proof."))) | Some(r,pfl) -> let gll,vl = List.split(List.map frontier pfl) in (List.flatten gll, @@ -131,7 +131,7 @@ let tac_tab = Hashtbl.create 17 let add_tactic s t = if Hashtbl.mem tac_tab s then errorlabstrm ("Refiner.add_tactic: "^s) - [<'sTR "Cannot redeclare a tactic.">]; + (str "Cannot redeclare a tactic."); Hashtbl.add tac_tab s t let overwriting_add_tactic s t = @@ -146,13 +146,13 @@ let lookup_tactic s = Hashtbl.find tac_tab s with Not_found -> errorlabstrm "Refiner.lookup_tactic" - [< 'sTR"The tactic " ; 'sTR s ; 'sTR" is not installed" >] + (str"The tactic " ++ str s ++ str" is not installed") (* refiner r is a tactic applying the rule r *) let bad_subproof () = - anomalylabstrm "Refiner.refiner" [< 'sTR"Bad subproof in validation.">] + anomalylabstrm "Refiner.refiner" (str"Bad subproof in validation.") let check_subproof_connection gl spfl = if not (list_for_all2eq (fun g pf -> g=pf.goal) gl spfl) @@ -290,7 +290,7 @@ let goal_goal_list gls = {it=[gls.it];sigma=gls.sigma} let tclIDTAC gls = (goal_goal_list gls, idtac_valid) (* General failure tactic *) -let tclFAIL_s s gls = errorlabstrm "Refiner.tclFAIL_s" [< 'sTR s>] +let tclFAIL_s s gls = errorlabstrm "Refiner.tclFAIL_s" (str s) (* A special exception for levels for the Fail tactic *) exception FailError of int @@ -308,7 +308,7 @@ let thens_tac tac2l taci (sigr,gs,p) = let (gl,gi) = try list_chop (List.length tac2l) gs with Failure _ -> errorlabstrm "Refiner.combine_tactics" - [<'sTR "Wrong number of tactics.">] in + (str "Wrong number of tactics.") in let tac2gl = List.combine gl tac2l @ list_map_i (fun i g -> (g, taci i)) 1 gi in let gll,pl = @@ -321,14 +321,14 @@ let then_tac tac = thens_tac [] (fun _ -> tac) let non_existent_goal n = errorlabstrm ("No such goal: "^(string_of_int n)) - [< 'sTR"Trying to apply a tactic to a non existent goal" >] + (str"Trying to apply a tactic to a non existent goal") (* Apply tac on the i-th goal (if i>0). If i<0, then start counting from the last goal (i=-1). *) let theni_tac i tac ((_,gl,_) as subgoals) = let nsg = List.length gl in let k = if i < 0 then nsg + i + 1 else i in - if nsg < 1 then errorlabstrm "theni_tac" [< 'sTR"No more subgoals.">] + if nsg < 1 then errorlabstrm "theni_tac" (str"No more subgoals.") else if k >= 1 & k <= nsg then thens_tac [] (fun i -> if i = k then tac else tclIDTAC) subgoals else non_existent_goal k @@ -398,14 +398,14 @@ the goal unchanged *) let tclPROGRESS tac ptree = let rslt = tac ptree in if progress (fst rslt) ptree then rslt - else errorlabstrm "Refiner.PROGRESS" [< 'sTR"Failed to progress.">] + else errorlabstrm "Refiner.PROGRESS" (str"Failed to progress.") (* weak_PROGRESS tac ptree applies tac to the goal ptree and fails if tac leaves the goal unchanged, possibly modifying sigma *) let tclWEAK_PROGRESS tac ptree = let rslt = tac ptree in if weak_progress (fst rslt) ptree then rslt - else errorlabstrm "Refiner.tclWEAK_PROGRESS" [< 'sTR"Failed to progress.">] + else errorlabstrm "Refiner.tclWEAK_PROGRESS" (str"Failed to progress.") (* Same as tclWEAK_PROGRESS but fails also if tactics generates several goals, @@ -415,7 +415,7 @@ let tclNOTSAMEGOAL (tac : tactic) goal = let gls = (fst rslt).it in if List.exists (same_goal goal.it) gls then errorlabstrm "Refiner.tclNOTSAMEGOAL" - [< 'sTR"Tactic generated a subgoal identical to the original goal.">] + (str"Tactic generated a subgoal identical to the original goal.") else rslt @@ -461,7 +461,7 @@ let tclSOLVE tacl = tclFIRST (List.map tclCOMPLETE tacl) let tclDO n t = let rec dorec k = if k < 0 then errorlabstrm "Refiner.tclDO" - [<'sTR"Wrong argument : Do needs a positive integer.">]; + (str"Wrong argument : Do needs a positive integer."); if k = 0 then tclIDTAC else if k = 1 then t else (tclTHEN t (dorec (k-1))) in @@ -660,12 +660,12 @@ let extract_open_pftreestate pts = let extract_pftreestate pts = if pts.tstack <> [] then errorlabstrm "extract_pftreestate" - [< 'sTR"Cannot extract from a proof-tree in which we have descended;" ; - 'sPC; 'sTR"Please ascend to the root" >]; + (str"Cannot extract from a proof-tree in which we have descended;" ++ + spc () ++ str"Please ascend to the root"); let pfterm,subgoals = extract_open_pftreestate pts in if subgoals <> [] then errorlabstrm "extract_proof" - [< 'sTR "Attempt to save an incomplete proof" >]; + (str "Attempt to save an incomplete proof"); let env = Global.env_of_context pts.tpf.goal.evar_hyps in strong whd_betaiotaevar env pts.tpfsigma pfterm (*** @@ -676,7 +676,7 @@ let extract_pftreestate pts = let rec first_unproven pts = let pf = (proof_of_pftreestate pts) in if is_complete_proof pf then - errorlabstrm "first_unproven" [< 'sTR"No unproven subgoals" >]; + errorlabstrm "first_unproven" (str"No unproven subgoals"); if is_leaf_proof pf then pts else @@ -693,7 +693,7 @@ let rec first_unproven pts = let rec last_unproven pts = let pf = proof_of_pftreestate pts in if is_complete_proof pf then - errorlabstrm "last_unproven" [< 'sTR"No unproven subgoals" >]; + errorlabstrm "last_unproven" (str"No unproven subgoals"); if is_leaf_proof pf then pts else @@ -710,17 +710,17 @@ let rec last_unproven pts = let rec nth_unproven n pts = let pf = proof_of_pftreestate pts in if is_complete_proof pf then - errorlabstrm "nth_unproven" [< 'sTR"No unproven subgoals" >]; + errorlabstrm "nth_unproven" (str"No unproven subgoals"); if is_leaf_proof pf then if n = 1 then pts else - errorlabstrm "nth_unproven" [< 'sTR"Not enough unproven subgoals" >] + errorlabstrm "nth_unproven" (str"Not enough unproven subgoals") else let children = children_of_proof pf in let rec process i k = function | [] -> - errorlabstrm "nth_unproven" [< 'sTR"Not enough unproven subgoals" >] + errorlabstrm "nth_unproven" (str"Not enough unproven subgoals") | pf1::rest -> let k1 = nb_unsolved_goals pf1 in if k1 < k then @@ -789,17 +789,17 @@ let pr_tactic (s,l) = let pr_rule = function | Prim r -> pr_prim_rule r - | Tactic texp -> hOV 0 (pr_tactic texp) + | Tactic texp -> hov 0 (pr_tactic texp) | Change_evars -> (* This is internal tactic and cannot be replayed at user-level. Function pr_rule_dot below is used when we want to hide Change_evars *) - [< 'sTR"Evar change" >] + str "Evar change" (* Does not print change of evars *) let pr_rule_dot = function - | Change_evars -> [<>] - | r -> [< pr_rule r; 'sTR"." ; 'fNL >] + | Change_evars -> (mt ()) + | r -> (pr_rule r ++ str"." ++ fnl ()) exception Different @@ -819,69 +819,68 @@ let rec print_proof sigma osign pf = let hyps' = thin_sign osign hyps in match pf.ref with | None -> - hOV 0 [< pr_seq {evar_hyps=hyps'; evar_concl=cl; - evar_body=body} >] + hov 0 (pr_seq {evar_hyps=hyps'; evar_concl=cl; evar_body=body}) | Some(r,spfl) -> - hOV 0 [< hOV 0 (pr_seq {evar_hyps=hyps'; evar_concl=cl; - evar_body=body}); - 'sPC ; 'sTR" BY "; - hOV 0 [< pr_rule r >]; 'fNL ; - 'sTR" "; - hOV 0 (prlist_with_sep pr_fnl (print_proof sigma hyps) spfl) - >] + hov 0 + (hov 0 (pr_seq {evar_hyps=hyps'; evar_concl=cl; evar_body=body}) ++ + spc () ++ str" BY " ++ + hov 0 (pr_rule r) ++ fnl () ++ + str" " ++ + hov 0 (prlist_with_sep pr_fnl (print_proof sigma hyps) spfl) +) -let pr_change gl = [< 'sTR"Change " ; prterm gl.evar_concl ; 'sTR"." ; 'fNL>] +let pr_change gl = (str"Change " ++ prterm gl.evar_concl ++ str"." ++ fnl ()) let rec print_script nochange sigma osign pf = let {evar_hyps=sign; evar_concl=cl} = pf.goal in match pf.ref with | None -> if nochange then - [< 'sTR"<Your Tactic Text here>" >] + (str"<Your Tactic Text here>") else pr_change pf.goal | Some(r,spfl) -> - [< (if nochange then [< >] else (pr_change pf.goal)); - pr_rule_dot r; + ((if nochange then (mt ()) else (pr_change pf.goal)) ++ + pr_rule_dot r ++ prlist_with_sep pr_fnl - (print_script nochange sigma sign) spfl >] + (print_script nochange sigma sign) spfl) let rec print_treescript sigma osign pf = let {evar_hyps=sign; evar_concl=cl} = pf.goal in match pf.ref with - | None -> [< >] + | None -> (mt ()) | Some(r,spfl) -> - [< pr_rule_dot r ; + (pr_rule_dot r ++ let prsub = prlist_with_sep pr_fnl (print_treescript sigma sign) spfl in if List.length spfl > 1 then - [< 'sTR" "; hOV 0 prsub >] + (str" " ++ hov 0 prsub) else prsub - >] +) let rec print_info_script sigma osign pf = let {evar_hyps=sign; evar_concl=cl} = pf.goal in match pf.ref with - | None -> [< >] + | None -> (mt ()) | Some(Change_evars,[spf]) -> print_info_script sigma osign spf | Some(r,spfl) -> - [< pr_rule r ; + (pr_rule r ++ match spfl with | [pf1] -> if pf1.ref = None then - [<'sTR "."; 'fNL >] + (str "." ++ fnl ()) else - [< 'sTR";" ; 'bRK(1,3) ; - print_info_script sigma sign pf1 >] - | _ -> [< 'sTR"." ; 'fNL ; + (str";" ++ brk(1,3) ++ + print_info_script sigma sign pf1) + | _ -> (str"." ++ fnl () ++ prlist_with_sep pr_fnl - (print_info_script sigma sign) spfl >] >] + (print_info_script sigma sign) spfl)) let format_print_info_script sigma osign pf = - hOV 0 (print_info_script sigma osign pf) + hov 0 (print_info_script sigma osign pf) let print_subscript sigma sign pf = if is_tactic_proof pf then @@ -894,10 +893,9 @@ let tclINFO (tac : tactic) gls = begin try let pf = v (List.map leaf (sig_it sgl)) in let sign = (sig_it gls).evar_hyps in - mSGNL(hOV 0 [< 'sTR" == "; - print_subscript - (sig_sig gls) sign pf >]) + msgnl (hov 0 (str" == " ++ + print_subscript (sig_sig gls) sign pf)) with e when catchable_exception e -> - mSGNL(hOV 0 [< 'sTR "Info failed to apply validation" >]) + msgnl (hov 0 (str "Info failed to apply validation")) end; res diff --git a/proofs/tacinterp.ml b/proofs/tacinterp.ml index 56fe36890..08535e641 100644 --- a/proofs/tacinterp.ml +++ b/proofs/tacinterp.ml @@ -37,7 +37,7 @@ open Safe_typing let err_msg_tactic_not_found macro_loc macro = user_err_loc (macro_loc,"macro_expand", - [<'sTR "Tactic macro "; 'sTR macro; 'sPC; 'sTR "not found">]) + (str "Tactic macro " ++ str macro ++ spc () ++ str "not found")) (* Values for interpretation *) type value = @@ -74,24 +74,24 @@ let tactic_of_value vle g = let id_of_Identifier = function | Identifier id -> id | _ -> - anomalylabstrm "id_of_Identifier" [<'sTR "Not an IDENTIFIER tactic_arg">] + anomalylabstrm "id_of_Identifier" (str "Not an IDENTIFIER tactic_arg") (* Gives the constr corresponding to a Constr tactic_arg *) let constr_of_Constr = function | Constr c -> c - | _ -> anomalylabstrm "constr_of_Constr" [<'sTR "Not a Constr tactic_arg">] + | _ -> anomalylabstrm "constr_of_Constr" (str "Not a Constr tactic_arg") (* Gives the constr corresponding to a Constr_context tactic_arg *) let constr_of_Constr_context = function | Constr_context c -> c | _ -> - anomalylabstrm "constr_of_Constr_context" [<'sTR - "Not a Constr_context tactic_arg">] + anomalylabstrm "constr_of_Constr_context" (str + "Not a Constr_context tactic_arg") (* Gives the qualid corresponding to a Qualid tactic_arg *) let qualid_of_Qualid = function | Qualid id -> id - | _ -> anomalylabstrm "qualid_of_Qualid" [<'sTR "Not a Qualid tactic_arg">] + | _ -> anomalylabstrm "qualid_of_Qualid" (str "Not a Qualid tactic_arg") (* Gives identifiers and makes the possible injection constr -> ident *) let make_ids ast = function @@ -100,9 +100,9 @@ let make_ids ast = function (try destVar c with | Invalid_argument "destVar" -> anomalylabstrm "make_ids" - [<'sTR "This term cannot be reduced to an identifier"; 'fNL; - print_ast ast>]) - | _ -> anomalylabstrm "make_ids" [< 'sTR "Not an identifier" >] + (str "This term cannot be reduced to an identifier" ++ fnl () ++ + print_ast ast)) + | _ -> anomalylabstrm "make_ids" (str "Not an identifier") (* Gives Qualid's and makes the possible injection identifier -> qualid *) let make_qid = function @@ -111,8 +111,8 @@ let make_qid = function | VArg (Constr c) -> (match (kind_of_term c) with | Const cst -> VArg (Qualid (qualid_of_sp cst)) - | _ -> anomalylabstrm "make_qid" [< 'sTR "Not a Qualid" >]) - | _ -> anomalylabstrm "make_qid" [< 'sTR "Not a Qualid" >] + | _ -> anomalylabstrm "make_qid" (str "Not a Qualid")) + | _ -> anomalylabstrm "make_qid" (str "Not a Qualid") (* Transforms a named_context into a (string * constr) list *) let make_hyps = List.map (fun (id,_,typ) -> (string_of_id id,body_of_type typ)) @@ -160,10 +160,10 @@ let tacticOut = function if (tag d) = "tactic" then tactic_out d else - anomalylabstrm "tacticOut" [<'sTR "Dynamic tag should be tactic">] + anomalylabstrm "tacticOut" (str "Dynamic tag should be tactic") | ast -> anomalylabstrm "tacticOut" - [<'sTR "Not a Dynamic ast: "; print_ast ast>] + (str "Not a Dynamic ast: " ++ print_ast ast) let valueIn t = Dynamic (dummy_loc,value_in t) let valueOut = function @@ -171,10 +171,10 @@ let valueOut = function if (tag d) = "value" then value_out d else - anomalylabstrm "valueOut" [<'sTR "Dynamic tag should be value">] + anomalylabstrm "valueOut" (str "Dynamic tag should be value") | ast -> anomalylabstrm "valueOut" - [<'sTR "Not a Dynamic ast: "; print_ast ast>] + (str "Not a Dynamic ast: " ++ print_ast ast) let constrIn = constrIn let constrOut = constrOut @@ -192,8 +192,8 @@ let interp_add (ast_typ,interp_fun) = with Failure _ -> errorlabstrm "interp_add" - [<'sTR "Cannot add the interpretation function for "; 'sTR ast_typ; - 'sTR " twice">] + (str "Cannot add the interpretation function for " ++ str ast_typ ++ + str " twice") (* Adds a possible existing interpretation function *) let overwriting_interp_add (ast_typ,interp_fun) = @@ -249,7 +249,7 @@ let _ = (* Unboxes the tactic_arg *) let unvarg = function | VArg a -> a - | _ -> errorlabstrm "unvarg" [<'sTR "Not a tactic argument">] + | _ -> errorlabstrm "unvarg" (str "Not a tactic argument") (* Unboxes VRec *) let unrec = function @@ -259,7 +259,7 @@ let unrec = function (* Unboxes REDEXP *) let unredexp = function | Redexp c -> c - | _ -> errorlabstrm "unredexp" [<'sTR "Not a REDEXP tactic_arg">] + | _ -> errorlabstrm "unredexp" (str "Not a REDEXP tactic_arg") (* Reads the head of Fun *) let read_fun ast = @@ -268,12 +268,12 @@ let read_fun ast = | Nvar(_,s)::tl -> (Some s)::(read_fun_rec tl) | [] -> [] | _ -> - anomalylabstrm "Tacinterp.read_fun_rec" [<'sTR "Fun not well formed">] + anomalylabstrm "Tacinterp.read_fun_rec" (str "Fun not well formed") in match ast with | Node(_,"FUNVAR",l) -> read_fun_rec l | _ -> - anomalylabstrm "Tacinterp.read_fun" [<'sTR "Fun not well formed">] + anomalylabstrm "Tacinterp.read_fun" (str "Fun not well formed") (* Reads the clauses of a Rec *) let rec read_rec_clauses = function @@ -282,7 +282,7 @@ let rec read_rec_clauses = function (name,it,body)::(read_rec_clauses tl) |_ -> anomalylabstrm "Tacinterp.read_rec_clauses" - [<'sTR "Rec not well formed">] + (str "Rec not well formed") (* Associates variables with values and gives the remaining variables and values *) @@ -322,8 +322,8 @@ let give_context ctxt = function let ast_of_command = function | Node(_,"COMMAND",[c]) -> c | ast -> - anomaly_loc (Ast.loc ast, "Tacinterp.ast_of_command",[<'sTR - "Not a COMMAND ast node: "; print_ast ast>]) + anomaly_loc (Ast.loc ast, "Tacinterp.ast_of_command",(str + "Not a COMMAND ast node: " ++ print_ast ast)) (* Reads a pattern *) let read_pattern evc env lfun = function @@ -336,8 +336,8 @@ let read_pattern evc env lfun = function | Node(_,"TERM",[pc]) -> Term (snd (interp_constrpattern_gen evc env lfun (ast_of_command pc))) | ast -> - anomaly_loc (Ast.loc ast, "Tacinterp.read_pattern",[<'sTR - "Not a pattern ast node: "; print_ast ast>]) + anomaly_loc (Ast.loc ast, "Tacinterp.read_pattern",(str + "Not a pattern ast node: " ++ print_ast ast)) (* Reads the hypotheses of a Match Context rule *) let rec read_match_context_hyps evc env lfun = function @@ -348,8 +348,8 @@ let rec read_match_context_hyps evc env lfun = function (Hyp (s,read_pattern evc env lfun mp))::(read_match_context_hyps evc env lfun tl) | ast::tl -> - anomaly_loc (Ast.loc ast, "Tacinterp.read_match_context_hyp",[<'sTR - "Not a MATCHCONTEXTHYP ast node: "; print_ast ast>]) + anomaly_loc (Ast.loc ast, "Tacinterp.read_match_context_hyp",(str + "Not a MATCHCONTEXTHYP ast node: " ++ print_ast ast)) | [] -> [] (* Reads the rules of a Match Context *) @@ -362,8 +362,8 @@ let rec read_match_context_rule evc env lfun = function rl))),read_pattern evc env lfun (List.nth rl 1),List.hd rl))::(read_match_context_rule evc env lfun tl) | ast::tl -> - anomaly_loc (Ast.loc ast, "Tacinterp.read_match_context_rule",[<'sTR - "Not a MATCHCONTEXTRULE ast node: "; print_ast ast>]) + anomaly_loc (Ast.loc ast, "Tacinterp.read_match_context_rule",(str + "Not a MATCHCONTEXTRULE ast node: " ++ print_ast ast)) | [] -> [] (* Reads the rules of a Match *) @@ -374,8 +374,8 @@ let rec read_match_rule evc env lfun = function (Pat ([],read_pattern evc env lfun mp,te))::(read_match_rule evc env lfun tl) | ast::tl -> - anomaly_loc (Ast.loc ast, "Tacinterp.read_match_context_rule",[<'sTR - "Not a MATCHRULE ast node: "; print_ast ast>]) + anomaly_loc (Ast.loc ast, "Tacinterp.read_match_context_rule",(str + "Not a MATCHRULE ast node: " ++ print_ast ast)) | [] -> [] (* For Match Context and Match *) @@ -472,8 +472,8 @@ let get_debug () = !debug (* Interprets any expression *) let rec val_interp ist ast = -(* mSGNL [<print_ast ast>]; *) -(* mSGNL [<print_ast (Termast.ast_of_constr false (Pretty.assumptions_for_print []) c)>] *) +(* mSGNL (print_ast ast); *) +(* mSGNL (print_ast (Termast.ast_of_constr false (Pretty.assumptions_for_print []) c)) *) let value_interp ist = match ast with @@ -574,10 +574,10 @@ let rec val_interp ist ast = VArg (Constr (Pretyping.constr_out t)) else anomaly_loc (Ast.loc ast, "Tacinterp.val_interp", - [<'sTR "Unknown dynamic ast: "; print_ast ast>]) + (str "Unknown dynamic ast: " ++ print_ast ast)) | _ -> anomaly_loc (Ast.loc ast, "Tacinterp.val_interp", - [<'sTR "Unrecognizable ast: "; print_ast ast>]) in + (str "Unrecognizable ast: " ++ print_ast ast)) in if ist.debug = DebugOn then match debug_prompt ist.goalopt ast with | Exit -> VTactic tclIDTAC @@ -601,7 +601,7 @@ and app_interp ist fv largs ast = VFun(olfun@newlfun,lvar,body) | _ -> user_err_loc (Ast.loc ast, "Tacinterp.app_interp", - [<'sTR"Illegal tactic application: "; print_ast ast>]) + (str"Illegal tactic application: " ++ print_ast ast)) (* Interprets recursive expressions *) and rec_interp ist ast = function @@ -626,7 +626,7 @@ and rec_interp ist ast = function end | _ -> anomaly_loc (Ast.loc ast, "Tacinterp.rec_interp", - [<'sTR"Rec not well formed: "; print_ast ast>]) + (str"Rec not well formed: " ++ print_ast ast)) (* Interprets the clauses of a Let *) and let_interp ist ast = function @@ -635,7 +635,7 @@ and let_interp ist ast = function (id,val_interp ist t)::(let_interp ist ast tl) | _ -> anomaly_loc (Ast.loc ast, "Tacinterp.let_interp", - [<'sTR"Let not well formed: "; print_ast ast>]) + (str"Let not well formed: " ++ print_ast ast)) (* Interprets the clauses of a LetCutIn *) and letin_interp ist ast = function @@ -654,7 +654,7 @@ and letin_interp ist ast = function (letin_interp ist ast tl) with | Not_found -> errorlabstrm "Tacinterp.letin_interp" - [< 'sTR "Term or tactic expected" >]) + (str "Term or tactic expected")) | _ -> (try let t = tactic_of_value tac in @@ -671,10 +671,10 @@ and letin_interp ist ast = function with | NotTactic -> delete_proof id; errorlabstrm "Tacinterp.letin_interp" - [< 'sTR "Term or tactic expected" >])) + (str "Term or tactic expected"))) | _ -> anomaly_loc (Ast.loc ast, "Tacinterp.letin_interp", - [<'sTR "LetIn not well formed: "; print_ast ast>]) + (str "LetIn not well formed: " ++ print_ast ast)) (* Interprets the clauses of a LetCut *) and letcut_interp ist ast = function @@ -685,8 +685,8 @@ and letcut_interp ist ast = function and (ndc,ccl) = match ist.goalopt with | None -> - errorlabstrm "Tacinterp.letcut_interp" [< 'sTR - "Do not use Let for toplevel definitions, use Lemma, ... instead" >] + errorlabstrm "Tacinterp.letcut_interp" (str + "Do not use Let for toplevel definitions, use Lemma, ... instead") | Some g -> (pf_hyps g,pf_concl g) in (match tac with | VArg (Constr csr) -> @@ -709,7 +709,7 @@ and letcut_interp ist ast = function (letcut_interp ist ast tl);exat] with | Not_found -> errorlabstrm "Tacinterp.letin_interp" - [< 'sTR "Term or tactic expected" >]) + (str "Term or tactic expected")) | _ -> (try let t = tactic_of_value tac in @@ -730,18 +730,18 @@ and letcut_interp ist ast = function with | NotTactic -> delete_proof id; errorlabstrm "Tacinterp.letcut_interp" - [< 'sTR "Term or tactic expected" >])) + (str "Term or tactic expected"))) | _ -> - anomaly_loc (Ast.loc ast, "Tacinterp.letcut_interp",[<'sTR - "LetCut not well formed: "; print_ast ast>]) + anomaly_loc (Ast.loc ast, "Tacinterp.letcut_interp",(str + "LetCut not well formed: " ++ print_ast ast)) (* Interprets the Match Context expressions *) and match_context_interp ist ast lmr = (* let goal = (match goalopt with | None -> - errorlabstrm "Tacinterp.apply_match_context" [< 'sTR - "No goal available" >] + errorlabstrm "Tacinterp.apply_match_context" (str + "No goal available") | Some g -> g) in*) let rec apply_goal_sub ist goal nocc (id,c) csr mt mhyps hyps = @@ -793,8 +793,8 @@ and match_context_interp ist ast lmr = with | No_match | _ -> apply_match_context ist goal tl)) | _ -> - errorlabstrm "Tacinterp.apply_match_context" [<'sTR - "No matching clauses for Match Context">] in + errorlabstrm "Tacinterp.apply_match_context" (str + "No matching clauses for Match Context") in let app_wo_goal = (fun ist goal -> apply_match_context ist goal @@ -855,8 +855,8 @@ and apply_hyps_context ist mt lgmatch mhyps hyps = (hyp_match::newlhyps) lhyps_rest (Some (nocc + 1)))) end | [] -> - anomalylabstrm "apply_hyps_context_rec" [<'sTR - "Empty list should not occur" >] in + anomalylabstrm "apply_hyps_context_rec" (str + "Empty list should not occur") in apply_hyps_context_rec ist mt [] lgmatch mhyps hyps hyps None (* Interprets a VContext value *) @@ -925,8 +925,8 @@ and match_interp ist ast lmr = with | No_match -> apply_match ist csr tl)) | _ -> - errorlabstrm "Tacinterp.apply_match" [<'sTR - "No matching clauses for Match">] in + errorlabstrm "Tacinterp.apply_match" (str + "No matching clauses for Match") in let csr = constr_of_Constr (unvarg (val_interp ist (List.hd lmr))) and ilr = read_match_rule ist.evc ist.env (constr_list ist.goalopt ist.lfun) (List.tl lmr) in @@ -943,19 +943,19 @@ and tac_interp lfun lmatch debug ast g = goalopt=Some g; debug=debug } in try tactic_of_value (val_interp ist ast) g with | NotTactic -> - errorlabstrm "Tacinterp.tac_interp" [<'sTR - "Must be a command or must give a tactic value">] + errorlabstrm "Tacinterp.tac_interp" (str + "Must be a command or must give a tactic value") -(* errorlabstrm "Tacinterp.tac_interp" [<'sTR - "Interpretation gives a non-tactic value">] *) +(* errorlabstrm "Tacinterp.tac_interp" (str + "Interpretation gives a non-tactic value") *) (* match (val_interp (evc,env,lfun,lmatch,(Some g),debug) ast) with | VTactic tac -> (tac g) | VFTactic (largs,f) -> (f largs g) | VRTactic res -> res | _ -> - errorlabstrm "Tacinterp.tac_interp" [<'sTR - "Interpretation gives a non-tactic value">]*) + errorlabstrm "Tacinterp.tac_interp" (str + "Interpretation gives a non-tactic value")*) (* Interprets a primitive tactic *) and interp_atomic opn args = vernac_tactic(opn,args) @@ -985,8 +985,8 @@ and bind_interp ist = function (val_interp ist (Node(loc,"COMMAND",[c]))))) | x -> - errorlabstrm "bind_interp" [<'sTR "Not the expected form in binding"; - print_ast x>] + errorlabstrm "bind_interp" (str "Not the expected form in binding" ++ + print_ast x) (* Interprets a COMMAND expression (in case of failure, returns Command) *) and com_interp ist com = @@ -1002,8 +1002,8 @@ and com_interp ist com = subst_meta [-1,ic] ctxt with | Not_found -> - errorlabstrm "com_interp" [<'sTR "Unbound context identifier"; - print_ast ast>]) + errorlabstrm "com_interp" (str "Unbound context identifier" ++ + print_ast ast)) | c -> interp_constr ist c None in begin db_constr ist.debug ist.env csr; @@ -1027,14 +1027,14 @@ and cast_com_interp ist com = and ctxt = constr_of_Constr_context (unvarg (List.assoc s ist.lfun)) in begin - wARNING [<'sTR - "Cannot pre-constrain the context expression with goal">]; + warning + "Cannot pre-constrain the context expression with goal"; subst_meta [-1,ic] ctxt end with | Not_found -> - errorlabstrm "cast_com_interp" [<'sTR "Unbound context identifier"; - print_ast ast>]) + errorlabstrm "cast_com_interp" (str "Unbound context identifier" ++ + print_ast ast)) | c -> interp_constr ist c (Some (pf_concl gl)) in begin @@ -1042,7 +1042,7 @@ and cast_com_interp ist com = VArg (Constr csr) end | None -> - errorlabstrm "val_interp" [<'sTR "Cannot cast a constr without goal">] + errorlabstrm "val_interp" (str "Cannot cast a constr without goal") (* Interprets a CASTEDOPENCOMMAND expression *) and cast_opencom_interp ist com = @@ -1060,19 +1060,19 @@ and cast_opencom_interp ist com = and ctxt = constr_of_Constr_context (unvarg (List.assoc s ist.lfun)) in begin - wARNING [<'sTR - "Cannot pre-constrain the context expression with goal">]; + warning + "Cannot pre-constrain the context expression with goal"; VArg (Constr (subst_meta [-1,ic] ctxt)) end with | Not_found -> - errorlabstrm "cast_opencom_interp" [<'sTR "Unbound context identifier"; - print_ast ast>]) + errorlabstrm "cast_opencom_interp" (str "Unbound context identifier" ++ + print_ast ast)) | c -> VArg (OpenConstr (interp_openconstr ist c (Some (pf_concl gl))))) | None -> - errorlabstrm "val_interp" [<'sTR "Cannot cast a constr without goal">] + errorlabstrm "val_interp" (str "Cannot cast a constr without goal") (* Interprets a qualified name. This can be a metavariable to be injected *) and qid_interp ist = function @@ -1080,8 +1080,8 @@ and qid_interp ist = function | Node(loc,"QUALIDMETA",[Num(_,n)]) -> Nametab.qualid_of_sp (destConst(List.assoc n ist.lmatch)) | ast -> - anomaly_loc (Ast.loc ast, "Tacinterp.qid_interp",[<'sTR - "Unrecognizable qualid ast: "; print_ast ast>]) + anomaly_loc (Ast.loc ast, "Tacinterp.qid_interp",(str + "Unrecognizable qualid ast: " ++ print_ast ast)) and cvt_pattern ist = function | Node(_,"PATTERN", Node(loc,"COMMAND",[com])::nums) -> @@ -1136,7 +1136,7 @@ and flag_of_ast ist lf = | Node(_,"Zeta",[])::lf -> add_flag (red_add red fZETA) lf | Node(loc,("Unf"|"UnfBut"),l)::_ -> user_err_loc(loc,"flag_of_ast", - [<'sTR "Delta must be specified just before">]) + (str "Delta must be specified just before")) | arg::_ -> invalid_arg_loc (Ast.loc arg,"flag_of_ast") in @@ -1167,8 +1167,8 @@ and cvt_intro_pattern ist = function ListPat (List.map (cvt_intro_pattern ist) l) | x -> errorlabstrm "cvt_intro_pattern" - [<'sTR "Not the expected form for an introduction pattern!";'fNL; - print_ast x>] + (str "Not the expected form for an introduction pattern!" ++fnl () ++ + print_ast x) (* Interprets a pattern of Let *) and cvt_letpattern ist (o,l) = function @@ -1199,13 +1199,13 @@ let interp = fun ast -> tac_interp [] [] !debug ast let hide_interp = let htac = hide_tactic "Interp" (function [Tacexp t] -> interp t - | _ -> anomalylabstrm "hide_interp" [<'sTR "Not a tactic AST">]) in + | _ -> anomalylabstrm "hide_interp" (str "Not a tactic AST")) in fun ast -> htac [Tacexp ast] (* For bad tactic calls *) let bad_tactic_args s = anomalylabstrm s - [<'sTR "Tactic "; 'sTR s; 'sTR " called with bad arguments">] + (str "Tactic " ++ str s ++ str " called with bad arguments") (* Declaration of the TAC-DEFINITION object *) let (inMD,outMD) = @@ -1227,9 +1227,9 @@ let add_tacdef na vbody = begin if Gmap.mem na !mactab then errorlabstrm "Tacinterp.add_tacdef" - [< 'sTR - "There is already a Meta Definition or a Tactic Definition named "; - pr_id na>]; + (str "There is already a Meta Definition or a Tactic Definition named " + ++ + pr_id na); let _ = Lib.add_leaf na (inMD (na,vbody)) in - Options.if_verbose mSGNL [< pr_id na; 'sTR " is defined" >] + Options.if_verbose msgnl (pr_id na ++ str " is defined") end diff --git a/proofs/tacmach.ml b/proofs/tacmach.ml index 377893fd2..adb4df3d5 100644 --- a/proofs/tacmach.ml +++ b/proofs/tacmach.ml @@ -482,25 +482,25 @@ let pr_com sigma goal com = (Astterm.interp_constr sigma (Evarutil.evar_env goal) com)) let pr_one_binding sigma goal = function - | (Dep id,com) -> [< pr_id id ; 'sTR":=" ; pr_com sigma goal com >] - | (NoDep n,com) -> [< 'iNT n ; 'sTR":=" ; pr_com sigma goal com >] - | (Com,com) -> [< pr_com sigma goal com >] + | (Dep id,com) -> pr_id id ++ str ":=" ++ pr_com sigma goal com + | (NoDep n,com) -> int n ++ str ":=" ++ pr_com sigma goal com + | (Com,com) -> pr_com sigma goal com let pr_bindings sigma goal lb = let prf = pr_one_binding sigma goal in match lb with - | [] -> [< prlist_with_sep pr_spc prf lb >] - | _ -> [<'sTR"with";'sPC;prlist_with_sep pr_spc prf lb >] + | [] -> prlist_with_sep pr_spc prf lb + | _ -> str "with" ++ spc () ++ prlist_with_sep pr_spc prf lb let rec pr_list f = function - | [] -> [<>] - | a::l1 -> [< (f a) ; pr_list f l1>] + | [] -> mt () + | a::l1 -> (f a) ++ pr_list f l1 let pr_gls gls = - hOV 0 [< pr_decls (sig_sig gls) ; 'fNL ; pr_seq (sig_it gls) >] + hov 0 (pr_decls (sig_sig gls) ++ fnl () ++ pr_seq (sig_it gls)) let pr_glls glls = - hOV 0 [< pr_decls (sig_sig glls) ; 'fNL ; - prlist_with_sep pr_fnl pr_seq (sig_it glls) >] - + hov 0 (pr_decls (sig_sig glls) ++ fnl () ++ + prlist_with_sep pr_fnl pr_seq (sig_it glls)) + let pr_tactic = Refiner.pr_tactic diff --git a/proofs/tactic_debug.ml b/proofs/tactic_debug.ml index 08446d011..61ccbcac7 100644 --- a/proofs/tactic_debug.ml +++ b/proofs/tactic_debug.ml @@ -21,26 +21,27 @@ type debug_info = (* Prints the goal if it exists *) let db_pr_goal = function - | None -> mSGNL [< 'sTR "No goal" >] + | None -> + msgnl (str "No goal") | Some g -> - mSGNL [<'sTR ("Goal:"); 'fNL; Proof_trees.pr_goal (Tacmach.sig_it g) >] + msgnl (str "Goal:" ++ fnl () ++ Proof_trees.pr_goal (Tacmach.sig_it g)) (* Prints the commands *) let help () = - mSGNL [< 'sTR "Commands: <Enter>=Continue, h=Help, s=Skip, x=Exit" >] + msgnl (str "Commands: <Enter>=Continue, h=Help, s=Skip, x=Exit") (* Prints the state and waits for an instruction *) let debug_prompt goalopt tac_ast = db_pr_goal goalopt; - mSG [< 'sTR "Going to execute:"; 'fNL; (gentacpr tac_ast); 'fNL >]; -(* 'sTR "Commands: <Enter>=Continue, s=Skip, x=Exit" >];*) -(* mSG [< 'sTR "Going to execute:"; 'fNL; (gentacpr tac_ast); 'fNL; 'fNL; - 'sTR "----<Enter>=Continue----s=Skip----x=Exit----" >];*) + msg (str "Going to execute:" ++ fnl () ++ (gentacpr tac_ast) ++ fnl ()); +(* str "Commands: <Enter>=Continue, s=Skip, x=Exit" >];*) +(* mSG (str "Going to execute:" ++ fnl () ++ (gentacpr tac_ast) ++ fnl () ++ fnl () ++ + str "----<Enter>=Continue----s=Skip----x=Exit----");*) let rec prompt () = - mSG [<'fNL; 'sTR "TcDebug > " >]; + msg (fnl () ++ str "TcDebug > "); flush stdout; let inst = read_line () in -(* mSGNL [<>];*) +(* mSGNL (mt ());*) match inst with | "" -> DebugOn | "s" -> DebugOff @@ -56,15 +57,15 @@ let debug_prompt goalopt tac_ast = (* Prints a constr *) let db_constr debug env c = if debug = DebugOn then - mSGNL [< 'sTR "Evaluated term --> "; prterm_env env c >] + msgnl (str "Evaluated term --> " ++ prterm_env env c) (* Prints a matched hypothesis *) let db_matched_hyp debug env (id,c) = if debug = DebugOn then - mSGNL [< 'sTR "Matched hypothesis --> "; 'sTR (id^": "); - prterm_env env c >] + msgnl (str "Matched hypothesis --> " ++ str (id^": ") ++ + prterm_env env c) (* Prints the matched conclusion *) let db_matched_concl debug env c = if debug = DebugOn then - mSGNL [< 'sTR "Matched goal --> "; prterm_env env c >] + msgnl (str "Matched goal --> " ++ prterm_env env c) diff --git a/tactics/auto.ml b/tactics/auto.ml index a1b251c7a..5c1729108 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -223,8 +223,8 @@ let make_apply_entry env sigma (eapply,verbose) name (c,cty) = in if eapply & (nmiss <> 0) then begin if verbose then - wARN [< 'sTR "the hint: EApply "; prterm c; - 'sTR " will only be used by EAuto" >]; + warn (str "the hint: EApply " ++ prterm c ++ + str " will only be used by EAuto"); (hd, { hname = name; pri = nb_hyp cty + nmiss; @@ -249,7 +249,7 @@ let make_resolves env sigma name eap (c,cty) = [make_exact_entry; make_apply_entry env sigma eap] in if ents = [] then - errorlabstrm "Hint" [< prterm c; 'sPC; 'sTR "cannot be used as a hint" >]; + errorlabstrm "Hint" (prterm c ++ spc () ++ str "cannot be used as a hint"); ents (* used to add an hypothesis to the local hint database *) @@ -306,7 +306,7 @@ let add_extern name pri (patmetas,pat) tacast dbname = match (list_subtract tacmetas patmetas) with | i::_ -> errorlabstrm "add_extern" - [< 'sTR "The meta-variable ?"; 'iNT i; 'sTR" is not bound" >] + (str "The meta-variable ?" ++ int i ++ str" is not bound") | [] -> Lib.add_anonymous_leaf (inAutoHint(dbname, [make_extern name pri pat tacast])) @@ -479,24 +479,24 @@ let _ = (**************************************************************************) let fmt_autotactic = function - | Res_pf (c,clenv) -> [< 'sTR"Apply "; prterm c >] - | ERes_pf (c,clenv) -> [< 'sTR"EApply "; prterm c >] - | Give_exact c -> [< 'sTR"Exact " ; prterm c >] + | Res_pf (c,clenv) -> (str"Apply " ++ prterm c) + | ERes_pf (c,clenv) -> (str"EApply " ++ prterm c) + | Give_exact c -> (str"Exact " ++ prterm c) | Res_pf_THEN_trivial_fail (c,clenv) -> - [< 'sTR"Apply "; prterm c ; 'sTR" ; Trivial" >] - | Unfold_nth c -> [< 'sTR"Unfold " ; pr_global c >] - | Extern coqast -> [< 'sTR "Extern "; gentacpr coqast >] + (str"Apply " ++ prterm c ++ str" ; Trivial") + | Unfold_nth c -> (str"Unfold " ++ pr_global c) + | Extern coqast -> (str "Extern " ++ gentacpr coqast) let fmt_hint v = - [< fmt_autotactic v.code; 'sTR"("; 'iNT v.pri; 'sTR")"; 'sPC >] + (fmt_autotactic v.code ++ str"(" ++ int v.pri ++ str")" ++ spc ()) let fmt_hint_list hintlist = - [< 'sTR " "; hOV 0 (prlist fmt_hint hintlist); 'fNL >] + (str " " ++ hov 0 (prlist fmt_hint hintlist) ++ fnl ()) let fmt_hints_db (name,db,hintlist) = - [< 'sTR "In the database "; 'sTR name; 'sTR ":"; - if hintlist = [] then [< 'sTR " nothing"; 'fNL >] - else [< 'fNL; fmt_hint_list hintlist >] >] + (str "In the database " ++ str name ++ str ":" ++ + if hintlist = [] then (str " nothing" ++ fnl ()) + else (fnl () ++ fmt_hint_list hintlist)) (* Print all hints associated to head c in any database *) let fmt_hint_list_for_head c = @@ -507,16 +507,16 @@ let fmt_hint_list_for_head c = dbs in if valid_dbs = [] then - [<'sTR "No hint declared for :"; pr_ref_label c >] + (str "No hint declared for :" ++ pr_ref_label c) else - hOV 0 - [< 'sTR"For "; pr_ref_label c; 'sTR" -> "; 'fNL; - hOV 0 (prlist fmt_hints_db valid_dbs) >] + hov 0 + (str"For " ++ pr_ref_label c ++ str" -> " ++ fnl () ++ + hov 0 (prlist fmt_hints_db valid_dbs)) let fmt_hint_ref ref = fmt_hint_list_for_head (label_of_ref ref) (* Print all hints associated to head id in any database *) -let print_hint_qid qid = pPNL(fmt_hint_ref (Nametab.global dummy_loc qid)) +let print_hint_qid qid = ppnl(fmt_hint_ref (Nametab.global dummy_loc qid)) let fmt_hint_term cl = try @@ -538,14 +538,14 @@ let fmt_hint_term cl = dbs in if valid_dbs = [] then - [<'sTR "No hint applicable for current goal" >] + (str "No hint applicable for current goal") else - [< 'sTR "Applicable Hints :"; 'fNL; - hOV 0 (prlist fmt_hints_db valid_dbs) >] + (str "Applicable Hints :" ++ fnl () ++ + hov 0 (prlist fmt_hints_db valid_dbs)) with Bound | Match_failure _ | Failure _ -> - [<'sTR "No hint applicable for current goal" >] + (str "No hint applicable for current goal") -let print_hint_term cl = pPNL (fmt_hint_term cl) +let print_hint_term cl = ppnl (fmt_hint_term cl) (* print all hints that apply to the concl of the current goal *) let print_applicable_hint () = @@ -557,9 +557,9 @@ let print_applicable_hint () = let print_hint_db db = Hint_db.iter (fun head hintlist -> - mSG (hOV 0 - [< 'sTR "For "; pr_ref_label head; 'sTR " -> "; - fmt_hint_list hintlist >])) + msg (hov 0 + (str "For " ++ pr_ref_label head ++ str " -> " ++ + fmt_hint_list hintlist))) db let print_hint_db_by_name dbname = @@ -572,7 +572,7 @@ let print_hint_db_by_name dbname = let print_searchtable () = Stringmap.iter (fun name db -> - mSG [< 'sTR "In the database "; 'sTR name; 'fNL >]; + msg (str "In the database " ++ str name ++ fnl ()); print_hint_db db) !searchtable @@ -728,7 +728,7 @@ let decomp_unary_term c gls = if Hipattern.is_conjunction hd then simplest_case c gls else - errorlabstrm "Auto.decomp_unary_term" [<'sTR "not a unary type" >] + errorlabstrm "Auto.decomp_unary_term" (str "not a unary type") let decomp_empty_term c gls = let typc = pf_type_of gls c in @@ -736,7 +736,7 @@ let decomp_empty_term c gls = if Hipattern.is_empty_type hd then simplest_case c gls else - errorlabstrm "Auto.decomp_empty_term" [<'sTR "not an empty type" >] + errorlabstrm "Auto.decomp_empty_term" (str "not an empty type") (* decomp is an natural number giving an indication on decomposition @@ -941,20 +941,20 @@ let cvt_autoArg = function | "UsingTDB" -> [UsingTDB] | "NoAutoArg" -> [] | x -> errorlabstrm "cvt_autoArg" - [< 'sTR "Unexpected argument for Auto!"; 'sTR x >] + (str "Unexpected argument for Auto!" ++ str x) let cvt_autoArgs = list_join_map (function | Quoted_string s -> (cvt_autoArg s) - | _ -> errorlabstrm "cvt_autoArgs" [< 'sTR "String expected" >]) + | _ -> errorlabstrm "cvt_autoArgs" (str "String expected")) let interp_to_add gl = function | Qualid qid -> let _,id = Nametab.repr_qualid qid in (next_ident_away id (pf_ids_of_hyps gl), Declare.constr_of_reference (Nametab.global dummy_loc qid)) - | _ -> errorlabstrm "cvt_autoArgs" [< 'sTR "Qualid expected" >] + | _ -> errorlabstrm "cvt_autoArgs" (str "Qualid expected") let dyn_superauto l g = match l with diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml index c8d1c4370..3216a6065 100644 --- a/tactics/autorewrite.ml +++ b/tactics/autorewrite.ml @@ -44,7 +44,7 @@ let one_base tac_main bas = let lrul = Hashtbl.find_all !rewtab bas in if lrul = [] then errorlabstrm "AutoRewrite" - [<'sTR ("Rewriting base "^(bas)^" does not exist") >] + (str ("Rewriting base "^(bas)^" does not exist")) else tclREPEAT_MAIN (tclPROGRESS (List.fold_left (fun tac (csr,dir,tc) -> tclTHEN tac diff --git a/tactics/dhyp.ml b/tactics/dhyp.ml index 839c63978..10e4230d6 100644 --- a/tactics/dhyp.ml +++ b/tactics/dhyp.ml @@ -77,7 +77,7 @@ hypothesis" is defined in this way: Require DHyp. Hint Destruct Hypothesis less_than_zero (le (S ?) O) 1 - [<:tactic:<Inversion $0>>]. + (:tactic:<Inversion $0>). Then, the tactic is used like this: @@ -91,7 +91,7 @@ hypothesis H. Similarly for the conclusion : -Hint Destruct Conclusion equal_zero (? = ?) 1 [<:tactic:<Reflexivity>>]. +Hint Destruct Conclusion equal_zero (? = ?) 1 (:tactic:<Reflexivity>). Goal (plus O O)=O. DConcl. @@ -101,7 +101,7 @@ The "Discardable" option clears the hypothesis after using it. Require DHyp. Hint Destruct Discardable Hypothesis less_than_zero (le (S ?) O) 1 - [<:tactic:<Inversion $0>>]. + (:tactic:<Inversion $0>). Goal (n:nat)(le (S n) O) -> False. Intros n H. @@ -174,8 +174,8 @@ let add (na,dd) = | Concl p -> p.d_typ in if Nbtermdn.in_dn tactab na then begin - mSGNL [< 'sTR "Warning [Overriding Destructor Entry " ; - 'sTR (string_of_id na) ; 'sTR"]" >]; + msgnl (str "Warning [Overriding Destructor Entry " ++ + str (string_of_id na) ++ str"]"); Nbtermdn.remap tactab na (pat,dd) end else Nbtermdn.add tactab (na,(pat,dd)) @@ -192,8 +192,8 @@ let cache_dd (_,(na,dd)) = add (na,dd) with _ -> anomalylabstrm "Dhyp.add" - [< 'sTR"The code which adds destructor hints broke;"; 'sPC; - 'sTR"this is not supposed to happen" >] + (str"The code which adds destructor hints broke;" ++ spc () ++ + str"this is not supposed to happen") let export_dd x = Some x diff --git a/tactics/eauto.ml b/tactics/eauto.ml index 1e28b23bb..f7076af25 100644 --- a/tactics/eauto.ml +++ b/tactics/eauto.ml @@ -78,7 +78,7 @@ let prolog_tac l n gl = (* let l = List.map (pf_interp_constr gl) lcom in *) try (prolog l n gl) with UserError ("Refiner.tclFIRST",_) -> - errorlabstrm "Prolog.prolog" [< 'sTR "Prolog failed" >] + errorlabstrm "Prolog.prolog" (str "Prolog failed") let vernac_prolog = let uncom = function @@ -218,7 +218,7 @@ module SearchProblem = struct filter_tactics s.tacres (List.map (fun id -> (e_give_exact_constr (mkVar id), - [< 'sTR "Exact"; 'sPC; pr_id id>])) + (str "Exact" ++ spc () ++ pr_id id))) (pf_ids_of_hyps g)) in List.map (fun (res,pp) -> { depth = s.depth; tacres = res; @@ -236,7 +236,7 @@ module SearchProblem = struct { depth = s.depth; tacres = res; last_tactic = pp; dblist = s.dblist; localdb = ldb :: List.tl s.localdb }) - (filter_tactics s.tacres [Tactics.intro,[< 'sTR "Intro" >]]) + (filter_tactics s.tacres [Tactics.intro,(str "Intro")]) in let rec_tacs = let l = @@ -259,8 +259,8 @@ module SearchProblem = struct List.sort compare (assumption_tacs @ intro_tac @ rec_tacs) let pp s = - mSG (hOV 0 [< 'sTR " depth="; 'iNT s.depth; 'sPC; - s.last_tactic; 'sTR "\n" >]) + msg (hov 0 (str " depth=" ++ int s.depth ++ spc () ++ + s.last_tactic ++ str "\n")) end @@ -269,7 +269,7 @@ module Search = Explore.Make(SearchProblem) let make_initial_state n gl dblist localdb = { SearchProblem.depth = n; SearchProblem.tacres = tclIDTAC gl; - SearchProblem.last_tactic = [< >]; + SearchProblem.last_tactic = (mt ()); SearchProblem.dblist = dblist; SearchProblem.localdb = [localdb] } diff --git a/tactics/elim.ml b/tactics/elim.ml index a79186719..1b56914e9 100644 --- a/tactics/elim.ml +++ b/tactics/elim.ml @@ -108,7 +108,7 @@ let inductive_of_qualid gls qid = | Ind ity -> ity | _ -> errorlabstrm "Decompose" - [< Nametab.pr_qualid qid; 'sTR " is not an inductive type" >] + (Nametab.pr_qualid qid ++ str " is not an inductive type") let decompose_these c l gls = let indl = List.map (inductive_of_qualid gls) l in diff --git a/tactics/equality.ml b/tactics/equality.ml index ebb6b165f..aea683dc6 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -217,7 +217,7 @@ let necessary_elimination sort_arity sort = Type_Type else errorlabstrm "necessary_elimination" - [< 'sTR "no primitive equality on proofs" >] + (str "no primitive equality on proofs") | _ -> if is_Set sort_arity then Set_SetorProp @@ -225,7 +225,7 @@ let necessary_elimination sort_arity sort = if is_Type sort_arity then Type_SetorProp else errorlabstrm "necessary_elimination" - [< 'sTR "no primitive equality on proofs" >] + (str "no primitive equality on proofs") let find_eq_pattern aritysort sort = match necessary_elimination aritysort sort with @@ -429,8 +429,8 @@ let construct_discriminator sigma env dirn c sort = CP : changed assert false in a more informative error *) errorlabstrm "Equality.construct_discriminator" - [< 'sTR "Cannot discriminate on inductive constructors with - dependent types" >] in + (str "Cannot discriminate on inductive constructors with + dependent types") in let (mib,mip) = lookup_mind_specif env ind in let arsign,arsort = get_arity env indf in let (true_0,false_0,sort_0) = @@ -473,7 +473,7 @@ let find_eq_data_decompose eqn = else if (is_matching (build_coq_idT_pattern ()) eqn) then (build_coq_idT_data, match_eq (build_coq_idT_pattern ()) eqn) else - errorlabstrm "find_eq_data_decompose" [< >] + errorlabstrm "find_eq_data_decompose" (mt ()) let gen_absurdity id gl = if is_empty_type (clause_type (Some id) gl) @@ -481,7 +481,7 @@ let gen_absurdity id gl = simplest_elim (mkVar id) gl else errorlabstrm "Equality.gen_absurdity" - [< 'sTR "Not the negation of an equality" >] + (str "Not the negation of an equality") (* Precondition: eq is leibniz equality @@ -529,14 +529,14 @@ let discr id gls = let (lbeq,(t,t1,t2)) = try find_eq_data_decompose eqn with e when catchable_exception e -> - errorlabstrm "discr" [<'sTR(string_of_id id); - 'sTR" Not a primitive equality here " >] + errorlabstrm "discr" (str(string_of_id id) ++ + str" Not a primitive equality here ") in let sigma = project gls in let env = pf_env gls in (match find_positions env sigma t1 t2 with | Inr _ -> - errorlabstrm "discr" [< 'sTR" Not a discriminable equality" >] + errorlabstrm "discr" (str" Not a discriminable equality") | Inl (cpath, (_,dirn), _) -> let e = pf_get_new_id (id_of_string "ee") gls in let e_env = push_named_decl (e,None,t) env in @@ -552,8 +552,8 @@ let discr id gls = let not_found_message id = - [<'sTR "The variable"; 'sPC ; 'sTR (string_of_id id) ; 'sPC; - 'sTR" was not found in the current environment" >] + (str "The variable" ++ spc () ++ str (string_of_id id) ++ spc () ++ + str" was not found in the current environment") let onNegatedEquality tac gls = if is_matching (build_coq_not_pattern ()) (pf_concl gls) then @@ -562,7 +562,7 @@ let onNegatedEquality tac gls = (tclTHEN intro (onLastHyp tac)) gls else errorlabstrm "extract_negated_equality_then" - [< 'sTR"The goal should negate an equality">] + (str"The goal should negate an equality") let discrClause = function | None -> onNegatedEquality discr @@ -572,7 +572,7 @@ let discrEverywhere = tclORELSE (Tacticals.tryAllClauses discrClause) (fun gls -> - errorlabstrm "DiscrEverywhere" [< 'sTR" No discriminable equalities" >]) + errorlabstrm "DiscrEverywhere" (str" No discriminable equalities")) let discrConcl gls = discrClause None gls let discrHyp id gls = discrClause (Some id) gls @@ -773,19 +773,19 @@ let inj id gls = try find_eq_data_decompose eqn with e when catchable_exception e -> - errorlabstrm "Inj" [<'sTR(string_of_id id); - 'sTR" Not a primitive equality here " >] + errorlabstrm "Inj" (str(string_of_id id) ++ + str" Not a primitive equality here ") in let sigma = project gls in let env = pf_env gls in match find_positions env sigma t1 t2 with | Inl _ -> errorlabstrm "Inj" - [<'sTR (string_of_id id); - 'sTR" is not a projectable equality but a discriminable one" >] + (str (string_of_id id) ++ + str" is not a projectable equality but a discriminable one") | Inr [] -> errorlabstrm "Equality.inj" - [<'sTR"Nothing to do, it is an equality between convertible terms">] + (str"Nothing to do, it is an equality between convertible terms") | Inr posns -> let e = pf_get_new_id (id_of_string "e") gls in let e_env = push_named_decl (e,None,t) env in @@ -802,7 +802,7 @@ let inj id gls = in if injectors = [] then errorlabstrm "Equality.inj" - [<'sTR "Failed to decompose the equality">]; + (str "Failed to decompose the equality"); tclMAP (fun (injfun,resty) -> let pf = applist(eq.congr (), @@ -816,7 +816,7 @@ let inj id gls = with | UserError("refiner__fail",_) -> errorlabstrm "InjClause" - [< 'sTR (string_of_id id); 'sTR" Not a projectable equality" >] + (str (string_of_id id) ++ str" Not a projectable equality") in ((tclTHENS (cut ty) ([tclIDTAC;refine pf])))) injectors gls @@ -853,7 +853,7 @@ let decompEqThen ntac id gls = refine (mkApp (pf, [| mkVar id |]))]))) gls | Inr [] -> errorlabstrm "Equality.inj" - [<'sTR"Nothing to do, it is an equality between convertible terms">] + (str"Nothing to do, it is an equality between convertible terms") | Inr posns -> (let e = pf_get_new_id (id_of_string "e") gls in let e_env = push_named_decl (e,None,t) env in @@ -870,7 +870,7 @@ let decompEqThen ntac id gls = in if injectors = [] then errorlabstrm "Equality.decompEqThen" - [<'sTR "Discriminate failed to decompose the equality">]; + (str "Discriminate failed to decompose the equality"); ((tclTHEN (tclMAP (fun (injfun,resty) -> let pf = applist(lbeq.congr (), @@ -901,9 +901,9 @@ let dEqHyp_tac = hide_ident_or_numarg_tactic "DEqHyp" dEqHyp let rewrite_msg = function | None -> - [<'sTR "passed term is not a primitive equality">] + (str "passed term is not a primitive equality") | Some id -> - [<'sTR (string_of_id id); 'sTR "does not satisfy preconditions ">] + (str (string_of_id id) ++ str "does not satisfy preconditions ") let swap_equands gls eqn = let (lbeq,(t,e1,e2)) = @@ -939,12 +939,12 @@ let find_elim sort_of_gl lbeq = (match lbeq.rrec with | Some eq_rec -> (eq_rec (), false) | None -> errorlabstrm "find_elim" - [< 'sTR "this type of elimination is not allowed">]) + (str "this type of elimination is not allowed")) | _ (* Type *) -> (match lbeq.rect with | Some eq_rect -> (eq_rect (), true) | None -> errorlabstrm "find_elim" - [< 'sTR "this type of elimination is not allowed">]) + (str "this type of elimination is not allowed")) (* builds a predicate [e:t][H:(lbeq t e t1)](body e) to be used as an argument for equality dependent elimination principle: @@ -971,7 +971,7 @@ let bareRevSubstInConcl lbeq body (t,e1,e2) gls = find_elim (pf_type_of gls (pf_concl gls)) lbeq with e when catchable_exception e -> errorlabstrm "RevSubstIncConcl" - [< 'sTR "this type of substitution is not allowed">] + (str "this type of substitution is not allowed") in let p = if dep then @@ -1024,7 +1024,7 @@ let find_sigma_data_decompose ex = let subst = match_sigma ex (build_coq_existT_pattern ()) in (build_sigma_type (),subst) with PatternMatchingFailure -> - errorlabstrm "find_sigma_data_decompose" [< >]) + errorlabstrm "find_sigma_data_decompose" (mt ())) let decomp_tuple_term env c t = let rec decomprec inner_code ex exty = @@ -1072,7 +1072,7 @@ let substInConcl eqn gls = let substInHyp eqn id gls = let (lbeq,(t,e1,e2)) = (find_eq_data_decompose eqn) in let body = subst_term e1 (clause_type (Some id) gls) in - if not (dependent (mkRel 1) body) then errorlabstrm "SubstInHyp" [<>]; + if not (dependent (mkRel 1) body) then errorlabstrm "SubstInHyp" (mt ()); (tclTHENS (cut_replacing id (subst1 e2 body)) ([tclIDTAC; (tclTHENS (bareRevSubstInConcl lbeq body (t,e1,e2)) @@ -1088,15 +1088,15 @@ let try_rewrite tac gls = tac gls with | UserError ("find_eq_data_decompose",_) -> errorlabstrm - "try_rewrite" [< 'sTR "Not a primitive equality here">] + "try_rewrite" (str "Not a primitive equality here") | UserError ("swap_equamds",_) -> errorlabstrm - "try_rewrite" [< 'sTR "Not a primitive equality here">] + "try_rewrite" (str "Not a primitive equality here") | UserError("find_eq_elim",s) -> errorlabstrm "try_rew" - [<'sTR "This type of elimination is not allowed ">] + (str "This type of elimination is not allowed ") | e when catchable_exception e -> errorlabstrm "try_rewrite" - [< 'sTR "Cannot find a well type generalisation of the goal that"; - 'sTR " makes progress the proof.">] + (str "Cannot find a well type generalisation of the goal that" ++ + str " makes progress the proof.") (* list_int n 0 [] gives the list [1;2;...;n] *) let rec list_int n cmr l = @@ -1202,7 +1202,7 @@ let general_rewrite_in lft2rgt id (c,lb) gls = (match sub_term_with_unif typ_id mbr_eq with | None -> errorlabstrm "general_rewrite_in" - [<'sTR "Nothing to rewrite in: "; pr_id id>] + (str "Nothing to rewrite in: " ++ pr_id id) | Some (l2,nb_occ) -> (tclTHENSI (tclTHEN @@ -1248,7 +1248,7 @@ let rewrite_in lR com id gls = (try let _ = lookup_named id (pf_env gls) in () with Not_found -> - errorlabstrm "rewrite_in" [< 'sTR"No such hypothesis : " ;pr_id id >]); + errorlabstrm "rewrite_in" (str"No such hypothesis : " ++pr_id id)); let c = pf_interp_constr gls com in let eqn = pf_type_of gls c in try @@ -1259,7 +1259,7 @@ let rewrite_in lR com id gls = ([tclIDTAC ; exact_no_check c])) gls with UserError("SubstInHyp",_) -> tclIDTAC gls) with UserError ("find_eq_data_decompose",_)-> - errorlabstrm "rewrite_in" [< 'sTR"No equality here" >] + errorlabstrm "rewrite_in" (str"No equality here") let subst eqn cls gls = match cls with @@ -1459,7 +1459,7 @@ let sub_list lref i_s i_e = else if (i>=i_s) & (i<i_e) then sub_list_rec (l@[List.nth lref i]) (i+1) else - anomalylabstrm "Equality.sub_list" [<'sTR "Out of range">] + anomalylabstrm "Equality.sub_list" (str "Out of range") in sub_list_rec [] i_s @@ -1514,8 +1514,8 @@ type hint_base = let explicit_hint_base gl = function | By_name id -> begin match rules_of_base id with - | [] -> errorlabstrm "autorewrite" [<'sTR ("Base "^(string_of_id id)^ - " does not exist")>] + | [] -> errorlabstrm "autorewrite" (str ("Base "^(string_of_id id)^ + " does not exist")) | lbs -> lbs end | Explicit lbs -> @@ -1569,7 +1569,7 @@ let autorewrite lbases ltacstp opt_step ltacrest opt_rest depth_step gls = let cmd = ref cmod and wrn = ref warn in if !cmd=depth_step then begin - wARNING [<'sTR ((string_of_int cglob)^" rewriting(s) carried out") >]; + msg_warning (str ((string_of_int cglob)^" rewriting(s) carried out")); cmd := 0; wrn := true end; @@ -1686,7 +1686,7 @@ let autorewrite lbases ltacstp opt_step ltacrest opt_rest depth_step gls = in let (gl,lvalid)= let (gl_res,lvalid_res,warn)=iterative_rew 0 0 (0,0,false) [g] [] in - if warn then mSGNL [<>]; + if warn then msgnl (mt ()); (gl_res,lvalid_res) in let validation_fun= @@ -1721,7 +1721,7 @@ let autorewrite lbases ltacstp opt_step ltacrest opt_rest depth_step gls = and int_arg=function | [(Integer n)] -> n | _ -> anomalylabstrm "dyn_autorewrite" - [<'sTR "Bad call of int_arg (not an INTEGER)">] + (str "Bad call of int_arg (not an INTEGER)") and list_args_rest (lstep,evstep) (ostep,evostep) (lrest,evrest) (orest,evorest) (depth,evdepth) = function | [] -> (lstep,ostep,lrest,orest,depth) @@ -1755,13 +1755,13 @@ let autorewrite lbases ltacstp opt_step ltacrest opt_rest depth_step gls = (orest,evorest) (dth,true) tail else errorlabstrm "dyn_autorewrite" - [<'sTR "Depth value lower or equal to 0">]) + (str "Depth value lower or equal to 0")) else anomalylabstrm "dyn_autorewrite" - [<'sTR "Bad call of list_args_rest">] + (str "Bad call of list_args_rest") | _ -> anomalylabstrm "dyn_autorewrite" - [<'sTR "Bad call of list_args_rest">] + (str "Bad call of list_args_rest") and list_args = function | (Redexp (s,lbases))::tail -> if s = "BaseList" then @@ -1774,10 +1774,10 @@ let autorewrite lbases ltacstp opt_step ltacrest opt_rest depth_step gls = ostep (if lrest=[] then None else Some lrest) orest depth) else anomalylabstrm "dyn_autorewrite" - [<'sTR "Bad call of list_args (not a BaseList tagged REDEXP)">] + (str "Bad call of list_args (not a BaseList tagged REDEXP)") | _ -> anomalylabstrm "dyn_autorewrite" - [<'sTR "Bad call of list_args (not a REDEXP)">] + (str "Bad call of list_args (not a REDEXP)") in list_args largs*) diff --git a/tactics/inv.ml b/tactics/inv.ml index 67e92ac8f..d639fcf5e 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -71,7 +71,7 @@ let dest_match_eq gls eqn = pf_matches gls (Coqlib.build_coq_idT_pattern ()) eqn with PatternMatchingFailure -> errorlabstrm "dest_match_eq" - [< 'sTR "no primitive equality here" >])) + (str "no primitive equality here"))) (* Environment management *) let push_rels vars env = @@ -95,7 +95,7 @@ let make_inv_predicate env sigma ind id status concl = | Dep dflt_concl -> if not (dependent (mkVar id) concl) then errorlabstrm "make_inv_predicate" - [< 'sTR "Current goal does not depend on "; pr_id id >]; + (str "Current goal does not depend on " ++ pr_id id); (* We abstract the conclusion of goal with respect to realargs and c to * be concl in order to rewrite and have c also rewritten when the case * will be done *) @@ -335,10 +335,10 @@ let check_no_metas clenv ccl = let metas = List.map (fun n -> Intmap.find n clenv.namenv) (collect_meta_variables ccl) in errorlabstrm "res_case_then" - [< 'sTR ("Cannot find an instantiation for variable"^ - (if List.length metas = 1 then " " else "s ")); + (str ("Cannot find an instantiation for variable"^ + (if List.length metas = 1 then " " else "s ")) ++ prlist_with_sep pr_coma pr_id metas - (* ajouter "in "; prterm ccl mais il faut le bon contexte *) >] + (* ajouter "in " ++ prterm ccl mais il faut le bon contexte *)) let res_case_then gene thin indbinding id status gl = let env = pf_env gl and sigma = project gl in @@ -354,7 +354,7 @@ let res_case_then gene thin indbinding id status gl = try find_rectype env sigma ccl with Induc -> errorlabstrm "res_case_then" - [< 'sTR ("The type of "^(string_of_id id)^" is not inductive") >] in + (str ("The type of "^(string_of_id id)^" is not inductive")) in let (elim_predicate,neqns) = make_inv_predicate env sigma indt id status (pf_concl gl) in let (cut_concl,case_tac) = @@ -382,22 +382,22 @@ let res_case_then gene thin indbinding id status gl = (* Error messages of the inversion tactics *) let not_found_message ids = if List.length ids = 1 then - [<'sTR "the variable"; 'sPC ; 'sTR (string_of_id (List.hd ids)) ; 'sPC; - 'sTR" was not found in the current environment" >] + (str "the variable" ++ spc () ++ str (string_of_id (List.hd ids)) ++ spc () ++ + str" was not found in the current environment") else - [<'sTR "the variables ["; - 'sPC ; prlist (fun id -> [<'sTR (string_of_id id) ; 'sPC >]) ids; - 'sTR" ] were not found in the current environment" >] + (str "the variables [" ++ + spc () ++ prlist (fun id -> (str (string_of_id id) ++ spc ())) ids ++ + str" ] were not found in the current environment") let dep_prop_prop_message id = errorlabstrm "Inv" - [< 'sTR "Inversion on "; pr_id id ; - 'sTR " would needs dependent elimination Prop-Prop" >] + (str "Inversion on " ++ pr_id id ++ + str " would needs dependent elimination Prop-Prop") let not_inductive_here id = errorlabstrm "mind_specif_of_mind" - [< 'sTR "Cannot recognize an inductive predicate in "; pr_id id ; - 'sTR ". If there is one, may be the structure of the arity or of the type of constructors is hidden by constant definitions." >] + (str "Cannot recognize an inductive predicate in " ++ pr_id id ++ + str ". If there is one, may be the structure of the arity or of the type of constructors is hidden by constant definitions.") (* Noms d'errreurs obsolètes ?? *) let wrap_inv_error id = function diff --git a/tactics/leminv.ml b/tactics/leminv.ml index a3bca6d23..bc3e8ca56 100644 --- a/tactics/leminv.ml +++ b/tactics/leminv.ml @@ -37,11 +37,11 @@ open Safe_typing let not_work_message = "tactic fails to build the inversion lemma, may be because the predicate has arguments that depend on other arguments" let no_inductive_inconstr env constr = - [< 'sTR "Cannot recognize an inductive predicate in "; - prterm_env env constr; - 'sTR "."; 'sPC; 'sTR "If there is one, may be the structure of the arity"; - 'sPC; 'sTR "or of the type of constructors"; 'sPC; - 'sTR "is hidden by constant definitions." >] + (str "Cannot recognize an inductive predicate in " ++ + prterm_env env constr ++ + str "." ++ spc () ++ str "If there is one, may be the structure of the arity" ++ + spc () ++ str "or of the type of constructors" ++ spc () ++ + str "is hidden by constant definitions.") (* Inversion stored in lemmas *) @@ -175,9 +175,12 @@ let compute_first_inversion_scheme env sigma ind sort dep_option = let revargs,ownsign = fold_named_context (fun env (id,_,_ as d) (revargs,hyps) -> - if List.mem id ivars then ((mkVar id)::revargs,add_named_decl d hyps) - else (revargs,hyps)) - env ([],[]) in + if List.mem id ivars then + ((mkVar id)::revargs,add_named_decl d hyps) + else + (revargs,hyps)) + env ~init:([],[]) + in let pty = it_mkNamedProd_or_LetIn (mkSort sort) ownsign in let goal = mkArrow i (applist(mkVar p, List.rev revargs)) in (pty,goal) @@ -209,7 +212,7 @@ let inversion_scheme env sigma t sort dep_option inv_op = (ids_of_named_context (named_context invEnv))); (* errorlabstrm "lemma_inversion" - [< 'sTR"Computed inversion goal was not closed in initial signature" >]; + (str"Computed inversion goal was not closed in initial signature"); *) let invSign = named_context invEnv in let pfs = mk_pftreestate (mk_goal invSign invGoal) in @@ -261,9 +264,9 @@ let inversion_lemma_from_goal n na id sort dep_option inv_op = let thin_ids = thin_ids (hyps,fv) in if not(list_subset thin_ids fv) then errorlabstrm "lemma_inversion" - [< 'sTR"Cannot compute lemma inversion when there are" ; 'sPC ; - 'sTR"free variables in the types of an inductive" ; 'sPC ; - 'sTR"which are not free in its instance" >]; *) + (str"Cannot compute lemma inversion when there are" ++ spc () ++ + str"free variables in the types of an inductive" ++ spc () ++ + str"which are not free in its instance"); *) add_inversion_lemma na env sigma t sort dep_option inv_op open Vernacinterp @@ -349,8 +352,8 @@ let lemInv id c gls = *) | UserError (a,b) -> errorlabstrm "LemInv" - [< 'sTR "Cannot refine current goal with the lemma "; - prterm_env (Global.env()) c >] + (str "Cannot refine current goal with the lemma " ++ + prterm_env (Global.env()) c) let useInversionLemma = let gentac = diff --git a/tactics/refine.ml b/tactics/refine.ml index 366611d43..ac1bd4f4f 100644 --- a/tactics/refine.ml +++ b/tactics/refine.ml @@ -68,15 +68,15 @@ and sg_proofs = (term_with_holes option) list (* pour debugger *) let rec pp_th (TH(c,mm,sg)) = - [< 'sTR"TH=[ "; hOV 0 [< prterm c; 'fNL; - (* pp_mm mm; 'fNL; *) - pp_sg sg >] ; 'sTR "]" >] + (str"TH=[ " ++ hov 0 (prterm c ++ fnl () ++ + (* pp_mm mm ++ fnl () ++ *) + pp_sg sg) ++ str "]") and pp_mm l = - hOV 0 (prlist_with_sep (fun _ -> [< 'fNL >]) - (fun (n,c) -> [< 'iNT n; 'sTR" --> "; prterm c >]) l) + hov 0 (prlist_with_sep (fun _ -> (fnl ())) + (fun (n,c) -> (int n ++ str" --> " ++ prterm c)) l) and pp_sg sg = - hOV 0 (prlist_with_sep (fun _ -> [< 'fNL >]) - (function None -> [< 'sTR"None" >] | Some th -> [< pp_th th >]) sg) + hov 0 (prlist_with_sep (fun _ -> (fnl ())) + (function None -> (str"None") | Some th -> (pp_th th)) sg) (* compute_metamap : constr -> 'a evar_map -> term_with_holes * réalise le 2. ci-dessus diff --git a/tactics/setoid_replace.ml b/tactics/setoid_replace.ml index 0f1b749a6..5c6391dc5 100644 --- a/tactics/setoid_replace.ml +++ b/tactics/setoid_replace.ml @@ -156,9 +156,9 @@ let find_theory a = setoid_table_find a with Not_found -> errorlabstrm "Setoid" - [< 'sTR "No Declared Setoid Theory for "; - prterm a; 'fNL; - 'sTR "Use Add Setoid to declare it">] + (str "No Declared Setoid Theory for " ++ + prterm a ++ fnl () ++ + str "Use Add Setoid to declare it") (* Add a Setoid to the database after a type verification. *) @@ -217,7 +217,7 @@ let gen_eq_lem_name = let add_setoid a aeq th = if setoid_table_mem a then errorlabstrm "Add Setoid" - [< 'sTR "A Setoid Theory is already declared for "; prterm a >] + (str "A Setoid Theory is already declared for " ++ prterm a) else let env = Global.env () in if (is_conv env Evd.empty (Typing.type_of env Evd.empty th) (mkApp ((Lazy.force coq_Setoid_Theory), [| a; aeq |]))) @@ -230,7 +230,7 @@ let add_setoid a aeq th = let trans = mkApp ((Lazy.force coq_seq_trans), [|a; aeq; th|]) in let eq_morph = eq_lem_proof env a aeq sym trans in let eq_morph2 = eq_lem2_proof env a aeq sym trans in - Options.if_verbose pPNL [< prterm a;'sTR " is registered as a setoid">]; + Options.if_verbose ppnl (prterm a ++str " is registered as a setoid"); let eq_ext_name = gen_eq_lem_name () in let eq_ext_name2 = gen_eq_lem_name () in let _ = Declare.declare_constant eq_ext_name @@ -251,8 +251,8 @@ let add_setoid a aeq th = profil = [true; true]; arg_types = [a;a]; lem2 = (Some eqmorph2)}))); - Options.if_verbose pPNL [< prterm aeq;'sTR " is registered as a morphism">]) - else errorlabstrm "Add Setoid" [< 'sTR "Not a valid setoid theory" >] + Options.if_verbose ppnl (prterm aeq ++str " is registered as a morphism")) + else errorlabstrm "Add Setoid" (str "Not a valid setoid theory") (* The vernac command "Add Setoid" *) @@ -302,7 +302,7 @@ let gen_lem_name m = match kind_of_term m with | Ind (sp, i) -> add_suffix (basename sp) ((string_of_int i)^"_ext") | Construct ((sp,i),j) -> add_suffix (basename sp) ((string_of_int i)^(string_of_int i)^"_ext") - | _ -> errorlabstrm "New Morphism" [< 'sTR "The term "; prterm m; 'sTR "is not a known name">] + | _ -> errorlabstrm "New Morphism" (str "The term " ++ prterm m ++ str "is not a known name") let gen_lemma_tail m lisset body n = let l = (List.length lisset) in @@ -348,7 +348,7 @@ let gen_compat_lemma env m body larg lisset = let new_morphism m id = if morphism_table_mem m then errorlabstrm "New Morphism" - [< 'sTR "The term "; prterm m; 'sTR " is already declared as a morphism">] + (str "The term " ++ prterm m ++ str " is already declared as a morphism") else let env = Global.env() in let typeofm = (Typing.type_of env Evd.empty m) in @@ -357,10 +357,10 @@ let new_morphism m id = let args = (List.rev argsrev) in if (args=[]) then errorlabstrm "New Morphism" - [< 'sTR "The term "; prterm m; 'sTR " is not a product">] + (str "The term " ++ prterm m ++ str " is not a product") else if (check_is_dependent typ (List.length args)) then errorlabstrm "New Morphism" - [< 'sTR "The term "; prterm m; 'sTR " should not be a dependent product">] + (str "The term " ++ prterm m ++ str " should not be a dependent product") else ( let args_t = (List.map snd args) in let poss = (List.map setoid_table_mem args_t) in @@ -443,7 +443,7 @@ let gen_lem_iff env m mext larg lisset = let add_morphism lem_name (m,profil) = if morphism_table_mem m then errorlabstrm "New Morphism" - [< 'sTR "The term "; prterm m; 'sTR " is already declared as a morpism">] + (str "The term " ++ prterm m ++ str " is already declared as a morpism") else let env = Global.env() in let mext = (current_constant lem_name) in @@ -478,7 +478,7 @@ let add_morphism lem_name (m,profil) = profil = poss; arg_types = args_t; lem2 = None})))); - Options.if_verbose pPNL [< prterm m;'sTR " is registered as a morphism">] + Options.if_verbose ppnl (prterm m ++str " is registered as a morphism") let _ = let current_save = vinterp_map "SaveNamed" in @@ -517,7 +517,7 @@ let _ = with Not_found -> errorlabstrm "New Morphism" - [< 'sTR "The term "; 'sTR(string_of_id s); 'sTR" is not a known name">]) + (str "The term " ++ str(string_of_id s) ++ str" is not a known name")) | _ -> anomaly "NewMorphism") *) @@ -618,7 +618,7 @@ and zapply is_r gl gl_m c1 c2 hyp glll = (match ((kind_of_term gl), gl_m) with | Some xom -> tclTHENS (apply (mkApp (xom, args))) (create_tac_list 0 a al c1 c2 hyp m.arg_types m.profil)) with Not_found -> errorlabstrm "Setoid_replace" - [< 'sTR "The term "; prterm c; 'sTR " has not been declared as a morphism">]) + (str "The term " ++ prterm c ++ str " has not been declared as a morphism")) | ((Prod (_,hh, cc)),(Mimp (hhm, ccm))) -> let al = [|hh; cc|] in let a = [|hhm; ccm|] in @@ -644,9 +644,9 @@ and zapply is_r gl gl_m c1 c2 hyp glll = (match ((kind_of_term gl), gl_m) with | (_, Toreplace) -> (res_tac gl (pf_type_of glll gl) hyp) (* tclORELSE Auto.full_trivial tclIDTAC *) | (_, Tokeep) -> (match hyp with | None -> errorlabstrm "Setoid_replace" - [< 'sTR "No replacable occurence of "; prterm c1; 'sTR " found">] + (str "No replacable occurence of " ++ prterm c1 ++ str " found") | Some _ ->errorlabstrm "Setoid_replace" - [< 'sTR "No rewritable occurence of "; prterm c1; 'sTR " found">]) + (str "No rewritable occurence of " ++ prterm c1 ++ str " found")) | _ -> anomaly ("Bug in Setoid_replace")) glll let setoid_replace c1 c2 hyp gl = diff --git a/tactics/tactics.ml b/tactics/tactics.ml index f820fe5fb..18ec501b8 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -197,13 +197,13 @@ let change_hyp_and_check t env sigma c = if is_conv env sigma t c then t else - errorlabstrm "convert-check-hyp" [< 'sTR "Not convertible" >] + errorlabstrm "convert-check-hyp" (str "Not convertible") let change_concl_and_check t env sigma c = if is_conv_leq env sigma t c then t else - errorlabstrm "convert-check-concl" [< 'sTR "Not convertible" >] + errorlabstrm "convert-check-concl" (str "Not convertible") let change_in_concl t = reduct_in_concl (change_concl_and_check t) let change_in_hyp t = reduct_in_hyp (change_hyp_and_check t) @@ -252,7 +252,7 @@ let dyn_reduce = function let unfold_constr = function | ConstRef sp -> unfold_in_concl [[],Closure.EvalConstRef sp] | VarRef id -> unfold_in_concl [[],Closure.EvalVarRef id] - | _ -> errorlabstrm "unfold_constr" [< 'sTR "Cannot unfold a non-constant.">] + | _ -> errorlabstrm "unfold_constr" (str "Cannot unfold a non-constant.") (*******************************************) (* Introduction tactics *) @@ -323,7 +323,7 @@ let rec intro_gen name_flag move_flag force_flag gl = (intro_gen name_flag move_flag force_flag)) gl) with Redelimination -> errorlabstrm "Intro" - [<'sTR "No product even after head-reduction">] + (str "No product even after head-reduction") else raise e @@ -378,8 +378,8 @@ let rec intros_until s g = ((tclTHEN (reduce (Red true) []) (intros_until s)) g) with Redelimination -> errorlabstrm "Intros" - [<'sTR ("No hypothesis "^(string_of_id s)^" in current goal"); - 'sTR " even after head-reduction" >] + (str ("No hypothesis "^(string_of_id s)^" in current goal") ++ + str " even after head-reduction") let rec intros_until_n_gen red n g = match pf_lookup_index_as_renamed (pf_concl g) n with @@ -390,12 +390,12 @@ let rec intros_until_n_gen red n g = ((tclTHEN (reduce (Red true) []) (intros_until_n_gen red n)) g) with Redelimination -> errorlabstrm "Intros" - [<'sTR ("No "^(string_of_int n)); - 'sTR (match n with 1 -> "st" | 2 -> "nd" | _ -> "th"); - 'sTR " non dependent hypothesis in current goal"; - 'sTR " even after head-reduction" >] + (str ("No "^(string_of_int n)) ++ + str (match n with 1 -> "st" | 2 -> "nd" | _ -> "th") ++ + str " non dependent hypothesis in current goal" ++ + str " even after head-reduction") else - errorlabstrm "Intros" [<'sTR "No such hypothesis in current goal" >] + errorlabstrm "Intros" (str "No such hypothesis in current goal") let intros_until_n = intros_until_n_gen true let intros_until_n_wored = intros_until_n_gen false @@ -666,7 +666,7 @@ let generalize_dep c gl = d::toquant else toquant in - let toq_rev = Sign.fold_named_context_reverse seek [] sign in + let toq_rev = Sign.fold_named_context_reverse seek ~init:[] sign in let qhyps = List.map (fun (id,_,_) -> id) toq_rev in let to_quantify = List.fold_left @@ -752,7 +752,7 @@ let letin_abstract id c (occ_ccl,occ_hyps) gl = (accu, Some hyp) in let (depdecls,marks),_ = - fold_named_context_reverse abstract (([],[]),None) env in + fold_named_context_reverse abstract ~init:(([],[]),None) env in let occ_ccl = if everywhere then Some [] else occ_ccl in let ccl = match occ_ccl with | None -> pf_concl gl @@ -1047,7 +1047,7 @@ let elimination_clause_scheme kONT wc elimclause indclause gl = (match kind_of_term (last_arg (clenv_template elimclause).rebus) with | Meta mv -> mv | _ -> errorlabstrm "elimination_clause" - [< 'sTR "The type of elimination clause is not well-formed" >]) + (str "The type of elimination clause is not well-formed")) in let elimclause' = clenv_fchain indmv elimclause indclause in elim_res_pf kONT elimclause' gl @@ -1351,7 +1351,7 @@ let cook_sign hyp0 indvars env = else Some hyp in - let _ = fold_named_context seek_deps env None in + let _ = fold_named_context seek_deps env ~init:None in (* 2nd phase from R to L: get left hyp of [hyp0] and [lhyps] *) let compute_lstatus lhyp (hyp,_,_ as d) = if hyp = hyp0 then raise (Shunt lhyp); @@ -1362,7 +1362,7 @@ let cook_sign hyp0 indvars env = if List.mem hyp !indhyps then lhyp else (Some hyp) in try - let _ = fold_named_context_reverse compute_lstatus None env in + let _ = fold_named_context_reverse compute_lstatus ~init:None env in anomaly "hyp0 not found" with Shunt lhyp0 -> let statuslists = (!lstatus,List.rev !rstatus) in @@ -1447,7 +1447,7 @@ let induction_from_context isrec style hyp0 gl = (*test suivant sans doute inutile car refait par le letin_tac*) if List.mem hyp0 (ids_of_named_context (Global.named_context())) then errorlabstrm "induction" - [< 'sTR "Cannot generalize a global variable" >]; + (str "Cannot generalize a global variable"); let tmptyp0 = pf_get_hyp_typ gl hyp0 in let env = pf_env gl in let (mind,typ0) = pf_reduce_to_quantified_ind gl tmptyp0 in @@ -1661,7 +1661,7 @@ let andE id gl = (tclTHEN (simplest_elim (mkVar id)) (tclDO 2 intro)) gl else errorlabstrm "andE" - [< 'sTR("Tactic andE expects "^(string_of_id id)^" is a conjunction.")>] + (str("Tactic andE expects "^(string_of_id id)^" is a conjunction.")) let dAnd cls gl = match cls with @@ -1674,7 +1674,7 @@ let orE id gl = (tclTHEN (simplest_elim (mkVar id)) intro) gl else errorlabstrm "orE" - [< 'sTR("Tactic orE expects "^(string_of_id id)^" is a disjunction.")>] + (str("Tactic orE expects "^(string_of_id id)^" is a disjunction.")) let dorE b cls gl = match cls with @@ -1689,8 +1689,8 @@ let impE id gl = [tclIDTAC;apply_term (mkVar id) [mkMeta (new_meta())]]) gl else errorlabstrm "impE" - [< 'sTR("Tactic impE expects "^(string_of_id id)^ - " is a an implication.")>] + (str("Tactic impE expects "^(string_of_id id)^ + " is a an implication.")) let dImp cls gl = match cls with @@ -1748,7 +1748,7 @@ let intros_reflexivity = (tclTHEN intros reflexivity) let dyn_reflexivity = function | [] -> intros_reflexivity | _ -> errorlabstrm "Tactics.reflexivity" - [<'sTR "Tactic applied to bad arguments!">] + (str "Tactic applied to bad arguments!") (* Symmetry tactics *) diff --git a/tactics/tauto.ml4 b/tactics/tauto.ml4 index 7ccca8c75..f8ad93280 100644 --- a/tactics/tauto.ml4 +++ b/tactics/tauto.ml4 @@ -137,7 +137,7 @@ let tauto g = (tclORELSE (tclTHEN reduction_not_iff (interp (tacticIn tauto_main))) (tclTHEN reduction (interp (tacticIn tauto_main))))) g - with UserError _ -> errorlabstrm "tauto" [< 'sTR "Tauto failed" >] + with UserError _ -> errorlabstrm "tauto" [< str "Tauto failed" >] let intuition = tclTHEN init_intros diff --git a/tactics/wcclausenv.ml b/tactics/wcclausenv.ml index a8d53dae9..a233aef2d 100644 --- a/tactics/wcclausenv.ml +++ b/tactics/wcclausenv.ml @@ -63,22 +63,22 @@ let clenv_constrain_with_bindings bl clause = | Dep s -> if List.mem_assoc b t then errorlabstrm "clenv_match_args" - [< 'sTR "The variable "; pr_id s; - 'sTR " occurs more than once in binding" >]; + (str "The variable " ++ pr_id s ++ + str " occurs more than once in binding"); clenv_lookup_name clause s | Nodep n -> let index = if n > 0 then n-1 else nb_indep+n in if List.mem_assoc (Nodep (index+1)) t or List.mem_assoc (Nodep (index-nb_indep)) t then errorlabstrm "clenv_match_args" - [< 'sTR "The position "; 'iNT n ; - 'sTR " occurs more than once in binding" >]; + (str "The position " ++ int n ++ + str " occurs more than once in binding"); (try List.nth ind_mvs index with Failure _ -> errorlabstrm "clenv_constrain_with_bindings" - [< 'sTR"Clause did not have " ; 'iNT n ; 'sTR"-th" ; - 'sTR" unnamed argument" >]) + (str"Clause did not have " ++ int n ++ str"-th" ++ + str" unnamed argument")) | Abs n -> (try if n > 0 then @@ -88,8 +88,8 @@ let clenv_constrain_with_bindings bl clause = else error "clenv_constrain_with_bindings" with Failure _ -> errorlabstrm "clenv_constrain_with_bindings" - [< 'sTR"Clause did not have " ; 'iNT n ; 'sTR"-th" ; - 'sTR" absolute argument" >]) + (str"Clause did not have " ++ int n ++ str"-th" ++ + str" absolute argument")) in let env = Global.env () in let sigma = Evd.empty in diff --git a/toplevel/class.ml b/toplevel/class.ml index 8ffb08c55..d9500b11d 100644 --- a/toplevel/class.ml +++ b/toplevel/class.ml @@ -87,29 +87,29 @@ exception CoercionError of coercion_error_kind let explain_coercion_error g = function | AlreadyExists -> - [< Printer.pr_global g; 'sTR" is already a coercion" >] + (Printer.pr_global g ++ str" is already a coercion") | NotAFunction -> - [< Printer.pr_global g; 'sTR" is not a function" >] + (Printer.pr_global g ++ str" is not a function") | NoSource -> - [< Printer.pr_global g; 'sTR ": cannot find the source class" >] + (Printer.pr_global g ++ str ": cannot find the source class") | NoSourceFunClass -> - [< Printer.pr_global g; 'sTR ": FUNCLASS cannot be a source class" >] + (Printer.pr_global g ++ str ": FUNCLASS cannot be a source class") | NoSourceSortClass -> - [< Printer.pr_global g; 'sTR ": SORTCLASS cannot be a source class" >] + (Printer.pr_global g ++ str ": SORTCLASS cannot be a source class") | NotUniform -> - [< Printer.pr_global g; - 'sTR" does not respect the inheritance uniform condition" >]; + (Printer.pr_global g ++ + str" does not respect the inheritance uniform condition"); | NoTarget -> - [<'sTR"Cannot find the target class" >] + (str"Cannot find the target class") | WrongTarget (clt,cl) -> - [<'sTR"Found target class "; 'sTR(string_of_class cl); - 'sTR " while "; 'sTR(string_of_class clt); - 'sTR " is expected" >] + (str"Found target class " ++ str(string_of_class cl) ++ + str " while " ++ str(string_of_class clt) ++ + str " is expected") | NotAClass ref -> - [< 'sTR "Type of "; Printer.pr_global ref; - 'sTR " does not end with a sort" >] + (str "Type of " ++ Printer.pr_global ref ++ + str " does not end with a sort") | NotEnoughClassArgs cl -> - [< 'sTR"Wrong number of parameters for ";'sTR(string_of_class cl) >] + (str"Wrong number of parameters for " ++str(string_of_class cl)) (* Verifications pour l'ajout d'une classe *) @@ -143,7 +143,7 @@ let try_add_class cl streopt fail_if_exists = declare_class (cl,stre,p) else if fail_if_exists then errorlabstrm "try_add_new_class" - [< 'sTR (string_of_class cl) ; 'sTR " is already a class" >] + (str (string_of_class cl) ++ str " is already a class") (* Coercions *) @@ -178,8 +178,8 @@ let class_of_ref = function | VarRef id -> CL_SECVAR id | ConstructRef _ as c -> errorlabstrm "class_of_ref" - [< 'sTR "Constructors, such as "; Printer.pr_global c; - 'sTR " cannot be used as class" >] + (str "Constructors, such as " ++ Printer.pr_global c ++ + str " cannot be used as class") (* lp est la liste (inverse'e) des arguments de la coercion @@ -242,7 +242,7 @@ let get_strength stre ref cls clt = let error_not_transparent source = errorlabstrm "build_id_coercion" - [< 'sTR ((string_of_class source)^" must be a transparent constant") >] + (str ((string_of_class source)^" must be a transparent constant")) let build_id_coercion idf_opt source = let env = Global.env () in @@ -342,14 +342,14 @@ let try_add_new_coercion_subclass cl stre = let coe_ref = build_id_coercion None cl in try_add_new_coercion_core coe_ref stre (Some cl) None true -let try_add_new_coercion_with_target ref stre source target = +let try_add_new_coercion_with_target ref stre ~source ~target = try_add_new_coercion_core ref stre (Some source) (Some target) false -let try_add_new_identity_coercion id stre source target = +let try_add_new_identity_coercion id stre ~source ~target = let ref = build_id_coercion (Some id) source in try_add_new_coercion_core ref stre (Some source) (Some target) true -let try_add_new_coercion_with_source ref stre source = +let try_add_new_coercion_with_source ref stre ~source = try_add_new_coercion_core ref stre (Some source) None false (* try_add_new_class : global_reference -> strength -> unit *) diff --git a/toplevel/command.ml b/toplevel/command.ml index 400f12fa2..4a517144e 100644 --- a/toplevel/command.ml +++ b/toplevel/command.ml @@ -70,7 +70,7 @@ let red_constant_entry ce = function let declare_global_definition ident ce n local = let sp = declare_constant ident (ConstantEntry ce,n) in if local then - wARNING [< pr_id ident; 'sTR" is declared as a global definition" >]; + msg_warning (pr_id ident ++ str" is declared as a global definition"); if_verbose message ((string_of_id ident) ^ " is defined"); ConstRef sp @@ -85,15 +85,15 @@ let definition_body_red red_option ident (local,n) com comtypeopt = let sp = declare_variable ident (Lib.cwd(), c, n) in if_verbose message ((string_of_id ident) ^ " is defined"); if Pfedit.refining () then - mSGERRNL [< 'sTR"Warning: Local definition "; pr_id ident; - 'sTR" is not visible from current goals" >]; + msgerrnl (str"Warning: Local definition " ++ pr_id ident ++ + str" is not visible from current goals"); VarRef ident end else declare_global_definition ident ce' n true | NotDeclare -> anomalylabstrm "Command.definition_body_red" - [<'sTR "Strength NotDeclare not for Definition, only for Let" >] + (str "Strength NotDeclare not for Definition, only for Let") let definition_body = definition_body_red None @@ -112,8 +112,8 @@ let parameter_def_var ident c = let declare_global_assumption ident c = let sp = parameter_def_var ident c in - wARNING [< pr_id ident; 'sTR" is declared as a parameter"; - 'sTR" because it is at a global level" >]; + msg_warning (pr_id ident ++ str" is declared as a parameter" ++ + str" because it is at a global level"); ConstRef sp let hypothesis_def_var is_refining ident n c = @@ -125,37 +125,37 @@ let hypothesis_def_var is_refining ident n c = let sp = declare_variable ident (Lib.cwd(),SectionLocalAssum t,n) in if_verbose message ((string_of_id ident) ^ " is assumed"); if is_refining then - mSGERRNL [< 'sTR"Warning: Variable "; pr_id ident; - 'sTR" is not visible from current goals" >]; + msgerrnl (str"Warning: Variable " ++ pr_id ident ++ + str" is not visible from current goals"); VarRef ident end else declare_global_assumption ident c | NotDeclare -> anomalylabstrm "Command.hypothesis_def_var" - [<'sTR "Strength NotDeclare not for Variable, only for Let" >] + (str "Strength NotDeclare not for Variable, only for Let") (* 3| Mutual Inductive definitions *) let minductive_message = function | [] -> error "no inductive definition" - | [x] -> [< pr_id x; 'sTR " is defined">] - | l -> hOV 0 [< prlist_with_sep pr_coma pr_id l; - 'sPC; 'sTR "are defined">] + | [x] -> (pr_id x ++ str " is defined") + | l -> hov 0 (prlist_with_sep pr_coma pr_id l ++ + spc () ++ str "are defined") let recursive_message v = match Array.length v with | 0 -> error "no recursive definition" - | 1 -> [< Printer.pr_global v.(0); 'sTR " is recursively defined">] - | _ -> hOV 0 [< prvect_with_sep pr_coma Printer.pr_global v; - 'sPC; 'sTR "are recursively defined">] + | 1 -> (Printer.pr_global v.(0) ++ str " is recursively defined") + | _ -> hov 0 (prvect_with_sep pr_coma Printer.pr_global v ++ + spc () ++ str "are recursively defined") let corecursive_message v = match Array.length v with | 0 -> error "no corecursive definition" - | 1 -> [< Printer.pr_global v.(0); 'sTR " is corecursively defined">] - | _ -> hOV 0 [< prvect_with_sep pr_coma Printer.pr_global v; - 'sPC; 'sTR "are corecursively defined">] + | 1 -> (Printer.pr_global v.(0) ++ str " is corecursively defined") + | _ -> hov 0 (prvect_with_sep pr_coma Printer.pr_global v ++ + spc () ++ str "are corecursively defined") let interp_mutual lparams lnamearconstrs finite = let allnames = @@ -218,7 +218,7 @@ let declare_mutual_with_eliminations mie = let lrecnames = List.map (fun e -> e.mind_entry_typename) mie.mind_entry_inds in let sp = declare_mind mie in - if_verbose pPNL (minductive_message lrecnames); + if_verbose ppnl (minductive_message lrecnames); Indrec.declare_eliminations sp; sp @@ -311,7 +311,7 @@ let build_recursive lnameargsardef = in (* declare the recursive definitions *) let lrefrec = Array.mapi declare namerec in - if_verbose pPNL (recursive_message lrefrec); + if_verbose ppnl (recursive_message lrefrec); (* The others are declared as normal definitions *) let var_subst id = (id, global_reference id) in let _ = @@ -374,7 +374,7 @@ let build_corecursive lnameardef = (ConstRef sp) in let lrefrec = Array.mapi declare namerec in - if_verbose pPNL (corecursive_message lrefrec); + if_verbose ppnl (corecursive_message lrefrec); let var_subst id = (id, global_reference id) in let _ = List.fold_left @@ -394,8 +394,8 @@ let inductive_of_ident qid = match Nametab.global dummy_loc qid with | IndRef ind -> ind | ref -> errorlabstrm "inductive_of_ident" - [< pr_id (id_of_global (Global.env()) ref); - 'sPC; 'sTR "is not an inductive type">] + (pr_id (id_of_global (Global.env()) ref) ++ + spc () ++ str "is not an inductive type") let build_scheme lnamedepindsort = let lrecnames = List.map (fun (f,_,_,_) -> f) lnamedepindsort @@ -419,7 +419,7 @@ let build_scheme lnamedepindsort = ConstRef sp :: lrecref in let lrecref = List.fold_right2 declare listdecl lrecnames [] in - if_verbose pPNL (recursive_message (Array.of_list lrecref)) + if_verbose ppnl (recursive_message (Array.of_list lrecref)) let start_proof_com sopt stre com = let env = Global.env () in @@ -428,7 +428,7 @@ let start_proof_com sopt stre com = | Some id -> (* We check existence here: it's a bit late at Qed time *) if Nametab.exists_cci (Lib.make_path id) then - errorlabstrm "start_proof" [< pr_id id; 'sTR " already exists" >]; + errorlabstrm "start_proof" (pr_id id ++ str " already exists"); id | None -> next_ident_away (id_of_string "Unnamed_thm") diff --git a/toplevel/coqinit.ml b/toplevel/coqinit.ml index 8bd52929e..8ddb5de78 100644 --- a/toplevel/coqinit.ml +++ b/toplevel/coqinit.ml @@ -40,14 +40,14 @@ let load_rcfile() = else () (* Options.if_verbose - mSGNL [< 'sTR ("No .coqrc or .coqrc."^Coq_config.version^ - " found. Skipping rcfile loading.") >] + mSGNL (str ("No .coqrc or .coqrc."^Coq_config.version^ + " found. Skipping rcfile loading.")) *) with e -> - (mSGNL [< 'sTR"Load of rcfile failed." >]; + (msgnl (str"Load of rcfile failed."); raise e) else - Options.if_verbose mSGNL [< 'sTR"Skipping rcfile loading." >] + Options.if_verbose msgnl (str"Skipping rcfile loading.") let add_ml_include s = Mltop.add_ml_dir s diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index 864b2fa2c..3b98ce2f4 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -111,7 +111,7 @@ let usage () = flush stderr ; exit 1 -let warning s = wARNING [< 'sTR s >] +let warning s = msg_warning (str s) let parse_args () = let rec parse = function @@ -198,9 +198,9 @@ let parse_args () = try Stream.empty s; exit 1 with Stream.Failure -> - mSGNL (Errors.explain_exn e); exit 1 + msgnl (Errors.explain_exn e); exit 1 end - | e -> begin mSGNL (Errors.explain_exn e); exit 1 end + | e -> begin msgnl (Errors.explain_exn e); exit 1 end (* To prevent from doing the initialization twice *) @@ -227,7 +227,7 @@ let start () = with e -> flush_all(); if not !batch_mode then message "Error during initialization :"; - mSGNL (Toplevel.print_toplevel_error e); + msgnl (Toplevel.print_toplevel_error e); exit 1 end; if !batch_mode then (flush_all(); Profile.print_profile ();exit 0); diff --git a/toplevel/discharge.ml b/toplevel/discharge.ml index 4c5e21b0a..6a3e135ff 100644 --- a/toplevel/discharge.ml +++ b/toplevel/discharge.ml @@ -149,20 +149,20 @@ let process_inductive osecsp nsecsp oldenv (ids_to_discard,modlist) mib = (* Discharge messages. *) let constant_message id = - Options.if_verbose pPNL [< pr_id id; 'sTR " is discharged." >] + Options.if_verbose ppnl (pr_id id ++ str " is discharged.") let inductive_message inds = Options.if_verbose - pPNL - (hOV 0 + ppnl + (hov 0 (match inds with | [] -> assert false | [ind] -> - [< pr_id ind.mind_entry_typename; 'sTR " is discharged." >] + (pr_id ind.mind_entry_typename ++ str " is discharged.") | l -> - [< prlist_with_sep pr_coma - (fun ind -> pr_id ind.mind_entry_typename) l; - 'sPC; 'sTR "are discharged.">])) + (prlist_with_sep pr_coma + (fun ind -> pr_id ind.mind_entry_typename) l ++ + spc () ++ str "are discharged."))) (* Discharge operations for the various objects of the environment. *) diff --git a/toplevel/errors.ml b/toplevel/errors.ml index 623ebbfbb..da9ae4a4d 100644 --- a/toplevel/errors.ml +++ b/toplevel/errors.ml @@ -18,100 +18,100 @@ open Lexer let print_loc loc = if loc = dummy_loc then - [< 'sTR"<unknown>" >] + (str"<unknown>") else - [< 'iNT (fst loc); 'sTR"-"; 'iNT (snd loc) >] + (int (fst loc) ++ str"-" ++ int (snd loc)) let guill s = "\""^s^"\"" let where s = - if !Options.debug then [< 'sTR"in "; 'sTR s; 'sTR":"; 'sPC >] else [<>] + if !Options.debug then (str"in " ++ str s ++ str":" ++ spc ()) else (mt ()) -let report () = [< 'sTR "."; 'sPC; 'sTR "Please report." >] +let report () = (str "." ++ spc () ++ str "Please report.") (* assumption : explain_sys_exn does NOT end with a 'FNL anymore! *) let rec explain_exn_default = function | Stream.Failure -> - hOV 0 [< 'sTR "Anomaly: Uncaught Stream.Failure." >] + hov 0 (str "Anomaly: Uncaught Stream.Failure.") | Stream.Error txt -> - hOV 0 [< 'sTR "Syntax error: "; 'sTR txt >] + hov 0 (str "Syntax error: " ++ str txt) | Token.Error txt -> - hOV 0 [< 'sTR "Syntax error: "; 'sTR txt >] + hov 0 (str "Syntax error: " ++ str txt) | Sys_error msg -> - hOV 0 [< 'sTR "Error: OS: "; 'sTR msg >] + hov 0 (str "Error: OS: " ++ str msg) | UserError(s,pps) -> - hOV 1 [< 'sTR"Error: "; where s; pps >] + hov 1 (str"Error: " ++ where s ++ pps) | Out_of_memory -> - hOV 0 [< 'sTR "Out of memory" >] + hov 0 (str "Out of memory") | Stack_overflow -> - hOV 0 [< 'sTR "Stack overflow" >] + hov 0 (str "Stack overflow") | Ast.No_match s -> - hOV 0 [< 'sTR "Anomaly: Ast matching error: "; 'sTR s; report () >] + hov 0 (str "Anomaly: Ast matching error: " ++ str s ++ report ()) | Anomaly (s,pps) -> - hOV 1 [< 'sTR "Anomaly: "; where s; pps; report () >] + hov 1 (str "Anomaly: " ++ where s ++ pps ++ report ()) | Match_failure(filename,pos1,pos2) -> - hOV 1 [< 'sTR "Anomaly: Match failure in file "; - 'sTR (guill filename); 'sTR " from char #"; - 'iNT pos1; 'sTR " to #"; 'iNT pos2; - report () >] + hov 1 (str "Anomaly: Match failure in file " ++ + str (guill filename) ++ str " from char #" ++ + int pos1 ++ str " to #" ++ int pos2 ++ + report ()) | Not_found -> - hOV 0 [< 'sTR "Anomaly: Search error"; report () >] + hov 0 (str "Anomaly: Search error" ++ report ()) | Failure s -> - hOV 0 [< 'sTR "Anomaly: Failure "; 'sTR (guill s); report () >] + hov 0 (str "Anomaly: Failure " ++ str (guill s) ++ report ()) | Invalid_argument s -> - hOV 0 [< 'sTR "Anomaly: Invalid argument "; 'sTR (guill s); report () >] + hov 0 (str "Anomaly: Invalid argument " ++ str (guill s) ++ report ()) | Sys.Break -> - hOV 0 [< 'fNL; 'sTR"User Interrupt." >] + hov 0 (fnl () ++ str"User Interrupt.") | Univ.UniverseInconsistency -> - hOV 0 [< 'sTR "Error: Universe Inconsistency." >] + hov 0 (str "Error: Universe Inconsistency.") | TypeError(ctx,te) -> - hOV 0 [< 'sTR "Error:"; 'sPC; Himsg.explain_type_error ctx te >] + hov 0 (str "Error:" ++ spc () ++ Himsg.explain_type_error ctx te) | PretypeError(ctx,te) -> - hOV 0 [< 'sTR "Error:"; 'sPC; Himsg.explain_pretype_error ctx te >] + hov 0 (str "Error:" ++ spc () ++ Himsg.explain_pretype_error ctx te) | InductiveError e -> - hOV 0 [< 'sTR "Error:"; 'sPC; Himsg.explain_inductive_error e >] + hov 0 (str "Error:" ++ spc () ++ Himsg.explain_inductive_error e) | Cases.PatternMatchingError (env,e) -> - hOV 0 - [< 'sTR "Error:"; 'sPC; Himsg.explain_pattern_matching_error env e >] + hov 0 + (str "Error:" ++ spc () ++ Himsg.explain_pattern_matching_error env e) | Logic.RefinerError e -> - hOV 0 [< 'sTR "Error:"; 'sPC; Himsg.explain_refiner_error e >] + hov 0 (str "Error:" ++ spc () ++ Himsg.explain_refiner_error e) | Nametab.GlobalizationError q -> - hOV 0 [< 'sTR "Error:"; 'sPC; - 'sTR "The reference"; 'sPC; Nametab.pr_qualid q; - 'sPC ; 'sTR "was not found"; - 'sPC ; 'sTR "in the current"; 'sPC ; 'sTR "environment" >] + hov 0 (str "Error:" ++ spc () ++ + str "The reference" ++ spc () ++ Nametab.pr_qualid q ++ + spc () ++ str "was not found" ++ + spc () ++ str "in the current" ++ spc () ++ str "environment") | Nametab.GlobalizationConstantError q -> - hOV 0 [< 'sTR "Error:"; 'sPC; - 'sTR "No constant of this name:"; 'sPC; Nametab.pr_qualid q >] + hov 0 (str "Error:" ++ spc () ++ + str "No constant of this name:" ++ spc () ++ Nametab.pr_qualid q) | Tacmach.FailError i -> - hOV 0 [< 'sTR "Error: Fail tactic always fails (level "; - 'iNT i; 'sTR")." >] + hov 0 (str "Error: Fail tactic always fails (level " ++ + int i ++ str").") | Stdpp.Exc_located (loc,exc) -> - hOV 0 [< if loc = Ast.dummy_loc then [<>] - else [< 'sTR"At location "; print_loc loc; 'sTR":"; 'fNL >]; - explain_exn_default exc >] + hov 0 (if loc = Ast.dummy_loc then (mt ()) + else (str"At location " ++ print_loc loc ++ str":" ++ fnl ()) ++ + explain_exn_default exc) | Lexer.Error Illegal_character -> - hOV 0 [< 'sTR "Syntax error: Illegal character." >] + hov 0 (str "Syntax error: Illegal character.") | Lexer.Error Unterminated_comment -> - hOV 0 [< 'sTR "Syntax error: Unterminated comment." >] + hov 0 (str "Syntax error: Unterminated comment.") | Lexer.Error Unterminated_string -> - hOV 0 [< 'sTR "Syntax error: Unterminated string." >] + hov 0 (str "Syntax error: Unterminated string.") | Lexer.Error Undefined_token -> - hOV 0 [< 'sTR "Syntax error: Undefined token." >] + hov 0 (str "Syntax error: Undefined token.") | Lexer.Error (Bad_token s) -> - hOV 0 [< 'sTR "Syntax error: Bad token"; 'sPC; 'sTR s; 'sTR "." >] + hov 0 (str "Syntax error: Bad token" ++ spc () ++ str s ++ str ".") | Assert_failure (s,b,e) -> - hOV 0 [< 'sTR "Anomaly: assert failure"; 'sPC; + hov 0 (str "Anomaly: assert failure" ++ spc () ++ if s <> "" then - [< 'sTR ("(file \"" ^ s ^ "\", characters "); - 'iNT b; 'sTR "-"; 'iNT e; 'sTR ")" >] + (str ("(file \"" ^ s ^ "\", characters ") ++ + int b ++ str "-" ++ int e ++ str ")") else - [< >]; - report () >] + (mt ()) ++ + report ()) | reraise -> - hOV 0 [< 'sTR "Anomaly: Uncaught exception "; - 'sTR (Printexc.to_string reraise); report () >] + hov 0 (str "Anomaly: Uncaught exception " ++ + str (Printexc.to_string reraise) ++ report ()) let raise_if_debug e = if !Options.debug then raise e diff --git a/toplevel/fhimsg.ml b/toplevel/fhimsg.ml index 2f248885b..c5294c0b7 100644 --- a/toplevel/fhimsg.ml +++ b/toplevel/fhimsg.ml @@ -26,13 +26,13 @@ module Make = functor (P : Printer) -> struct let print_decl k env (s,typ) = let ptyp = P.pr_term k env (body_of_type typ) in - [< 'sPC; pr_id s; 'sTR" : "; ptyp >] + (spc () ++ pr_id s ++ str" : " ++ ptyp) let print_binding k env = function | Anonymous,ty -> - [< 'sPC; 'sTR"_" ; 'sTR" : " ; P.pr_term k env (body_of_type ty) >] + (spc () ++ str"_" ++ str" : " ++ P.pr_term k env (body_of_type ty)) | Name id,ty -> - [< 'sPC; pr_id id ; 'sTR" : "; P.pr_term k env (body_of_type ty) >] + (spc () ++ pr_id id ++ str" : " ++ P.pr_term k env (body_of_type ty)) (**** let sign_it_with f sign e = @@ -50,55 +50,55 @@ module Make = functor (P : Printer) -> struct let sign_env = fold_named_context (fun env (id,_,t) pps -> - let pidt = print_decl k env (id,t) in [< pps ; 'fNL ; pidt >]) - env [< >] + let pidt = print_decl k env (id,t) in (pps ++ fnl () ++ pidt)) + env (mt ()) in let db_env = fold_rel_context (fun env (na,_,t) pps -> - let pnat = print_binding k env (na,t) in [< pps ; 'fNL ; pnat >]) - env [< >] + let pnat = print_binding k env (na,t) in (pps ++ fnl () ++ pnat)) + env (mt ()) in - [< sign_env; db_env >] + (sign_env ++ db_env) let pr_ne_ctx header k env = if rel_context env = [] && named_context env = [] then - [< >] + (mt ()) else - [< header; pr_env k env >] + (header ++ pr_env k env) let explain_unbound_rel k ctx n = - let pe = pr_ne_ctx [< 'sTR"in environment" >] k ctx in - [< 'sTR"Unbound reference: "; pe; 'fNL; - 'sTR"The reference "; 'iNT n; 'sTR" is free" >] + let pe = pr_ne_ctx (str"in environment") k ctx in + (str"Unbound reference: " ++ pe ++ fnl () ++ + str"The reference " ++ int n ++ str" is free") let explain_not_type k ctx c = - let pe = pr_ne_ctx [< 'sTR"In environment" >] k ctx in + let pe = pr_ne_ctx (str"In environment") k ctx in let pc = P.pr_term k ctx c in - [< pe; 'cUT; 'sTR "the term"; 'bRK(1,1); pc; 'sPC; - 'sTR"should be typed by Set, Prop or Type." >];; + (pe ++ cut () ++ str "the term" ++ brk(1,1) ++ pc ++ spc () ++ + str"should be typed by Set, Prop or Type.");; let explain_bad_assumption k ctx c = let pc = P.pr_term k ctx c in - [< 'sTR "Cannot declare a variable or hypothesis over the term"; - 'bRK(1,1); pc; 'sPC; 'sTR "because this term is not a type." >];; + (str "Cannot declare a variable or hypothesis over the term" ++ + brk(1,1) ++ pc ++ spc () ++ str "because this term is not a type.");; let explain_reference_variables id = - [< 'sTR "the constant"; 'sPC; pr_id id; 'sPC; - 'sTR "refers to variables which are not in the context" >] + (str "the constant" ++ spc () ++ pr_id id ++ spc () ++ + str "refers to variables which are not in the context") let msg_bad_elimination ctx k = function | Some(ki,kp,explanation) -> let pki = P.pr_term k ctx ki in let pkp = P.pr_term k ctx kp in - (hOV 0 - [< 'fNL; 'sTR "Elimination of an inductive object of sort : "; - pki; 'bRK(1,0); - 'sTR "is not allowed on a predicate in sort : "; pkp ;'fNL; - 'sTR "because"; 'sPC; 'sTR explanation >]) + (hov 0 + (fnl () ++ str "Elimination of an inductive object of sort : " ++ + pki ++ brk(1,0) ++ + str "is not allowed on a predicate in sort : " ++ pkp ++fnl () ++ + str "because" ++ spc () ++ str explanation)) | None -> - [<>] + (mt ()) let explain_elim_arity k ctx ind aritylst c pj okinds = let pi = P.pr_term k ctx ind in @@ -106,58 +106,58 @@ let explain_elim_arity k ctx ind aritylst c pj okinds = let pc = P.pr_term k ctx c in let pp = P.pr_term k ctx pj.uj_val in let ppt = P.pr_term k ctx pj.uj_type in - [< 'sTR "Incorrect elimination of"; 'bRK(1,1); pc; 'sPC; - 'sTR "in the inductive type"; 'bRK(1,1); pi; 'fNL; - 'sTR "The elimination predicate"; 'bRK(1,1); pp; 'sPC; - 'sTR "has type"; 'bRK(1,1); ppt; 'fNL; - 'sTR "It should be one of :"; 'bRK(1,1) ; hOV 0 ppar; 'fNL; - msg_bad_elimination ctx k okinds >] + (str "Incorrect elimination of" ++ brk(1,1) ++ pc ++ spc () ++ + str "in the inductive type" ++ brk(1,1) ++ pi ++ fnl () ++ + str "The elimination predicate" ++ brk(1,1) ++ pp ++ spc () ++ + str "has type" ++ brk(1,1) ++ ppt ++ fnl () ++ + str "It should be one of :" ++ brk(1,1) ++ hov 0 ppar ++ fnl () ++ + msg_bad_elimination ctx k okinds) let explain_case_not_inductive k ctx cj = let pc = P.pr_term k ctx cj.uj_val in let pct = P.pr_term k ctx cj.uj_type in - [< 'sTR "In Cases expression"; 'bRK(1,1); pc; 'sPC; - 'sTR "has type"; 'bRK(1,1); pct; 'sPC; - 'sTR "which is not an inductive definition" >] + (str "In Cases expression" ++ brk(1,1) ++ pc ++ spc () ++ + str "has type" ++ brk(1,1) ++ pct ++ spc () ++ + str "which is not an inductive definition") let explain_number_branches k ctx cj expn = let pc = P.pr_term k ctx cj.uj_val in let pct = P.pr_term k ctx cj.uj_val in - [< 'sTR "Cases on term"; 'bRK(1,1); pc; 'sPC ; - 'sTR "of type"; 'bRK(1,1); pct; 'sPC; - 'sTR "expects "; 'iNT expn; 'sTR " branches" >] + (str "Cases on term" ++ brk(1,1) ++ pc ++ spc () ++ + str "of type" ++ brk(1,1) ++ pct ++ spc () ++ + str "expects " ++ int expn ++ str " branches") let explain_ill_formed_branch k ctx c i actty expty = let pc = P.pr_term k ctx c in let pa = P.pr_term k ctx actty in let pe = P.pr_term k ctx expty in - [< 'sTR "In Cases expression on term"; 'bRK(1,1); pc; - 'sPC; 'sTR "the branch " ; 'iNT (i+1); - 'sTR " has type"; 'bRK(1,1); pa ; 'sPC; - 'sTR "which should be:"; 'bRK(1,1); pe >] + (str "In Cases expression on term" ++ brk(1,1) ++ pc ++ + spc () ++ str "the branch " ++ int (i+1) ++ + str " has type" ++ brk(1,1) ++ pa ++ spc () ++ + str "which should be:" ++ brk(1,1) ++ pe) let explain_generalization k ctx (name,var) c = - let pe = pr_ne_ctx [< 'sTR"in environment" >] k ctx in + let pe = pr_ne_ctx (str"in environment") k ctx in let pv = P.pr_term k ctx (body_of_type var) in let pc = P.pr_term k (push_rel (name,None,var) ctx) c in - [< 'sTR"Illegal generalization: "; pe; 'fNL; - 'sTR"Cannot generalize"; 'bRK(1,1); pv; 'sPC; - 'sTR"over"; 'bRK(1,1); pc; 'sPC; - 'sTR"which should be typed by Set, Prop or Type." >] + (str"Illegal generalization: " ++ pe ++ fnl () ++ + str"Cannot generalize" ++ brk(1,1) ++ pv ++ spc () ++ + str"over" ++ brk(1,1) ++ pc ++ spc () ++ + str"which should be typed by Set, Prop or Type.") let explain_actual_type k ctx c ct pt = - let pe = pr_ne_ctx [< 'sTR"In environment" >] k ctx in + let pe = pr_ne_ctx (str"In environment") k ctx in let pc = P.pr_term k ctx c in let pct = P.pr_term k ctx ct in let pt = P.pr_term k ctx pt in - [< pe; 'fNL; - 'sTR"The term"; 'bRK(1,1); pc ; 'sPC ; - 'sTR"does not have type"; 'bRK(1,1); pt; 'fNL; - 'sTR"Actually, it has type" ; 'bRK(1,1); pct >] + (pe ++ fnl () ++ + str"The term" ++ brk(1,1) ++ pc ++ spc () ++ + str"does not have type" ++ brk(1,1) ++ pt ++ fnl () ++ + str"Actually, it has type" ++ brk(1,1) ++ pct) let explain_cant_apply_bad_type k ctx (n,exptyp,actualtyp) rator randl = let ctx = make_all_name_different ctx in - let pe = pr_ne_ctx [< 'sTR"in environment" >] k ctx in + let pe = pr_ne_ctx (str"in environment") k ctx in let pr = pr_term k ctx rator.uj_val in let prt = pr_term k ctx (body_of_type rator.uj_type) in let term_string = if List.length randl > 1 then "terms" else "term" in @@ -166,20 +166,20 @@ let explain_cant_apply_bad_type k ctx (n,exptyp,actualtyp) rator randl = (fun c -> let pc = pr_term k ctx c.uj_val in let pct = pr_term k ctx (body_of_type c.uj_type) in - hOV 2 [< pc; 'sPC; 'sTR": " ; pct >]) randl + hov 2 (pc ++ spc () ++ str": " ++ pct)) randl in - [< 'sTR"Illegal application (Type Error): "; pe; 'fNL; - 'sTR"The term"; 'bRK(1,1); pr; 'sPC; - 'sTR"of type"; 'bRK(1,1); prt; 'sPC ; - 'sTR("cannot be applied to the "^term_string); 'fNL; - 'sTR" "; v 0 appl; 'fNL; - 'sTR"The ";'iNT n; 'sTR (many^" term of type "); - pr_term k ctx actualtyp; - 'sTR" should be of type "; pr_term k ctx exptyp >] + (str"Illegal application (Type Error): " ++ pe ++ fnl () ++ + str"The term" ++ brk(1,1) ++ pr ++ spc () ++ + str"of type" ++ brk(1,1) ++ prt ++ spc () ++ + str("cannot be applied to the "^term_string) ++ fnl () ++ + str" " ++ v 0 appl ++ fnl () ++ + str"The " ++int n ++ str (many^" term of type ") ++ + pr_term k ctx actualtyp ++ + str" should be of type " ++ pr_term k ctx exptyp) let explain_cant_apply_not_functional k ctx rator randl = let ctx = make_all_name_different ctx in - let pe = pr_ne_ctx [< 'sTR"in environment" >] k ctx in + let pe = pr_ne_ctx (str"in environment") k ctx in let pr = pr_term k ctx rator.uj_val in let prt = pr_term k ctx (body_of_type rator.uj_type) in let term_string = if List.length randl > 1 then "terms" else "term" in @@ -187,13 +187,13 @@ let explain_cant_apply_not_functional k ctx rator randl = (fun c -> let pc = pr_term k ctx c.uj_val in let pct = pr_term k ctx (body_of_type c.uj_type) in - hOV 2 [< pc; 'sPC; 'sTR": " ; pct >]) randl + hov 2 (pc ++ spc () ++ str": " ++ pct)) randl in - [< 'sTR"Illegal application (Non-functional construction): "; pe; 'fNL; - 'sTR"The term"; 'bRK(1,1); pr; 'sPC; - 'sTR"of type"; 'bRK(1,1); prt; 'sPC ; - 'sTR("cannot be applied to the "^term_string); 'fNL; - 'sTR" "; v 0 appl; 'fNL >] + (str"Illegal application (Non-functional construction): " ++ pe ++ fnl () ++ + str"The term" ++ brk(1,1) ++ pr ++ spc () ++ + str"of type" ++ brk(1,1) ++ prt ++ spc () ++ + str("cannot be applied to the "^term_string) ++ fnl () ++ + str" " ++ v 0 appl ++ fnl ()) (* (co)fixpoints *) let explain_ill_formed_rec_body k ctx err names i vdefs = @@ -201,89 +201,89 @@ let explain_ill_formed_rec_body k ctx err names i vdefs = (* Fixpoint guard errors *) | NotEnoughAbstractionInFixBody -> - [< 'sTR "Not enough abstractions in the definition" >] + (str "Not enough abstractions in the definition") | RecursionNotOnInductiveType -> - [< 'sTR "Recursive definition on a non inductive type" >] + (str "Recursive definition on a non inductive type") | RecursionOnIllegalTerm -> - [< 'sTR "Recursive call applied to an illegal term" >] + (str "Recursive call applied to an illegal term") | NotEnoughArgumentsForFixCall -> - [< 'sTR "Not enough arguments for the recursive call" >] + (str "Not enough arguments for the recursive call") (* CoFixpoint guard errors *) (* TODO : récupérer le contexte des termes pour pouvoir les afficher *) | CodomainNotInductiveType c -> - [< 'sTR "The codomain is"; 'sPC; P.pr_term k ctx c; 'sPC; - 'sTR "which should be a coinductive type" >] + (str "The codomain is" ++ spc () ++ P.pr_term k ctx c ++ spc () ++ + str "which should be a coinductive type") | NestedRecursiveOccurrences -> - [< 'sTR "Nested recursive occurrences" >] + (str "Nested recursive occurrences") | UnguardedRecursiveCall c -> - [< 'sTR "Unguarded recursive call" >] + (str "Unguarded recursive call") | RecCallInTypeOfAbstraction c -> - [< 'sTR "Not allowed recursive call in the domain of an abstraction" >] + (str "Not allowed recursive call in the domain of an abstraction") | RecCallInNonRecArgOfConstructor c -> - [< 'sTR "Not allowed recursive call in a non-recursive argument of constructor" >] + (str "Not allowed recursive call in a non-recursive argument of constructor") | RecCallInTypeOfDef c -> - [< 'sTR "Not allowed recursive call in the type of a recursive definition" >] + (str "Not allowed recursive call in the type of a recursive definition") | RecCallInCaseFun c -> - [< 'sTR "Not allowed recursive call in a branch of cases" >] + (str "Not allowed recursive call in a branch of cases") | RecCallInCaseArg c -> - [< 'sTR "Not allowed recursive call in the argument of cases" >] + (str "Not allowed recursive call in the argument of cases") | RecCallInCasePred c -> - [< 'sTR "Not allowed recursive call in the type of cases in" >] + (str "Not allowed recursive call in the type of cases in") | NotGuardedForm -> - [< 'sTR "Definition not in guarded form" >] + (str "Definition not in guarded form") in let pvd = P.pr_term k ctx vdefs.(i) in let s = match names.(i) with Name id -> string_of_id id | Anonymous -> "_" in - [< str; 'fNL; 'sTR"The "; - if Array.length vdefs = 1 then [<>] else [<'iNT (i+1); 'sTR "-th ">]; - 'sTR"recursive definition"; 'sPC; 'sTR s; - 'sPC ; 'sTR":="; 'sPC ; pvd; 'sPC; - 'sTR "is not well-formed" >] + (str ++ fnl () ++ str"The " ++ + if Array.length vdefs = 1 then (mt ()) else (int (i+1) ++ str "-th ") ++ + str"recursive definition" ++ spc () ++ str s ++ + spc () ++ str":=" ++ spc () ++ pvd ++ spc () ++ + str "is not well-formed") let explain_ill_typed_rec_body k ctx i lna vdefj vargs = let pvd = P.pr_term k ctx (vdefj.(i)).uj_val in let pvdt = P.pr_term k ctx (body_of_type (vdefj.(i)).uj_type) in let pv = P.pr_term k ctx (body_of_type vargs.(i)) in - [< 'sTR"The " ; - if Array.length vdefj = 1 then [<>] else [<'iNT (i+1); 'sTR "-th">]; - 'sTR"recursive definition" ; 'sPC; pvd; 'sPC; - 'sTR "has type"; 'sPC; pvdt;'sPC; 'sTR "it should be"; 'sPC; pv >] + (str"The " ++ + if Array.length vdefj = 1 then (mt ()) else (int (i+1) ++ str "-th") ++ + str"recursive definition" ++ spc () ++ pvd ++ spc () ++ + str "has type" ++ spc () ++ pvdt ++spc () ++ str "it should be" ++ spc () ++ pv) let explain_not_inductive k ctx c = let pc = P.pr_term k ctx c in - [< 'sTR"The term"; 'bRK(1,1); pc; 'sPC; - 'sTR "is not an inductive definition" >] + (str"The term" ++ brk(1,1) ++ pc ++ spc () ++ + str "is not an inductive definition") let explain_ml_case k ctx mes c ct br brt = let pc = P.pr_term k ctx c in let pct = P.pr_term k ctx ct in let expln = match mes with - | "Inductive" -> [< pct; 'sTR "is not an inductive definition">] - | "Predicate" -> [< 'sTR "ML case not allowed on a predicate">] - | "Absurd" -> [< 'sTR "Ill-formed case expression on an empty type" >] + | "Inductive" -> (pct ++ str "is not an inductive definition") + | "Predicate" -> (str "ML case not allowed on a predicate") + | "Absurd" -> (str "Ill-formed case expression on an empty type") | "Decomp" -> let plf = P.pr_term k ctx br in let pft = P.pr_term k ctx brt in - [< 'sTR "The branch "; plf; 'wS 1; 'cUT; 'sTR "has type "; pft; - 'wS 1; 'cUT; - 'sTR "does not correspond to the inductive definition" >] + (str "The branch " ++ plf ++ 'wS 1 ++ cut () ++ str "has type " ++ pft ++ + 'wS 1 ++ cut () ++ + str "does not correspond to the inductive definition") | "Dependent" -> - [< 'sTR "ML case not allowed for a dependent case elimination">] - | _ -> [<>] + (str "ML case not allowed for a dependent case elimination") + | _ -> (mt ()) in - hOV 0 [< 'sTR "In ML case expression on "; pc; 'wS 1; 'cUT ; - 'sTR "of type"; 'wS 1; pct; 'wS 1; 'cUT; - 'sTR "which is an inductive predicate."; 'fNL; expln >] + hov 0 (str "In ML case expression on " ++ pc ++ 'wS 1 ++ cut () ++ + str "of type" ++ 'wS 1 ++ pct ++ 'wS 1 ++ cut () ++ + str "which is an inductive predicate." ++ fnl () ++ expln) (* let explain_cant_find_case_type loc k ctx c = let pe = P.pr_term k ctx c in Ast.user_err_loc (loc,"pretype", - hOV 3 [<'sTR "Cannot infer type of whole Case expression on"; - 'wS 1; pe >]) + hov 3 (str "Cannot infer type of whole Case expression on" ++ + 'wS 1 ++ pe)) *) let explain_type_error k ctx = function | UnboundRel n -> @@ -321,41 +321,41 @@ let explain_type_error k ctx = function explain_ml_case k ctx mes c ct br brt *) | _ -> - [< 'sTR "Unknown type error (TODO)" >] + (str "Unknown type error (TODO)") let explain_refiner_bad_type k ctx arg ty conclty = errorlabstrm "Logic.conv_leq_goal" - [< 'sTR"refiner was given an argument"; 'bRK(1,1); - P.pr_term k ctx arg; 'sPC; - 'sTR"of type"; 'bRK(1,1); P.pr_term k ctx ty; 'sPC; - 'sTR"instead of"; 'bRK(1,1); P.pr_term k ctx conclty >] + (str"refiner was given an argument" ++ brk(1,1) ++ + P.pr_term k ctx arg ++ spc () ++ + str"of type" ++ brk(1,1) ++ P.pr_term k ctx ty ++ spc () ++ + str"instead of" ++ brk(1,1) ++ P.pr_term k ctx conclty) let explain_refiner_occur_meta k ctx t = errorlabstrm "Logic.mk_refgoals" - [< 'sTR"cannot refine with term"; 'bRK(1,1); P.pr_term k ctx t; - 'sPC; 'sTR"because there are metavariables, and it is"; - 'sPC; 'sTR"neither an application nor a Case" >] + (str"cannot refine with term" ++ brk(1,1) ++ P.pr_term k ctx t ++ + spc () ++ str"because there are metavariables, and it is" ++ + spc () ++ str"neither an application nor a Case") let explain_refiner_cannot_applt k ctx t harg = errorlabstrm "Logic.mkARGGOALS" - [< 'sTR"in refiner, a term of type "; 'bRK(1,1); - P.pr_term k ctx t; 'sPC; 'sTR"could not be applied to"; 'bRK(1,1); - P.pr_term k ctx harg >] + (str"in refiner, a term of type " ++ brk(1,1) ++ + P.pr_term k ctx t ++ spc () ++ str"could not be applied to" ++ brk(1,1) ++ + P.pr_term k ctx harg) let explain_occur_check k ctx ev rhs = let id = "?" ^ string_of_int ev in let pt = P.pr_term k ctx rhs in errorlabstrm "Trad.occur_check" - [< 'sTR"Occur check failed: tried to define "; 'sTR id; - 'sTR" with term"; 'bRK(1,1); pt >] + (str"Occur check failed: tried to define " ++ str id ++ + str" with term" ++ brk(1,1) ++ pt) let explain_not_clean k ctx sp t = let c = mkRel (Intset.choose (free_rels t)) in let id = string_of_id (Names.basename sp) in let var = P.pr_term k ctx c in errorlabstrm "Trad.not_clean" - [< 'sTR"Tried to define "; 'sTR id; - 'sTR" with a term using variable "; var; 'sPC; - 'sTR"which is not in its scope." >] + (str"Tried to define " ++ str id ++ + str" with a term using variable " ++ var ++ spc () ++ + str"which is not in its scope.") end diff --git a/toplevel/himsg.ml b/toplevel/himsg.ml index 678ad6431..4af71a587 100644 --- a/toplevel/himsg.ml +++ b/toplevel/himsg.ml @@ -31,34 +31,34 @@ let guill s = "\""^s^"\"" let explain_unbound_rel ctx n = let ctx = make_all_name_different ctx in - let pe = pr_ne_context_of [< 'sTR "In environment" >] ctx in - [< 'sTR"Unbound reference: "; pe; - 'sTR"The reference "; 'iNT n; 'sTR" is free" >] + let pe = pr_ne_context_of (str "In environment") ctx in + str"Unbound reference: " ++ pe ++ + str"The reference " ++ int n ++ str " is free" let explain_unbound_var ctx v = let var = pr_id v in - [< 'sTR"No such section variable or assumption : "; var >] + str"No such section variable or assumption : " ++ var let explain_not_type ctx j = let ctx = make_all_name_different ctx in - let pe = pr_ne_context_of [< 'sTR"In environment" >] ctx in + let pe = pr_ne_context_of (str"In environment") ctx in let pc,pt = prjudge_env ctx j in - [< pe; 'sTR "the term"; 'bRK(1,1); pc; 'sPC; - 'sTR"has type"; 'sPC; pt; 'sPC; - 'sTR"which should be Set, Prop or Type." >];; + pe ++ str "the term" ++ brk(1,1) ++ pc ++ spc () ++ + str"has type" ++ spc () ++ pt ++ spc () ++ + str"which should be Set, Prop or Type." let explain_bad_assumption ctx j = let ctx = make_all_name_different ctx in - let pe = pr_ne_context_of [< 'sTR"In environment" >] ctx in + let pe = pr_ne_context_of (str"In environment") ctx in let pc,pt = prjudge_env ctx j in - [< pe; 'sTR "cannot declare a variable or hypothesis over the term"; - 'bRK(1,1); pc; 'sPC; 'sTR"of type"; 'sPC; pt; 'sPC; - 'sTR "because this term is not a type." >];; + pe ++ str "cannot declare a variable or hypothesis over the term" ++ + brk(1,1) ++ pc ++ spc () ++ str"of type" ++ spc () ++ pt ++ spc () ++ + str "because this term is not a type." let explain_reference_variables c = let pc = prterm c in - [< 'sTR "the constant"; 'sPC; pc; 'sPC; - 'sTR "refers to variables which are not in the context" >] + str "the constant" ++ spc () ++ pc ++ spc () ++ + str "refers to variables which are not in the context" let explain_elim_arity ctx ind aritylst c pj okinds = let pi = pr_inductive ctx ind in @@ -77,68 +77,69 @@ let explain_elim_arity ctx ind aritylst c pj okinds = "strong elimination on non-small inductive types leads to paradoxes." | WrongArity -> "wrong arity" in - (hOV 0 - [< 'fNL; 'sTR "Elimination of an inductive object of sort : "; - pki; 'bRK(1,0); - 'sTR "is not allowed on a predicate in sort : "; pkp ;'fNL; - 'sTR "because"; 'sPC; 'sTR explanation >]) + (hov 0 + (fnl () ++ str "Elimination of an inductive object of sort : " ++ + pki ++ brk(1,0) ++ + str "is not allowed on a predicate in sort : " ++ pkp ++fnl () ++ + str "because" ++ spc () ++ str explanation)) | None -> - [<>] + mt () in - [< 'sTR "Incorrect elimination of"; 'bRK(1,1); pc; 'sPC; - 'sTR "in the inductive type"; 'bRK(1,1); pi; 'fNL; - 'sTR "The elimination predicate"; 'bRK(1,1); pp; 'sPC; - 'sTR "has type"; 'bRK(1,1); ppt; 'fNL; - 'sTR "It should be one of :"; 'bRK(1,1) ; hOV 0 ppar; 'fNL; - msg >] + str "Incorrect elimination of" ++ brk(1,1) ++ pc ++ spc () ++ + str "in the inductive type" ++ brk(1,1) ++ pi ++ fnl () ++ + str "The elimination predicate" ++ brk(1,1) ++ pp ++ spc () ++ + str "has type" ++ brk(1,1) ++ ppt ++ fnl () ++ + str "It should be one of :" ++ brk(1,1) ++ hov 0 ppar ++ fnl () ++ + msg let explain_case_not_inductive ctx cj = let pc = prterm_env ctx cj.uj_val in let pct = prterm_env ctx cj.uj_type in - [< 'sTR "In Cases expression, the matched term"; 'bRK(1,1); pc; 'sPC; - 'sTR "has type"; 'bRK(1,1); pct; 'sPC; - 'sTR "which is not a (co-)inductive type" >] + str "In Cases expression, the matched term" ++ brk(1,1) ++ pc ++ spc () ++ + str "has type" ++ brk(1,1) ++ pct ++ spc () ++ + str "which is not a (co-)inductive type" let explain_number_branches ctx cj expn = let pc = prterm_env ctx cj.uj_val in let pct = prterm_env ctx cj.uj_type in - [< 'sTR "Cases on term"; 'bRK(1,1); pc; 'sPC ; - 'sTR "of type"; 'bRK(1,1); pct; 'sPC; - 'sTR "expects "; 'iNT expn; 'sTR " branches" >] + str "Cases on term" ++ brk(1,1) ++ pc ++ spc () ++ + str "of type" ++ brk(1,1) ++ pct ++ spc () ++ + str "expects " ++ int expn ++ str " branches" let explain_ill_formed_branch ctx c i actty expty = let pc = prterm_env ctx c in let pa = prterm_env ctx actty in let pe = prterm_env ctx expty in - [< 'sTR "In Cases expression on term"; 'bRK(1,1); pc; - 'sPC; 'sTR "the branch " ; 'iNT (i+1); - 'sTR " has type"; 'bRK(1,1); pa ; 'sPC; - 'sTR "which should be"; 'bRK(1,1); pe >] + str "In Cases expression on term" ++ brk(1,1) ++ pc ++ + spc () ++ str "the branch " ++ int (i+1) ++ + str " has type" ++ brk(1,1) ++ pa ++ spc () ++ + str "which should be" ++ brk(1,1) ++ pe let explain_generalization ctx (name,var) j = let ctx = make_all_name_different ctx in - let pe = pr_ne_context_of [< 'sTR "In environment" >] ctx in + let pe = pr_ne_context_of (str "In environment") ctx in let pv = prtype_env ctx var in let (pc,pt) = prjudge_env (push_rel_assum (name,var) ctx) j in - [< 'sTR"Illegal generalization: "; pe; - 'sTR"Cannot generalize"; 'bRK(1,1); pv; 'sPC; - 'sTR"over"; 'bRK(1,1); pc; 'sTR","; 'sPC; 'sTR"it has type"; 'sPC; pt; - 'sPC; 'sTR"which should be Set, Prop or Type." >] + str"Illegal generalization: " ++ pe ++ + str"Cannot generalize" ++ brk(1,1) ++ pv ++ spc () ++ + str"over" ++ brk(1,1) ++ pc ++ str"," ++ spc () ++ + str"it has type" ++ spc () ++ pt ++ + spc () ++ str"which should be Set, Prop or Type." let explain_actual_type ctx j pt = let ctx = make_all_name_different ctx in - let pe = pr_ne_context_of [< 'sTR "In environment" >] ctx in + let pe = pr_ne_context_of (str "In environment") ctx in let (pc,pct) = prjudge_env ctx j in let pt = prterm_env ctx pt in - [< pe; - 'sTR "The term"; 'bRK(1,1); pc ; 'sPC ; - 'sTR "has type" ; 'bRK(1,1); pct; 'bRK(1,1); - 'sTR "while it is expected to have type"; 'bRK(1,1); pt >] + pe ++ + str "The term" ++ brk(1,1) ++ pc ++ spc () ++ + str "has type" ++ brk(1,1) ++ pct ++ brk(1,1) ++ + str "while it is expected to have type" ++ brk(1,1) ++ pt let explain_cant_apply_bad_type ctx (n,exptyp,actualtyp) rator randl = let randl = Array.to_list randl in let ctx = make_all_name_different ctx in -(* let pe = pr_ne_context_of [< 'sTR"in environment" >] ctx in*) +(* let pe = pr_ne_context_of (str"in environment") ctx in*) let pr,prt = prjudge_env ctx rator in let term_string1,term_string2 = if List.length randl > 1 then @@ -149,20 +150,20 @@ let explain_cant_apply_bad_type ctx (n,exptyp,actualtyp) rator randl = let appl = prlist_with_sep pr_fnl (fun c -> let pc,pct = prjudge_env ctx c in - hOV 2 [< pc; 'sPC; 'sTR": " ; pct >]) randl + hov 2 (pc ++ spc () ++ str": " ++ pct)) randl in - [< 'sTR"Illegal application (Type Error): "; (* pe; *) 'fNL; - 'sTR"The term"; 'bRK(1,1); pr; 'sPC; - 'sTR"of type"; 'bRK(1,1); prt; 'sPC ; - 'sTR("cannot be applied to the "^term_string1); 'fNL; - 'sTR" "; v 0 appl; 'fNL; 'sTR (term_string2^" has type"); - 'bRK(1,1); prterm_env ctx actualtyp; 'sPC; - 'sTR"which should be coercible to"; 'bRK(1,1); prterm_env ctx exptyp >] + str"Illegal application (Type Error): " ++ (* pe ++ *) fnl () ++ + str"The term" ++ brk(1,1) ++ pr ++ spc () ++ + str"of type" ++ brk(1,1) ++ prt ++ spc () ++ + str("cannot be applied to the "^term_string1) ++ fnl () ++ + str" " ++ v 0 appl ++ fnl () ++ str (term_string2^" has type") ++ + brk(1,1) ++ prterm_env ctx actualtyp ++ spc () ++ + str"which should be coercible to" ++ brk(1,1) ++ prterm_env ctx exptyp let explain_cant_apply_not_functional ctx rator randl = let randl = Array.to_list randl in let ctx = make_all_name_different ctx in -(* let pe = pr_ne_context_of [< 'sTR"in environment" >] ctx in*) +(* let pe = pr_ne_context_of (str"in environment") ctx in*) let pr = prterm_env ctx rator.uj_val in let prt = prterm_env ctx (body_of_type rator.uj_type) in let term_string = if List.length randl > 1 then "terms" else "term" in @@ -170,131 +171,133 @@ let explain_cant_apply_not_functional ctx rator randl = (fun c -> let pc = prterm_env ctx c.uj_val in let pct = prterm_env ctx (body_of_type c.uj_type) in - hOV 2 [< pc; 'sPC; 'sTR": " ; pct >]) randl + hov 2 (pc ++ spc () ++ str": " ++ pct)) randl in - [< 'sTR"Illegal application (Non-functional construction): "; (* pe; *) 'fNL; - 'sTR"The expression"; 'bRK(1,1); pr; 'sPC; - 'sTR"of type"; 'bRK(1,1); prt; 'sPC ; - 'sTR("cannot be applied to the "^term_string); 'fNL; - 'sTR" "; v 0 appl >] + str"Illegal application (Non-functional construction): " ++ + (* pe ++ *) fnl () ++ + str"The expression" ++ brk(1,1) ++ pr ++ spc () ++ + str"of type" ++ brk(1,1) ++ prt ++ spc () ++ + str("cannot be applied to the "^term_string) ++ fnl () ++ + str" " ++ v 0 appl let explain_unexpected_type ctx actual_type expected_type = let ctx = make_all_name_different ctx in let pract = prterm_env ctx actual_type in let prexp = prterm_env ctx expected_type in - [< 'sTR"This type is"; 'sPC; pract; 'sPC; 'sTR "but is expected to be"; - 'sPC; prexp >] + str"This type is" ++ spc () ++ pract ++ spc () ++ + str "but is expected to be" ++ + spc () ++ prexp let explain_not_product ctx c = let ctx = make_all_name_different ctx in let pr = prterm_env ctx c in - [< 'sTR"The type of this term is a product,"; 'sPC; - 'sTR"but it is casted with type"; - 'bRK(1,1); pr >] + str"The type of this term is a product," ++ spc () ++ + str"but it is casted with type" ++ + brk(1,1) ++ pr (* TODO: use the names *) (* (co)fixpoints *) let explain_ill_formed_rec_body ctx err names i vdefs = - let str = match err with + let st = match err with (* Fixpoint guard errors *) | NotEnoughAbstractionInFixBody -> - [< 'sTR "Not enough abstractions in the definition" >] + str "Not enough abstractions in the definition" | RecursionNotOnInductiveType -> - [< 'sTR "Recursive definition on a non inductive type" >] + str "Recursive definition on a non inductive type" | RecursionOnIllegalTerm -> - [< 'sTR "Recursive call applied to an illegal term" >] + str "Recursive call applied to an illegal term" | NotEnoughArgumentsForFixCall -> - [< 'sTR "Not enough arguments for the recursive call" >] + str "Not enough arguments for the recursive call" (* CoFixpoint guard errors *) (* TODO : récupérer le contexte des termes pour pouvoir les afficher *) | CodomainNotInductiveType c -> - [< 'sTR "The codomain is"; 'sPC; prterm c; 'sPC; - 'sTR "which should be a coinductive type" >] + str "The codomain is" ++ spc () ++ prterm c ++ spc () ++ + str "which should be a coinductive type" | NestedRecursiveOccurrences -> - [< 'sTR "Nested recursive occurrences" >] + str "Nested recursive occurrences" | UnguardedRecursiveCall c -> - [< 'sTR "Unguarded recursive call" >] + str "Unguarded recursive call" | RecCallInTypeOfAbstraction c -> - [< 'sTR "Not allowed recursive call in the domain of an abstraction" >] + str "Not allowed recursive call in the domain of an abstraction" | RecCallInNonRecArgOfConstructor c -> - [< 'sTR "Not allowed recursive call in a non-recursive argument of constructor" >] + str "Not allowed recursive call in a non-recursive argument of constructor" | RecCallInTypeOfDef c -> - [< 'sTR "Not allowed recursive call in the type of a recursive definition" >] + str "Not allowed recursive call in the type of a recursive definition" | RecCallInCaseFun c -> - [< 'sTR "Not allowed recursive call in a branch of cases" >] + str "Not allowed recursive call in a branch of cases" | RecCallInCaseArg c -> - [< 'sTR "Not allowed recursive call in the argument of cases" >] + str "Not allowed recursive call in the argument of cases" | RecCallInCasePred c -> - [< 'sTR "Not allowed recursive call in the type of cases in" >] + str "Not allowed recursive call in the type of cases in" | NotGuardedForm -> - [< 'sTR "Definition not in guarded form" >] + str "Definition not in guarded form" in let pvd = prterm_env ctx vdefs.(i) in - let s = - match names.(i) with Name id -> string_of_id id | Anonymous -> "_" in - [< str; 'fNL; 'sTR"The "; - if Array.length vdefs = 1 then [<>] else [<'iNT (i+1); 'sTR "-th ">]; - 'sTR"recursive definition"; 'sPC; 'sTR s; - 'sPC ; 'sTR":="; 'sPC ; pvd; 'sPC; - 'sTR "is not well-formed" >] + let s = match names.(i) with Name id -> string_of_id id | Anonymous -> "_" in + st ++ fnl () ++ str"The " ++ + (if Array.length vdefs = 1 then mt () else (int (i+1) ++ str "-th ")) ++ + str"recursive definition" ++ spc () ++ str s ++ + spc () ++ str":=" ++ spc () ++ pvd ++ spc () ++ + str "is not well-formed" let explain_ill_typed_rec_body ctx i names vdefj vargs = let pvd,pvdt = prjudge_env ctx (vdefj.(i)) in let pv = prterm_env ctx (body_of_type vargs.(i)) in - [< 'sTR"The " ; - if Array.length vdefj = 1 then [<>] else [<'iNT (i+1); 'sTR "-th">]; - 'sTR"recursive definition" ; 'sPC; pvd; 'sPC; - 'sTR "has type"; 'sPC; pvdt;'sPC; 'sTR "it should be"; 'sPC; pv >] + str"The " ++ + (if Array.length vdefj = 1 then mt () else int (i+1) ++ str "-th") ++ + str"recursive definition" ++ spc () ++ pvd ++ spc () ++ + str "has type" ++ spc () ++ pvdt ++spc () ++ + str "it should be" ++ spc () ++ pv let explain_not_inductive ctx c = let pc = prterm_env ctx c in - [< 'sTR"The term"; 'bRK(1,1); pc; 'sPC; - 'sTR "is not an inductive definition" >] + str"The term" ++ brk(1,1) ++ pc ++ spc () ++ + str "is not an inductive definition" let explain_ml_case ctx mes = let expln = match mes with | MlCaseAbsurd -> - [< 'sTR "Unable to infer a predicate for an elimination an empty type">] + str "Unable to infer a predicate for an elimination an empty type" | MlCaseDependent -> - [< 'sTR "Unable to infer a dependent elimination predicate">] + str "Unable to infer a dependent elimination predicate" in - hOV 0 [< 'sTR "Cannot infer ML Case predicate:"; 'fNL; expln >] + hov 0 (str "Cannot infer ML Case predicate:" ++ fnl () ++ expln) let explain_cant_find_case_type ctx c = let pe = prterm_env ctx c in - hOV 3 [<'sTR "Cannot infer type of whole Case expression on"; 'wS 1; pe >] + hov 3 (str "Cannot infer type of whole Case expression on" ++ ws 1 ++ pe) let explain_occur_check ctx ev rhs = let id = "?" ^ string_of_int ev in let pt = prterm_env ctx rhs in - [< 'sTR"Occur check failed: tried to define "; 'sTR id; - 'sTR" with term"; 'bRK(1,1); pt >] + str"Occur check failed: tried to define " ++ str id ++ + str" with term" ++ brk(1,1) ++ pt let explain_not_clean ctx ev t = let c = mkRel (Intset.choose (free_rels t)) in let id = "?" ^ string_of_int ev in let var = prterm_env ctx c in - [< 'sTR"Tried to define "; 'sTR id; - 'sTR" with a term using variable "; var; 'sPC; - 'sTR"which is not in its scope." >] + str"Tried to define " ++ str id ++ + str" with a term using variable " ++ var ++ spc () ++ + str"which is not in its scope." let explain_var_not_found ctx id = - [< 'sTR "The variable"; 'sPC; 'sTR (string_of_id id); - 'sPC ; 'sTR "was not found"; - 'sPC ; 'sTR "in the current"; 'sPC ; 'sTR "environment" >] + str "The variable" ++ spc () ++ str (string_of_id id) ++ + spc () ++ str "was not found" ++ + spc () ++ str "in the current" ++ spc () ++ str "environment" let explain_wrong_case_info ctx ind ci = let pi = prterm (mkInd ind) in if ci.ci_ind = ind then - [< 'sTR"Cases expression on an object of inductive"; 'sPC; pi; - 'sPC; 'sTR"has invalid information" >] + str"Cases expression on an object of inductive" ++ spc () ++ pi ++ + spc () ++ str"has invalid information" else let pc = prterm (mkInd ci.ci_ind) in - [< 'sTR"A term of inductive type"; 'sPC; pi; 'sPC; - 'sTR"was given to a Cases expression on the inductive type"; - 'sPC; pc >] + str"A term of inductive type" ++ spc () ++ pi ++ spc () ++ + str"was given to a Cases expression on the inductive type" ++ + spc () ++ pc let explain_type_error ctx = function @@ -353,52 +356,52 @@ let explain_pretype_error ctx = function (* Refiner errors *) let explain_refiner_bad_type arg ty conclty = - [< 'sTR"refiner was given an argument"; 'bRK(1,1); - prterm arg; 'sPC; - 'sTR"of type"; 'bRK(1,1); prterm ty; 'sPC; - 'sTR"instead of"; 'bRK(1,1); prterm conclty >] + str"refiner was given an argument" ++ brk(1,1) ++ + prterm arg ++ spc () ++ + str"of type" ++ brk(1,1) ++ prterm ty ++ spc () ++ + str"instead of" ++ brk(1,1) ++ prterm conclty let explain_refiner_occur_meta t = - [< 'sTR"cannot refine with term"; 'bRK(1,1); prterm t; - 'sPC; 'sTR"because there are metavariables, and it is"; - 'sPC; 'sTR"neither an application nor a Case" >] + str"cannot refine with term" ++ brk(1,1) ++ prterm t ++ + spc () ++ str"because there are metavariables, and it is" ++ + spc () ++ str"neither an application nor a Case" let explain_refiner_occur_meta_goal t = - [< 'sTR"generated subgoal"; 'bRK(1,1); prterm t; - 'sPC; 'sTR"has metavariables in it" >] + str"generated subgoal" ++ brk(1,1) ++ prterm t ++ + spc () ++ str"has metavariables in it" let explain_refiner_cannot_applt t harg = - [< 'sTR"in refiner, a term of type "; 'bRK(1,1); - prterm t; 'sPC; 'sTR"could not be applied to"; 'bRK(1,1); - prterm harg >] + str"in refiner, a term of type " ++ brk(1,1) ++ + prterm t ++ spc () ++ str"could not be applied to" ++ brk(1,1) ++ + prterm harg let explain_refiner_cannot_unify m n = let pm = prterm m in let pn = prterm n in - [< 'sTR"Impossible to unify"; 'bRK(1,1) ; pm; 'sPC ; - 'sTR"with"; 'bRK(1,1) ; pn >] + str"Impossible to unify" ++ brk(1,1) ++ pm ++ spc () ++ + str"with" ++ brk(1,1) ++ pn let explain_refiner_cannot_generalize ty = - [< 'sTR "Cannot find a well-typed generalisation of the goal with type : "; - prterm ty >] + str "Cannot find a well-typed generalisation of the goal with type : " ++ + prterm ty let explain_refiner_not_well_typed c = - [< 'sTR"The term " ; prterm c ; 'sTR" is not well-typed" >] + str"The term " ++ prterm c ++ str" is not well-typed" let explain_refiner_bad_tactic_args s l = - [< 'sTR "Internal tactic "; 'sTR s; 'sTR " cannot be applied to "; - Tacmach.pr_tactic (s,l) >] + str "Internal tactic " ++ str s ++ str " cannot be applied to " ++ + Tacmach.pr_tactic (s,l) let explain_intro_needs_product () = - [< 'sTR "Introduction tactics needs products" >] + str "Introduction tactics needs products" let explain_does_not_occur_in c hyp = - [< 'sTR "The term"; 'sPC; prterm c; 'sPC; 'sTR "does not occur in"; - 'sPC; pr_id hyp >] + str "The term" ++ spc () ++ prterm c ++ spc () ++ str "does not occur in" ++ + spc () ++ pr_id hyp let explain_non_linear_proof c = - [< 'sTR "cannot refine with term"; 'bRK(1,1); prterm c; - 'sPC; 'sTR"because a metavariable has several occurrences" >] + str "cannot refine with term" ++ brk(1,1) ++ prterm c ++ + spc () ++ str"because a metavariable has several occurrences" let explain_refiner_error = function | BadType (arg,ty,conclty) -> explain_refiner_bad_type arg ty conclty @@ -418,20 +421,20 @@ let explain_refiner_error = function let error_non_strictly_positive env c v = let pc = prterm_env env c in let pv = prterm_env env v in - [< 'sTR "Non strictly positive occurrence of "; pv; 'sTR " in"; - 'bRK(1,1); pc >] + str "Non strictly positive occurrence of " ++ pv ++ str " in" ++ + brk(1,1) ++ pc let error_ill_formed_inductive env c v = let pc = prterm_env env c in let pv = prterm_env env v in - [< 'sTR "Not enough arguments applied to the "; pv; - 'sTR " in"; 'bRK(1,1); pc >] + str "Not enough arguments applied to the " ++ pv ++ + str " in" ++ brk(1,1) ++ pc let error_ill_formed_constructor env c v = let pc = prterm_env env c in let pv = prterm_env env v in - [< 'sTR "The conclusion of"; 'bRK(1,1); pc; 'bRK(1,1); - 'sTR "is not valid;"; 'bRK(1,1); 'sTR "it must be built from "; pv >] + str "The conclusion of" ++ brk(1,1) ++ pc ++ brk(1,1) ++ + str "is not valid ++" ++ brk(1,1) ++ str "it must be built from " ++ pv let str_of_nth n = (string_of_int n)^ @@ -445,38 +448,38 @@ let error_bad_ind_parameters env c n v1 v2 = let pc = prterm_env_at_top env c in let pv1 = prterm_env env v1 in let pv2 = prterm_env env v2 in - [< 'sTR ("The "^(str_of_nth n)^" argument of "); pv2; 'bRK(1,1); - 'sTR "must be "; pv1; 'sTR " in"; 'bRK(1,1); pc >] + str ("The "^(str_of_nth n)^" argument of ") ++ pv2 ++ brk(1,1) ++ + str "must be " ++ pv1 ++ str " in" ++ brk(1,1) ++ pc let error_same_names_types id = - [< 'sTR "The name"; 'sPC; pr_id id; 'sPC; - 'sTR "is used twice is the inductive types definition." >] + str "The name" ++ spc () ++ pr_id id ++ spc () ++ + str "is used twice is the inductive types definition." let error_same_names_constructors id cid = - [< 'sTR "The constructor name"; 'sPC; pr_id cid; 'sPC; - 'sTR "is used twice is the definition of type"; 'sPC; - pr_id id >] + str "The constructor name" ++ spc () ++ pr_id cid ++ spc () ++ + str "is used twice is the definition of type" ++ spc () ++ + pr_id id let error_not_an_arity id = - [< 'sTR "The type of"; 'sPC; pr_id id; 'sPC; 'sTR "is not an arity." >] + str "The type of" ++ spc () ++ pr_id id ++ spc () ++ str "is not an arity." let error_bad_entry () = - [< 'sTR "Bad inductive definition." >] + str "Bad inductive definition." let error_not_allowed_case_analysis dep kind i = - [< 'sTR (if dep then "Dependent" else "Non Dependent"); - 'sTR " case analysis on sort: "; print_sort kind; 'fNL; - 'sTR "is not allowed for inductive definition: "; - pr_inductive (Global.env()) i >] + str (if dep then "Dependent" else "Non Dependent") ++ + str " case analysis on sort: " ++ print_sort kind ++ fnl () ++ + str "is not allowed for inductive definition: " ++ + pr_inductive (Global.env()) i let error_bad_induction dep indid kind = - [<'sTR (if dep then "Dependent" else "Non dependent"); - 'sTR " induction for type "; pr_id indid; - 'sTR " and sort "; print_sort kind; 'sPC; - 'sTR "is not allowed">] + str (if dep then "Dependent" else "Non dependent") ++ + str " induction for type " ++ pr_id indid ++ + str " and sort " ++ print_sort kind ++ spc () ++ + str "is not allowed" let error_not_mutual_in_scheme () = - [< 'sTR "Induction schemes is concerned only with mutually inductive types" >] + str "Induction schemes is concerned only with mutually inductive types" let explain_inductive_error = function (* These are errors related to inductive constructions *) @@ -499,59 +502,58 @@ let explain_inductive_error = function let explain_bad_pattern ctx cstr ty = let pt = prterm_env ctx ty in let pc = pr_constructor ctx cstr in - [< 'sTR "Found the constructor "; pc; 'bRK(1,1); - 'sTR "while matching a term of type "; pt; 'bRK(1,1); - 'sTR "which is not an inductive type" >] + str "Found the constructor " ++ pc ++ brk(1,1) ++ + str "while matching a term of type " ++ pt ++ brk(1,1) ++ + str "which is not an inductive type" let explain_bad_constructor ctx cstr ind = let pi = pr_inductive ctx ind in (* let pc = pr_constructor ctx cstr in*) let pt = pr_inductive ctx (inductive_of_constructor cstr) in - [< 'sTR "Found a constructor of inductive type "; pt; 'bRK(1,1) ; - 'sTR "while a constructor of " ; pi; 'bRK(1,1) ; - 'sTR "is expected" >] + str "Found a constructor of inductive type " ++ pt ++ brk(1,1) ++ + str "while a constructor of " ++ pi ++ brk(1,1) ++ + str "is expected" let explain_wrong_numarg_of_constructor ctx cstr n = let pc = pr_constructor ctx cstr in - [<'sTR "The constructor "; pc; 'sTR " expects " ; - if n = 0 then [< 'sTR "no argument.">] - else if n = 1 then [< 'sTR "1 argument.">] - else [< 'iNT n ; 'sTR " arguments.">] - >] + str "The constructor " ++ pc ++ str " expects " ++ + (if n = 0 then str "no argument." else if n = 1 then str "1 argument." + else (int n ++ str " arguments.")) let explain_wrong_predicate_arity ctx pred nondep_arity dep_arity= let pp = prterm_env ctx pred in - [<'sTR "The elimination predicate "; 'sPC; pp; 'fNL; - 'sTR "should be of arity" ; 'sPC; - prterm_env ctx nondep_arity ; 'sPC; 'sTR "(for non dependent case) or" ; - 'sPC; prterm_env ctx dep_arity ; 'sPC; 'sTR "(for dependent case).">] + str "The elimination predicate " ++ spc () ++ pp ++ fnl () ++ + str "should be of arity" ++ spc () ++ + prterm_env ctx nondep_arity ++ spc () ++ + str "(for non dependent case) or" ++ + spc () ++ prterm_env ctx dep_arity ++ spc () ++ str "(for dependent case)." let explain_needs_inversion ctx x t = let px = prterm_env ctx x in let pt = prterm_env ctx t in - [< 'sTR "Sorry, I need inversion to compile pattern matching of term "; - px ; 'sTR " of type: "; pt>] + str "Sorry, I need inversion to compile pattern matching of term " ++ + px ++ str " of type: " ++ pt let explain_unused_clause env pats = let s = if List.length pats > 1 then "s" else "" in (* Without localisation - [<'sTR ("Unused clause with pattern"^s); 'sPC; - hOV 0 (prlist_with_sep pr_spc pr_cases_pattern pats); 'sTR ")" >] + (str ("Unused clause with pattern"^s) ++ spc () ++ + hov 0 (prlist_with_sep pr_spc pr_cases_pattern pats) ++ str ")") *) - [<'sTR "This clause is redundant" >] + str "This clause is redundant" let explain_non_exhaustive env pats = let s = if List.length pats > 1 then "s" else "" in - [<'sTR ("Non exhaustive pattern-matching: no clause found for pattern"^s); - 'sPC; hOV 0 (prlist_with_sep pr_spc pr_cases_pattern pats) >] + str ("Non exhaustive pattern-matching: no clause found for pattern"^s) ++ + spc () ++ hov 0 (prlist_with_sep pr_spc pr_cases_pattern pats) let explain_cannot_infer_predicate env typs = let pr_branch (cstr,typ) = let cstr,_ = decompose_app cstr in - [< 'sTR "For "; prterm_env env cstr; 'sTR " : "; prterm_env env typ >] + str "For " ++ prterm_env env cstr ++ str " : " ++ prterm_env env typ in - [<'sTR "Unable to unify the types found in the branches:"; - 'sPC; hOV 0 (prlist_with_sep pr_fnl pr_branch (Array.to_list typs)) >] + str "Unable to unify the types found in the branches:" ++ + spc () ++ hov 0 (prlist_with_sep pr_fnl pr_branch (Array.to_list typs)) let explain_pattern_matching_error env = function | BadPattern (c,t) -> diff --git a/toplevel/metasyntax.ml b/toplevel/metasyntax.ml index ec311d9ae..487c87bd4 100644 --- a/toplevel/metasyntax.ml +++ b/toplevel/metasyntax.ml @@ -226,10 +226,10 @@ let add_infix assoc n inf pr = (* check the precedence *) if n<1 or n>10 then errorlabstrm "Metasyntax.infix_grammar_entry" - [< 'sTR"Precedence must be between 1 and 10." >]; + (str"Precedence must be between 1 and 10."); if (assoc<>None) & (n<6 or n>9) then errorlabstrm "Vernacentries.infix_grammar_entry" - [< 'sTR"Associativity Precedence must be 6,7,8 or 9." >]; + (str"Associativity Precedence must be 6,7,8 or 9."); (* check the grammar entry *) let prefname = inf^"_infix" in let gram_rule = gram_infix assoc n (split inf) prefname pr in diff --git a/toplevel/minicoq.ml b/toplevel/minicoq.ml index 3ad4ab41c..610f8afa3 100644 --- a/toplevel/minicoq.ml +++ b/toplevel/minicoq.ml @@ -50,7 +50,7 @@ let check c = let (j,u) = safe_infer !env c in let ty = j_type j in let pty = pr_term CCI (env_of_safe_env !env) ty in - mSGNL (hOV 0 [< 'sTR" :"; 'sPC; hOV 0 pty; 'fNL >]) + mSGNL (hov 0 (str" :" ++ spc () ++ hov 0 pty ++ fnl ())) let definition id ty c = let c = globalize [] c in @@ -58,20 +58,20 @@ let definition id ty c = let ce = { const_entry_body = c; const_entry_type = ty } in let sp = make_path [] id CCI in env := add_constant sp ce (locals()) !env; - mSGNL (hOV 0 [< pr_id id; 'sPC; 'sTR"is defined"; 'fNL >]) + mSGNL (hov 0 (pr_id id ++ spc () ++ str"is defined" ++ fnl ())) let parameter id t = let t = globalize [] t in let sp = make_path [] id CCI in env := add_parameter sp t (locals()) !env; - mSGNL (hOV 0 [< 'sTR"parameter"; 'sPC; pr_id id; - 'sPC; 'sTR"is declared"; 'fNL >]) + mSGNL (hov 0 (str"parameter" ++ spc () ++ pr_id id ++ + spc () ++ str"is declared" ++ fnl ())) let variable id t = let t = globalize [] t in env := push_named_assum (id,t) !env; - mSGNL (hOV 0 [< 'sTR"variable"; 'sPC; pr_id id; - 'sPC; 'sTR"is declared"; 'fNL >]) + mSGNL (hov 0 (str"variable" ++ spc () ++ pr_id id ++ + spc () ++ str"is declared" ++ fnl ())) let inductive par inds = let nparams = List.length par in @@ -97,7 +97,7 @@ let inductive par inds = let mi1 = List.hd inds in make_path [] mi1.mind_entry_typename CCI in env := add_mind sp mie (locals()) !env; - mSGNL (hOV 0 [< 'sTR"inductive type(s) are declared"; 'fNL >]) + mSGNL (hov 0 (str"inductive type(s) are declared" ++ fnl ())) let execute = function @@ -122,12 +122,12 @@ module Explain = Fhimsg.Make(struct let pr_term = pr_term end) let rec explain_exn = function | TypeError (k,ctx,te) -> - mSGNL (hOV 0 [< 'sTR "type error:"; 'sPC; - Explain.explain_type_error k ctx te; 'fNL >]) + mSGNL (hov 0 (str "type error:" ++ spc () ++ + Explain.explain_type_error k ctx te ++ fnl ())) | Stdpp.Exc_located (_,exn) -> explain_exn exn | exn -> - mSGNL (hOV 0 [< 'sTR"error: "; 'sTR (Printexc.to_string exn); 'fNL >]) + mSGNL (hov 0 (str"error: " ++ str (Printexc.to_string exn) ++ fnl ())) let top () = let cs = Stream.of_channel stdin in diff --git a/toplevel/mltop.ml4 b/toplevel/mltop.ml4 index 3fc937724..d9325a2e7 100644 --- a/toplevel/mltop.ml4 +++ b/toplevel/mltop.ml4 @@ -89,7 +89,7 @@ let ocaml_toploop () = | _ -> () (* errorlabstrm "Mltop.ocaml_toploop" - [< 'sTR"Cannot access the ML toplevel" >] + [< str"Cannot access the ML toplevel" >] *) (* Dynamic loading of .cmo *) @@ -101,11 +101,11 @@ let dir_ml_load s = with | (UserError _ | Failure _ | Anomaly _ | Not_found as u) -> raise u | _ -> errorlabstrm "Mltop.load_object" - [< 'sTR"Cannot link ml-object "; 'sTR s; - 'sTR" to Coq code." >] + [< str"Cannot link ml-object "; str s; + str" to Coq code." >] else errorlabstrm "Mltop.load_object" - [< 'sTR"File not found on loadpath : "; 'sTR s >] + [< str"File not found on loadpath : "; str s >] | WithoutTop -> ifdef Byte then (if is_in_path !coq_mlpath_copy s then @@ -119,14 +119,14 @@ let dir_ml_load s = with | Dynlink.Error(a) -> errorlabstrm "Mltop.load_object" - [< 'sTR (Dynlink.error_message a) >] + [< str (Dynlink.error_message a) >] else errorlabstrm "Mltop.load_object" - [< 'sTR"File not found on loadpath : "; 'sTR s >]) + [< str"File not found on loadpath : "; str s >]) else () | Native -> errorlabstrm "Mltop.no_load_object" - [< 'sTR"Loading of ML object file forbidden in a native Coq" >] + [< str"Loading of ML object file forbidden in a native Coq" >] (* Dynamic interpretation of .ml *) let dir_ml_use s = @@ -147,14 +147,14 @@ let add_rec_ml_dir dir = (* Adding files to Coq and ML loadpath *) -let add_path dir coq_dirpath = +let add_path ~unix_path:dir ~coq_root:coq_dirpath = if exists_dir dir then begin add_ml_dir dir; Library.add_load_path_entry (dir,coq_dirpath) end else - wARNING [< 'sTR ("Cannot open " ^ dir) >] + msg_warning [< str ("Cannot open " ^ dir) >] let convert_string d = try Names.id_of_string d @@ -164,7 +164,7 @@ let convert_string d = flush_all (); failwith "caught" -let add_rec_path dir coq_dirpath = +let add_rec_path ~unix_path:dir ~coq_root:coq_dirpath = let dirs = all_subdirs dir in let prefix = Names.repr_dirpath coq_dirpath in if dirs <> [] then @@ -177,7 +177,7 @@ let add_rec_path dir coq_dirpath = List.iter Library.add_load_path_entry dirs end else - wARNING [< 'sTR ("Cannot open " ^ dir) >] + msg_warning [< str ("Cannot open " ^ dir) >] (* convertit un nom quelconque en nom de fichier ou de module *) let mod_of_name name = @@ -244,7 +244,7 @@ let unfreeze_ml_modules x = load_object mname fname else errorlabstrm "Mltop.unfreeze_ml_modules" - [< 'sTR"Loading of ML object file forbidden in a native Coq" >]; + [< str"Loading of ML object file forbidden in a native Coq" >]; add_loaded_module mname) x @@ -266,11 +266,11 @@ let cache_ml_module_object (_,{mnames=mnames}) = begin try if_verbose - mSG [< 'sTR"[Loading ML file "; 'sTR fname; 'sTR" ..." >]; + msg [< str"[Loading ML file "; str fname; str" ..." >]; load_object mname fname; - if_verbose mSGNL [< 'sTR"done]" >] + if_verbose msgnl [< str"done]" >] with e -> - if_verbose mSGNL [< 'sTR"failed]" >]; + if_verbose msgnl [< str"failed]" >]; raise e end; add_loaded_module mname) @@ -290,11 +290,11 @@ let declare_ml_modules l = let print_ml_path () = let l = !coq_mlpath_copy in - pPNL [< 'sTR"ML Load Path:"; 'fNL; 'sTR" "; - hV 0 (prlist_with_sep pr_fnl pr_str l) >] + ppnl [< str"ML Load Path:"; fnl (); str" "; + hv 0 (prlist_with_sep pr_fnl pr_str l) >] (* Printing of loaded ML modules *) let print_ml_modules () = let l = get_loaded_modules () in - pP [< 'sTR"Loaded ML Modules: " ; pr_vertical_list pr_str l >] + pp [< str"Loaded ML Modules: " ; pr_vertical_list pr_str l >] diff --git a/toplevel/protectedtoplevel.ml b/toplevel/protectedtoplevel.ml index 66a41e2c1..730b6768d 100644 --- a/toplevel/protectedtoplevel.ml +++ b/toplevel/protectedtoplevel.ml @@ -32,7 +32,7 @@ let output_results_nl stream = let _ = Sys.signal Sys.sigint (Sys.Signal_handle(fun i -> break_happened := true;())) in - mSGNL stream + msgnl stream let rearm_break () = let _ = Sys.signal Sys.sigint (Sys.Signal_handle(fun _ -> raise Sys.Break)) in @@ -50,14 +50,14 @@ let global_request_id = ref 013 let acknowledge_command_ref = ref(fun request_id command_count opt_exn - -> [<'fNL; 'sTR "acknowledge command number "; - 'iNT request_id; 'fNL; - 'sTR "successfully executed "; 'iNT command_count; 'fNL; - 'sTR "error message"; 'fNL; + -> (fnl () ++ str "acknowledge command number " ++ + int request_id ++ fnl () ++ + str "successfully executed " ++ int command_count ++ fnl () ++ + str "error message" ++ fnl () ++ (match opt_exn with Some e -> Errors.explain_exn e - | None -> [< >]); 'fNL; - 'sTR "E-n-d---M-e-s-s-a-g-e"; 'fNL>]) + | None -> (mt ())) ++ fnl () ++ + str "E-n-d---M-e-s-s-a-g-e" ++ fnl ())) let set_acknowledge_command f = acknowledge_command_ref := f @@ -168,6 +168,6 @@ let protected_loop input_chan = explain_and_restart e | e -> explain_and_restart e in begin - mSGNL [<'sTR "Starting Centaur Specialized loop" >]; + msgnl (str "Starting Centaur Specialized loop"); looprec input_chan end diff --git a/toplevel/record.ml b/toplevel/record.ml index 2f294af98..71443abb5 100644 --- a/toplevel/record.ml +++ b/toplevel/record.ml @@ -76,26 +76,26 @@ let warning_or_error coe indsp err = let st = match err with | MissingProj (fi,projs) -> let s,have = if List.length projs > 1 then "s","have" else "","has" in - [< 'sTR(string_of_id fi); - 'sTR" cannot be defined because the projection"; 'sTR s; 'sPC; - prlist_with_sep pr_coma pr_id projs; 'sPC; 'sTR have; 'sTR "n't." >] + (str(string_of_id fi) ++ + str" cannot be defined because the projection" ++ str s ++ spc () ++ + prlist_with_sep pr_coma pr_id projs ++ spc () ++ str have ++ str "n't.") | BadTypedProj (fi,ctx,te) -> match te with | ElimArity (_,_,_,_,Some (_,_,NonInformativeToInformative)) -> - [<'sTR (string_of_id fi); - 'sTR" cannot be defined because it is informative and "; - Printer.pr_inductive (Global.env()) indsp; - 'sTR " is not." >] + (str (string_of_id fi) ++ + str" cannot be defined because it is informative and " ++ + Printer.pr_inductive (Global.env()) indsp ++ + str " is not.") | ElimArity (_,_,_,_,Some (_,_,StrongEliminationOnNonSmallType)) -> - [<'sTR (string_of_id fi); - 'sTR" cannot be defined because it is large and "; - Printer.pr_inductive (Global.env()) indsp; - 'sTR " is not." >] + (str (string_of_id fi) ++ + str" cannot be defined because it is large and " ++ + Printer.pr_inductive (Global.env()) indsp ++ + str " is not.") | _ -> - [<'sTR " cannot be defined because it is not typable" >] + (str " cannot be defined because it is not typable") in if coe then errorlabstrm "structure" st; - Options.if_verbose pPNL (hOV 0 [< 'sTR"Warning: "; st >]) + Options.if_verbose ppnl (hov 0 (str"Warning: " ++ st)) (* We build projections *) let declare_projections indsp coers fields = diff --git a/toplevel/recordobj.ml b/toplevel/recordobj.ml index b065d7b57..50f2ef83b 100755 --- a/toplevel/recordobj.ml +++ b/toplevel/recordobj.ml @@ -31,8 +31,8 @@ let typ_lams_of t = let objdef_err ref = errorlabstrm "object_declare" - [< pr_id (Termops.id_of_global (Global.env()) ref); - 'sTR" is not a structure object" >] + (pr_id (Termops.id_of_global (Global.env()) ref) ++ + str" is not a structure object") let objdef_declare ref = let sp = match ref with ConstRef sp -> sp | _ -> objdef_err ref in diff --git a/toplevel/toplevel.ml b/toplevel/toplevel.ml index 00be368af..972fd22b4 100644 --- a/toplevel/toplevel.ml +++ b/toplevel/toplevel.ml @@ -55,7 +55,7 @@ let prompt_char ic ibuf count = | ll::_ -> ibuf.len == ll | [] -> ibuf.len == 0 in - if bol then mSGERR [< 'sTR (ibuf.prompt()) >]; + if bol then msgerr (str (ibuf.prompt())); try let c = input_char ic in if c == '\n' then ibuf.bols <- (ibuf.len+1) :: ibuf.bols; @@ -109,31 +109,31 @@ let print_highlight_location ib (bp,ep) = let highlight_lines = match get_bols_of_loc ib (bp,ep) with | ([],(bl,el)) -> - [< 'sTR"> "; 'sTR(String.sub ib.str bl (el-bl-1)); 'fNL; - 'sTR"> "; 'sTR(String.make (bp-bl) ' '); - 'sTR(String.make (ep-bp) '^') >] + (str"> " ++ str(String.sub ib.str bl (el-bl-1)) ++ fnl () ++ + str"> " ++ str(String.make (bp-bl) ' ') ++ + str(String.make (ep-bp) '^')) | ((b1,e1)::ml,(bn,en)) -> let (d1,s1) = dotted_location (b1,bp) in let (dn,sn) = dotted_location (ep,en) in - let l1 = [< 'sTR"> "; 'sTR d1; 'sTR s1; - 'sTR(String.sub ib.str bp (e1-bp)) >] in + let l1 = (str"> " ++ str d1 ++ str s1 ++ + str(String.sub ib.str bp (e1-bp))) in let li = prlist (fun (bi,ei) -> - [< 'sTR"> "; 'sTR(String.sub ib.str bi (ei-bi)) >]) ml in - let ln = [< 'sTR"> "; 'sTR(String.sub ib.str bn (ep-bn)); - 'sTR sn; 'sTR dn >] in - [< l1; li; ln >] + (str"> " ++ str(String.sub ib.str bi (ei-bi)))) ml in + let ln = (str"> " ++ str(String.sub ib.str bn (ep-bn)) ++ + str sn ++ str dn) in + (l1 ++ li ++ ln) in - [< 'sTR"Toplevel input, characters "; Errors.print_loc (bp,ep); 'fNL; - highlight_lines; 'fNL >] + (str"Toplevel input, characters " ++ Errors.print_loc (bp,ep) ++ fnl () ++ + highlight_lines ++ fnl ()) (* Functions to report located errors in a file. *) let print_location_in_file s fname (bp,ep) = - let errstrm = [< 'sTR"Error while reading "; 'sTR s; 'sTR" :"; 'fNL; - 'sTR"File "; 'sTR ("\""^fname^"\"") >] in + let errstrm = (str"Error while reading " ++ str s ++ str" :" ++ fnl () ++ + str"File " ++ str ("\""^fname^"\"")) in if (bp,ep) = Ast.dummy_loc then - [< errstrm; 'sTR", unknown location."; 'fNL >] + (errstrm ++ str", unknown location." ++ fnl ()) else let ic = open_in fname in let rec line_of_pos lin bol cnt = @@ -146,16 +146,16 @@ let print_location_in_file s fname (bp,ep) = try let (line, bol) = line_of_pos 1 0 0 in close_in ic; - [< errstrm; 'sTR", line "; 'iNT line; - 'sTR", characters "; Errors.print_loc (bp-bol,ep-bol); 'fNL >] - with e -> (close_in ic; [< errstrm; 'sTR", invalid location."; 'fNL >]) + (errstrm ++ str", line " ++ int line ++ + str", characters " ++ Errors.print_loc (bp-bol,ep-bol) ++ fnl ()) + with e -> (close_in ic; (errstrm ++ str", invalid location." ++ fnl ())) let print_command_location ib dloc = match dloc with | Some (bp,ep) -> - [< 'sTR"Error during interpretation of command:"; 'fNL; - 'sTR(String.sub ib.str (bp-ib.start) (ep-bp)); 'fNL >] - | None -> [<>] + (str"Error during interpretation of command:" ++ fnl () ++ + str(String.sub ib.str (bp-ib.start) (ep-bp)) ++ fnl ()) + | None -> (mt ()) let valid_loc dloc (b,e) = (b,e) <> Ast.dummy_loc @@ -185,7 +185,7 @@ let top_buffer = str = ""; len = 0; bols = []; - tokens = Gram.parsable [<>]; + tokens = Gram.parsable (Stream.of_list []); start = 0 } let set_prompt prompt = @@ -217,32 +217,32 @@ let print_toplevel_error exc = if valid_buffer_loc top_buffer dloc loc then (print_highlight_location top_buffer loc, ie) else - ([<>] (* print_command_location top_buffer dloc *), ie) + ((mt ()) (* print_command_location top_buffer dloc *), ie) | Error_in_file (s, (fname, loc), ie) -> (print_location_in_file s fname loc, ie) | _ -> - ([<>] (* print_command_location top_buffer dloc *), exc) + ((mt ()) (* print_command_location top_buffer dloc *), exc) in match exc with | End_of_input -> - mSGERRNL [<>]; pp_flush(); exit 0 + msgerrnl (mt ()); pp_flush(); exit 0 | Vernacinterp.Drop -> (* Last chance *) if Mltop.is_ocaml_top() then raise Vernacinterp.Drop; - [< 'sTR"Error: There is no ML toplevel."; 'fNL >] + (str"Error: There is no ML toplevel." ++ fnl ()) | Vernacinterp.ProtectedLoop -> raise Vernacinterp.ProtectedLoop | Vernacinterp.Quit -> raise Vernacinterp.Quit | _ -> - [< if is_pervasive_exn exc then [<>] else locstrm; - Errors.explain_exn exc >] + (if is_pervasive_exn exc then (mt ()) else locstrm ++ + Errors.explain_exn exc) (* Read the input stream until a dot is encountered *) let parse_to_dot = - let rec dot = parser - | [< '("", ".") >] -> () - | [< '("EOI", "") >] -> raise End_of_input - | [< '_; s >] -> dot s + let rec dot st = match Stream.next st with + | ("", ".") -> () + | ("EOI", "") -> raise End_of_input + | _ -> dot st in Gram.Entry.of_parser "Coqtoplevel.dot" dot @@ -275,13 +275,13 @@ let process_error = function Otherwise, exit. End_of_input: Ctrl-D was typed in, we will quit *) let do_vernac () = - mSGERRNL [<>]; + msgerrnl (mt ()); resynch_buffer top_buffer; begin try raw_do_vernac top_buffer.tokens with e -> - mSGNL (print_toplevel_error (process_error e)) + msgnl (print_toplevel_error (process_error e)) end; flush_all() @@ -309,10 +309,10 @@ let rec coq_switch b = | Vernacinterp.ProtectedLoop -> Lib.declare_initial_state(); coq_switch false - | End_of_input -> mSGERRNL [<>]; pp_flush(); exit 0 + | End_of_input -> msgerrnl (mt ()); pp_flush(); exit 0 | Vernacinterp.Quit -> exit 0 | e -> - mSGERRNL [< 'sTR"Anomaly: toplevel loop. Please report." >]; + msgerrnl (str"Anomaly: toplevel loop. Please report."); coq_switch b let loop () = coq_switch true diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index b7d34070a..3562acd7a 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -111,8 +111,8 @@ let rec vernac interpfun input = let tstart = System.get_time() in interp v; let tend = System.get_time() in - mSGNL [< 'sTR"Finished transaction in " ; - System.fmt_time_difference tstart tend >] + msgnl (str"Finished transaction in " ++ + System.fmt_time_difference tstart tend) | _ -> if not !just_parsing then interpfun com in diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index 1ce0e27a1..d5366f8c6 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -58,85 +58,85 @@ let show_script () = let pts = get_pftreestate () in let pf = proof_of_pftreestate pts and evc = evc_of_pftreestate pts in - mSGNL(Refiner.print_script true evc (Global.named_context()) pf) + msgnl(Refiner.print_script true evc (Global.named_context()) pf) let show_prooftree () = let pts = get_pftreestate () in let pf = proof_of_pftreestate pts and evc = evc_of_pftreestate pts in - mSG(Refiner.print_proof evc (Global.named_context()) pf) + msg(Refiner.print_proof evc (Global.named_context()) pf) let show_open_subgoals () = let pfts = get_pftreestate () in - mSG(pr_subgoals_of_pfts pfts) + msg(pr_subgoals_of_pfts pfts) let show_nth_open_subgoal n = let pf = proof_of_pftreestate (get_pftreestate ()) in - mSG(pr_subgoal n (fst(frontier pf))) + msg(pr_subgoal n (fst(frontier pf))) let show_open_subgoals_focused () = let pfts = get_pftreestate () in match focus() with | 0 -> - mSG(pr_subgoals_of_pfts pfts) + msg(pr_subgoals_of_pfts pfts) | n -> let pf = proof_of_pftreestate pfts in let gls = fst(frontier pf) in if n > List.length gls then - (make_focus 0; mSG(pr_subgoals_of_pfts pfts)) + (make_focus 0; msg(pr_subgoals_of_pfts pfts)) else if List.length gls < 2 then - mSG(pr_subgoal n gls) + msg(pr_subgoal n gls) else - mSG (v 0 [< 'iNT(List.length gls); 'sTR" subgoals"; 'cUT; - pr_subgoal n gls >]) + msg (v 0 (int(List.length gls) ++ str" subgoals" ++ cut () ++ + pr_subgoal n gls)) let show_node () = let pts = get_pftreestate () in let pf = proof_of_pftreestate pts and cursor = cursor_of_pftreestate pts in - mSG [< prlist_with_sep pr_spc pr_int (List.rev cursor); 'fNL ; - prgl pf.goal ; 'fNL ; + msg (prlist_with_sep pr_spc pr_int (List.rev cursor) ++ fnl () ++ + prgl pf.goal ++ fnl () ++ (match pf.ref with - | None -> [< 'sTR"BY <rule>" >] + | None -> (str"BY <rule>") | Some(r,spfl) -> - [< 'sTR"BY "; Refiner.pr_rule r; 'fNL; 'sTR" "; - hOV 0 (prlist_with_sep pr_fnl prgl - (List.map (fun p -> p.goal) spfl)) >]); - 'fNL >] + (str"BY " ++ Refiner.pr_rule r ++ fnl () ++ str" " ++ + hov 0 (prlist_with_sep pr_fnl prgl + (List.map (fun p -> p.goal) spfl)))) ++ + fnl ()) let show_top_evars () = let pfts = get_pftreestate () in let gls = top_goal_of_pftreestate pfts in let sigma = project gls in - mSG (pr_evars_int 1 (Evd.non_instantiated sigma)) + msg (pr_evars_int 1 (Evd.non_instantiated sigma)) let locate_file f = try let _,file = System.where_in_path (Library.get_load_path()) f in - mSG [< 'sTR file; 'fNL >] + msg (str file ++ fnl ()) with Not_found -> - mSG (hOV 0 [< 'sTR"Can't find file"; 'sPC; 'sTR f; 'sPC; - 'sTR"on loadpath"; 'fNL >]) + msg (hov 0 (str"Can't find file" ++ spc () ++ str f ++ spc () ++ + str"on loadpath" ++ fnl ())) let print_located_qualid qid = try let sp = Nametab.sp_of_global (Global.env()) (Nametab.locate qid) in - mSG [< pr_sp sp; 'fNL >] + msg (pr_sp sp ++ fnl ()) with Not_found -> try - mSG [< pr_sp (Syntax_def.locate_syntactic_definition qid); 'fNL >] + msg (pr_sp (Syntax_def.locate_syntactic_definition qid) ++ fnl ()) with Not_found -> error ((Nametab.string_of_qualid qid) ^ " is not a defined object") let print_path_entry (s,l) = - [< 'sTR s; 'tBRK (0,2); 'sTR (string_of_dirpath l) >] + (str s ++ tbrk (0,2) ++ str (string_of_dirpath l)) let print_loadpath () = let l = Library.get_full_load_path () in - mSGNL (Pp.t [< 'sTR "Physical path: "; - 'tAB; 'sTR "Logical Path:"; 'fNL; - prlist_with_sep pr_fnl print_path_entry l >]) + msgnl (Pp.t (str "Physical path: " ++ + tab () ++ str "Logical Path:" ++ fnl () ++ + prlist_with_sep pr_fnl print_path_entry l)) let get_current_context_of_args = function | [VARG_NUMBER n] -> get_goal_context n @@ -157,21 +157,21 @@ let _ = let msg_found_library = function | Library.LibLoaded, fulldir, file -> - mSG [< pr_dirpath fulldir; 'sTR " has been loaded from file"; 'fNL; - 'sTR file; 'fNL >] + msg (pr_dirpath fulldir ++ str " has been loaded from file" ++ fnl () ++ + str file ++ fnl ()) | Library.LibInPath, fulldir, file -> - mSG [< pr_dirpath fulldir; 'sTR " is bound to file "; 'sTR file; 'fNL >] + msg (pr_dirpath fulldir ++ str " is bound to file " ++ str file ++ fnl ()) let msg_notfound_library qid = function | Library.LibUnmappedDir -> let dir = fst (Nametab.repr_qualid qid) in errorlabstrm "locate_library" - [< 'sTR "Cannot find a physical path bound to logical path "; - pr_dirpath dir; 'fNL >] + (str "Cannot find a physical path bound to logical path " ++ + pr_dirpath dir ++ fnl ()) | Library.LibNotFound -> - mSG (hOV 0 - [< 'sTR"Unable to locate library"; - 'sPC; Nametab.pr_qualid qid; 'fNL >]) + msg (hov 0 + (str"Unable to locate library" ++ + spc () ++ Nametab.pr_qualid qid ++ fnl ())) | e -> assert false let _ = @@ -375,10 +375,10 @@ let _ = and loaded = Library.loaded_modules () in let loaded_opened = list_intersect loaded opened and only_loaded = list_subtract loaded opened in - mSG [< 'sTR"Loaded and imported modules: "; - pr_vertical_list pr_dirpath loaded_opened; 'fNL; - 'sTR"Loaded and not imported modules: "; - pr_vertical_list pr_dirpath only_loaded >]) + msg (str"Loaded and imported modules: " ++ + pr_vertical_list pr_dirpath loaded_opened ++ fnl () ++ + str"Loaded and not imported modules: " ++ + pr_vertical_list pr_dirpath only_loaded)) | _ -> bad_vernac_args "PrintModules") (* Sections *) @@ -516,7 +516,7 @@ let coercion_of_qualid loc qid = let coe = Classops.coe_of_reference ref in if not (Classops.coercion_exists coe) then errorlabstrm "try_add_coercion" - [< Printer.pr_global ref; 'sTR" is not a coercion" >]; + (Printer.pr_global ref ++ str" is not a coercion"); coe let _ = declare_bool_option @@ -675,14 +675,14 @@ let _ = let cursor = cursor_of_pftreestate pts in let evc = evc_of_pftreestate pts in let (pfterm,meta_types) = extract_open_pftreestate pts in - mSGNL [< 'sTR"LOC: " ; - prlist_with_sep pr_spc pr_int (List.rev cursor); 'fNL ; - 'sTR"Subgoals" ; 'fNL ; + msgnl (str"LOC: " ++ + prlist_with_sep pr_spc pr_int (List.rev cursor) ++ fnl () ++ + str"Subgoals" ++ fnl () ++ prlist (fun (mv,ty) -> - [< 'iNT mv ; 'sTR" -> " ; prtype ty ; 'fNL >]) - meta_types; - 'sTR"Proof: " ; prterm (Evarutil.nf_evar evc pfterm) >]) + (int mv ++ str" -> " ++ prtype ty ++ fnl ())) + meta_types ++ + str"Proof: " ++ prterm (Evarutil.nf_evar evc pfterm))) | _ -> bad_vernac_args "ShowProof") let _ = @@ -698,11 +698,11 @@ let _ = try Inductiveops.control_only_guard (Evarutil.evar_env pf.goal) pfterm; - [< 'sTR "The condition holds up to here" >] + (str "The condition holds up to here") with UserError(_,s) -> - [< 'sTR ("Condition violated : ") ;s >] + (str ("Condition violated : ") ++s) in - mSGNL message) + msgnl message) | _ -> bad_vernac_args "CheckGuard") let _ = @@ -729,7 +729,7 @@ let _ = | (n::l) -> aux (Tacmach.traverse n pts) l in let pts = aux pts (l@[-1]) in let pf = proof_of_pftreestate pts in - mSG (Refiner.print_script true evc (Global.named_context()) pf)) + msg (Refiner.print_script true evc (Global.named_context()) pf)) let _ = add "ExplainProofTree" @@ -743,26 +743,26 @@ let _ = | (n::l) -> aux (Tacmach.traverse n pts) l in let pts = aux pts (l@[-1]) in let pf = proof_of_pftreestate pts in - mSG (Refiner.print_proof evc (Global.named_context()) pf)) + msg (Refiner.print_proof evc (Global.named_context()) pf)) let _ = add "ShowProofs" (function [] -> (fun () -> let l = Pfedit.get_all_proof_names() in - mSGNL (prlist_with_sep pr_spc pr_id l)) + msgnl (prlist_with_sep pr_spc pr_id l)) | _ -> bad_vernac_args "ShowProofs") let _ = add "PrintAll" (function - | [] -> (fun () -> mSG(print_full_context_typ ())) + | [] -> (fun () -> msg(print_full_context_typ ())) | _ -> bad_vernac_args "PrintAll") let _ = add "PRINT" (function - | [] -> (fun () -> mSG(print_local_context())) + | [] -> (fun () -> msg(print_local_context())) | _ -> bad_vernac_args "PRINT") (* Pris en compte dans PrintOption *) @@ -770,19 +770,19 @@ let _ = let _ = add "PrintId" (function - | [VARG_QUALID qid] -> (fun () -> mSG(print_name qid)) + | [VARG_QUALID qid] -> (fun () -> msg(print_name qid)) | _ -> bad_vernac_args "PrintId") let _ = add "PrintOpaqueId" (function - | [VARG_QUALID qid] -> (fun () -> mSG(print_opaque_name qid)) + | [VARG_QUALID qid] -> (fun () -> msg(print_opaque_name qid)) | _ -> bad_vernac_args "PrintOpaqueId") let _ = add "PrintSec" (function - | [VARG_QUALID qid] -> (fun () -> mSG(print_sec_context_typ qid)) + | [VARG_QUALID qid] -> (fun () -> msg(print_sec_context_typ qid)) | _ -> bad_vernac_args "PrintSec") let _ = declare_bool_option @@ -824,8 +824,8 @@ let _ = fun () -> begin if (kind = "LETTOP") && not(refining ()) then - errorlabstrm "Vernacentries.StartProof" [< 'sTR - "Let declarations can only be used in proof editing mode" >]; + errorlabstrm "Vernacentries.StartProof" (str + "Let declarations can only be used in proof editing mode"); start_proof_com (Some s) stre com; if_verbose show_open_subgoals () end @@ -863,15 +863,15 @@ let _ = () with e -> if (is_unsafe "proof") && not (kind = "LETTOP") then begin - mSGNL [< 'sTR "Warning: checking of theorem "; pr_id id; - 'sPC; 'sTR "failed"; - 'sTR "... converting to Axiom" >]; + msgnl (str "Warning: checking of theorem " ++ pr_id id ++ + spc () ++ str "failed" ++ + str "... converting to Axiom"); delete_proof id; let _ = parameter_def_var id com in () end else errorlabstrm "Vernacentries.TheoremProof" - [< 'sTR "checking of theorem "; pr_id id; 'sPC; - 'sTR "failed... aborting" >]) + (str "checking of theorem " ++ pr_id id ++ spc () ++ + str "failed... aborting")) | _ -> bad_vernac_args "TheoremProof") let _ = @@ -964,7 +964,7 @@ let _ = | VARG_TACTIC_ARG (Redexp redexp) :: VARG_CONSTR c :: g -> let (evmap,sign) = get_current_context_of_args g in let redfun = print_eval (reduction_of_redexp redexp) sign in - fun () -> mSG (redfun (judgment_of_rawconstr evmap sign c)) + fun () -> msg (redfun (judgment_of_rawconstr evmap sign c)) | _ -> bad_vernac_args "Eval") let _ = @@ -977,14 +977,14 @@ let _ = let c = interp_constr evmap env c in let senv = Global.safe_env() in let j = Safe_typing.typing senv c in - mSG (print_safe_judgment env j)) + msg (print_safe_judgment env j)) | VARG_STRING "CHECK" :: VARG_CONSTR c :: g -> (fun () -> let (evmap, env) = get_current_context_of_args g in let c = interp_constr evmap env c in let (j,cst) = Typeops.infer env c in let _ = Environ.add_constraints cst env in - mSG (print_judgment env j)) + msg (print_judgment env j)) | _ -> bad_vernac_args "Check") @@ -1031,7 +1031,7 @@ let _ = let _ = add "INSPECT" (function - | [VARG_NUMBER n] -> (fun () -> mSG(inspect n)) + | [VARG_NUMBER n] -> (fun () -> msg(inspect n)) | _ -> bad_vernac_args "INSPECT") let _ = @@ -1340,19 +1340,19 @@ let _ = let _ = add "PrintGRAPH" (function - | [] -> (fun () -> pPNL (Prettyp.print_graph())) + | [] -> (fun () -> ppnl (Prettyp.print_graph())) | _ -> bad_vernac_args "PrintGRAPH") let _ = add "PrintCLASSES" (function - | [] -> (fun () -> pPNL (Prettyp.print_classes())) + | [] -> (fun () -> ppnl (Prettyp.print_classes())) | _ -> bad_vernac_args "PrintCLASSES") let _ = add "PrintCOERCIONS" (function - | [] -> (fun () -> pPNL (Prettyp.print_coercions())) + | [] -> (fun () -> ppnl (Prettyp.print_coercions())) | _ -> bad_vernac_args "PrintCOERCIONS") let _ = @@ -1360,7 +1360,7 @@ let _ = (function | [VARG_QUALID qids;VARG_QUALID qidt] -> (fun () -> - pPNL (Prettyp.print_path_between + ppnl (Prettyp.print_path_between (cl_of_qualid qids) (cl_of_qualid qidt))) | _ -> bad_vernac_args "PrintPATH") @@ -1702,7 +1702,7 @@ let _ = if (string_of_id t) = "Tables" then print_tables () else - mSG(print_name (Nametab.make_short_qualid t))) + msg(print_name (Nametab.make_short_qualid t))) | _ -> bad_vernac_args "TableField") @@ -1792,13 +1792,13 @@ let _ = vinterp_add "PrintMLModules" let _ = vinterp_add "DumpUniverses" (function - | [] -> (fun () -> pP (Univ.pr_universes (Global.universes ()))) + | [] -> (fun () -> pp (Univ.pr_universes (Global.universes ()))) | [VARG_STRING s] -> (fun () -> let output = open_out s in try Univ.dump_universes output (Global.universes ()); close_out output; - mSG [<'sTR ("Universes written to file \""^s^"\"."); 'fNL >] + msg (str ("Universes written to file \""^s^"\".") ++ fnl ()) with e -> close_out output; raise e ) diff --git a/toplevel/vernacinterp.ml b/toplevel/vernacinterp.ml index 0b32cd141..039a42766 100644 --- a/toplevel/vernacinterp.ml +++ b/toplevel/vernacinterp.ml @@ -23,7 +23,7 @@ exception Quit let disable_drop e = if e <> Drop then e - else UserError("Vernac.disable_drop",[< 'sTR"Drop is forbidden." >]) + else UserError("Vernac.disable_drop",(str"Drop is forbidden.")) type vernac_arg = | VARG_VARGLIST of vernac_arg list @@ -54,7 +54,7 @@ let vinterp_add s f = Hashtbl.add vernac_tab s f with Failure _ -> errorlabstrm "vinterp_add" - [< 'sTR"Cannot add the vernac command " ; 'sTR s ; 'sTR" twice" >] + (str"Cannot add the vernac command " ++ str s ++ str" twice") let overwriting_vinterp_add s f = begin @@ -69,7 +69,7 @@ let vinterp_map s = Hashtbl.find vernac_tab s with Not_found -> errorlabstrm "Vernac Interpreter" - [< 'sTR"Cannot find vernac command " ; 'sTR s >] + (str"Cannot find vernac command " ++ str s) let vinterp_init () = Hashtbl.clear vernac_tab @@ -110,8 +110,8 @@ let rec cvt_varg ast = VARG_TACTIC_ARG (interp_tacarg ist targ) | Node(_,"VERNACDYN",[Dynamic (_,d)]) -> VARG_DYN d | _ -> anomaly_loc (Ast.loc ast, "Vernacinterp.cvt_varg", - [< 'sTR "Unrecognizable ast node of vernac arg:"; - 'bRK(1,0); print_ast ast >]) + (str "Unrecognizable ast node of vernac arg:" ++ + brk(1,0) ++ print_ast ast)) (* Interpretation of a vernac command *) @@ -128,7 +128,7 @@ let call (opn,converted_args) = | ProtectedLoop -> raise ProtectedLoop | e -> if !Options.debug then - mSGNL [< 'sTR"Vernac Interpreter " ; 'sTR !loc >]; + msgnl (str"Vernac Interpreter " ++ str !loc); raise e let interp = function @@ -138,14 +138,14 @@ let interp = function List.map cvt_varg argl with e -> if !Options.debug then - mSGNL [< 'sTR"Vernac Interpreter " ; 'sTR"Converting arguments" >]; + msgnl (str"Vernac Interpreter " ++ str"Converting arguments"); raise e in call (opn,converted_args) | cmd -> errorlabstrm "Vernac Interpreter" - [< 'sTR"Malformed vernac AST : " ; print_ast cmd >] + (str"Malformed vernac AST : " ++ print_ast cmd) let bad_vernac_args s = anomalylabstrm s - [< 'sTR"Vernac "; 'sTR s; 'sTR" called with bad arguments" >] + (str"Vernac " ++ str s ++ str" called with bad arguments") |