# HG changeset patch
# User haftmann
# Date 1138982553 -3600
# Node ID 340ffeaaaedebaba6f92390b2a698fc7611d6ba3
# Parent  5590770e1b09014ee902b0b13e83d0f80f618087
fix

diff -r 5590770e1b09 -r 340ffeaaaede src/Pure/Tools/codegen_package.ML
--- a/src/Pure/Tools/codegen_package.ML	Fri Feb 03 11:48:11 2006 +0100
+++ b/src/Pure/Tools/codegen_package.ML	Fri Feb 03 17:02:33 2006 +0100
@@ -178,7 +178,7 @@
   |> Symtab.update (
        #haskell CodegenSerializer.serializers
        |> apsnd (fn seri => seri
-            nsp_dtcon
+            [nsp_module, nsp_class, nsp_tyco, nsp_dtcon]
             [[nsp_module], [nsp_class], [nsp_tyco], [nsp_const, nsp_overl, nsp_mem], [nsp_dtcon], [nsp_inst]]
           )
      )
diff -r 5590770e1b09 -r 340ffeaaaede src/Pure/Tools/codegen_serializer.ML
--- a/src/Pure/Tools/codegen_serializer.ML	Fri Feb 03 11:48:11 2006 +0100
+++ b/src/Pure/Tools/codegen_serializer.ML	Fri Feb 03 17:02:33 2006 +0100
@@ -24,7 +24,7 @@
   val pretty_list: string -> string -> int * string -> CodegenThingol.iexpr pretty_syntax;
   val serializers: {
     ml: string * (string * string * (string -> bool) -> serializer),
-    haskell: string * (string -> serializer)
+    haskell: string * (string list -> serializer)
   }
 end;
 
@@ -242,7 +242,7 @@
     | SOME ps => (Pretty.block o map pr) ps
   end;
 
-fun abstract_serializer (target, nspgrp) name_root (from_defs, from_module, validator)
+fun abstract_serializer (target, nspgrp) name_root (from_defs, from_module, validator, postproc)
     postprocess preprocess (class_syntax : string -> string option, tyco_syntax, const_syntax)
     select module =
   let
@@ -261,7 +261,7 @@
     |> preprocess
     |> debug 3 (fn _ => "serializing...")
     |> serialize (from_defs (from_prim, (class_syntax, tyco_syntax, const_syntax)))
-         from_module' validator nspgrp name_root
+         from_module' validator postproc nspgrp name_root
     |> K ()
   end;
 
@@ -703,7 +703,8 @@
           false;
     fun is_cons c = has_nsp c nsp_dtcon;
     val serializer = abstract_serializer (target, nspgrp)
-      "ROOT" (ml_from_defs (is_cons, needs_type), ml_from_module, abstract_validator reserved_ml);
+      "ROOT" (ml_from_defs (is_cons, needs_type), ml_from_module,
+        abstract_validator reserved_ml, snd);
     fun eta_expander module const_syntax s =
       case const_syntax s
        of SOME ((i, _), _) => i
@@ -742,43 +743,18 @@
 
 local
 
-fun hs_from_defs is_cons (from_prim, (class_syntax, tyco_syntax, const_syntax))
+fun hs_from_defs (from_prim, (class_syntax, tyco_syntax, const_syntax))
     resolv defs =
   let
-    fun upper_first s =
-      let
-        val (pr, b) = split_last (NameSpace.unpack s);
-        val (c::cs) = String.explode b;
-      in NameSpace.pack (pr @ [String.implode (Char.toUpper c :: cs)]) end;
-    fun lower_first s =
-      let
-        val (pr, b) = split_last (NameSpace.unpack s);
-        val (c::cs) = String.explode b;
-      in NameSpace.pack (pr @ [String.implode (Char.toLower c :: cs)]) end;
-    val resolv = fn s =>
-      let
-        val (prfix, base) = (split_last o NameSpace.unpack o resolv) s
-      in
-        NameSpace.pack (map upper_first prfix @ [base])
-      end;
-    fun resolv_const f =
-      if NameSpace.is_qualified f
-      then
-        if is_cons f
-        then (upper_first o resolv) f
-        else (lower_first o resolv) f
-      else
-        f;
     fun hs_from_sctxt vs =
       let
         fun from_class cls =
-         case class_syntax cls
-          of NONE => (upper_first o resolv) cls
-           | SOME cls => cls
+          class_syntax cls
+          |> the_default (resolv cls)
         fun from_sctxt [] = str ""
           | from_sctxt vs =
               vs
-              |> map (fn (v, cls) => str (from_class cls ^ " " ^ lower_first v))
+              |> map (fn (v, cls) => str (from_class cls ^ " " ^ v))
               |> Pretty.enum "," "(" ")"
               |> (fn p => Pretty.block [p, str " => "])
       in 
@@ -790,7 +766,7 @@
     fun hs_from_type fxy (IType (tyco, tys)) =
           (case tyco_syntax tyco
            of NONE =>
-                brackify fxy ((str o upper_first o resolv) tyco :: map (hs_from_type BR) tys)
+                brackify fxy ((str o resolv) tyco :: map (hs_from_type BR) tys)
             | SOME ((i, k), pr) =>
                 if not (i <= length tys andalso length tys <= k)
                 then error ("number of argument mismatch in customary serialization: "
@@ -805,7 +781,7 @@
             hs_from_type (INFX (1, R)) t2
           ]
       | hs_from_type fxy (IVarT (v, _)) =
-          (str o lower_first) v;
+          str v;
     fun hs_from_sctxt_type (sctxt, ty) =
       Pretty.block [hs_from_sctxt sctxt, hs_from_type NOBR ty]
     fun hs_from_expr fxy (e as IApp (e1, e2)) =
@@ -819,14 +795,14 @@
       | hs_from_expr fxy (e as IConst x) =
           hs_from_app fxy (x, [])
       | hs_from_expr fxy (IVarE (v, _)) =
-          (str o lower_first) v
+          str v
       | hs_from_expr fxy (e as IAbs _) =
           let
             val (vs, body) = unfold_abs e
           in
             brackify fxy (
               str "\\"
-              :: map (str o lower_first o fst) vs @ [
+              :: map (str o fst) vs @ [
               str "->",
               hs_from_expr NOBR body
             ])
@@ -863,14 +839,14 @@
             (Pretty.chunks o map mk_clause) cs
           ] end
     and hs_mk_app c es =
-      (str o resolv_const) c :: map (hs_from_expr BR) es
+      (str o resolv) c :: map (hs_from_expr BR) es
     and hs_from_app fxy (((c, _), ls), es) =
       from_app hs_mk_app hs_from_expr const_syntax fxy (c, es);
     fun hs_from_funeqs (name, eqs) =
       let
         fun from_eq name (args, rhs) =
           Pretty.block [
-            (str o lower_first o resolv) name,
+            (str o resolv) name,
             Pretty.block (map (fn p => Pretty.block [Pretty.brk 1, hs_from_expr BR p]) args),
             Pretty.brk 1,
             str ("="),
@@ -885,7 +861,7 @@
       | hs_from_def (name, Fun (eqs, (sctxt, ty))) =
           Pretty.chunks [
             Pretty.block [
-              (str o suffix " ::" o lower_first o resolv) name,
+              (str o suffix " ::" o resolv) name,
               Pretty.brk 1,
               hs_from_sctxt_type (sctxt, ty)
             ],
@@ -903,7 +879,7 @@
           let
             fun mk_cons (co, tys) =
               (Pretty.block o Pretty.breaks) (
-                str ((upper_first o resolv) co)
+                (str o resolv) co
                 :: map (hs_from_type NOBR) tys
               )
           in
@@ -932,7 +908,7 @@
             Pretty.block [
               str "class ",
               hs_from_sctxt (map (fn class => (v, [class])) supclasss),
-              str ((upper_first o resolv) name ^ " " ^ v),
+              str (resolv name ^ " " ^ v),
               str " where",
               Pretty.fbrk,
               Pretty.chunks (map mk_member membrs)
@@ -943,7 +919,7 @@
       | hs_from_def (_, Classinst (((clsname, (tyco, arity)), _), memdefs)) = 
           Pretty.block [
             str "instance ",
-            hs_from_sctxt_type (arity, IType ((upper_first o resolv) clsname, map (IVarT o rpair [] o fst) arity)),
+            hs_from_sctxt_type (arity, IType (clsname, map (IVarT o rpair [] o fst) arity)),
             str " ",
             hs_from_sctxt_type (arity, IType (tyco, map (IVarT o rpair [] o fst) arity)),
             str " where",
@@ -958,7 +934,7 @@
 
 in
 
-fun hs_from_thingol target nsp_dtcon nspgrp =
+fun hs_from_thingol target nsps_upper nspgrp =
   let
     val reserved_hs = [
       "hiding", "deriving", "where", "case", "of", "infix", "infixl", "infixr",
@@ -967,21 +943,22 @@
     ] @ [
       "Bool", "fst", "snd", "Integer", "True", "False", "negate"
     ];
-    fun upper_first s =
-      let
-        val (pr, b) = split_last (NameSpace.unpack s);
-        val (c::cs) = String.explode b;
-      in NameSpace.pack (pr @ [String.implode (Char.toUpper c :: cs)]) end;
     fun hs_from_module imps ((_, name), ps) =
       (Pretty.block o Pretty.fbreaks) (
-          str ("module " ^ (upper_first name) ^ " where")
+          str ("module " ^ name ^ " where")
       :: map (str o prefix "import ") imps @ [
           str "",
           Pretty.chunks (separate (str "") ps)
       ]);
-    fun is_cons c = has_nsp c nsp_dtcon;
+    fun postproc (shallow, n) =
+      let
+        fun ch_first f = String.implode o nth_map 0 f o String.explode;
+      in if member (op =) nsps_upper shallow
+        then ch_first Char.toUpper n
+        else ch_first Char.toLower n
+      end;
     val serializer = abstract_serializer (target, nspgrp)
-      "Main" (hs_from_defs is_cons, hs_from_module, abstract_validator reserved_hs);
+      "Main" (hs_from_defs, hs_from_module, abstract_validator reserved_hs, postproc);
     fun eta_expander const_syntax c =
       const_syntax c
       |> Option.map (fst o fst)
diff -r 5590770e1b09 -r 340ffeaaaede src/Pure/Tools/codegen_thingol.ML
--- a/src/Pure/Tools/codegen_thingol.ML	Fri Feb 03 11:48:11 2006 +0100
+++ b/src/Pure/Tools/codegen_thingol.ML	Fri Feb 03 17:02:33 2006 +0100
@@ -94,6 +94,7 @@
     ((string -> string) -> (string * def) list -> 'a option)
     -> (string list -> (string * string) * 'a list -> 'a option)
     -> (string -> string option)
+    -> (string * string -> string)
     -> string list list -> string -> module -> 'a option;
 end;
 
@@ -1047,7 +1048,7 @@
             val SOME (N (p', tab')) = Symtab.lookup tab p
           in ([p'], tab') end
       | get_path_name [p1, p2] tab =
-          case Symtab.lookup tab p1
+          (case Symtab.lookup tab p1
            of SOME (N (p', SOME tab')) => 
                 let
                   val (ps', tab'') = get_path_name [p2] tab'
@@ -1055,7 +1056,7 @@
             | NONE =>
                 let
                   val SOME (N (p', NONE)) = Symtab.lookup tab (NameSpace.pack [p1, p2])
-                in ([p'], NONE) end
+                in ([p'], NONE) end)
       | get_path_name (p::ps) tab =
           let
             val SOME (N (p', SOME tab')) = Symtab.lookup tab p
@@ -1074,9 +1075,9 @@
 
 (* serialization *)
 
-fun serialize seri_defs seri_module validate nsp_conn name_root module =
+fun serialize seri_defs seri_module validate preprocess nsp_conn name_root module =
   let
-    val resolver = mk_deresolver module nsp_conn snd validate;
+    val resolver = mk_deresolver module nsp_conn preprocess validate;
     fun mk_name prfx name =
       let
         val name_qual = NameSpace.pack (prfx @ [name])