[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 181beeb..bf63c5f 100644 (file)
--- a/ghc/compiler/deSugar/DsUtils.lhs
+++ b/ghc/compiler/deSugar/DsUtils.lhs
@@ -21,6 +21,7 @@ module DsUtils (
        mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult,
 
        mkErrorAppDs, mkNilExpr, mkConsExpr,
+       mkStringLit, mkStringLitFS,
 
        mkSelectorBinds, mkTupleExpr, mkTupleSelector,
 
@@ -41,7 +42,7 @@ import DsMonad
 import CoreUtils       ( exprType, mkIfThenElse )
 import PrelInfo                ( iRREFUT_PAT_ERROR_ID )
 import Id              ( idType, Id, mkWildId )
-import Literal         ( Literal )
+import Literal         ( Literal(..) )
 import TyCon           ( isNewTyCon, tyConDataCons )
 import DataCon         ( DataCon, StrictnessMark, maybeMarkedUnboxed, 
                          dataConStrictMarks, dataConId, splitProductType_maybe
@@ -67,8 +68,11 @@ import TysWiredIn    ( nilDataCon, consDataCon,
                           addrTy, addrDataCon,
                           wordTy, wordDataCon
                        )
+import BasicTypes      ( Boxity(..) )
 import UniqSet         ( mkUniqSet, minusUniqSet, isEmptyUniqSet, UniqSet )
+import Unique          ( unpackCStringIdKey, unpackCStringUtf8IdKey )
 import Outputable
+import UnicodeUtil      ( stringToUtf8 )
 \end{code}
 
 
@@ -88,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
 
@@ -118,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}
 
 
@@ -376,8 +382,28 @@ mkErrorAppDs err_id ty msg
     let
        full_msg = showSDoc (hcat [ppr src_loc, text "|", text msg])
     in
-    returnDs (mkApps (Var err_id) [(Type . unUsgTy) ty, mkStringLit full_msg])
+    mkStringLit full_msg               `thenDs` \ core_msg ->
+    returnDs (mkApps (Var err_id) [(Type . unUsgTy) ty, core_msg])
     -- unUsgTy *required* -- KSW 1999-04-07
+
+mkStringLit   :: String       -> DsM CoreExpr
+mkStringLit str        = mkStringLitFS (_PK_ str)
+
+mkStringLitFS :: FAST_STRING  -> DsM CoreExpr
+mkStringLitFS str
+  | 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
+    chars = _UNPK_INT_ str
+    safeChar c = c >= 1 && c <= 0xFF
 \end{code}
 
 %************************************************************************
@@ -421,9 +447,10 @@ mkSelectorBinds pat val_expr
     let
        full_msg = showSDoc (hcat [ppr src_loc, text "|", ppr pat])
     in
+    mkStringLit full_msg                       `thenDs` \ core_msg -> 
     mapDs (mk_bind val_var msg_var) binders    `thenDs` \ binds ->
     returnDs ( (val_var, val_expr) : 
-              (msg_var, mkStringLit full_msg) :
+              (msg_var, core_msg) :
               binds )
 
 
@@ -455,7 +482,7 @@ mkSelectorBinds pat val_expr
         binder_ty = idType bndr_var
         error_expr = mkApps (Var iRREFUT_PAT_ERROR_ID) [Type binder_ty, Var msg_var]
 
-    is_simple_pat (TuplePat ps True{-boxed-}) = all is_triv_pat ps
+    is_simple_pat (TuplePat ps Boxed)  = all is_triv_pat ps
     is_simple_pat (ConPat _ _ _ _ ps)  = all is_triv_pat ps
     is_simple_pat (VarPat _)          = True
     is_simple_pat (RecPat _ _ _ _ ps)  = and [is_triv_pat p | (_,p,_) <- ps]
@@ -476,7 +503,7 @@ mkTupleExpr :: [Id] -> CoreExpr
 
 mkTupleExpr []  = Var unitDataConId
 mkTupleExpr [id] = Var id
-mkTupleExpr ids         = mkConApp (tupleCon (length ids))
+mkTupleExpr ids         = mkConApp (tupleCon Boxed (length ids))
                            (map (Type . unUsgTy . idType) ids ++ [ Var i | i <- ids ])
 \end{code}
 
@@ -503,7 +530,7 @@ mkTupleSelector [var] should_be_the_same_var scrut_var scrut
 
 mkTupleSelector vars the_var scrut_var scrut
   = ASSERT( not (null vars) )
-    Case scrut scrut_var [(DataAlt (tupleCon (length vars)), vars, Var the_var)]
+    Case scrut scrut_var [(DataAlt (tupleCon Boxed (length vars)), vars, Var the_var)]
 \end{code}