127 ^ Syntax.string_of_sort_global thy inferred_sort |
127 ^ Syntax.string_of_sort_global thy inferred_sort |
128 ^ " of type parameter " ^ Name.aT ^ " of sort " |
128 ^ " of type parameter " ^ Name.aT ^ " of sort " |
129 ^ Syntax.string_of_sort_global thy a_sort ^ ".") |
129 ^ Syntax.string_of_sort_global thy a_sort ^ ".") |
130 | _ => error "Multiple type variables in class specification."; |
130 | _ => error "Multiple type variables in class specification."; |
131 in (map o map_atyps) (K (TFree (Name.aT, fixate_sort))) Ts end; |
131 in (map o map_atyps) (K (TFree (Name.aT, fixate_sort))) Ts end; |
|
132 val after_infer_fixate = (map o map_atyps) |
|
133 (fn T as TFree _ => T | T as TVar (vi, sort) => |
|
134 if Type_Infer.is_param vi then Type_Infer.param 0 (Name.aT, sort) else T); |
132 fun add_typ_check level name f = Context.proof_map |
135 fun add_typ_check level name f = Context.proof_map |
133 (Syntax.add_typ_check level name (fn Ts => fn ctxt => |
136 (Syntax.add_typ_check level name (fn Ts => fn ctxt => |
134 let val Ts' = f Ts in if eq_list (op =) (Ts, Ts') then NONE else SOME (Ts', ctxt) end)); |
137 let val Ts' = f Ts in if eq_list (op =) (Ts, Ts') then NONE else SOME (Ts', ctxt) end)); |
135 |
138 |
136 (* preprocessing elements, retrieving base sort from type-checked elements *) |
139 (* preprocessing elements, retrieving base sort from type-checked elements *) |
|
140 val raw_supexpr = (map (fn sup => (sup, (("", false), |
|
141 Expression.Positional []))) sups, []); |
137 val init_class_body = fold (ProofContext.add_const_constraint o apsnd SOME) base_constraints |
142 val init_class_body = fold (ProofContext.add_const_constraint o apsnd SOME) base_constraints |
138 #> Class.redeclare_operations thy sups |
143 #> Class.redeclare_operations thy sups |
139 #> add_typ_check 10 "reject_bcd_etc" reject_bcd_etc |
144 #> add_typ_check 10 "reject_bcd_etc" reject_bcd_etc |
140 #> add_typ_check ~10 "singleton_fixate" singleton_fixate; |
145 #> add_typ_check ~10 "singleton_fixate" singleton_fixate; |
141 val raw_supexpr = (map (fn sup => (sup, (("", false), |
|
142 Expression.Positional []))) sups, []); |
|
143 val ((raw_supparams, _, raw_inferred_elems), _) = ProofContext.init_global thy |
146 val ((raw_supparams, _, raw_inferred_elems), _) = ProofContext.init_global thy |
|
147 |> add_typ_check 5 "after_infer_fixate" after_infer_fixate |
144 |> prep_decl raw_supexpr init_class_body raw_elems; |
148 |> prep_decl raw_supexpr init_class_body raw_elems; |
145 fun filter_element (Element.Fixes []) = NONE |
149 fun filter_element (Element.Fixes []) = NONE |
146 | filter_element (e as Element.Fixes _) = SOME e |
150 | filter_element (e as Element.Fixes _) = SOME e |
147 | filter_element (Element.Constrains []) = NONE |
151 | filter_element (Element.Constrains []) = NONE |
148 | filter_element (e as Element.Constrains _) = SOME e |
152 | filter_element (e as Element.Constrains _) = SOME e |