src/Pure/Syntax/type_ext.ML
author nipkow
Sun May 20 11:20:41 2001 +0200 (2001-05-20)
changeset 11312 4104bd8d1528
parent 10572 b070825579b8
child 12317 fed7bed97293
permissions -rw-r--r--
added (no)_type_brackets
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@8895
     5
Utilities for input and output of types.  Also the concrete syntax of
wenzelm@8895
     6
types, which is required to bootstrap Pure.
clasohm@0
     7
*)
clasohm@0
     8
clasohm@0
     9
signature TYPE_EXT0 =
wenzelm@2584
    10
sig
wenzelm@8895
    11
  val sort_of_term: term -> sort
wenzelm@3778
    12
  val raw_term_sorts: term -> (indexname * sort) list
wenzelm@2584
    13
  val typ_of_term: (indexname -> sort) -> term -> typ
wenzelm@6901
    14
  val term_of_typ: bool -> typ -> term
wenzelm@10572
    15
  val no_brackets: unit -> bool
wenzelm@2584
    16
end;
clasohm@0
    17
clasohm@0
    18
signature TYPE_EXT =
wenzelm@2584
    19
sig
clasohm@0
    20
  include TYPE_EXT0
wenzelm@2584
    21
  val term_of_sort: sort -> term
paulson@1511
    22
  val tappl_ast_tr': Ast.ast * Ast.ast list -> Ast.ast
wenzelm@8895
    23
  val sortT: typ
paulson@1511
    24
  val type_ext: SynExt.syn_ext
wenzelm@2584
    25
end;
clasohm@0
    26
paulson@1511
    27
structure TypeExt : TYPE_EXT =
clasohm@0
    28
struct
wenzelm@2584
    29
wenzelm@2584
    30
wenzelm@2584
    31
(** input utils **)
clasohm@0
    32
wenzelm@8895
    33
(* sort_of_term *)
wenzelm@2584
    34
wenzelm@8895
    35
fun sort_of_term tm =
wenzelm@557
    36
  let
wenzelm@18
    37
    fun classes (Const (c, _)) = [c]
wenzelm@18
    38
      | classes (Free (c, _)) = [c]
wenzelm@3778
    39
      | classes (Const ("_classes", _) $ Const (c, _) $ cs) = c :: classes cs
wenzelm@3778
    40
      | classes (Const ("_classes", _) $ Free (c, _) $ cs) = c :: classes cs
wenzelm@8895
    41
      | classes tm = raise TERM ("sort_of_term: bad encoding of classes", [tm]);
clasohm@0
    42
wenzelm@2584
    43
    fun sort (Const ("_topsort", _)) = []
wenzelm@2584
    44
      | sort (Const (c, _)) = [c]
wenzelm@2584
    45
      | sort (Free (c, _)) = [c]
wenzelm@3778
    46
      | sort (Const ("_sort", _) $ cs) = classes cs
wenzelm@8895
    47
      | sort tm = raise TERM ("sort_of_term: bad encoding of sort", [tm]);
wenzelm@8895
    48
  in sort tm end;
wenzelm@8895
    49
wenzelm@2584
    50
wenzelm@8895
    51
(* raw_term_sorts *)
wenzelm@8895
    52
wenzelm@8895
    53
fun raw_term_sorts tm =
wenzelm@8895
    54
  let
wenzelm@8895
    55
    fun add_env (Const ("_ofsort", _) $ Free (x, _) $ cs) env = ((x, ~1), sort_of_term cs) ins env
wenzelm@8895
    56
      | add_env (Const ("_ofsort", _) $ Var (xi, _) $ cs) env = (xi, sort_of_term cs) ins env
wenzelm@3778
    57
      | add_env (Abs (_, _, t)) env = add_env t env
wenzelm@3778
    58
      | add_env (t1 $ t2) env = add_env t1 (add_env t2 env)
wenzelm@3778
    59
      | add_env t env = env;
wenzelm@8895
    60
  in add_env tm [] end;
wenzelm@557
    61
wenzelm@557
    62
wenzelm@2584
    63
(* typ_of_term *)
clasohm@0
    64
wenzelm@2584
    65
fun typ_of_term get_sort t =
wenzelm@557
    66
  let
wenzelm@557
    67
    fun typ_of (Free (x, _)) =
wenzelm@5690
    68
          if Lexicon.is_tid x then TFree (x, get_sort (x, ~1))
wenzelm@557
    69
          else Type (x, [])
wenzelm@557
    70
      | typ_of (Var (xi, _)) = TVar (xi, get_sort xi)
wenzelm@557
    71
      | typ_of (Const ("_ofsort", _) $ Free (x, _) $ _) =
wenzelm@557
    72
          TFree (x, get_sort (x, ~1))
wenzelm@557
    73
      | typ_of (Const ("_ofsort", _) $ Var (xi, _) $ _) =
wenzelm@557
    74
          TVar (xi, get_sort xi)
wenzelm@557
    75
      | typ_of tm =
clasohm@0
    76
          let
clasohm@0
    77
            val (t, ts) = strip_comb tm;
clasohm@0
    78
            val a =
wenzelm@18
    79
              (case t of
clasohm@0
    80
                Const (x, _) => x
clasohm@0
    81
              | Free (x, _) => x
wenzelm@3778
    82
              | _ => raise TERM ("typ_of_term: bad encoding of type", [tm]));
clasohm@0
    83
          in
wenzelm@557
    84
            Type (a, map typ_of ts)
wenzelm@557
    85
          end;
wenzelm@8895
    86
  in typ_of t end;
clasohm@0
    87
clasohm@0
    88
clasohm@0
    89
wenzelm@2584
    90
(** output utils **)
wenzelm@2584
    91
wenzelm@2699
    92
(* term_of_sort *)
wenzelm@2584
    93
wenzelm@2584
    94
fun term_of_sort S =
wenzelm@2584
    95
  let
wenzelm@5690
    96
    fun class c = Lexicon.const "_class" $ Lexicon.free c;
wenzelm@2584
    97
wenzelm@2584
    98
    fun classes [] = sys_error "term_of_sort"
wenzelm@2584
    99
      | classes [c] = class c
wenzelm@5690
   100
      | classes (c :: cs) = Lexicon.const "_classes" $ class c $ classes cs;
wenzelm@2584
   101
  in
wenzelm@2584
   102
    (case S of
wenzelm@5690
   103
      [] => Lexicon.const "_topsort"
wenzelm@2584
   104
    | [c] => class c
wenzelm@5690
   105
    | cs => Lexicon.const "_sort" $ classes cs)
wenzelm@2584
   106
  end;
wenzelm@2584
   107
wenzelm@2584
   108
wenzelm@2584
   109
(* term_of_typ *)
clasohm@0
   110
clasohm@0
   111
fun term_of_typ show_sorts ty =
clasohm@0
   112
  let
wenzelm@2584
   113
    fun of_sort t S =
wenzelm@5690
   114
      if show_sorts then Lexicon.const "_ofsort" $ t $ term_of_sort S
wenzelm@2584
   115
      else t;
clasohm@0
   116
wenzelm@5690
   117
    fun term_of (Type (a, Ts)) = list_comb (Lexicon.const a, map term_of Ts)
wenzelm@5690
   118
      | term_of (TFree (x, S)) = of_sort (Lexicon.const "_tfree" $ Lexicon.free x) S
wenzelm@5690
   119
      | term_of (TVar (xi, S)) = of_sort (Lexicon.const "_tvar" $ Lexicon.var xi) S;
wenzelm@8895
   120
  in term_of ty end;
clasohm@0
   121
clasohm@0
   122
clasohm@0
   123
clasohm@0
   124
(** the type syntax **)
clasohm@0
   125
wenzelm@10572
   126
(* print mode *)
wenzelm@10572
   127
wenzelm@10572
   128
val bracketsN = "brackets";
wenzelm@10572
   129
val no_bracketsN = "no_brackets";
wenzelm@10572
   130
wenzelm@10572
   131
fun no_brackets () =
nipkow@11312
   132
  Library.find_first (equal bracketsN orf equal no_bracketsN) (! print_mode)
nipkow@11312
   133
  = Some no_bracketsN;
nipkow@11312
   134
nipkow@11312
   135
val type_bracketsN = "type_brackets";
nipkow@11312
   136
val no_type_bracketsN = "no_type_brackets";
nipkow@11312
   137
nipkow@11312
   138
fun no_type_brackets () =
nipkow@11312
   139
  Library.find_first (equal type_bracketsN orf equal no_type_bracketsN)
nipkow@11312
   140
                     (! print_mode)
nipkow@11312
   141
  = Some no_type_bracketsN;
wenzelm@10572
   142
wenzelm@10572
   143
wenzelm@18
   144
(* parse ast translations *)
clasohm@0
   145
wenzelm@5690
   146
fun tapp_ast_tr (*"_tapp"*) [ty, f] = Ast.Appl [f, ty]
wenzelm@5690
   147
  | tapp_ast_tr (*"_tapp"*) asts = raise Ast.AST ("tapp_ast_tr", asts);
wenzelm@347
   148
wenzelm@347
   149
fun tappl_ast_tr (*"_tappl"*) [ty, tys, f] =
wenzelm@5690
   150
      Ast.Appl (f :: ty :: Ast.unfold_ast "_types" tys)
wenzelm@5690
   151
  | tappl_ast_tr (*"_tappl"*) asts = raise Ast.AST ("tappl_ast_tr", asts);
clasohm@0
   152
clasohm@0
   153
fun bracket_ast_tr (*"_bracket"*) [dom, cod] =
wenzelm@5690
   154
      Ast.fold_ast_p "fun" (Ast.unfold_ast "_types" dom, cod)
wenzelm@5690
   155
  | bracket_ast_tr (*"_bracket"*) asts = raise Ast.AST ("bracket_ast_tr", asts);
clasohm@0
   156
clasohm@0
   157
wenzelm@18
   158
(* print ast translations *)
clasohm@0
   159
wenzelm@5690
   160
fun tappl_ast_tr' (f, []) = raise Ast.AST ("tappl_ast_tr'", [f])
wenzelm@5690
   161
  | tappl_ast_tr' (f, [ty]) = Ast.Appl [Ast.Constant "_tapp", ty, f]
wenzelm@347
   162
  | tappl_ast_tr' (f, ty :: tys) =
wenzelm@5690
   163
      Ast.Appl [Ast.Constant "_tappl", ty, Ast.fold_ast "_types" tys, f];
clasohm@0
   164
clasohm@0
   165
fun fun_ast_tr' (*"fun"*) asts =
nipkow@11312
   166
  if no_brackets() orelse no_type_brackets() then raise Match
wenzelm@10572
   167
  else
wenzelm@10572
   168
    (case Ast.unfold_ast_p "fun" (Ast.Appl (Ast.Constant "fun" :: asts)) of
wenzelm@10572
   169
      (dom as _ :: _ :: _, cod)
wenzelm@10572
   170
        => Ast.Appl [Ast.Constant "_bracket", Ast.fold_ast "_types" dom, cod]
wenzelm@10572
   171
    | _ => raise Match);
clasohm@0
   172
clasohm@0
   173
clasohm@0
   174
(* type_ext *)
clasohm@0
   175
clasohm@0
   176
val sortT = Type ("sort", []);
clasohm@0
   177
val classesT = Type ("classes", []);
clasohm@0
   178
val typesT = Type ("types", []);
clasohm@0
   179
wenzelm@5690
   180
local open Lexicon SynExt in
wenzelm@5690
   181
wenzelm@7500
   182
val type_ext = mk_syn_ext false ["dummy"]
wenzelm@347
   183
  [Mfix ("_",           tidT --> typeT,                "", [], max_pri),
wenzelm@239
   184
   Mfix ("_",           tvarT --> typeT,               "", [], max_pri),
wenzelm@239
   185
   Mfix ("_",           idT --> typeT,                 "", [], max_pri),
wenzelm@3829
   186
   Mfix ("_",           longidT --> typeT,             "", [], max_pri),
clasohm@330
   187
   Mfix ("_::_",        [tidT, sortT] ---> typeT,      "_ofsort", [max_pri, 0], max_pri),
wenzelm@239
   188
   Mfix ("_::_",        [tvarT, sortT] ---> typeT,     "_ofsort", [max_pri, 0], max_pri),
wenzelm@239
   189
   Mfix ("_",           idT --> sortT,                 "", [], max_pri),
wenzelm@3829
   190
   Mfix ("_",           longidT --> sortT,             "", [], max_pri),
wenzelm@2584
   191
   Mfix ("{}",          sortT,                         "_topsort", [], max_pri),
wenzelm@239
   192
   Mfix ("{_}",         classesT --> sortT,            "_sort", [], max_pri),
wenzelm@239
   193
   Mfix ("_",           idT --> classesT,              "", [], max_pri),
wenzelm@3829
   194
   Mfix ("_",           longidT --> classesT,          "", [], max_pri),
wenzelm@239
   195
   Mfix ("_,_",         [idT, classesT] ---> classesT, "_classes", [], max_pri),
wenzelm@3829
   196
   Mfix ("_,_",         [longidT, classesT] ---> classesT, "_classes", [], max_pri),
clasohm@330
   197
   Mfix ("_ _",         [typeT, idT] ---> typeT,       "_tapp", [max_pri, 0], max_pri),
wenzelm@3829
   198
   Mfix ("_ _",         [typeT, longidT] ---> typeT,   "_tapp", [max_pri, 0], max_pri),
wenzelm@9067
   199
   Mfix ("((1'(_,/ _')) _)", [typeT, typesT, idT] ---> typeT, "_tappl", [], max_pri),
wenzelm@9067
   200
   Mfix ("((1'(_,/ _')) _)", [typeT, typesT, longidT] ---> typeT, "_tappl", [], max_pri),
wenzelm@239
   201
   Mfix ("_",           typeT --> typesT,              "", [], max_pri),
wenzelm@239
   202
   Mfix ("_,/ _",       [typeT, typesT] ---> typesT,   "_types", [], max_pri),
wenzelm@239
   203
   Mfix ("(_/ => _)",   [typeT, typeT] ---> typeT,     "fun", [1, 0], 0),
clasohm@624
   204
   Mfix ("([_]/ => _)", [typesT, typeT] ---> typeT,    "_bracket", [0, 0], 0),
wenzelm@2678
   205
   Mfix ("'(_')",       typeT --> typeT,               "", [0], max_pri),
wenzelm@2678
   206
   Mfix ("'_",          typeT,                         "dummy", [], max_pri)]
wenzelm@258
   207
  []
wenzelm@347
   208
  ([("_tapp", tapp_ast_tr), ("_tappl", tappl_ast_tr), ("_bracket", bracket_ast_tr)],
wenzelm@239
   209
   [],
wenzelm@239
   210
   [],
wenzelm@239
   211
   [("fun", fun_ast_tr')])
wenzelm@2699
   212
  TokenTrans.token_translation
wenzelm@239
   213
  ([], []);
clasohm@0
   214
clasohm@0
   215
end;
wenzelm@5690
   216
wenzelm@5690
   217
end;