src/Pure/Tools/codegen_serializer.ML

   val parse_syntax: ('b -> int) -> (string -> 'b -> 'a * 'b) -> OuterParse.token list ->
     ('b -> 'a pretty_syntax * 'b) * OuterParse.token list;
   val pretty_list: string -> string -> int * string -> CodegenThingol.iexpr pretty_syntax;
   val serializers: {
     ml: string * (string * string * (string -> bool) -> serializer),
-    haskell: string * (string list -> serializer)
+    haskell: string * (string * string list -> serializer)
   };
   val mk_flat_ml_resolver: string list -> string -> string;
   val ml_fun_datatype: string * string * (string -> bool)
     -> ((string -> CodegenThingol.itype pretty_syntax option)
         * (string -> CodegenThingol.iexpr pretty_syntax option))

     p
     |> write_file true (Path.append prfx name')
     |> postprocess_module name
   end;
 
-fun constructive_fun (name, (eqs, ty)) =
+fun constructive_fun is_cons (name, (eqs, ty)) =
   let
     fun check_eq (eq as (lhs, rhs)) =
-      if forall CodegenThingol.is_pat lhs
+      if forall (CodegenThingol.is_pat is_cons) lhs
       then SOME eq
       else (warning ("in function " ^ quote name ^ ", throwing away one "
         ^ "non-executable function clause"); NONE)
   in case map_filter check_eq eqs
    of [] => error ("in function " ^ quote name ^ ", no "

 fun ml_expr_seri (is_cons, needs_type) (tyco_syntax, const_syntax) resolv =
   let
     val ml_from_label =
       str o translate_string (fn "_" => "__" | "." => "_" | c => c)
         o NameSpace.base o resolv;
-    fun ml_from_tyvar (v, sort) =
-      let
-        fun mk_class v class =
-          str (prefix "'" v ^ " " ^ resolv class);
-      in
-        Pretty.block [
-          str "(",
-          str v,
-          str ":",
-          case sort
-           of [] => str "unit"
-            | [class] => mk_class v class
-            | _ => Pretty.enum " *" "" "" (map (mk_class v) sort),
-          str ")"
-        ]
-      end;
+    fun ml_from_tyvar (v, []) =
+          str "()"
+      | ml_from_tyvar (v, sort) =
+          let
+            val w = (Char.toString o Char.toUpper o the o Char.fromString) v;
+            fun mk_class class =
+              str (prefix "'" v ^ " " ^ resolv class);
+          in
+            Pretty.block [
+              str "(",
+              str w,
+              str ":",
+              case sort
+               of [class] => mk_class class
+                | _ => Pretty.enum " *" "" "" (map mk_class sort),
+              str ")"
+            ]
+          end;
     fun ml_from_sortlookup fxy lss =
       let
         fun from_label l =
           Pretty.block [str "#",
             if (is_some o Int.fromString) l then str l
             else ml_from_label l
           ];
-        fun from_lookup fxy [] p = p
-          | from_lookup fxy [l] p =
+        fun from_lookup fxy [] v =
+              v
+          | from_lookup fxy [l] v =
               brackify fxy [
                 from_label l,
-                p
+                v
               ]
-          | from_lookup fxy ls p =
+          | from_lookup fxy ls v =
               brackify fxy [
                 Pretty.enum " o" "(" ")" (map from_label ls),
-                p
+                v
               ];
         fun from_classlookup fxy (Instance (inst, lss)) =
               brackify fxy (
                 (str o resolv) inst
                 :: map (ml_from_sortlookup BR) lss
               )
           | from_classlookup fxy (Lookup (classes, (v, ~1))) =
-              from_lookup BR classes (str v)
+              from_lookup BR classes
+                ((str o Char.toString o Char.toUpper o the o Char.fromString) v)
           | from_classlookup fxy (Lookup (classes, (v, i))) =
-              from_lookup BR (string_of_int (i+1) :: classes) (str v)
+              from_lookup BR (string_of_int (i+1) :: classes)
+                ((str o Char.toString o Char.toUpper o the o Char.fromString) v)
       in case lss
        of [] => str "()"
         | [ls] => from_classlookup fxy ls
         | lss => (Pretty.list "(" ")" o map (from_classlookup NOBR)) lss
       end;

             (Pretty.block o Pretty.fbreaks o shift) (
               mk_eq definer eq
               :: map (mk_eq "|") eq_tl
             )
           end;
-        val def' :: defs' = map (apsnd eta_expand_poly_fun o constructive_fun) defs
+        val def' :: defs' = map (apsnd eta_expand_poly_fun o constructive_fun is_cons) defs
       in
         chunk_defs (
           (mk_fun (the (fold check_args defs NONE))) def'
           :: map (mk_fun "and") defs'
         )

                 ^ (Pretty.output o CodegenThingol.pretty_def) def)) defs
        of [class] => class
         | _ => error ("class block without class: " ^ (commas o map (quote o fst)) defs)
     fun ml_from_class (name, (supclasses, (v, membrs))) =
       let
+        val w = (Char.toString o Char.toUpper o the o Char.fromString) v;
         fun from_supclass class =
           Pretty.block [
             ml_from_label class,
             str ":",
             Pretty.brk 1,

           ];
         fun from_membr_fun (m, _) =
           (Pretty.block o Pretty.breaks) [
             str "fun",
             (str o resolv) m, 
-            Pretty.enclose "(" ")" [str (v ^ ":'" ^ v ^ " " ^ resolv name)],
+            Pretty.enclose "(" ")" [str (w ^ ":'" ^ v ^ " " ^ resolv name)],
             str "=",
             Pretty.block [str "#", ml_from_label m],
-            str (v ^ ";")
+            str (w ^ ";")
           ];
       in
         Pretty.chunks (
           (Pretty.block o Pretty.breaks) [
             str "type",

             ]
           ) |> SOME
       | ml_from_def (name, CodegenThingol.Classinst (((class, (tyco, arity)), suparities), memdefs)) =
           let
             val definer = if null arity then "val" else "fun"
-            fun from_supclass (supclass, (supinst, lss)) =
-              (Pretty.block o Pretty.breaks) (
-                ml_from_label supclass
-                :: str "="
-                :: (str o resolv) supinst
-                :: (if null lss andalso (not o null) arity
-                     then [str "()"]
-                     else map (ml_from_sortlookup NOBR) lss)
-              );
+            fun from_supclass (supclass, ls) =
+              (Pretty.block o Pretty.breaks) [
+                ml_from_label supclass,
+                str "=",
+                ml_from_sortlookup NOBR ls
+              ];
             fun from_memdef (m, ((m', def), lss)) =
               (ml_from_funs [(m', def)], (Pretty.block o Pretty.breaks) (
                 ml_from_label m
                 :: str "="
                 :: (str o resolv) m'

 
 end; (* local *)
 
 local
 
-fun hs_from_defs with_typs (class_syntax, tyco_syntax, const_syntax)
+fun hs_from_defs (is_cons, with_typs) (class_syntax, tyco_syntax, const_syntax)
     resolver prefix defs =
   let
     val resolv = resolver "";
     val resolv_here = resolver prefix;
     fun hs_from_sctxt vs =

             Pretty.brk 1,
             str ("="),
             Pretty.brk 1,
             hs_from_expr NOBR rhs
           ]
-      in Pretty.chunks ((map from_eq o fst o snd o constructive_fun) def) end;
+      in Pretty.chunks ((map from_eq o fst o snd o constructive_fun is_cons) def) end;
     fun hs_from_def (name, CodegenThingol.Fun (def as (_, (sctxt, ty)))) =
           let
             val body = hs_from_funeqs (name, def);
           in if with_typs then
             Pretty.chunks [

       | l => (SOME o Pretty.chunks o separate (str "")) l
   end;
 
 in
 
-fun hs_from_thingol target nsps_upper nspgrp =
+fun hs_from_thingol target (nsp_dtcon, nsps_upper) nspgrp =
   let
     val reserved_hs = [
       "hiding", "deriving", "where", "case", "of", "infix", "infixl", "infixr",
       "import", "default", "forall", "let", "in", "class", "qualified", "data",
       "newtype", "instance", "if", "then", "else", "type", "as", "do", "module"
     ] @ [
       "Bool", "Integer", "Maybe", "True", "False", "Nothing", "Just", "not", "negate"
     ];
+    fun is_cons c = CodegenThingol.has_nsp c nsp_dtcon;
     fun hs_from_module resolv imps ((_, name), ps) =
       (Pretty.chunks) (
         str ("module " ^ name ^ " where")
         :: map (str o prefix "import qualified ") imps @ (
           str ""

       in if member (op =) nsps_upper shallow
         then ch_first Char.toUpper n
         else ch_first Char.toLower n
       end;
     fun serializer with_typs = abstract_serializer (target, nspgrp)
-      "Main" (hs_from_defs with_typs, hs_from_module, abstract_validator reserved_hs, postproc);
+      "Main" (hs_from_defs (is_cons, with_typs), hs_from_module, abstract_validator reserved_hs, postproc);
     fun eta_expander const_syntax c =
       const_syntax c
       |> Option.map (fst o fst)
       |> the_default 0;
   in