[project @ 2000-08-07 23:37:19 by qrczak]

[ghc-hetmet.git] / ghc / compiler / deSugar / DsUtils.lhs

diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs
index cdd1fd3..bf63c5f 100644 (file)
--- a/ghc/compiler/deSugar/DsUtils.lhs
+++ b/ghc/compiler/deSugar/DsUtils.lhs
@@ -70,8 +70,9 @@ import TysWiredIn     ( nilDataCon, consDataCon,
                        )
 import BasicTypes      ( Boxity(..) )
 import UniqSet         ( mkUniqSet, minusUniqSet, isEmptyUniqSet, UniqSet )
-import Unique          ( unpackCStringIdKey, unpackCString2IdKey )
+import Unique          ( unpackCStringIdKey, unpackCStringUtf8IdKey )
 import Outputable
+import UnicodeUtil      ( stringToUtf8 )
 \end{code}
 
 
@@ -91,11 +92,8 @@ tidyLitPat lit lit_ty default_pat
   | lit_ty == floatTy            = ConPat floatDataCon  lit_ty [] [] [LitPat (mk_float lit)  floatPrimTy]
   | lit_ty == doubleTy           = ConPat doubleDataCon lit_ty [] [] [LitPat (mk_double lit) doublePrimTy]
 
-               -- Convert the literal pattern "" to the constructor pattern [].
-  | null_str_lit lit       = ConPat nilDataCon lit_ty [] [] [] 
-               -- Similar special case for "x"
-  | one_str_lit        lit        = ConPat consDataCon lit_ty [] [] 
-                               [mk_first_char_lit lit, ConPat nilDataCon lit_ty [] [] []]
+               -- Convert literal patterns like "foo" to 'f':'o':'o':[]
+  | str_lit lit           = mk_list lit
 
   | otherwise = default_pat
 
@@ -121,9 +119,14 @@ tidyLitPat lit lit_ty default_pat
     null_str_lit (HsString s) = _NULL_ s
     null_str_lit other_lit    = False
 
-    one_str_lit (HsString s) = _LENGTH_ s == (1::Int)
-    one_str_lit other_lit    = False
-    mk_first_char_lit (HsString s) = ConPat charDataCon charTy [] [] [LitPat (HsCharPrim (_HEAD_ s)) charPrimTy]
+    str_lit (HsString s)     = True
+    str_lit _                = False
+
+    mk_list (HsString s)     = foldr
+       (\c pat -> ConPat consDataCon lit_ty [] [] [mk_char_lit c,pat])
+       (ConPat nilDataCon lit_ty [] [] []) (_UNPK_INT_ s)
+
+    mk_char_lit c            = ConPat charDataCon charTy [] [] [LitPat (HsCharPrim c) charPrimTy]
 \end{code}
 
 
@@ -388,20 +391,19 @@ mkStringLit str   = mkStringLitFS (_PK_ str)
 
 mkStringLitFS :: FAST_STRING  -> DsM CoreExpr
 mkStringLitFS str
-  | any is_NUL (_UNPK_ str)
-  =     -- Must cater for NULs in literal string
-    dsLookupGlobalValue unpackCString2IdKey    `thenDs` \ unpack_id ->
-    returnDs (mkApps (Var unpack_id)
-                    [Lit (MachStr str),
-                    mkIntLitInt (_LENGTH_ str)])
-
-  | otherwise
-  =    -- No NULs in the string
+  | all safeChar chars
+  =
     dsLookupGlobalValue unpackCStringIdKey     `thenDs` \ unpack_id ->
     returnDs (App (Var unpack_id) (Lit (MachStr str)))
 
+  | otherwise
+  =
+    dsLookupGlobalValue unpackCStringUtf8IdKey `thenDs` \ unpack_id ->
+    returnDs (App (Var unpack_id) (Lit (MachStr (_PK_ (stringToUtf8 chars)))))
+
   where
-    is_NUL c = c == '\0'
+    chars = _UNPK_INT_ str
+    safeChar c = c >= 1 && c <= 0xFF
 \end{code}
 
 %************************************************************************