TFL/thry.sml
author paulson
Thu May 15 12:29:59 1997 +0200 (1997-05-15)
changeset 3191 14bd6e5985f1
parent 2112 3902e9af752f
child 3245 241838c01caf
permissions -rw-r--r--
TFL now integrated with HOL (more work needed)
paulson@2112
     1
structure Thry : Thry_sig (* LThry_sig *) = 
paulson@2112
     2
struct
paulson@2112
     3
paulson@2112
     4
structure USyntax  = USyntax;
paulson@2112
     5
type Type = USyntax.Type
paulson@2112
     6
type Preterm = USyntax.Preterm
paulson@2112
     7
type Term = USyntax.Term
paulson@2112
     8
type Thm = Thm.thm
paulson@2112
     9
type Thry = theory;
paulson@2112
    10
paulson@2112
    11
open Mask;
paulson@2112
    12
structure S = USyntax;
paulson@2112
    13
paulson@2112
    14
paulson@2112
    15
fun THRY_ERR{func,mesg} = Utils.ERR{module = "Thry",func=func,mesg=mesg};
paulson@2112
    16
paulson@2112
    17
(*---------------------------------------------------------------------------
paulson@2112
    18
 *    Matching 
paulson@2112
    19
 *---------------------------------------------------------------------------*)
paulson@2112
    20
paulson@2112
    21
local open Utils
paulson@2112
    22
      infix 3 |->
paulson@2112
    23
      fun tybind (x,y) = TVar (x,["term"])  |-> y
paulson@2112
    24
      fun tmbind (x,y) = Var  (x,type_of y) |-> y
paulson@2112
    25
in
paulson@2112
    26
 fun match_term thry pat ob = 
paulson@2112
    27
    let val tsig = #tsig(Sign.rep_sg(sign_of thry))
paulson@2112
    28
        val (ty_theta,tm_theta) = Pattern.match tsig (pat,ob)
paulson@2112
    29
    in (map tmbind tm_theta, map tybind ty_theta)
paulson@2112
    30
    end
paulson@2112
    31
paulson@2112
    32
 fun match_type thry pat ob = 
paulson@2112
    33
    map tybind(Type.typ_match (#tsig(Sign.rep_sg(sign_of thry))) ([],(pat,ob)))
paulson@2112
    34
end;
paulson@2112
    35
paulson@2112
    36
paulson@2112
    37
(*---------------------------------------------------------------------------
paulson@2112
    38
 * Typing 
paulson@2112
    39
 *---------------------------------------------------------------------------*)
paulson@2112
    40
paulson@2112
    41
fun typecheck thry = cterm_of (sign_of thry);
paulson@2112
    42
paulson@2112
    43
paulson@2112
    44
paulson@2112
    45
(*----------------------------------------------------------------------------
paulson@2112
    46
 * Making a definition. The argument "tm" looks like "f = WFREC R M". This 
paulson@2112
    47
 * entrypoint is specialized for interactive use, since it closes the theory
paulson@2112
    48
 * after making the definition. This allows later interactive definitions to
paulson@2112
    49
 * refer to previous ones. The name for the new theory is automatically 
paulson@2112
    50
 * generated from the name of the argument theory.
paulson@2112
    51
 *---------------------------------------------------------------------------*)
paulson@3191
    52
paulson@3191
    53
paulson@3191
    54
(*---------------------------------------------------------------------------
paulson@3191
    55
 * TFL attempts to make definitions where the lhs is a variable. Isabelle
paulson@3191
    56
 * wants it to be a constant, so here we map it to a constant. Moreover, the
paulson@3191
    57
 * theory should already have the constant, so we refrain from adding the
paulson@3191
    58
 * constant to the theory. We just add the axiom and return the theory.
paulson@3191
    59
 *---------------------------------------------------------------------------*)
paulson@2112
    60
local val (imp $ tprop $ (eeq $ _ $ _ )) = #prop(rep_thm(eq_reflection))
paulson@2112
    61
      val Const(eeq_name, ty) = eeq
paulson@2112
    62
      val prop = #2 (S.strip_type ty)
paulson@2112
    63
in
paulson@2112
    64
fun make_definition parent s tm = 
paulson@2112
    65
   let val {lhs,rhs} = S.dest_eq tm
paulson@2112
    66
       val {Name,Ty} = S.dest_var lhs
paulson@2112
    67
       val lhs1 = S.mk_const{Name = Name, Ty = Ty}
paulson@2112
    68
       val eeq1 = S.mk_const{Name = eeq_name, Ty = Ty --> Ty --> prop}
paulson@2112
    69
       val dtm = S.list_mk_comb(eeq1,[lhs1,rhs])      (* Rename "=" to "==" *)
paulson@3191
    70
       val (_, tm', _) = Sign.infer_types (sign_of parent)
paulson@3191
    71
	             (K None) (K None) [] true ([dtm],propT)
paulson@3191
    72
       val new_thy = add_defs_i [(s,tm')] parent
paulson@2112
    73
   in 
paulson@3191
    74
   (freezeT((get_axiom new_thy s) RS meta_eq_to_obj_eq), new_thy)
paulson@3191
    75
   end;
paulson@2112
    76
end;
paulson@2112
    77
paulson@2112
    78
(*---------------------------------------------------------------------------
paulson@2112
    79
 * Utility routine. Insert into list ordered by the key (a string). If two 
paulson@2112
    80
 * keys are equal, the new element replaces the old. A more efficient option 
paulson@2112
    81
 * for the future is needed. In fact, having the list of datatype facts be 
paulson@2112
    82
 * ordered is useless, since the lookup should never fail!
paulson@2112
    83
 *---------------------------------------------------------------------------*)
paulson@2112
    84
fun insert (el as (x:string, _)) = 
paulson@2112
    85
 let fun canfind[] = [el] 
paulson@2112
    86
       | canfind(alist as ((y as (k,_))::rst)) = 
paulson@2112
    87
           if (x<k) then el::alist
paulson@2112
    88
           else if (x=k) then el::rst
paulson@2112
    89
           else y::canfind rst 
paulson@2112
    90
 in canfind
paulson@2112
    91
 end;
paulson@2112
    92
paulson@2112
    93
paulson@2112
    94
(*---------------------------------------------------------------------------
paulson@2112
    95
 *     A collection of facts about datatypes
paulson@2112
    96
 *---------------------------------------------------------------------------*)
paulson@2112
    97
val nat_record = Dtype.build_record (Nat.thy, ("nat",["0","Suc"]), nat_ind_tac)
paulson@2112
    98
val prod_record =
paulson@2112
    99
    let val prod_case_thms = Dtype.case_thms (sign_of Prod.thy) [split] 
paulson@2112
   100
                                 (fn s => res_inst_tac [("p",s)] PairE_lemma)
paulson@2112
   101
         fun const s = Const(s, the(Sign.const_type (sign_of Prod.thy) s))
paulson@2112
   102
     in ("*", 
paulson@2112
   103
         {constructors = [const "Pair"],
paulson@2112
   104
            case_const = const "split",
paulson@2112
   105
         case_rewrites = [split RS eq_reflection],
paulson@2112
   106
             case_cong = #case_cong prod_case_thms,
paulson@2112
   107
              nchotomy = #nchotomy prod_case_thms}) 
paulson@2112
   108
     end;
paulson@2112
   109
paulson@2112
   110
(*---------------------------------------------------------------------------
paulson@2112
   111
 * Hacks to make interactive mode work. Referring to "datatypes" directly
paulson@2112
   112
 * is temporary, I hope!
paulson@2112
   113
 *---------------------------------------------------------------------------*)
paulson@2112
   114
val match_info = fn thy =>
paulson@2112
   115
    fn "*" => Utils.SOME({case_const = #case_const (#2 prod_record),
paulson@2112
   116
                     constructors = #constructors (#2 prod_record)})
paulson@2112
   117
     | "nat" => Utils.SOME({case_const = #case_const (#2 nat_record),
paulson@2112
   118
                       constructors = #constructors (#2 nat_record)})
paulson@2112
   119
     | ty => case assoc(!datatypes,ty)
paulson@2112
   120
               of None => Utils.NONE
paulson@2112
   121
                | Some{case_const,constructors, ...} =>
paulson@2112
   122
                   Utils.SOME{case_const=case_const, constructors=constructors}
paulson@2112
   123
paulson@2112
   124
val induct_info = fn thy =>
paulson@2112
   125
    fn "*" => Utils.SOME({nchotomy = #nchotomy (#2 prod_record),
paulson@2112
   126
                     constructors = #constructors (#2 prod_record)})
paulson@2112
   127
     | "nat" => Utils.SOME({nchotomy = #nchotomy (#2 nat_record),
paulson@2112
   128
                       constructors = #constructors (#2 nat_record)})
paulson@2112
   129
     | ty => case assoc(!datatypes,ty)
paulson@2112
   130
               of None => Utils.NONE
paulson@2112
   131
                | Some{nchotomy,constructors, ...} =>
paulson@2112
   132
                  Utils.SOME{nchotomy=nchotomy, constructors=constructors}
paulson@2112
   133
paulson@2112
   134
val extract_info = fn thy => 
paulson@2112
   135
 let val case_congs = map (#case_cong o #2) (!datatypes)
paulson@2112
   136
         val case_rewrites = flat(map (#case_rewrites o #2) (!datatypes))
paulson@2112
   137
 in {case_congs = #case_cong (#2 prod_record)::
paulson@2112
   138
                  #case_cong (#2 nat_record)::case_congs,
paulson@2112
   139
     case_rewrites = #case_rewrites(#2 prod_record)@
paulson@2112
   140
                     #case_rewrites(#2 nat_record)@case_rewrites}
paulson@2112
   141
 end;
paulson@2112
   142
paulson@2112
   143
paulson@2112
   144
end; (* Thry *)