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