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; |