src/Pure/Syntax/type_ext.ML
changeset 5690 4b056ee5435c
parent 3829 d7333ef9e72c
child 6901 5e20ddfdf3c7
equal deleted inserted replaced
5689:ffecea547501 5690:4b056ee5435c
    21   val type_ext: SynExt.syn_ext
    21   val type_ext: SynExt.syn_ext
    22 end;
    22 end;
    23 
    23 
    24 structure TypeExt : TYPE_EXT =
    24 structure TypeExt : TYPE_EXT =
    25 struct
    25 struct
    26 
       
    27 open Lexicon SynExt Ast;
       
    28 
    26 
    29 
    27 
    30 (** input utils **)
    28 (** input utils **)
    31 
    29 
    32 (* raw_term_sorts *)
    30 (* raw_term_sorts *)
    58 (* typ_of_term *)
    56 (* typ_of_term *)
    59 
    57 
    60 fun typ_of_term get_sort t =
    58 fun typ_of_term get_sort t =
    61   let
    59   let
    62     fun typ_of (Free (x, _)) =
    60     fun typ_of (Free (x, _)) =
    63           if is_tid x then TFree (x, get_sort (x, ~1))
    61           if Lexicon.is_tid x then TFree (x, get_sort (x, ~1))
    64           else Type (x, [])
    62           else Type (x, [])
    65       | typ_of (Var (xi, _)) = TVar (xi, get_sort xi)
    63       | typ_of (Var (xi, _)) = TVar (xi, get_sort xi)
    66       | typ_of (Const ("_ofsort", _) $ Free (x, _) $ _) =
    64       | typ_of (Const ("_ofsort", _) $ Free (x, _) $ _) =
    67           TFree (x, get_sort (x, ~1))
    65           TFree (x, get_sort (x, ~1))
    68       | typ_of (Const ("_ofsort", _) $ Var (xi, _) $ _) =
    66       | typ_of (Const ("_ofsort", _) $ Var (xi, _) $ _) =
    88 
    86 
    89 (* term_of_sort *)
    87 (* term_of_sort *)
    90 
    88 
    91 fun term_of_sort S =
    89 fun term_of_sort S =
    92   let
    90   let
    93     fun class c = const "_class" $ free c;
    91     fun class c = Lexicon.const "_class" $ Lexicon.free c;
    94 
    92 
    95     fun classes [] = sys_error "term_of_sort"
    93     fun classes [] = sys_error "term_of_sort"
    96       | classes [c] = class c
    94       | classes [c] = class c
    97       | classes (c :: cs) = const "_classes" $ class c $ classes cs;
    95       | classes (c :: cs) = Lexicon.const "_classes" $ class c $ classes cs;
    98   in
    96   in
    99     (case S of
    97     (case S of
   100       [] => const "_topsort"
    98       [] => Lexicon.const "_topsort"
   101     | [c] => class c
    99     | [c] => class c
   102     | cs => const "_sort" $ classes cs)
   100     | cs => Lexicon.const "_sort" $ classes cs)
   103   end;
   101   end;
   104 
   102 
   105 
   103 
   106 (* term_of_typ *)
   104 (* term_of_typ *)
   107 
   105 
   108 fun term_of_typ show_sorts ty =
   106 fun term_of_typ show_sorts ty =
   109   let
   107   let
   110     fun of_sort t S =
   108     fun of_sort t S =
   111       if show_sorts then const "_ofsort" $ t $ term_of_sort S
   109       if show_sorts then Lexicon.const "_ofsort" $ t $ term_of_sort S
   112       else t;
   110       else t;
   113 
   111 
   114     fun term_of (Type (a, Ts)) = list_comb (const a, map term_of Ts)
   112     fun term_of (Type (a, Ts)) = list_comb (Lexicon.const a, map term_of Ts)
   115       | term_of (TFree (x, S)) = of_sort (const "_tfree" $ free x) S
   113       | term_of (TFree (x, S)) = of_sort (Lexicon.const "_tfree" $ Lexicon.free x) S
   116       | term_of (TVar (xi, S)) = of_sort (const "_tvar" $ var xi) S;
   114       | term_of (TVar (xi, S)) = of_sort (Lexicon.const "_tvar" $ Lexicon.var xi) S;
   117   in
   115   in
   118     term_of ty
   116     term_of ty
   119   end;
   117   end;
   120 
   118 
   121 
   119 
   122 
   120 
   123 (** the type syntax **)
   121 (** the type syntax **)
   124 
   122 
   125 (* parse ast translations *)
   123 (* parse ast translations *)
   126 
   124 
   127 fun tapp_ast_tr (*"_tapp"*) [ty, f] = Appl [f, ty]
   125 fun tapp_ast_tr (*"_tapp"*) [ty, f] = Ast.Appl [f, ty]
   128   | tapp_ast_tr (*"_tapp"*) asts = raise AST ("tapp_ast_tr", asts);
   126   | tapp_ast_tr (*"_tapp"*) asts = raise Ast.AST ("tapp_ast_tr", asts);
   129 
   127 
   130 fun tappl_ast_tr (*"_tappl"*) [ty, tys, f] =
   128 fun tappl_ast_tr (*"_tappl"*) [ty, tys, f] =
   131       Appl (f :: ty :: unfold_ast "_types" tys)
   129       Ast.Appl (f :: ty :: Ast.unfold_ast "_types" tys)
   132   | tappl_ast_tr (*"_tappl"*) asts = raise AST ("tappl_ast_tr", asts);
   130   | tappl_ast_tr (*"_tappl"*) asts = raise Ast.AST ("tappl_ast_tr", asts);
   133 
   131 
   134 fun bracket_ast_tr (*"_bracket"*) [dom, cod] =
   132 fun bracket_ast_tr (*"_bracket"*) [dom, cod] =
   135       fold_ast_p "fun" (unfold_ast "_types" dom, cod)
   133       Ast.fold_ast_p "fun" (Ast.unfold_ast "_types" dom, cod)
   136   | bracket_ast_tr (*"_bracket"*) asts = raise AST ("bracket_ast_tr", asts);
   134   | bracket_ast_tr (*"_bracket"*) asts = raise Ast.AST ("bracket_ast_tr", asts);
   137 
   135 
   138 
   136 
   139 (* print ast translations *)
   137 (* print ast translations *)
   140 
   138 
   141 fun tappl_ast_tr' (f, []) = raise AST ("tappl_ast_tr'", [f])
   139 fun tappl_ast_tr' (f, []) = raise Ast.AST ("tappl_ast_tr'", [f])
   142   | tappl_ast_tr' (f, [ty]) = Appl [Constant "_tapp", ty, f]
   140   | tappl_ast_tr' (f, [ty]) = Ast.Appl [Ast.Constant "_tapp", ty, f]
   143   | tappl_ast_tr' (f, ty :: tys) =
   141   | tappl_ast_tr' (f, ty :: tys) =
   144       Appl [Constant "_tappl", ty, fold_ast "_types" tys, f];
   142       Ast.Appl [Ast.Constant "_tappl", ty, Ast.fold_ast "_types" tys, f];
   145 
   143 
   146 fun fun_ast_tr' (*"fun"*) asts =
   144 fun fun_ast_tr' (*"fun"*) asts =
   147   (case unfold_ast_p "fun" (Appl (Constant "fun" :: asts)) of
   145   (case Ast.unfold_ast_p "fun" (Ast.Appl (Ast.Constant "fun" :: asts)) of
   148     (dom as _ :: _ :: _, cod)
   146     (dom as _ :: _ :: _, cod)
   149       => Appl [Constant "_bracket", fold_ast "_types" dom, cod]
   147       => Ast.Appl [Ast.Constant "_bracket", Ast.fold_ast "_types" dom, cod]
   150   | _ => raise Match);
   148   | _ => raise Match);
   151 
   149 
   152 
   150 
   153 (* type_ext *)
   151 (* type_ext *)
   154 
   152 
   155 val sortT = Type ("sort", []);
   153 val sortT = Type ("sort", []);
   156 val classesT = Type ("classes", []);
   154 val classesT = Type ("classes", []);
   157 val typesT = Type ("types", []);
   155 val typesT = Type ("types", []);
       
   156 
       
   157 local open Lexicon SynExt in
   158 
   158 
   159 val type_ext = mk_syn_ext false []
   159 val type_ext = mk_syn_ext false []
   160   [Mfix ("_",           tidT --> typeT,                "", [], max_pri),
   160   [Mfix ("_",           tidT --> typeT,                "", [], max_pri),
   161    Mfix ("_",           tvarT --> typeT,               "", [], max_pri),
   161    Mfix ("_",           tvarT --> typeT,               "", [], max_pri),
   162    Mfix ("_",           idT --> typeT,                 "", [], max_pri),
   162    Mfix ("_",           idT --> typeT,                 "", [], max_pri),
   188    [("fun", fun_ast_tr')])
   188    [("fun", fun_ast_tr')])
   189   TokenTrans.token_translation
   189   TokenTrans.token_translation
   190   ([], []);
   190   ([], []);
   191 
   191 
   192 end;
   192 end;
       
   193 
       
   194 
       
   195 end;