src/HOL/Import/import_rule.ML
changeset 81853 f06281e21df9
parent 81852 c693485575a9
child 81854 2a5cbd329241
equal deleted inserted replaced
81852:c693485575a9 81853:f06281e21df9
   313     NONE => error "Import_Rule.get: not a number"
   313     NONE => error "Import_Rule.get: not a number"
   314   | SOME i => (case Inttab.lookup map (Int.abs i) of
   314   | SOME i => (case Inttab.lookup map (Int.abs i) of
   315       NONE => error "Import_Rule.get: lookup failed"
   315       NONE => error "Import_Rule.get: lookup failed"
   316     | SOME res => (res, (if i < 0 then Inttab.delete (Int.abs i) map else map, no)))
   316     | SOME res => (res, (if i < 0 then Inttab.delete (Int.abs i) map else map, no)))
   317 
   317 
   318 fun getty i (thy, (tyi, tmi, thi)) = let val (i, tyi) = (get tyi i) in (i, (thy, (tyi, tmi, thi))) end
   318 fun typ i (thy, (tyi, tmi, thi)) = let val (i, tyi) = (get tyi i) in (i, (thy, (tyi, tmi, thi))) end
   319 fun gettm i (thy, (tyi, tmi, thi)) = let val (i, tmi) = (get tmi i) in (i, (thy, (tyi, tmi, thi))) end
   319 fun term i (thy, (tyi, tmi, thi)) = let val (i, tmi) = (get tmi i) in (i, (thy, (tyi, tmi, thi))) end
   320 fun getth i (thy, (tyi, tmi, thi)) = let val (i, thi) = (get thi i) in (i, (thy, (tyi, tmi, thi))) end
   320 fun thm i (thy, (tyi, tmi, thi)) = let val (i, thi) = (get thi i) in (i, (thy, (tyi, tmi, thi))) end
   321 fun set (map, no) v = (Inttab.update_new (no + 1, v) map, no + 1)
   321 fun set (map, no) v = (Inttab.update_new (no + 1, v) map, no + 1)
   322 fun setty v (thy, (tyi, tmi, thi)) = (thy, (set tyi v, tmi, thi))
   322 fun set_typ v (thy, (tyi, tmi, thi)) = (thy, (set tyi v, tmi, thi))
   323 fun settm v (thy, (tyi, tmi, thi)) = (thy, (tyi, set tmi v, thi))
   323 fun set_term v (thy, (tyi, tmi, thi)) = (thy, (tyi, set tmi v, thi))
   324 fun setth v (thy, (tyi, tmi, thi)) = (thy, (tyi, tmi, set thi v))
   324 fun set_thm v (thy, (tyi, tmi, thi)) = (thy, (tyi, tmi, set thi v))
   325 
   325 
   326 fun last_thm (_, _, (map, no)) =
   326 fun last_thm (_, _, (map, no)) =
   327   case Inttab.lookup map no of
   327   case Inttab.lookup map no of
   328     NONE => error "Import_Rule.last_thm: lookup failed"
   328     NONE => error "Import_Rule.last_thm: lookup failed"
   329   | SOME th => th
   329   | SOME th => th
   357         [] => error "parse_line: empty command"
   357         [] => error "parse_line: empty command"
   358       | c :: cs => (c, String.implode cs :: args)))
   358       | c :: cs => (c, String.implode cs :: args)))
   359 
   359 
   360 fun process_line str =
   360 fun process_line str =
   361   let
   361   let
   362     fun process (#"R", [t]) = gettm t #>> refl #-> setth
   362     fun process (#"R", [t]) = term t #>> refl #-> set_thm
   363       | process (#"B", [t]) = gettm t #>> beta #-> setth
   363       | process (#"B", [t]) = term t #>> beta #-> set_thm
   364       | process (#"1", [th]) = getth th #>> conj1 #-> setth
   364       | process (#"1", [th]) = thm th #>> conj1 #-> set_thm
   365       | process (#"2", [th]) = getth th #>> conj2 #-> setth
   365       | process (#"2", [th]) = thm th #>> conj2 #-> set_thm
   366       | process (#"H", [t]) = gettm t #>> Thm.apply \<^cterm>\<open>Trueprop\<close> #>> Thm.trivial #-> setth
   366       | process (#"H", [t]) = term t #>> Thm.apply \<^cterm>\<open>Trueprop\<close> #>> Thm.trivial #-> set_thm
   367       | process (#"A", [_, t]) =
   367       | process (#"A", [_, t]) =
   368           gettm t #>> Thm.apply \<^cterm>\<open>Trueprop\<close> #>> Skip_Proof.make_thm_cterm #-> setth
   368           term t #>> Thm.apply \<^cterm>\<open>Trueprop\<close> #>> Skip_Proof.make_thm_cterm #-> set_thm
   369       | process (#"C", [th1, th2]) = getth th1 ##>> getth th2 #>> uncurry comb #-> setth
   369       | process (#"C", [th1, th2]) = thm th1 ##>> thm th2 #>> uncurry comb #-> set_thm
   370       | process (#"T", [th1, th2]) = getth th1 ##>> getth th2 #>> uncurry trans #-> setth
   370       | process (#"T", [th1, th2]) = thm th1 ##>> thm th2 #>> uncurry trans #-> set_thm
   371       | process (#"E", [th1, th2]) = getth th1 ##>> getth th2 #>> uncurry eq_mp #-> setth
   371       | process (#"E", [th1, th2]) = thm th1 ##>> thm th2 #>> uncurry eq_mp #-> set_thm
   372       | process (#"D", [th1, th2]) = getth th1 ##>> getth th2 #>> uncurry deduct #-> setth
   372       | process (#"D", [th1, th2]) = thm th1 ##>> thm th2 #>> uncurry deduct #-> set_thm
   373       | process (#"L", [t, th]) = gettm t ##>> (fn ti => getth th ti) #>> uncurry abs #-> setth
   373       | process (#"L", [t, th]) = term t ##>> (fn ti => thm th ti) #>> uncurry abs #-> set_thm
   374       | process (#"M", [s]) = (fn (thy, state) =>
   374       | process (#"M", [s]) = (fn (thy, state) =>
   375           let
   375           let
   376             val ctxt = Proof_Context.init_global thy
   376             val ctxt = Proof_Context.init_global thy
   377             val th = freezeT thy (Global_Theory.get_thm thy s)
   377             val th = freezeT thy (Global_Theory.get_thm thy s)
   378             val ((_, [th']), _) = Variable.import true [th] ctxt
   378             val ((_, [th']), _) = Variable.import true [th] ctxt
   379           in
   379           in
   380             setth th' (thy, state)
   380             set_thm th' (thy, state)
   381           end)
   381           end)
   382       | process (#"Q", l) = (fn (thy, state) =>
   382       | process (#"Q", l) = (fn (thy, state) =>
   383           let
   383           let
   384             val (tys, th) = list_last l
   384             val (tys, th) = list_last l
   385             val (th, tstate) = getth th (thy, state)
   385             val (th, tstate) = thm th (thy, state)
   386             val (tys, tstate) = fold_map getty tys tstate
   386             val (tys, tstate) = fold_map typ tys tstate
   387           in
   387           in
   388             setth (inst_type thy (pair_list tys) th) tstate
   388             set_thm (inst_type thy (pair_list tys) th) tstate
   389           end)
   389           end)
   390       | process (#"S", l) = (fn tstate =>
   390       | process (#"S", l) = (fn tstate =>
   391           let
   391           let
   392             val (tms, th) = list_last l
   392             val (tms, th) = list_last l
   393             val (th, tstate) = getth th tstate
   393             val (th, tstate) = thm th tstate
   394             val (tms, tstate) = fold_map gettm tms tstate
   394             val (tms, tstate) = fold_map term tms tstate
   395           in
   395           in
   396             setth (inst (pair_list tms) th) tstate
   396             set_thm (inst (pair_list tms) th) tstate
   397           end)
   397           end)
   398       | process (#"F", [name, t]) = (fn tstate =>
   398       | process (#"F", [name, t]) = (fn tstate =>
   399           let
   399           let
   400             val (tm, (thy, state)) = gettm t tstate
   400             val (tm, (thy, state)) = term t tstate
   401             val (th, thy) = def (make_name name) tm thy
   401             val (th, thy) = def (make_name name) tm thy
   402           in
   402           in
   403             setth th (thy, state)
   403             set_thm th (thy, state)
   404           end)
   404           end)
   405       | process (#"F", [name]) = (fn (thy, state) => setth (mdef thy name) (thy, state))
   405       | process (#"F", [name]) = (fn (thy, state) => set_thm (mdef thy name) (thy, state))
   406       | process (#"Y", [name, absname, repname, t1, t2, th]) = (fn tstate =>
   406       | process (#"Y", [name, absname, repname, t1, t2, th]) = (fn tstate =>
   407           let
   407           let
   408             val (th, tstate) = getth th tstate
   408             val (th, tstate) = thm th tstate
   409             val (t1, tstate) = gettm t1 tstate
   409             val (t1, tstate) = term t1 tstate
   410             val (t2, (thy, state)) = gettm t2 tstate
   410             val (t2, (thy, state)) = term t2 tstate
   411             val (th, thy) = tydef name absname repname t1 t2 th thy
   411             val (th, thy) = tydef name absname repname t1 t2 th thy
   412           in
   412           in
   413             setth th (thy, state)
   413             set_thm th (thy, state)
   414           end)
   414           end)
   415       | process (#"Y", [name, _, _]) = (fn (thy, state) => setth (mtydef thy name) (thy, state))
   415       | process (#"Y", [name, _, _]) = (fn (thy, state) => set_thm (mtydef thy name) (thy, state))
   416       | process (#"t", [n]) = (fn (thy, state) =>
   416       | process (#"t", [n]) = (fn (thy, state) =>
   417           setty (Thm.global_ctyp_of thy (make_tfree n)) (thy, state))
   417           set_typ (Thm.global_ctyp_of thy (make_tfree n)) (thy, state))
   418       | process (#"a", n :: l) = (fn (thy, state) =>
   418       | process (#"a", n :: l) = (fn (thy, state) =>
   419           fold_map getty l (thy, state) |>>
   419           fold_map typ l (thy, state) |>>
   420             (fn tys => Thm.global_ctyp_of thy (make_type thy (n, map Thm.typ_of tys))) |-> setty)
   420             (fn tys => Thm.global_ctyp_of thy (make_type thy (n, map Thm.typ_of tys))) |-> set_typ)
   421       | process (#"v", [n, ty]) = (fn (thy, state) =>
   421       | process (#"v", [n, ty]) = (fn (thy, state) =>
   422           getty ty (thy, state) |>> (fn ty => Thm.global_cterm_of thy (make_free (n, Thm.typ_of ty))) |-> settm)
   422           typ ty (thy, state) |>> (fn ty => Thm.global_cterm_of thy (make_free (n, Thm.typ_of ty))) |-> set_term)
   423       | process (#"c", [n, ty]) = (fn (thy, state) =>
   423       | process (#"c", [n, ty]) = (fn (thy, state) =>
   424           getty ty (thy, state) |>> (fn ty => Thm.global_cterm_of thy (make_const thy (n, Thm.typ_of ty))) |-> settm)
   424           typ ty (thy, state) |>> (fn ty => Thm.global_cterm_of thy (make_const thy (n, Thm.typ_of ty))) |-> set_term)
   425       | process (#"f", [t1, t2]) = gettm t1 ##>> gettm t2 #>> uncurry Thm.apply #-> settm
   425       | process (#"f", [t1, t2]) = term t1 ##>> term t2 #>> uncurry Thm.apply #-> set_term
   426       | process (#"l", [t1, t2]) = gettm t1 ##>> gettm t2 #>> uncurry Thm.lambda #-> settm
   426       | process (#"l", [t1, t2]) = term t1 ##>> term t2 #>> uncurry Thm.lambda #-> set_term
   427       | process (#"+", [s]) = (fn (thy, state) =>
   427       | process (#"+", [s]) = (fn (thy, state) =>
   428           (store_thm (Binding.name (make_name s)) (last_thm state) thy, state))
   428           (store_thm (Binding.name (make_name s)) (last_thm state) thy, state))
   429       | process (c, _) = error ("process: unknown command: " ^ String.implode [c])
   429       | process (c, _) = error ("process: unknown command: " ^ String.implode [c])
   430   in
   430   in
   431     process (parse_line str)
   431     process (parse_line str)