src/Pure/Syntax/type_ext.ML
author wenzelm
Mon May 02 12:34:56 1994 +0200 (1994-05-02)
changeset 347 cd41a57221d0
parent 330 2fda15dd1e0f
child 557 9d386e6c02b7
permissions -rw-r--r--
changed translation of type applications according to new grammar;
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@18
     5
The concrete syntax of types (used to bootstrap Pure).
wenzelm@18
     6
wenzelm@18
     7
TODO:
wenzelm@18
     8
  term_of_typ: prune sorts
clasohm@0
     9
*)
clasohm@0
    10
clasohm@0
    11
signature TYPE_EXT0 =
clasohm@0
    12
sig
clasohm@0
    13
  val typ_of_term: (indexname -> sort) -> term -> typ
clasohm@0
    14
end;
clasohm@0
    15
clasohm@0
    16
signature TYPE_EXT =
clasohm@0
    17
sig
clasohm@0
    18
  include TYPE_EXT0
wenzelm@239
    19
  structure SynExt: SYN_EXT
wenzelm@239
    20
  local open SynExt SynExt.Ast in
clasohm@0
    21
    val term_of_typ: bool -> typ -> term
clasohm@0
    22
    val tappl_ast_tr': ast * ast list -> ast
wenzelm@239
    23
    val type_ext: syn_ext
clasohm@0
    24
  end
clasohm@0
    25
end;
clasohm@0
    26
wenzelm@239
    27
functor TypeExtFun(structure Lexicon: LEXICON and SynExt: SYN_EXT): TYPE_EXT =
clasohm@0
    28
struct
clasohm@0
    29
wenzelm@239
    30
structure SynExt = SynExt;
wenzelm@239
    31
open Lexicon SynExt SynExt.Ast;
clasohm@0
    32
clasohm@0
    33
wenzelm@18
    34
(** typ_of_term **)
clasohm@0
    35
clasohm@0
    36
fun typ_of_term def_sort t =
clasohm@0
    37
  let
clasohm@0
    38
    fun sort_err (xi as (x, i)) =
wenzelm@18
    39
      error ("Inconsistent sort constraints for type variable " ^
wenzelm@18
    40
        quote (if i < 0 then x else string_of_vname xi));
clasohm@0
    41
clasohm@0
    42
    fun put_sort scs xi s =
clasohm@0
    43
      (case assoc (scs, xi) of
clasohm@0
    44
        None => (xi, s) :: scs
clasohm@0
    45
      | Some s' =>  if s = s' then scs else sort_err xi);
clasohm@0
    46
wenzelm@18
    47
    fun insert x [] = [x: string]
wenzelm@18
    48
      | insert x (lst as y :: ys) =
wenzelm@18
    49
          if x > y then y :: insert x ys
wenzelm@18
    50
          else if x = y then lst
wenzelm@18
    51
          else x :: lst;
wenzelm@18
    52
wenzelm@18
    53
    fun classes (Const (c, _)) = [c]
wenzelm@18
    54
      | classes (Free (c, _)) = [c]
wenzelm@18
    55
      | classes (Const ("_classes", _) $ Const (c, _) $ cls) =
wenzelm@18
    56
          insert c (classes cls)
wenzelm@18
    57
      | classes (Const ("_classes", _) $ Free (c, _) $ cls) =
wenzelm@18
    58
          insert c (classes cls)
wenzelm@18
    59
      | classes tm = raise_term "typ_of_term: bad encoding of classes" [tm];
clasohm@0
    60
clasohm@0
    61
    fun sort (Const ("_emptysort", _)) = []
clasohm@0
    62
      | sort (Const (s, _)) = [s]
clasohm@0
    63
      | sort (Free (s, _)) = [s]
wenzelm@18
    64
      | sort (Const ("_sort", _) $ cls) = classes cls
wenzelm@18
    65
      | sort tm = raise_term "typ_of_term: bad encoding of sort" [tm];
clasohm@0
    66
clasohm@0
    67
    fun typ (Free (x, _), scs) =
clasohm@330
    68
          (if is_tid x then TFree (x, []) else Type (x, []), scs)
clasohm@0
    69
      | typ (Var (xi, _), scs) = (TVar (xi, []), scs)
clasohm@0
    70
      | typ (Const ("_ofsort", _) $ Free (x, _) $ st, scs) =
clasohm@0
    71
          (TFree (x, []), put_sort scs (x, ~1) (sort st))
clasohm@0
    72
      | typ (Const ("_ofsort", _) $ Var (xi, _) $ st, scs) =
clasohm@0
    73
          (TVar (xi, []), put_sort scs xi (sort st))
clasohm@0
    74
      | typ (Const (a, _), scs) = (Type (a, []), scs)
wenzelm@18
    75
      | typ (tm as _ $ _, scs) =
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@18
    82
              | _ => raise_term "typ_of_term: bad type application" [tm]);
clasohm@0
    83
            val (tys, scs') = typs (ts, scs);
clasohm@0
    84
          in
clasohm@0
    85
            (Type (a, tys), scs')
clasohm@0
    86
          end
wenzelm@18
    87
      | typ (tm, _) = raise_term "typ_of_term: bad encoding of typ" [tm]
clasohm@0
    88
    and typs (t :: ts, scs) =
clasohm@0
    89
          let
clasohm@0
    90
            val (ty, scs') = typ (t, scs);
clasohm@0
    91
            val (tys, scs'') = typs (ts, scs');
clasohm@0
    92
          in (ty :: tys, scs'') end
clasohm@0
    93
      | typs ([], scs) = ([], scs);
clasohm@0
    94
clasohm@0
    95
clasohm@0
    96
    val (ty, scs) = typ (t, []);
clasohm@0
    97
clasohm@0
    98
    fun get_sort xi =
clasohm@0
    99
      (case assoc (scs, xi) of
clasohm@0
   100
        None => def_sort xi
clasohm@0
   101
      | Some s => s);
clasohm@0
   102
clasohm@0
   103
    fun add_sorts (Type (a, tys)) = Type (a, map add_sorts tys)
clasohm@0
   104
      | add_sorts (TVar (xi, _)) = TVar (xi, get_sort xi)
clasohm@0
   105
      | add_sorts (TFree (x, _)) = TFree (x, get_sort (x, ~1));
clasohm@0
   106
  in
clasohm@0
   107
    add_sorts ty
clasohm@0
   108
  end;
clasohm@0
   109
clasohm@0
   110
clasohm@0
   111
clasohm@0
   112
(** term_of_typ **)
clasohm@0
   113
clasohm@0
   114
fun term_of_typ show_sorts ty =
clasohm@0
   115
  let
clasohm@0
   116
    fun const x = Const (x, dummyT);
wenzelm@18
   117
    fun free x = Free (x, dummyT);
wenzelm@18
   118
    fun var xi = Var (xi, dummyT);
clasohm@0
   119
clasohm@0
   120
    fun classes [] = raise Match
wenzelm@18
   121
      | classes [c] = free c
wenzelm@18
   122
      | classes (c :: cs) = const "_classes" $ free c $ classes cs;
clasohm@0
   123
clasohm@0
   124
    fun sort [] = const "_emptysort"
wenzelm@18
   125
      | sort [s] = free s
wenzelm@18
   126
      | sort ss = const "_sort" $ classes ss;
clasohm@0
   127
clasohm@0
   128
    fun of_sort t ss =
clasohm@0
   129
      if show_sorts then const "_ofsort" $ t $ sort ss else t;
clasohm@0
   130
wenzelm@18
   131
    fun term_of (Type (a, tys)) = list_comb (const a, map term_of tys)
wenzelm@18
   132
      | term_of (TFree (x, ss)) = of_sort (free x) ss
wenzelm@18
   133
      | term_of (TVar (xi, ss)) = of_sort (var xi) ss;
clasohm@0
   134
  in
wenzelm@18
   135
    term_of ty
clasohm@0
   136
  end;
clasohm@0
   137
clasohm@0
   138
clasohm@0
   139
clasohm@0
   140
(** the type syntax **)
clasohm@0
   141
wenzelm@18
   142
(* parse ast translations *)
clasohm@0
   143
wenzelm@347
   144
fun tapp_ast_tr (*"_tapp"*) [ty, f] = Appl [f, ty]
wenzelm@347
   145
  | tapp_ast_tr (*"_tapp"*) asts = raise_ast "tapp_ast_tr" asts;
wenzelm@347
   146
wenzelm@347
   147
fun tappl_ast_tr (*"_tappl"*) [ty, tys, f] =
wenzelm@347
   148
      Appl (f :: ty :: unfold_ast "_types" tys)
wenzelm@347
   149
  | tappl_ast_tr (*"_tappl"*) asts = raise_ast "tappl_ast_tr" asts;
clasohm@0
   150
clasohm@0
   151
fun bracket_ast_tr (*"_bracket"*) [dom, cod] =
clasohm@0
   152
      fold_ast_p "fun" (unfold_ast "_types" dom, cod)
clasohm@0
   153
  | bracket_ast_tr (*"_bracket"*) asts = raise_ast "bracket_ast_tr" asts;
clasohm@0
   154
clasohm@0
   155
wenzelm@18
   156
(* print ast translations *)
clasohm@0
   157
clasohm@0
   158
fun tappl_ast_tr' (f, []) = raise_ast "tappl_ast_tr'" [f]
clasohm@0
   159
  | tappl_ast_tr' (f, [ty]) = Appl [Constant "_tapp", ty, f]
wenzelm@347
   160
  | tappl_ast_tr' (f, ty :: tys) =
wenzelm@347
   161
      Appl [Constant "_tappl", ty, fold_ast "_types" tys, f];
clasohm@0
   162
clasohm@0
   163
fun fun_ast_tr' (*"fun"*) asts =
clasohm@0
   164
  (case unfold_ast_p "fun" (Appl (Constant "fun" :: asts)) of
wenzelm@18
   165
    (dom as _ :: _ :: _, cod)
clasohm@0
   166
      => Appl [Constant "_bracket", fold_ast "_types" dom, cod]
clasohm@0
   167
  | _ => raise Match);
clasohm@0
   168
clasohm@0
   169
clasohm@0
   170
(* type_ext *)
clasohm@0
   171
clasohm@0
   172
val sortT = Type ("sort", []);
clasohm@0
   173
val classesT = Type ("classes", []);
clasohm@0
   174
val typesT = Type ("types", []);
clasohm@0
   175
wenzelm@239
   176
val type_ext = syn_ext
clasohm@330
   177
  [logic, "type"] [logic, "type"]
wenzelm@347
   178
  [Mfix ("_",           tidT --> typeT,                "", [], max_pri),
wenzelm@239
   179
   Mfix ("_",           tvarT --> typeT,               "", [], max_pri),
wenzelm@239
   180
   Mfix ("_",           idT --> typeT,                 "", [], max_pri),
clasohm@330
   181
   Mfix ("_::_",        [tidT, sortT] ---> typeT,      "_ofsort", [max_pri, 0], max_pri),
wenzelm@239
   182
   Mfix ("_::_",        [tvarT, sortT] ---> typeT,     "_ofsort", [max_pri, 0], max_pri),
wenzelm@239
   183
   Mfix ("_",           idT --> sortT,                 "", [], max_pri),
wenzelm@239
   184
   Mfix ("{}",          sortT,                         "_emptysort", [], max_pri),
wenzelm@239
   185
   Mfix ("{_}",         classesT --> sortT,            "_sort", [], max_pri),
wenzelm@239
   186
   Mfix ("_",           idT --> classesT,              "", [], max_pri),
wenzelm@239
   187
   Mfix ("_,_",         [idT, classesT] ---> classesT, "_classes", [], max_pri),
clasohm@330
   188
   Mfix ("_ _",         [typeT, idT] ---> typeT,       "_tapp", [max_pri, 0], max_pri),
clasohm@330
   189
   Mfix ("((1'(_,/ _'))_)", [typeT, typesT, idT] ---> typeT, "_tappl", [], max_pri),
wenzelm@239
   190
   Mfix ("_",           typeT --> typesT,              "", [], max_pri),
wenzelm@239
   191
   Mfix ("_,/ _",       [typeT, typesT] ---> typesT,   "_types", [], max_pri),
wenzelm@239
   192
   Mfix ("(_/ => _)",   [typeT, typeT] ---> typeT,     "fun", [1, 0], 0),
wenzelm@239
   193
   Mfix ("([_]/ => _)", [typesT, typeT] ---> typeT,    "_bracket", [0, 0], 0)]
wenzelm@258
   194
  []
wenzelm@347
   195
  ([("_tapp", tapp_ast_tr), ("_tappl", tappl_ast_tr), ("_bracket", bracket_ast_tr)],
wenzelm@239
   196
   [],
wenzelm@239
   197
   [],
wenzelm@239
   198
   [("fun", fun_ast_tr')])
wenzelm@239
   199
  ([], []);
clasohm@0
   200
clasohm@0
   201
clasohm@0
   202
end;
clasohm@0
   203