1.1 --- a/src/Tools/Code/code_haskell.ML Tue Sep 07 16:26:14 2010 +0200
1.2 +++ b/src/Tools/Code/code_haskell.ML Tue Sep 07 16:37:23 2010 +0200
1.3 @@ -27,7 +27,6 @@
1.4 fun print_haskell_stmt labelled_name class_syntax tyco_syntax const_syntax
1.5 reserved deresolve contr_classparam_typs deriving_show =
1.6 let
1.7 - val deresolve_base = Long_Name.base_name o deresolve;
1.8 fun class_name class = case class_syntax class
1.9 of NONE => deresolve class
1.10 | SOME class => class;
1.11 @@ -121,7 +120,7 @@
1.12 val tyvars = intro_vars (map fst vs) reserved;
1.13 fun print_err n =
1.14 semicolon (
1.15 - (str o deresolve_base) name
1.16 + (str o deresolve) name
1.17 :: map str (replicate n "_")
1.18 @ str "="
1.19 :: str "error"
1.20 @@ -138,7 +137,7 @@
1.21 (insert (op =)) ts []);
1.22 in
1.23 semicolon (
1.24 - (str o deresolve_base) name
1.25 + (str o deresolve) name
1.26 :: map (print_term tyvars some_thm vars BR) ts
1.27 @ str "="
1.28 @@ print_term tyvars some_thm vars NOBR t
1.29 @@ -147,7 +146,7 @@
1.30 in
1.31 Pretty.chunks (
1.32 semicolon [
1.33 - (str o suffix " ::" o deresolve_base) name,
1.34 + (str o suffix " ::" o deresolve) name,
1.35 print_typscheme tyvars (vs, ty)
1.36 ]
1.37 :: (case filter (snd o snd) raw_eqs
1.38 @@ -161,7 +160,7 @@
1.39 in
1.40 semicolon [
1.41 str "data",
1.42 - print_typdecl tyvars (vs, (deresolve_base name, map (ITyVar o fst) vs))
1.43 + print_typdecl tyvars (vs, (deresolve name, map (ITyVar o fst) vs))
1.44 ]
1.45 end
1.46 | print_stmt (name, Code_Thingol.Datatype (_, (vs, [((co, _), [ty])]))) =
1.47 @@ -170,9 +169,9 @@
1.48 in
1.49 semicolon (
1.50 str "newtype"
1.51 - :: print_typdecl tyvars (vs, (deresolve_base name, map (ITyVar o fst) vs))
1.52 + :: print_typdecl tyvars (vs, (deresolve name, map (ITyVar o fst) vs))
1.53 :: str "="
1.54 - :: (str o deresolve_base) co
1.55 + :: (str o deresolve) co
1.56 :: print_typ tyvars BR ty
1.57 :: (if deriving_show name then [str "deriving (Read, Show)"] else [])
1.58 )
1.59 @@ -182,13 +181,13 @@
1.60 val tyvars = intro_vars (map fst vs) reserved;
1.61 fun print_co ((co, _), tys) =
1.62 concat (
1.63 - (str o deresolve_base) co
1.64 + (str o deresolve) co
1.65 :: map (print_typ tyvars BR) tys
1.66 )
1.67 in
1.68 semicolon (
1.69 str "data"
1.70 - :: print_typdecl tyvars (vs, (deresolve_base name, map (ITyVar o fst) vs))
1.71 + :: print_typdecl tyvars (vs, (deresolve name, map (ITyVar o fst) vs))
1.72 :: str "="
1.73 :: print_co co
1.74 :: map ((fn p => Pretty.block [str "| ", p]) o print_co) cos
1.75 @@ -200,7 +199,7 @@
1.76 val tyvars = intro_vars [v] reserved;
1.77 fun print_classparam (classparam, ty) =
1.78 semicolon [
1.79 - (str o deresolve_base) classparam,
1.80 + (str o deresolve) classparam,
1.81 str "::",
1.82 print_typ tyvars NOBR ty
1.83 ]
1.84 @@ -209,7 +208,7 @@
1.85 Pretty.block [
1.86 str "class ",
1.87 Pretty.block (print_typcontext tyvars [(v, map fst super_classes)]),
1.88 - str (deresolve_base name ^ " " ^ lookup_var tyvars v),
1.89 + str (deresolve name ^ " " ^ lookup_var tyvars v),
1.90 str " where {"
1.91 ],
1.92 str "};"
1.93 @@ -219,17 +218,17 @@
1.94 let
1.95 val tyvars = intro_vars (map fst vs) reserved;
1.96 fun requires_args classparam = case const_syntax classparam
1.97 - of NONE => 0
1.98 - | SOME (Code_Printer.Plain_const_syntax _) => 0
1.99 - | SOME (Code_Printer.Complex_const_syntax (k,_ )) => k;
1.100 + of NONE => NONE
1.101 + | SOME (Code_Printer.Plain_const_syntax _) => SOME 0
1.102 + | SOME (Code_Printer.Complex_const_syntax (k,_ )) => SOME k;
1.103 fun print_classparam_instance ((classparam, const), (thm, _)) =
1.104 case requires_args classparam
1.105 - of 0 => semicolon [
1.106 - (str o deresolve_base) classparam,
1.107 + of NONE => semicolon [
1.108 + (str o Long_Name.base_name o deresolve) classparam,
1.109 str "=",
1.110 print_app tyvars (SOME thm) reserved NOBR (const, [])
1.111 ]
1.112 - | k =>
1.113 + | SOME k =>
1.114 let
1.115 val (c, (_, tys)) = const;
1.116 val (vs, rhs) = (apfst o map) fst