src/Pure/ProofGeneral/proof_general_pgip.ML
changeset 22225 30ab97554602
parent 22216 c3f5aa951a68
child 22228 7c27195a4afc
equal deleted inserted replaced
22224:6c2373adc7a0 22225:30ab97554602
   353     in
   353     in
   354         issue_pgip (Metainforesponse {attrs=[("infotype", "isabelle_theorem_dependencies")],
   354         issue_pgip (Metainforesponse {attrs=[("infotype", "isabelle_theorem_dependencies")],
   355                                       content=[valuethms,valuedeps]})
   355                                       content=[valuethms,valuedeps]})
   356     end
   356     end
   357 
   357 
   358 (* FIXME: check this uses non-transitive closure function here *)
       
   359 fun tell_thm_deps ths =
   358 fun tell_thm_deps ths =
   360   if Output.has_mode thm_depsN then
   359   if Output.has_mode thm_depsN then 
   361     let
   360       let 
   362       val names = filter_out (equal "") (map PureThy.get_name_hint ths); (* da: HAS THIS NOW BECOME "??.unknown"? *)
   361 	  val names = filter_out (equal PureThy.unknown_name_hint) (map PureThy.get_name_hint ths) 
   363       val deps = filter_out (equal "")
   362 	  val deps = (Symtab.keys (fold Proofterm.thms_of_proof'
   364         (Symtab.keys (fold Proofterm.thms_of_proof
   363 					(map Thm.proof_of ths) Symtab.empty))
   365           (map Thm.proof_of ths) Symtab.empty));
   364       in 
   366     in
   365 	  if null names orelse null deps then ()
   367       if null names orelse null deps then ()
   366 	  else thm_deps_message (spaces_quote names, spaces_quote deps)
   368       else thm_deps_message (spaces_quote names, spaces_quote deps)
   367       end
   369     end
   368   else ()
   370   else ();
       
   371 
   369 
   372 in
   370 in
   373 
   371 
   374 fun setup_present_hook () =
   372 fun setup_present_hook () =
   375   Present.add_hook (fn _ => fn res => tell_thm_deps (maps #2 res));
   373   Present.add_hook (fn _ => fn res => tell_thm_deps (maps #2 res));
   575         val thyname = #thyname vs    (* ask for identifiers within a theory *)
   573         val thyname = #thyname vs    (* ask for identifiers within a theory *)
   576         val objtype = #objtype vs    (* ask for identifiers of a particular type *)
   574         val objtype = #objtype vs    (* ask for identifiers of a particular type *)
   577 
   575 
   578         fun idtable ty ctx ids = {objtype=ty,context=ctx,ids=ids}
   576         fun idtable ty ctx ids = {objtype=ty,context=ctx,ids=ids}
   579 
   577 
   580 	fun setids t  = issue_pgip (Setids {idtables = [t]})
   578 	fun setids t = issue_pgip (Setids {idtables = [t]})
   581 
   579 
   582         val thms_of_thy = map fst o PureThy.thms_of o ThyInfo.get_theory
   580         (* fake one-level nested "subtheories" by picking apart names. *)
   583     in
   581         val thms_of_thy = 
   584 (*      case (url_attr,thyname,objtype) of
   582 	    map fst o NameSpace.extern_table o PureThy.theorems_of o ThyInfo.get_theory;
   585             (NONE,NONE,NONE) =>
   583         val isnested_id =  String.isSubstring NameSpace.separator
   586 *)          (* top-level: return *)
   584         val immed_thms_of_thy = filter_out isnested_id o thms_of_thy
   587 
   585         fun thy_prefix s = case space_explode NameSpace.separator s of
   588         (* TODO: add askids for "file" here, which returns single theory with same name *)
   586 				    x::_::_ => SOME x  (* String.find? *)
   589         (* FIXME: objtypes on both sides *)
   587 				  | _ => NONE
       
   588 	fun subthys_of_thy s = 
       
   589 	    foldl  (fn (NONE,xs) => xs | (SOME x,xs) => insert op= x xs) [] 
       
   590 		   (map thy_prefix (thms_of_thy s))
       
   591 	fun subthms_of_thy thy = 
       
   592 	    (case thy_prefix thy of 
       
   593 		 NONE => immed_thms_of_thy thy
       
   594 	       | SOME prf => filter (String.isPrefix (unprefix (prf ^ NameSpace.separator) thy))
       
   595 				    (thms_of_thy prf))
       
   596        val qualified_thms_of_thy = (* for global query with single response *)
       
   597 	    filter_out (equal PureThy.unknown_name_hint) o 
       
   598 	    (map fst) o PureThy.thms_of o ThyInfo.get_theory;
       
   599     in 
   590         case (thyname,objtype) of
   600         case (thyname,objtype) of
   591            (* only files known in top context *)
   601            (NONE, NONE) => 
   592            (NONE, NONE)               => setids (idtable ObjFile NONE (ThyInfo.names())) (*FIXME: uris?*)
   602 	   setids (idtable ObjFile NONE (ThyInfo.names())) (*FIXME: uris*)
   593          | (NONE, SOME ObjFile)        => setids (idtable ObjFile NONE (ThyInfo.names())) (* ditto *)
   603          | (NONE, SOME ObjFile) => 
   594          | (SOME fi, SOME ObjFile)     => setids (idtable ObjTheory (SOME fi) [fi]) (* FIXME: lookup file *)
   604 	   setids (idtable ObjFile NONE (ThyInfo.names())) (*FIXME: uris*)
   595          | (NONE, SOME ObjTheory)      => setids (idtable ObjTheory NONE (ThyInfo.names()))
   605          | (SOME fi, SOME ObjFile) => 
   596          | (SOME thy, SOME ObjTheory)  => setids (idtable ObjTheory (SOME thy) (ThyInfo.get_succs thy))
   606 	   setids (idtable ObjTheory (SOME fi) [fi])       (* TODO: check exists *)
   597          | (SOME thy, SOME ObjTheorem) => setids (idtable ObjTheorem (SOME thy) (thms_of_thy thy))
   607          | (NONE, SOME ObjTheory) =>
   598          (* next case is both of above.  FIXME: cleanup this *)
   608 	   setids (idtable ObjTheory NONE (ThyInfo.names()))
   599          | (SOME thy, NONE) => (setids (idtable ObjTheory (SOME thy) (ThyInfo.get_preds thy));
   609          | (SOME thy, SOME ObjTheory) =>
   600                                 setids (idtable ObjTheorem (SOME thy) (thms_of_thy thy)))
   610 	   setids (idtable ObjTheory (SOME thy) (subthys_of_thy thy))
   601          | (_, SOME ot) => error ("No objects of type "^(PgipTypes.name_of_objtype ot)^" are available here.")
   611          | (SOME thy, SOME ObjTheorem) => 
       
   612 	   setids (idtable ObjTheorem (SOME thy) (subthms_of_thy thy))
       
   613          | (NONE, SOME ObjTheorem) => 
       
   614 	   (* A large query, but not unreasonable. ~5000 results for HOL.*)
       
   615 	   (* Several setids should be allowed, but Eclipse code is currently broken:
       
   616               Library.seq (fn thy => setids (idtable ObjTheorem (SOME thy) (subthms_of_thy thy)))
       
   617 		         (ThyInfo.names()) *)
       
   618            setids (idtable ObjTheorem NONE (* this one gives ~7000 for HOL *)
       
   619 			   (flat (map qualified_thms_of_thy (ThyInfo.names()))))
       
   620          | _ => warning ("askids: ignored argument combination")
   602     end
   621     end
   603 
   622 
   604 fun askrefs (Askrefs vs) =
   623 fun askrefs (Askrefs vs) =
   605     let
   624     let
   606         val url = #url vs            (* ask for references of a file (i.e. immediate pre-requisites) *)
   625         val url = #url vs            (* ask for references of a file (i.e. immediate pre-requisites) *)