src/Pure/Syntax/mixfix.ML
changeset 62796 99f2036f37af
parent 62773 e6443edaebff
child 62797 e08c44eed27f
equal deleted inserted replaced
62795:063d2f23cdf6 62796:99f2036f37af
   123 val typeT = Type ("type", []);
   123 val typeT = Type ("type", []);
   124 fun make_type n = replicate n typeT ---> typeT;
   124 fun make_type n = replicate n typeT ---> typeT;
   125 
   125 
   126 fun syn_ext_types type_decls =
   126 fun syn_ext_types type_decls =
   127   let
   127   let
   128     fun mk_infix sy ty t p1 p2 p3 range =
   128     fun mk_infix sy ty t p1 p2 p3 pos =
   129       Syntax_Ext.Mfix
   129       Syntax_Ext.Mfix
   130         (Symbol_Pos.explode0 "(_ " @ Input.source_explode sy @ Symbol_Pos.explode0 "/ _)",
   130         (Symbol_Pos.explode0 "(_ " @ Input.source_explode sy @ Symbol_Pos.explode0 "/ _)",
   131           ty, t, [p1, p2], p3, Position.set_range range);
   131           ty, t, [p1, p2], p3, pos);
   132 
   132 
   133     fun mfix_of (_, _, NoSyn) = NONE
   133     fun mfix_of (mfix as (_, _, mx)) =
   134       | mfix_of (t, ty, Mixfix (sy, ps, p, range)) =
   134       (case mfix of
   135           SOME (Syntax_Ext.Mfix (Input.source_explode sy, ty, t, ps, p, Position.set_range range))
   135         (_, _, NoSyn) => NONE
   136       | mfix_of (t, ty, Infix (sy, p, range)) = SOME (mk_infix sy ty t (p + 1) (p + 1) p range)
   136       | (t, ty, Mixfix (sy, ps, p, _)) =>
   137       | mfix_of (t, ty, Infixl (sy, p, range)) = SOME (mk_infix sy ty t p (p + 1) p range)
   137           SOME (Syntax_Ext.Mfix (Input.source_explode sy, ty, t, ps, p, pos_of mx))
   138       | mfix_of (t, ty, Infixr (sy, p, range)) = SOME (mk_infix sy ty t (p + 1) p p range)
   138       | (t, ty, Infix (sy, p, _)) => SOME (mk_infix sy ty t (p + 1) (p + 1) p (pos_of mx))
   139       | mfix_of (t, _, _) = error ("Bad mixfix declaration for " ^ quote t);
   139       | (t, ty, Infixl (sy, p, _)) => SOME (mk_infix sy ty t p (p + 1) p (pos_of mx))
       
   140       | (t, ty, Infixr (sy, p, _)) => SOME (mk_infix sy ty t (p + 1) p p (pos_of mx))
       
   141       | (t, _, _) => error ("Bad mixfix declaration for " ^ quote t ^ Position.here (pos_of mx)));
   140 
   142 
   141     fun check_args (_, ty, mx) (SOME (Syntax_Ext.Mfix (sy, _, _, _, _, _))) =
   143     fun check_args (_, ty, mx) (SOME (Syntax_Ext.Mfix (sy, _, _, _, _, _))) =
   142           if length (Term.binder_types ty) = Syntax_Ext.mfix_args sy then ()
   144           if length (Term.binder_types ty) = Syntax_Ext.mfix_args sy then ()
   143           else
   145           else
   144             error ("Bad number of type constructor arguments in mixfix annotation" ^
   146             error ("Bad number of type constructor arguments in mixfix annotation" ^
   156 val binder_stamp = stamp ();
   158 val binder_stamp = stamp ();
   157 val binder_name = suffix "_binder";
   159 val binder_name = suffix "_binder";
   158 
   160 
   159 fun syn_ext_consts logical_types const_decls =
   161 fun syn_ext_consts logical_types const_decls =
   160   let
   162   let
   161     fun mk_infix sy ty c p1 p2 p3 range =
   163     fun mk_infix sy ty c p1 p2 p3 pos =
   162       [Syntax_Ext.Mfix
   164       [Syntax_Ext.Mfix
   163         (Symbol_Pos.explode0 "op " @ Input.source_explode (Input.reset_pos sy),
   165         (Symbol_Pos.explode0 "op " @ Input.source_explode (Input.reset_pos sy),
   164           ty, c, [], 1000, Position.none),
   166           ty, c, [], 1000, Position.none),
   165        Syntax_Ext.Mfix
   167        Syntax_Ext.Mfix
   166         (Symbol_Pos.explode0 "(_ " @ Input.source_explode sy @ Symbol_Pos.explode0 "/ _)",
   168         (Symbol_Pos.explode0 "(_ " @ Input.source_explode sy @ Symbol_Pos.explode0 "/ _)",
   167           ty, c, [p1, p2], p3, Position.set_range range)];
   169           ty, c, [p1, p2], p3, pos)];
   168 
   170 
   169     fun binder_typ _ (Type ("fun", [Type ("fun", [_, ty2]), ty3])) =
   171     fun binder_typ _ (Type ("fun", [Type ("fun", [_, ty2]), ty3])) =
   170           [Type ("idts", []), ty2] ---> ty3
   172           [Type ("idts", []), ty2] ---> ty3
   171       | binder_typ c _ = error ("Bad type of binder: " ^ quote c);
   173       | binder_typ c _ = error ("Bad type of binder: " ^ quote c);
   172 
   174 
   173     fun mfix_of (_, _, NoSyn) = []
   175     fun mfix_of (mfix as (_, _, mx)) =
   174       | mfix_of (c, ty, Mixfix (sy, ps, p, range)) =
   176       (case mfix of
   175           [Syntax_Ext.Mfix (Input.source_explode sy, ty, c, ps, p, Position.set_range range)]
   177         (_, _, NoSyn) => []
   176       | mfix_of (c, ty, Infix (sy, p, range)) = mk_infix sy ty c (p + 1) (p + 1) p range
   178       | (c, ty, Mixfix (sy, ps, p, _)) =>
   177       | mfix_of (c, ty, Infixl (sy, p, range)) = mk_infix sy ty c p (p + 1) p range
   179           [Syntax_Ext.Mfix (Input.source_explode sy, ty, c, ps, p, pos_of mx)]
   178       | mfix_of (c, ty, Infixr (sy, p, range)) = mk_infix sy ty c (p + 1) p p range
   180       | (c, ty, Infix (sy, p, _)) => mk_infix sy ty c (p + 1) (p + 1) p (pos_of mx)
   179       | mfix_of (c, ty, Binder (sy, p, q, range)) =
   181       | (c, ty, Infixl (sy, p, _)) => mk_infix sy ty c p (p + 1) p (pos_of mx)
       
   182       | (c, ty, Infixr (sy, p, _)) => mk_infix sy ty c (p + 1) p p (pos_of mx)
       
   183       | (c, ty, Binder (sy, p, q, _)) =>
   180           [Syntax_Ext.Mfix
   184           [Syntax_Ext.Mfix
   181             (Symbol_Pos.explode0 "(3" @ Input.source_explode sy @ Symbol_Pos.explode0 "_./ _)",
   185             (Symbol_Pos.explode0 "(3" @ Input.source_explode sy @ Symbol_Pos.explode0 "_./ _)",
   182               binder_typ c ty, (binder_name c), [0, p], q, Position.set_range range)]
   186               binder_typ c ty, (binder_name c), [0, p], q, pos_of mx)]
   183       | mfix_of (c, _, mx) =
   187       | (c, _, mx) =>
   184           error ("Bad mixfix declaration for " ^ quote c ^ Position.here (pos_of mx));
   188           error ("Bad mixfix declaration for " ^ quote c ^ Position.here (pos_of mx)));
   185 
   189 
   186     fun binder (c, _, Binder _) = SOME (binder_name c, c)
   190     fun binder (c, _, Binder _) = SOME (binder_name c, c)
   187       | binder _ = NONE;
   191       | binder _ = NONE;
   188 
   192 
   189     val mfix = maps mfix_of const_decls;
   193     val mfix = maps mfix_of const_decls;