src/Pure/Syntax/type_ext.ML
author paulson
Thu Sep 25 12:09:41 1997 +0200 (1997-09-25)
changeset 3706 e57b5902822f
parent 2699 932fae4271d7
child 3778 b70c41bc7491
permissions -rw-r--r--
Generalized and exported biresolution_from_nets_tac to allow the declaration
of Clarify_tac
wenzelm@18
     1
(*  Title:      Pure/Syntax/type_ext.ML
clasohm@0
     2
    ID:         $Id$
clasohm@0
     3
    Author:     Tobias Nipkow and Markus Wenzel, TU Muenchen
clasohm@0
     4
wenzelm@2584
     5
Utilities for input and output of types. Also the concrete syntax of
wenzelm@2584
     6
types, which is used to bootstrap Pure.
clasohm@0
     7
*)
clasohm@0
     8
clasohm@0
     9
signature TYPE_EXT0 =
wenzelm@2584
    10
sig
wenzelm@2584
    11
  val raw_term_sorts: (sort * sort -> bool) -> term -> (indexname * sort) list
wenzelm@2584
    12
  val typ_of_term: (indexname -> sort) -> term -> typ
wenzelm@2584
    13
end;
clasohm@0
    14
clasohm@0
    15
signature TYPE_EXT =
wenzelm@2584
    16
sig
clasohm@0
    17
  include TYPE_EXT0
wenzelm@2584
    18
  val term_of_sort: sort -> term
paulson@1511
    19
  val term_of_typ: bool -> typ -> term
paulson@1511
    20
  val tappl_ast_tr': Ast.ast * Ast.ast list -> Ast.ast
paulson@1511
    21
  val type_ext: SynExt.syn_ext
wenzelm@2584
    22
end;
clasohm@0
    23
paulson@1511
    24
structure TypeExt : TYPE_EXT =
clasohm@0
    25
struct
wenzelm@2584
    26
paulson@1511
    27
open Lexicon SynExt Ast;
clasohm@0
    28
wenzelm@2584
    29
wenzelm@2584
    30
(** input utils **)
clasohm@0
    31
wenzelm@2584
    32
(* raw_term_sorts *)
wenzelm@2584
    33
wenzelm@2584
    34
fun raw_term_sorts eq_sort tm =
wenzelm@557
    35
  let
wenzelm@18
    36
    fun classes (Const (c, _)) = [c]
wenzelm@18
    37
      | classes (Free (c, _)) = [c]
wenzelm@557
    38
      | classes (Const ("_classes", _) $ Const (c, _) $ cls) = c :: classes cls
wenzelm@557
    39
      | classes (Const ("_classes", _) $ Free (c, _) $ cls) = c :: classes cls
wenzelm@557
    40
      | classes tm = raise_term "raw_term_sorts: bad encoding of classes" [tm];
clasohm@0
    41
wenzelm@2584
    42
    fun sort (Const ("_topsort", _)) = []
wenzelm@2584
    43
      | sort (Const (c, _)) = [c]
wenzelm@2584
    44
      | sort (Free (c, _)) = [c]
wenzelm@18
    45
      | sort (Const ("_sort", _) $ cls) = classes cls
wenzelm@557
    46
      | sort tm = raise_term "raw_term_sorts: bad encoding of sort" [tm];
wenzelm@557
    47
wenzelm@2584
    48
    fun eq ((xi, S), (xi', S')) =
wenzelm@2584
    49
      xi = xi' andalso eq_sort (S, S');
wenzelm@2584
    50
wenzelm@2584
    51
    fun env_of (Const ("_ofsort", _) $ Free (x, _) $ cls) = [((x, ~1), sort cls)]
wenzelm@2584
    52
      | env_of (Const ("_ofsort", _) $ Var (xi, _) $ cls) = [(xi, sort cls)]
wenzelm@557
    53
      | env_of (Abs (_, _, t)) = env_of t
wenzelm@2584
    54
      | env_of (t1 $ t2) = gen_union eq (env_of t1, env_of t2)
wenzelm@557
    55
      | env_of t = [];
wenzelm@557
    56
wenzelm@2584
    57
    val env = env_of tm;
wenzelm@557
    58
  in
wenzelm@2584
    59
    (case gen_duplicates eq_fst env of
wenzelm@557
    60
      [] => env
wenzelm@557
    61
    | dups => error ("Inconsistent sort constraints for type variable(s) " ^
wenzelm@2584
    62
        commas (map (quote o string_of_vname' o #1) dups)))
wenzelm@557
    63
  end;
wenzelm@557
    64
wenzelm@557
    65
wenzelm@2584
    66
(* typ_of_term *)
clasohm@0
    67
wenzelm@2584
    68
fun typ_of_term get_sort t =
wenzelm@557
    69
  let
wenzelm@557
    70
    fun typ_of (Free (x, _)) =
wenzelm@557
    71
          if is_tid x then TFree (x, get_sort (x, ~1))
wenzelm@557
    72
          else Type (x, [])
wenzelm@557
    73
      | typ_of (Var (xi, _)) = TVar (xi, get_sort xi)
wenzelm@557
    74
      | typ_of (Const ("_ofsort", _) $ Free (x, _) $ _) =
wenzelm@557
    75
          TFree (x, get_sort (x, ~1))
wenzelm@557
    76
      | typ_of (Const ("_ofsort", _) $ Var (xi, _) $ _) =
wenzelm@557
    77
          TVar (xi, get_sort xi)
wenzelm@557
    78
      | typ_of tm =
clasohm@0
    79
          let
clasohm@0
    80
            val (t, ts) = strip_comb tm;
clasohm@0
    81
            val a =
wenzelm@18
    82
              (case t of
clasohm@0
    83
                Const (x, _) => x
clasohm@0
    84
              | Free (x, _) => x
wenzelm@557
    85
              | _ => raise_term "typ_of_term: bad encoding of type" [tm]);
clasohm@0
    86
          in
wenzelm@557
    87
            Type (a, map typ_of ts)
wenzelm@557
    88
          end;
clasohm@0
    89
  in
wenzelm@557
    90
    typ_of t
clasohm@0
    91
  end;
clasohm@0
    92
clasohm@0
    93
clasohm@0
    94
wenzelm@2584
    95
(** output utils **)
wenzelm@2584
    96
wenzelm@2699
    97
(* term_of_sort *)
wenzelm@2584
    98
wenzelm@2584
    99
fun term_of_sort S =
wenzelm@2584
   100
  let
wenzelm@2699
   101
    fun class c = const "_class" $ free c;
wenzelm@2584
   102
wenzelm@2584
   103
    fun classes [] = sys_error "term_of_sort"
wenzelm@2584
   104
      | classes [c] = class c
wenzelm@2584
   105
      | classes (c :: cs) = const "_classes" $ class c $ classes cs;
wenzelm@2584
   106
  in
wenzelm@2584
   107
    (case S of
wenzelm@2584
   108
      [] => const "_topsort"
wenzelm@2584
   109
    | [c] => class c
wenzelm@2584
   110
    | cs => const "_sort" $ classes cs)
wenzelm@2584
   111
  end;
wenzelm@2584
   112
wenzelm@2584
   113
wenzelm@2584
   114
(* term_of_typ *)
clasohm@0
   115
clasohm@0
   116
fun term_of_typ show_sorts ty =
clasohm@0
   117
  let
wenzelm@2584
   118
    fun of_sort t S =
wenzelm@2584
   119
      if show_sorts then const "_ofsort" $ t $ term_of_sort S
wenzelm@2584
   120
      else t;
clasohm@0
   121
wenzelm@2699
   122
    fun term_of (Type (a, Ts)) = list_comb (const a, map term_of Ts)
wenzelm@2699
   123
      | term_of (TFree (x, S)) = of_sort (const "_tfree" $ free x) S
wenzelm@2699
   124
      | term_of (TVar (xi, S)) = of_sort (const "_tvar" $ var xi) S;
clasohm@0
   125
  in
wenzelm@18
   126
    term_of ty
clasohm@0
   127
  end;
clasohm@0
   128
clasohm@0
   129
clasohm@0
   130
clasohm@0
   131
(** the type syntax **)
clasohm@0
   132
wenzelm@18
   133
(* parse ast translations *)
clasohm@0
   134
wenzelm@347
   135
fun tapp_ast_tr (*"_tapp"*) [ty, f] = Appl [f, ty]
wenzelm@347
   136
  | tapp_ast_tr (*"_tapp"*) asts = raise_ast "tapp_ast_tr" asts;
wenzelm@347
   137
wenzelm@347
   138
fun tappl_ast_tr (*"_tappl"*) [ty, tys, f] =
wenzelm@347
   139
      Appl (f :: ty :: unfold_ast "_types" tys)
wenzelm@347
   140
  | tappl_ast_tr (*"_tappl"*) asts = raise_ast "tappl_ast_tr" asts;
clasohm@0
   141
clasohm@0
   142
fun bracket_ast_tr (*"_bracket"*) [dom, cod] =
clasohm@0
   143
      fold_ast_p "fun" (unfold_ast "_types" dom, cod)
clasohm@0
   144
  | bracket_ast_tr (*"_bracket"*) asts = raise_ast "bracket_ast_tr" asts;
clasohm@0
   145
clasohm@0
   146
wenzelm@18
   147
(* print ast translations *)
clasohm@0
   148
clasohm@0
   149
fun tappl_ast_tr' (f, []) = raise_ast "tappl_ast_tr'" [f]
clasohm@0
   150
  | tappl_ast_tr' (f, [ty]) = Appl [Constant "_tapp", ty, f]
wenzelm@347
   151
  | tappl_ast_tr' (f, ty :: tys) =
wenzelm@347
   152
      Appl [Constant "_tappl", ty, fold_ast "_types" tys, f];
clasohm@0
   153
clasohm@0
   154
fun fun_ast_tr' (*"fun"*) asts =
clasohm@0
   155
  (case unfold_ast_p "fun" (Appl (Constant "fun" :: asts)) of
wenzelm@18
   156
    (dom as _ :: _ :: _, cod)
clasohm@0
   157
      => Appl [Constant "_bracket", fold_ast "_types" dom, cod]
clasohm@0
   158
  | _ => raise Match);
clasohm@0
   159
clasohm@0
   160
clasohm@0
   161
(* type_ext *)
clasohm@0
   162
clasohm@0
   163
val sortT = Type ("sort", []);
clasohm@0
   164
val classesT = Type ("classes", []);
clasohm@0
   165
val typesT = Type ("types", []);
clasohm@0
   166
clasohm@764
   167
val type_ext = mk_syn_ext false []
wenzelm@347
   168
  [Mfix ("_",           tidT --> typeT,                "", [], max_pri),
wenzelm@239
   169
   Mfix ("_",           tvarT --> typeT,               "", [], max_pri),
wenzelm@239
   170
   Mfix ("_",           idT --> typeT,                 "", [], max_pri),
clasohm@330
   171
   Mfix ("_::_",        [tidT, sortT] ---> typeT,      "_ofsort", [max_pri, 0], max_pri),
wenzelm@239
   172
   Mfix ("_::_",        [tvarT, sortT] ---> typeT,     "_ofsort", [max_pri, 0], max_pri),
wenzelm@239
   173
   Mfix ("_",           idT --> sortT,                 "", [], max_pri),
wenzelm@2584
   174
   Mfix ("{}",          sortT,                         "_topsort", [], max_pri),
wenzelm@239
   175
   Mfix ("{_}",         classesT --> sortT,            "_sort", [], max_pri),
wenzelm@239
   176
   Mfix ("_",           idT --> classesT,              "", [], max_pri),
wenzelm@239
   177
   Mfix ("_,_",         [idT, classesT] ---> classesT, "_classes", [], max_pri),
clasohm@330
   178
   Mfix ("_ _",         [typeT, idT] ---> typeT,       "_tapp", [max_pri, 0], max_pri),
clasohm@330
   179
   Mfix ("((1'(_,/ _'))_)", [typeT, typesT, idT] ---> typeT, "_tappl", [], max_pri),
wenzelm@239
   180
   Mfix ("_",           typeT --> typesT,              "", [], max_pri),
wenzelm@239
   181
   Mfix ("_,/ _",       [typeT, typesT] ---> typesT,   "_types", [], max_pri),
wenzelm@239
   182
   Mfix ("(_/ => _)",   [typeT, typeT] ---> typeT,     "fun", [1, 0], 0),
clasohm@624
   183
   Mfix ("([_]/ => _)", [typesT, typeT] ---> typeT,    "_bracket", [0, 0], 0),
wenzelm@2678
   184
   Mfix ("'(_')",       typeT --> typeT,               "", [0], max_pri),
wenzelm@2678
   185
   Mfix ("'_",          typeT,                         "dummy", [], max_pri)]
wenzelm@258
   186
  []
wenzelm@347
   187
  ([("_tapp", tapp_ast_tr), ("_tappl", tappl_ast_tr), ("_bracket", bracket_ast_tr)],
wenzelm@239
   188
   [],
wenzelm@239
   189
   [],
wenzelm@239
   190
   [("fun", fun_ast_tr')])
wenzelm@2699
   191
  TokenTrans.token_translation
wenzelm@239
   192
  ([], []);
clasohm@0
   193
clasohm@0
   194
end;