robustness -- TFF1 does not support type classes
authorblanchet
Tue, 26 Jun 2012 11:14:40 +0200
changeset 49149fa23e699494c
parent 49148 a5ab5964065f
child 49150 a44f34694406
robustness -- TFF1 does not support type classes
src/HOL/Tools/ATP/atp_problem_generate.ML
     1.1 --- a/src/HOL/Tools/ATP/atp_problem_generate.ML	Tue Jun 26 11:14:40 2012 +0200
     1.2 +++ b/src/HOL/Tools/ATP/atp_problem_generate.ML	Tue Jun 26 11:14:40 2012 +0200
     1.3 @@ -652,25 +652,31 @@
     1.4                          level)
     1.5                else
     1.6                  raise Same.SAME
     1.7 -            | (Raw_Monomorphic, _) => raise Same.SAME
     1.8 -            | (poly, All_Types) =>
     1.9 -              Native (Higher_Order THF_With_Choice, poly, All_Types))
    1.10 +            | (poly as Raw_Polymorphic _, All_Types) =>
    1.11 +              Native (Higher_Order THF_With_Choice, poly, All_Types)
    1.12 +            | _ => raise Same.SAME)
    1.13           | ("guards", (SOME poly, _)) =>
    1.14 -           if poly = Mangled_Monomorphic andalso
    1.15 -              granularity_of_type_level level = Undercover_Vars then
    1.16 +           if (poly = Mangled_Monomorphic andalso
    1.17 +               granularity_of_type_level level = Undercover_Vars) orelse
    1.18 +              poly = Type_Class_Polymorphic then
    1.19               raise Same.SAME
    1.20             else
    1.21               Guards (poly, level)
    1.22           | ("tags", (SOME poly, _)) =>
    1.23 -           if granularity_of_type_level level = Undercover_Vars then
    1.24 +           if granularity_of_type_level level = Undercover_Vars orelse
    1.25 +              poly = Type_Class_Polymorphic then
    1.26               raise Same.SAME
    1.27             else
    1.28               Tags (poly, level)
    1.29           | ("args", (SOME poly, All_Types (* naja *))) =>
    1.30 -           Guards (poly, Const_Types false)
    1.31 +           if poly = Type_Class_Polymorphic then raise Same.SAME
    1.32 +           else Guards (poly, Const_Types false)
    1.33           | ("args", (SOME poly, Nonmono_Types (_, All_Vars) (* naja *))) =>
    1.34 -           if poly = Mangled_Monomorphic then raise Same.SAME
    1.35 -           else Guards (poly, Const_Types true)
    1.36 +           if poly = Mangled_Monomorphic orelse
    1.37 +              poly = Type_Class_Polymorphic then
    1.38 +             raise Same.SAME
    1.39 +           else
    1.40 +             Guards (poly, Const_Types true)
    1.41           | ("erased", (NONE, All_Types (* naja *))) =>
    1.42             Guards (Raw_Polymorphic With_Phantom_Type_Vars, No_Types)
    1.43           | _ => raise Same.SAME)
    1.44 @@ -680,9 +686,13 @@
    1.45      Higher_Order THF_Without_Choice
    1.46    | adjust_order _ type_enc = type_enc
    1.47  
    1.48 +fun no_type_classes Type_Class_Polymorphic =
    1.49 +    Raw_Polymorphic With_Phantom_Type_Vars
    1.50 +  | no_type_classes poly = poly
    1.51 +
    1.52  fun adjust_type_enc (THF (Polymorphic, _, choice, _))
    1.53                      (Native (order, poly, level)) =
    1.54 -    Native (adjust_order choice order, poly, level)
    1.55 +    Native (adjust_order choice order, no_type_classes poly, level)
    1.56    | adjust_type_enc (THF (Monomorphic, _, choice, _))
    1.57                           (Native (order, _, level)) =
    1.58      Native (adjust_order choice order, Mangled_Monomorphic, level)
    1.59 @@ -693,9 +703,9 @@
    1.60    | adjust_type_enc (DFG Monomorphic) (Native (_, _, level)) =
    1.61      Native (First_Order, Mangled_Monomorphic, level)
    1.62    | adjust_type_enc (TFF _) (Native (_, poly, level)) =
    1.63 -    Native (First_Order, poly, level)
    1.64 +    Native (First_Order, no_type_classes poly, level)
    1.65    | adjust_type_enc format (Native (_, poly, level)) =
    1.66 -    adjust_type_enc format (Guards (poly, level))
    1.67 +    adjust_type_enc format (Guards (no_type_classes poly, level))
    1.68    | adjust_type_enc CNF_UEQ (type_enc as Guards stuff) =
    1.69      (if is_type_enc_sound type_enc then Tags else Guards) stuff
    1.70    | adjust_type_enc _ type_enc = type_enc