54 val name_arities: arity -> string list |
54 val name_arities: arity -> string list |
55 val name_arity: string * sort list * class -> string |
55 val name_arity: string * sort list * class -> string |
56 val mk_arities: arity -> term list |
56 val mk_arities: arity -> term list |
57 val mk_arity: string * sort list * class -> term |
57 val mk_arity: string * sort list * class -> term |
58 val dest_arity: term -> string * sort list * class |
58 val dest_arity: term -> string * sort list * class |
59 val unconstrainT: sort list -> term -> |
59 type unconstrain_context = |
60 {atyp_map: typ -> typ, |
60 {present_map: (typ * typ) list, |
|
61 extra_map: (sort * typ) list, |
|
62 atyp_map: typ -> typ, |
61 constraints: ((typ * class) * term) list, |
63 constraints: ((typ * class) * term) list, |
62 outer_constraints: (typ * class) list, |
64 outer_constraints: (typ * class) list}; |
63 prop: term} |
65 val unconstrainT: sort list -> term -> unconstrain_context * term |
64 val protectC: term |
66 val protectC: term |
65 val protect: term -> term |
67 val protect: term -> term |
66 val unprotect: term -> term |
68 val unprotect: term -> term |
67 val mk_term: term -> term |
69 val mk_term: term -> term |
68 val dest_term: term -> term |
70 val dest_term: term -> term |
340 in (t, Ss, c) end; |
342 in (t, Ss, c) end; |
341 |
343 |
342 |
344 |
343 (* internalized sort constraints *) |
345 (* internalized sort constraints *) |
344 |
346 |
|
347 type unconstrain_context = |
|
348 {present_map: (typ * typ) list, |
|
349 extra_map: (sort * typ) list, |
|
350 atyp_map: typ -> typ, |
|
351 constraints: ((typ * class) * term) list, |
|
352 outer_constraints: (typ * class) list}; |
|
353 |
345 fun unconstrainT shyps prop = |
354 fun unconstrainT shyps prop = |
346 let |
355 let |
347 val present = rev ((fold_types o fold_atyps_sorts) (insert (eq_fst op =)) prop []); |
356 val present = rev ((fold_types o fold_atyps_sorts) (insert (eq_fst op =)) prop []); |
348 val extra = fold (Sorts.remove_sort o #2) present shyps; |
357 val extra = fold (Sorts.remove_sort o #2) present shyps; |
349 |
358 |
350 val n = length present; |
359 val n = length present; |
351 val (names1, names2) = Name.invent Name.context Name.aT (n + length extra) |> chop n; |
360 val (names1, names2) = Name.invent Name.context Name.aT (n + length extra) |> chop n; |
352 |
361 |
353 val present_map = |
362 val present_map = |
354 map2 (fn (T, S) => fn a => (T, TVar ((a, 0), S))) present names1; |
363 map2 (fn (T, S) => fn a => (T, TVar ((a, 0), S))) present names1; |
355 val constraints_map = |
364 val extra_map = |
356 map2 (fn (_, S) => fn a => (S, TVar ((a, 0), S))) present names1 @ |
|
357 map2 (fn S => fn a => (S, TVar ((a, 0), S))) extra names2; |
365 map2 (fn S => fn a => (S, TVar ((a, 0), S))) extra names2; |
358 |
366 |
359 fun atyp_map T = |
367 fun atyp_map T = |
360 (case AList.lookup (op =) present_map T of |
368 (case AList.lookup (op =) present_map T of |
361 SOME U => U |
369 SOME U => U |
362 | NONE => |
370 | NONE => |
363 (case AList.lookup (op =) constraints_map (Type.sort_of_atyp T) of |
371 (case AList.lookup (op =) extra_map (Type.sort_of_atyp T) of |
364 SOME U => U |
372 SOME U => U |
365 | NONE => raise TYPE ("Dangling type variable", [T], []))); |
373 | NONE => raise TYPE ("Dangling type variable", [T], []))); |
366 |
374 |
|
375 val constraints_map = |
|
376 map2 (fn (_, S) => fn a => (S, TVar ((a, 0), S))) present names1 @ extra_map; |
367 val constraints = |
377 val constraints = |
368 maps (fn (_, T as TVar (ai, S)) => |
378 constraints_map |> maps (fn (_, T as TVar (ai, S)) => |
369 map (fn c => ((T, c), mk_of_class (TVar (ai, []), c))) S) |
379 map (fn c => ((T, c), mk_of_class (TVar (ai, []), c))) S); |
370 constraints_map; |
|
371 |
380 |
372 val outer_constraints = |
381 val outer_constraints = |
373 maps (fn (T, S) => map (pair T) S) |
382 maps (fn (T, S) => map (pair T) S) |
374 (present @ map (fn S => (TFree ("'dummy", S), S)) extra); |
383 (present @ map (fn S => (TFree ("'dummy", S), S)) extra); |
375 |
384 |
376 val prop' = |
385 val context = |
377 prop |
386 {present_map = present_map, |
|
387 extra_map = extra_map, |
|
388 atyp_map = atyp_map, |
|
389 constraints = constraints, |
|
390 outer_constraints = outer_constraints}; |
|
391 val prop' = prop |
378 |> (Term.map_types o Term.map_atyps) (Type.strip_sorts o atyp_map) |
392 |> (Term.map_types o Term.map_atyps) (Type.strip_sorts o atyp_map) |
379 |> curry list_implies (map snd constraints); |
393 |> curry list_implies (map snd constraints); |
380 in |
394 in (context, prop') end; |
381 {atyp_map = atyp_map, |
|
382 constraints = constraints, |
|
383 outer_constraints = outer_constraints, |
|
384 prop = prop'} |
|
385 end; |
|
386 |
395 |
387 |
396 |
388 |
397 |
389 (** protected propositions and embedded terms **) |
398 (** protected propositions and embedded terms **) |
390 |
399 |