skalberg@14620: (*  Title:      HOL/Import/import_syntax.ML
skalberg@14620:     ID:         $Id$
skalberg@14620:     Author:     Sebastian Skalberg (TU Muenchen)
skalberg@14620: *)
skalberg@14620: 
skalberg@14516: signature HOL4_IMPORT_SYNTAX =
skalberg@14516: sig
skalberg@14516:     type token = OuterSyntax.token
skalberg@14516: 
skalberg@14516:     val import_segment: token list -> (theory -> theory) * token list
skalberg@14516:     val import_theory : token list -> (theory -> theory) * token list
skalberg@14516:     val end_import    : token list -> (theory -> theory) * token list
skalberg@14516: 
skalberg@14516:     val setup_theory  : token list -> (theory -> theory) * token list
skalberg@14516:     val end_setup     : token list -> (theory -> theory) * token list
skalberg@14516: 
skalberg@14516:     val thm_maps      : token list -> (theory -> theory) * token list
skalberg@14516:     val ignore_thms   : token list -> (theory -> theory) * token list
skalberg@14516:     val type_maps     : token list -> (theory -> theory) * token list
skalberg@14516:     val def_maps      : token list -> (theory -> theory) * token list
skalberg@14516:     val const_maps    : token list -> (theory -> theory) * token list
skalberg@14516:     val const_moves   : token list -> (theory -> theory) * token list
skalberg@14516:     val const_renames : token list -> (theory -> theory) * token list
skalberg@14516: 
skalberg@14516:     val setup        : unit -> unit
skalberg@14516: end
skalberg@14516: 
skalberg@14516: structure HOL4ImportSyntax :> HOL4_IMPORT_SYNTAX =
skalberg@14516: struct
skalberg@14516: 
skalberg@14516: type token = OuterSyntax.token
skalberg@14516: 
skalberg@14516: local structure P = OuterParse and K = OuterSyntax.Keyword in
skalberg@14516: 
skalberg@14516: (* Parsers *)
skalberg@14516: 
skalberg@14516: val import_segment = P.name >> set_import_segment
skalberg@14516: 
skalberg@14516: val import_theory = P.name >> (fn thyname =>
skalberg@14516: 			       fn thy =>
skalberg@14516: 				  thy |> set_generating_thy thyname
skalberg@14516: 				      |> Theory.add_path thyname
skalberg@14516: 				      |> add_dump (";setup_theory " ^ thyname))
skalberg@14516: 
skalberg@14518: fun end_import toks =
skalberg@14518:     Scan.succeed
skalberg@14518: 	(fn thy =>
skalberg@14518: 	    let
skalberg@14518: 		val thyname = get_generating_thy thy
skalberg@14518: 		val segname = get_import_segment thy
skalberg@14518: 		val (int_thms,facts) = Replay.setup_int_thms thyname thy
skalberg@14518: 		val thmnames = filter (not o should_ignore thyname thy) facts
skalberg@14518: 	    in
skalberg@14518: 		thy |> clear_import_thy
skalberg@14518: 		    |> set_segment thyname segname
skalberg@14518: 		    |> set_used_names facts
skalberg@14518: 		    |> Replay.import_thms thyname int_thms thmnames
skalberg@14518: 		    |> clear_used_names
skalberg@14518: 		    |> export_hol4_pending
skalberg@14518: 		    |> Theory.parent_path
skalberg@14518: 		    |> dump_import_thy thyname
skalberg@14518: 		    |> add_dump ";end_setup"
skalberg@14518: 	    end) toks
skalberg@14516: 
skalberg@14516: val ignore_thms = Scan.repeat1 P.name
skalberg@14516: 			       >> (fn ignored =>
skalberg@14516: 				   fn thy =>
skalberg@14516: 				      let
skalberg@14516: 					  val thyname = get_import_thy thy
skalberg@14516: 				      in
skalberg@14516: 					  foldl (fn (thy,thmname) => ignore_hol4 thyname thmname thy) (thy,ignored)
skalberg@14516: 				      end)
skalberg@14516: 
skalberg@14516: val thm_maps = Scan.repeat1 (P.name --| P.$$$ ">" -- P.xname)
skalberg@14516: 			    >> (fn thmmaps =>
skalberg@14516: 				fn thy =>
skalberg@14516: 				   let
skalberg@14516: 				       val thyname = get_import_thy thy
skalberg@14516: 				   in
skalberg@14516: 				       foldl (fn (thy,(hol,isa)) => add_hol4_mapping thyname hol isa thy) (thy,thmmaps)
skalberg@14516: 				   end)
skalberg@14516: 
skalberg@14516: val type_maps = Scan.repeat1 (P.name --| P.$$$ ">" -- P.xname)
skalberg@14516: 			     >> (fn typmaps =>
skalberg@14516: 				 fn thy =>
skalberg@14516: 				    let
skalberg@14516: 					val thyname = get_import_thy thy
skalberg@14516: 				    in
skalberg@14516: 					foldl (fn (thy,(hol,isa)) => add_hol4_type_mapping thyname hol false isa thy) (thy,typmaps)
skalberg@14516: 				    end)
skalberg@14516: 
skalberg@14516: val def_maps = Scan.repeat1 (P.name --| P.$$$ ">" -- P.xname)
skalberg@14516: 			    >> (fn defmaps =>
skalberg@14516: 				fn thy =>
skalberg@14516: 				   let
skalberg@14516: 				       val thyname = get_import_thy thy
skalberg@14516: 				   in
skalberg@14516: 				       foldl (fn (thy,(hol,isa)) => add_defmap thyname hol isa thy) (thy,defmaps)
skalberg@14516: 				   end)
skalberg@14516: 
skalberg@14516: val const_renames = Scan.repeat1 (P.name --| P.$$$ ">" -- P.name)
skalberg@14516: 				 >> (fn renames =>
skalberg@14516: 				     fn thy =>
skalberg@14516: 					let
skalberg@14516: 					    val thyname = get_import_thy thy
skalberg@14516: 					in
skalberg@14516: 					    foldl (fn (thy,(hol,isa)) => add_hol4_const_renaming thyname hol isa thy) (thy,renames)
skalberg@14516: 					end)
skalberg@14516: 																      
skalberg@14516: val const_maps = Scan.repeat1 (P.name --| P.$$$ ">" -- P.xname -- Scan.option (P.$$$ "::" |-- P.typ))
skalberg@14516: 			      >> (fn constmaps =>
skalberg@14516: 				  fn thy =>
skalberg@14516: 				     let
skalberg@14516: 					 val thyname = get_import_thy thy
skalberg@14516: 				     in
skalberg@14516: 					 foldl (fn (thy,((hol,isa),None)) => add_hol4_const_mapping thyname hol false isa thy
skalberg@14516: 						 | (thy,((hol,isa),Some ty)) => add_hol4_const_wt_mapping thyname hol false isa (typ_of (read_ctyp (sign_of thy) ty)) thy) (thy,constmaps)
skalberg@14516: 				     end)
skalberg@14516: 
skalberg@14516: val const_moves = Scan.repeat1 (P.name --| P.$$$ ">" -- P.xname -- Scan.option (P.$$$ "::" |-- P.typ))
skalberg@14516: 			       >> (fn constmaps =>
skalberg@14516: 				   fn thy =>
skalberg@14516: 				      let
skalberg@14516: 					  val thyname = get_import_thy thy
skalberg@14516: 				      in
skalberg@14516: 					  foldl (fn (thy,((hol,isa),None)) => add_hol4_const_mapping thyname hol true isa thy
skalberg@14516: 						  | (thy,((hol,isa),Some ty)) => add_hol4_const_wt_mapping thyname hol true isa (typ_of (read_ctyp (sign_of thy) ty)) thy) (thy,constmaps)
skalberg@14516: 				      end)
skalberg@14516: 
skalberg@14516: fun import_thy s =
skalberg@14516:     let
skalberg@14516: 	val is = TextIO.openIn(s ^ ".imp")
skalberg@14516: 	val inp = TextIO.inputAll is
skalberg@14516: 	val _ = TextIO.closeIn is
skalberg@14516: 	val orig_source = Source.of_string inp
skalberg@14516: 	val symb_source = Symbol.source false orig_source
skalberg@14516: 	val lexes = ref (OuterLex.make_lexicon ["import_segment","ignore_thms","import","end",">","::","const_maps","const_moves","thm_maps","const_renames","type_maps","def_maps"],
skalberg@14516: 			 Scan.empty_lexicon)
skalberg@14516: 	val get_lexes = fn () => !lexes
skalberg@14516: 	val token_source = OuterLex.source false get_lexes (Position.line 1) symb_source
skalberg@14516: 	val token_list = filter (not o (OuterLex.is_kind OuterLex.Space)) (Source.exhaust token_source)
skalberg@14516: 	val import_segmentP = OuterParse.$$$ "import_segment" |-- import_segment
skalberg@14516: 	val type_mapsP = OuterParse.$$$ "type_maps" |-- type_maps
skalberg@14516: 	val def_mapsP = OuterParse.$$$ "def_maps" |-- def_maps
skalberg@14516: 	val const_mapsP = OuterParse.$$$ "const_maps" |-- const_maps
skalberg@14516: 	val const_movesP = OuterParse.$$$ "const_moves" |-- const_moves
skalberg@14516: 	val const_renamesP = OuterParse.$$$ "const_renames" |-- const_renames
skalberg@14516: 	val ignore_thmsP = OuterParse.$$$ "ignore_thms" |-- ignore_thms
skalberg@14516: 	val thm_mapsP = OuterParse.$$$ "thm_maps" |-- thm_maps
skalberg@14516: 	val parser = type_mapsP || def_mapsP || const_mapsP || const_movesP || const_renamesP || thm_mapsP || ignore_thmsP || import_segmentP
skalberg@14516: 	val importP = OuterParse.$$$ "import" |-- Scan.repeat parser --| OuterParse.$$$ "end"
skalberg@14516: 	fun apply [] thy = thy
skalberg@14516: 	  | apply (f::fs) thy = apply fs (f thy)
skalberg@14516:     in
skalberg@14516: 	apply (set_replaying_thy s::Theory.add_path s::(fst (importP token_list)))
skalberg@14516:     end
skalberg@14516: 
skalberg@14620: fun create_int_thms thyname thy =
skalberg@14620:     case ImportData.get thy of
skalberg@14620: 	None => ImportData.put (Some (fst (Replay.setup_int_thms thyname thy))) thy
skalberg@14620:       | Some _ => error "Import data not closed - forgotten an end_setup, mayhap?"
skalberg@14620: 
skalberg@14620: fun clear_int_thms thy =
skalberg@14620:     case ImportData.get thy of
skalberg@14620: 	None => error "Import data already cleared - forgotten a setup_theory?"
skalberg@14620:       | Some _ => ImportData.put None thy
skalberg@14620: 
skalberg@14516: val setup_theory = P.name
skalberg@14516: 		       >>
skalberg@14516: 		       (fn thyname =>
skalberg@14516: 			fn thy =>
skalberg@14620: 			   (case HOL4DefThy.get thy of
skalberg@14620: 				NoImport => thy
skalberg@14620: 			      | Generating _ => error "Currently generating a theory!"
skalberg@14620: 			      | Replaying _ => thy |> clear_import_thy)
skalberg@14620: 			       |> import_thy thyname
skalberg@14620: 			       |> create_int_thms thyname)
skalberg@14516: 
skalberg@14518: fun end_setup toks =
skalberg@14518:     Scan.succeed
skalberg@14518: 	(fn thy =>
skalberg@14518: 	    let
skalberg@14518: 		val thyname = get_import_thy thy
skalberg@14518: 		val segname = get_import_segment thy
skalberg@14518: 	    in
skalberg@14518: 		thy |> set_segment thyname segname
skalberg@14518: 		    |> clear_import_thy
skalberg@14620: 		    |> clear_int_thms
skalberg@14518: 		    |> Theory.parent_path
skalberg@14518: 	    end) toks
skalberg@14516: 
skalberg@14516: val set_dump  = P.string -- P.string   >> setup_dump
skalberg@14518: fun fl_dump toks  = Scan.succeed flush_dump toks
skalberg@14516: val append_dump = (P.verbatim || P.string) >> add_dump
skalberg@14516: 
skalberg@14516: val parsers = 
skalberg@14516:   [OuterSyntax.command "import_segment"
skalberg@14516: 		       "Set import segment name"
skalberg@14516: 		       K.thy_decl (import_segment >> Toplevel.theory),
skalberg@14516:    OuterSyntax.command "import_theory"
skalberg@14516: 		       "Set default HOL4 theory name"
skalberg@14516: 		       K.thy_decl (import_theory >> Toplevel.theory),
skalberg@14516:    OuterSyntax.command "end_import"
skalberg@14516: 		       "End HOL4 import"
skalberg@14516: 		       K.thy_decl (end_import >> Toplevel.theory),
skalberg@14516:    OuterSyntax.command "setup_theory"
skalberg@14516: 		       "Setup HOL4 theory replaying"
skalberg@14516: 		       K.thy_decl (setup_theory >> Toplevel.theory),
skalberg@14516:    OuterSyntax.command "end_setup"
skalberg@14516: 		       "End HOL4 setup"
skalberg@14516: 		       K.thy_decl (end_setup >> Toplevel.theory),
skalberg@14516:    OuterSyntax.command "setup_dump"
skalberg@14516: 		       "Setup the dump file name"
skalberg@14516: 		       K.thy_decl (set_dump >> Toplevel.theory),
skalberg@14516:    OuterSyntax.command "append_dump"
skalberg@14516: 		       "Add text to dump file"
skalberg@14516: 		       K.thy_decl (append_dump >> Toplevel.theory),
skalberg@14516:    OuterSyntax.command "flush_dump"
skalberg@14516: 		       "Write the dump to file"
skalberg@14516: 		       K.thy_decl (fl_dump >> Toplevel.theory),
skalberg@14516:    OuterSyntax.command "ignore_thms"
skalberg@14516: 		       "Theorems to ignore in next HOL4 theory import"
skalberg@14516: 		       K.thy_decl (ignore_thms >> Toplevel.theory),
skalberg@14516:    OuterSyntax.command "type_maps"
skalberg@14516: 		       "Map HOL4 type names to existing Isabelle/HOL type names"
skalberg@14516: 		       K.thy_decl (type_maps >> Toplevel.theory),
skalberg@14516:    OuterSyntax.command "def_maps"
skalberg@14516: 		       "Map HOL4 constant names to their primitive definitions"
skalberg@14516: 		       K.thy_decl (def_maps >> Toplevel.theory),
skalberg@14516:    OuterSyntax.command "thm_maps"
skalberg@14516: 		       "Map HOL4 theorem names to existing Isabelle/HOL theorem names"
skalberg@14516: 		       K.thy_decl (thm_maps >> Toplevel.theory),
skalberg@14516:    OuterSyntax.command "const_renames"
skalberg@14516: 		       "Rename HOL4 const names"
skalberg@14516: 		       K.thy_decl (const_renames >> Toplevel.theory),
skalberg@14516:    OuterSyntax.command "const_moves"
skalberg@14516: 		       "Rename HOL4 const names to other HOL4 constants"
skalberg@14516: 		       K.thy_decl (const_moves >> Toplevel.theory),
skalberg@14516:    OuterSyntax.command "const_maps"
skalberg@14516: 		       "Map HOL4 const names to existing Isabelle/HOL const names"
skalberg@14516: 		       K.thy_decl (const_maps >> Toplevel.theory)]
skalberg@14516: 
skalberg@14516: fun setup () = (OuterSyntax.add_keywords[">"];
skalberg@14516: 		OuterSyntax.add_parsers parsers)
skalberg@14516: 
skalberg@14516: end
skalberg@14516: 
skalberg@14516: end