File typechk.ML (Isabelle2005: October 2005)

# File typechk.ML

    (*  Title:      ZF/Tools/typechk.ML
        ID:         $Id: typechk.ML,v 1.14 2005/08/16 11:42:27 wenzelm Exp $
        Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
        Copyright   1999  University of Cambridge

    Tactics for type checking -- from CTT.
    *)

    infix 4 addTCs delTCs;

    signature BASIC_TYPE_CHECK =
    sig
      type tcset
      val addTCs: tcset * thm list -> tcset
      val delTCs: tcset * thm list -> tcset
      val typecheck_tac: tcset -> tactic
      val type_solver_tac: tcset -> thm list -> int -> tactic
      val print_tc: tcset -> unit
      val print_tcset: theory -> unit
      val tcset_ref_of: theory -> tcset ref
      val tcset_of: theory -> tcset
      val tcset: unit -> tcset
      val TCSET: (tcset -> tactic) -> tactic
      val TCSET': (tcset -> 'a -> tactic) -> 'a -> tactic
      val AddTCs: thm list -> unit
      val DelTCs: thm list -> unit
      val TC_add_global: theory attribute
      val TC_del_global: theory attribute
      val TC_add_local: Proof.context attribute
      val TC_del_local: Proof.context attribute
      val Typecheck_tac: tactic
      val Type_solver_tac: thm list -> int -> tactic
      val local_tcset_of: Proof.context -> tcset
      val context_type_solver: context_solver
    end;

    signature TYPE_CHECK =
    sig
      include BASIC_TYPE_CHECK
      val setup: (theory -> theory) list
    end;

    structure TypeCheck: TYPE_CHECK =
    struct

    datatype tcset =
        TC of {rules: thm list,     (*the type-checking rules*)
               net: thm Net.net};   (*discrimination net of the same rules*)

    val mem_thm = gen_mem Drule.eq_thm_prop
    and rem_thm = gen_rem Drule.eq_thm_prop;

    fun addTC (cs as TC{rules, net}, th) =
      if mem_thm (th, rules) then
             (warning ("Ignoring duplicate type-checking rule\n" ^
                       string_of_thm th);
              cs)
      else
          TC{rules  = th::rules,
             net = Net.insert_term (K false) (concl_of th, th) net};

    fun delTC (cs as TC{rules, net}, th) =
      if mem_thm (th, rules) then
          TC{net = Net.delete_term Drule.eq_thm_prop (concl_of th, th) net,
             rules  = rem_thm (rules,th)}
      else (warning ("No such type-checking rule\n" ^ (string_of_thm th));
            cs);

    val op addTCs = Library.foldl addTC;
    val op delTCs = Library.foldl delTC;

    (*resolution using a net rather than rules*)
    fun net_res_tac maxr net =
      SUBGOAL
        (fn (prem,i) =>
          let val rls = Net.unify_term net (Logic.strip_assums_concl prem)
          in
             if length rls <= maxr then resolve_tac rls i else no_tac
          end);

    fun is_rigid_elem (Const("Trueprop",_) $ (Const("op :",_) $ a $ _)) =
          not (is_Var (head_of a))
      | is_rigid_elem _ = false;

    (*Try solving a:A by assumption provided a is rigid!*)
    val test_assume_tac = SUBGOAL(fn (prem,i) =>
        if is_rigid_elem (Logic.strip_assums_concl prem)
        then  assume_tac i  else  eq_assume_tac i);

    (*Type checking solves a:?A (a rigid, ?A maybe flexible).
      match_tac is too strict; would refuse to instantiate ?A*)
    fun typecheck_step_tac (TC{net,...}) =
        FIRSTGOAL (test_assume_tac ORELSE' net_res_tac 3 net);

    fun typecheck_tac tcset = REPEAT (typecheck_step_tac tcset);

    (*Compiles a term-net for speed*)
    val basic_res_tac = net_resolve_tac [TrueI,refl,reflexive_thm,iff_refl,
                                         ballI,allI,conjI,impI];

    (*Instantiates variables in typing conditions.
      drawback: does not simplify conjunctions*)
    fun type_solver_tac tcset hyps = SELECT_GOAL
        (DEPTH_SOLVE (etac FalseE 1
                      ORELSE basic_res_tac 1
                      ORELSE (ares_tac hyps 1
                              APPEND typecheck_step_tac tcset)));

    fun merge_tc (TC{rules,net}, TC{rules=rules',net=net'}) =
        TC {rules = gen_union Drule.eq_thm_prop (rules,rules'),
            net = Net.merge Drule.eq_thm_prop (net, net')};

    (*print tcsets*)
    fun print_tc (TC{rules,...}) =
        Pretty.writeln
           (Pretty.big_list "type-checking rules:" (map Display.pretty_thm rules));

    (** global tcset **)

    structure TypecheckingArgs =
    struct
      val name = "ZF/type-checker";
      type T = tcset ref;
      val empty = ref (TC{rules=[], net=Net.empty});
      fun copy (ref tc) = ref tc;
      val extend = copy;
      fun merge _ (ref tc1, ref tc2) = ref (merge_tc (tc1, tc2));
      fun print _ (ref tc) = print_tc tc;
    end;

    structure TypecheckingData = TheoryDataFun(TypecheckingArgs);

    val print_tcset = TypecheckingData.print;
    val tcset_ref_of = TypecheckingData.get;
    val tcset_of = ! o tcset_ref_of;
    val tcset = tcset_of o Context.the_context;
    val tcset_ref = tcset_ref_of o Context.the_context;

    fun TCSET tacf st = tacf (tcset_of (Thm.theory_of_thm st)) st;
    fun TCSET' tacf i st = tacf (tcset_of (Thm.theory_of_thm st)) i st;

    (* change global tcset *)

    fun change_tcset f x = tcset_ref () := (f (tcset (), x));

    val AddTCs = change_tcset (op addTCs);
    val DelTCs = change_tcset (op delTCs);

    fun Typecheck_tac st = typecheck_tac (tcset()) st;

    fun Type_solver_tac hyps = type_solver_tac (tcset()) hyps;

    (** local tcset **)

    structure LocalTypecheckingData = ProofDataFun
    (struct
      val name = TypecheckingArgs.name;
      type T = tcset;
      val init = tcset_of;
      fun print _ tcset = print_tc tcset;
    end);

    val local_tcset_of = LocalTypecheckingData.get;

    (* solver *)

    val context_type_solver =
      Simplifier.mk_context_solver "context types" (type_solver_tac o local_tcset_of);

    (* attributes *)

    fun global_att f (thy, th) =
      let val r = tcset_ref_of thy
      in r := f (! r, th); (thy, th) end;

    fun local_att f (ctxt, th) = (LocalTypecheckingData.map (fn tcset => f (tcset, th)) ctxt, th);

    val TC_add_global = global_att addTC;
    val TC_del_global = global_att delTC;
    val TC_add_local = local_att addTC;
    val TC_del_local = local_att delTC;

    val TC_attr =
     (Attrib.add_del_args TC_add_global TC_del_global,
      Attrib.add_del_args TC_add_local TC_del_local);

    (* methods *)

    fun TC_args x = Method.only_sectioned_args
      [Args.add -- Args.colon >> K (I, TC_add_local),
       Args.del -- Args.colon >> K (I, TC_del_local)] x;

    fun typecheck ctxt =
      Method.SIMPLE_METHOD (CHANGED (typecheck_tac (local_tcset_of ctxt)));

    (** theory setup **)

    val setup =
     [TypecheckingData.init, LocalTypecheckingData.init,
      Simplifier.add_context_unsafe_solver context_type_solver,
      Attrib.add_attributes [("TC", TC_attr, "declaration of typecheck rule")],
      Method.add_methods [("typecheck", TC_args typecheck, "ZF typecheck")]];

    (** outer syntax **)

    val print_tcsetP =
      OuterSyntax.improper_command "print_tcset" "print context of ZF type-checker"
        OuterKeyword.diag
        (Scan.succeed (Toplevel.no_timing o Toplevel.unknown_context o (Toplevel.keep
          (Toplevel.node_case print_tcset (LocalTypecheckingData.print o Proof.context_of)))));

    val _ = OuterSyntax.add_parsers [print_tcsetP];

    end;

    structure BasicTypeCheck: BASIC_TYPE_CHECK = TypeCheck;
    open BasicTypeCheck;