[project @ 2006-01-06 16:30:17 by simonmar]

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

diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs
index 671697b..1465554 100644 (file)
--- a/ghc/compiler/deSugar/DsUtils.lhs
+++ b/ghc/compiler/deSugar/DsUtils.lhs
@@ -16,8 +16,8 @@ module DsUtils (
        cantFailMatchResult, alwaysFailMatchResult,
        extractMatchResult, combineMatchResults, 
        adjustMatchResult,  adjustMatchResultDs,
-       mkCoLetMatchResult,
-       mkGuardedMatchResult, 
+       mkCoLetMatchResult, mkGuardedMatchResult, 
+       matchCanFail,
        mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult,
        wrapBind, wrapBinds,
 
@@ -29,7 +29,7 @@ module DsUtils (
        mkTupleType, mkTupleCase, mkBigCoreTup,
        mkCoreTup, mkCoreTupTy,
        
-       dsReboundNames, lookupReboundName,
+       dsSyntaxTable, lookupEvidence,
 
        selectSimpleMatchVarL, selectMatchVars
     ) where
@@ -69,11 +69,12 @@ import PrelNames    ( unpackCStringName, unpackCStringUtf8Name,
                          plusIntegerName, timesIntegerName, smallIntegerDataConName, 
                          lengthPName, indexPName )
 import Outputable
-import UnicodeUtil      ( intsToUtf8 )
 import SrcLoc          ( Located(..), unLoc )
 import Util             ( isSingleton, notNull, zipEqual, sortWith )
 import ListSetOps      ( assocDefault )
 import FastString
+
+import Data.Char       ( ord )
 \end{code}
 
 
@@ -85,11 +86,11 @@ import FastString
 %************************************************************************
 
 \begin{code}
-dsReboundNames :: ReboundNames Id 
+dsSyntaxTable :: SyntaxTable Id 
               -> DsM ([CoreBind],      -- Auxiliary bindings
                       [(Name,Id)])     -- Maps the standard name to its value
 
-dsReboundNames rebound_ids
+dsSyntaxTable rebound_ids
   = mapAndUnzipDs mk_bind rebound_ids  `thenDs` \ (binds_s, prs) ->
     return (concat binds_s, prs)
   where
@@ -101,11 +102,11 @@ dsReboundNames rebound_ids
           newSysLocalDs (exprType rhs)         `thenDs` \ id ->
           return ([NonRec id rhs], (std_name, id))
 
-lookupReboundName :: [(Name,Id)] -> Name -> CoreExpr
-lookupReboundName prs std_name
-  = Var (assocDefault (mk_panic std_name) prs std_name)
+lookupEvidence :: [(Name, Id)] -> Name -> Id
+lookupEvidence prs std_name
+  = assocDefault (mk_panic std_name) prs std_name
   where
-    mk_panic std_name = pprPanic "dsReboundNames" (ptext SLIT("Not found:") <+> ppr std_name)
+    mk_panic std_name = pprPanic "dsSyntaxTable" (ptext SLIT("Not found:") <+> ppr std_name)
 \end{code}
 
 
@@ -198,6 +199,10 @@ shiftEqns eqns = [ eqn { eqn_pats = tail (eqn_pats eqn) } | eqn <- eqns ]
 Functions on MatchResults
 
 \begin{code}
+matchCanFail :: MatchResult -> Bool
+matchCanFail (MatchResult CanFail _)  = True
+matchCanFail (MatchResult CantFail _) = False
+
 alwaysFailMatchResult :: MatchResult
 alwaysFailMatchResult = MatchResult CanFail (\fail -> returnDs fail)
 
@@ -325,13 +330,13 @@ mkCoAlgCaseMatchResult var ty match_alts
 
        -- Stuff for parallel arrays
        -- 
-       -- * the following is to desugar cases over fake constructors for
+       --  * the following is to desugar cases over fake constructors for
        --   parallel arrays, which are introduced by `tidy1' in the `PArrPat'
        --   case
        --
        -- Concerning `isPArrFakeAlts':
        --
-       -- * it is *not* sufficient to just check the type of the type
+       --  * it is *not* sufficient to just check the type of the type
        --   constructor, as we have to be careful not to confuse the real
        --   representation of parallel arrays with the fake constructors;
        --   moreover, a list of alternatives must not mix fake and real
@@ -407,6 +412,7 @@ mkErrorAppDs err_id ty msg
     let
        full_msg = showSDoc (hcat [ppr src_loc, text "|", text msg])
        core_msg = Lit (mkStringLit full_msg)
+       -- mkStringLit returns a result of type String#
     in
     returnDs (mkApps (Var err_id) [Type ty, core_msg])
 \end{code}
@@ -464,7 +470,7 @@ mkSmallIntegerLit small_integer_data_con i = mkConApp small_integer_data_con [mk
 mkStringExpr str = mkStringExprFS (mkFastString str)
 
 mkStringExprFS str
-  | nullFastString str
+  | nullFS str
   = returnDs (mkNilExpr charTy)
 
   | lengthFS str == 1
@@ -473,17 +479,17 @@ mkStringExprFS str
     in
     returnDs (mkConsExpr charTy the_char (mkNilExpr charTy))
 
-  | all safeChar int_chars
+  | all safeChar chars
   = dsLookupGlobalId unpackCStringName `thenDs` \ unpack_id ->
     returnDs (App (Var unpack_id) (Lit (MachStr str)))
 
   | otherwise
   = dsLookupGlobalId unpackCStringUtf8Name     `thenDs` \ unpack_id ->
-    returnDs (App (Var unpack_id) (Lit (MachStr (mkFastString (intsToUtf8 int_chars)))))
+    returnDs (App (Var unpack_id) (Lit (MachStr str)))
 
   where
-    int_chars = unpackIntFS str
-    safeChar c = c >= 1 && c <= 0xFF
+    chars = unpackFS str
+    safeChar c = ord c >= 1 && ord c <= 0xFF
 \end{code}