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