Fix a lint failure when we have a ! (# ... #) pattern in a where clause

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

diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs
index 62328bc..2a6e034 100644 (file)
--- a/compiler/deSugar/DsUtils.lhs
+++ b/compiler/deSugar/DsUtils.lhs
@@ -46,6 +46,7 @@ import {-# SOURCE #-} DsExpr( dsExpr )
 
 import HsSyn
 import TcHsSyn
+import TcType( tcSplitTyConApp )
 import CoreSyn
 import DsMonad
 
@@ -72,8 +73,6 @@ import Util
 import ListSetOps
 import FastString
 import StaticFlags
-
-import Data.Char
 \end{code}
 
 
@@ -143,12 +142,12 @@ selectMatchVars :: [Pat Id] -> DsM [Id]
 selectMatchVars ps = mapM selectMatchVar ps
 
 selectMatchVar :: Pat Id -> DsM Id
-selectMatchVar (BangPat pat)   = selectMatchVar (unLoc pat)
-selectMatchVar (LazyPat pat)   = selectMatchVar (unLoc pat)
-selectMatchVar (ParPat pat)    = selectMatchVar (unLoc pat)
-selectMatchVar (VarPat var)    = return var
+selectMatchVar (BangPat pat) = selectMatchVar (unLoc pat)
+selectMatchVar (LazyPat pat) = selectMatchVar (unLoc pat)
+selectMatchVar (ParPat pat)  = selectMatchVar (unLoc pat)
+selectMatchVar (VarPat var)  = return var
 selectMatchVar (AsPat var _) = return (unLoc var)
-selectMatchVar other_pat       = newSysLocalDs (hsPatType other_pat)
+selectMatchVar other_pat     = newSysLocalDs (hsPatType other_pat)
                                  -- OK, better make up one...
 \end{code}
 
@@ -287,7 +286,8 @@ mkCoAlgCaseMatchResult var ty match_alts
     (con1, arg_ids1, match_result1) = ASSERT( notNull match_alts ) head match_alts
     arg_id1    = ASSERT( notNull arg_ids1 ) head arg_ids1
     var_ty      = idType var
-    (tc, ty_args) = splitNewTyConApp var_ty
+    (tc, ty_args) = tcSplitTyConApp var_ty     -- Don't look through newtypes
+                                               -- (not that splitTyConApp does, these days)
     newtype_rhs = unwrapNewTypeBody tc ty_args (Var var)
                
        -- Stuff for data types
@@ -299,11 +299,10 @@ mkCoAlgCaseMatchResult var ty match_alts
              | otherwise
              = CanFail
 
-    wild_var = mkWildId (idType var)
     sorted_alts  = sortWith get_tag match_alts
     get_tag (con, _, _) = dataConTag con
     mk_case fail = do alts <- mapM (mk_alt fail) sorted_alts
-                      return (Case (Var var) wild_var ty (mk_default fail ++ alts))
+                      return (mkWildCase (Var var) (idType var) ty (mk_default fail ++ alts))
 
     mk_alt fail (con, args, MatchResult _ body_fn) = do
           body <- body_fn fail
@@ -350,7 +349,7 @@ mkCoAlgCaseMatchResult var ty match_alts
     mk_parrCase fail = do
       lengthP <- dsLookupGlobalId lengthPName
       alt <- unboxAlt
-      return (Case (len lengthP) (mkWildId intTy) ty [alt])
+      return (mkWildCase (len lengthP) intTy ty [alt])
       where
        elemTy      = case splitTyConApp (idType var) of
                        (_, [elemTy]) -> elemTy
@@ -362,9 +361,8 @@ mkCoAlgCaseMatchResult var ty match_alts
          l      <- newSysLocalDs intPrimTy
          indexP <- dsLookupGlobalId indexPName
          alts   <- mapM (mkAlt indexP) sorted_alts
-         return (DataAlt intDataCon, [l], (Case (Var l) wild ty (dft : alts)))
+         return (DataAlt intDataCon, [l], mkWildCase (Var l) intPrimTy ty (dft : alts))
           where
-           wild = mkWildId intPrimTy
            dft  = (DEFAULT, [], fail)
        --
        -- each alternative matches one array length (corresponding to one
@@ -392,13 +390,13 @@ mkCoAlgCaseMatchResult var ty match_alts
 \begin{code}
 mkErrorAppDs :: Id             -- The error function
             -> Type            -- Type to which it should be applied
-            -> String          -- The error message string to pass
+            -> SDoc            -- The error message string to pass
             -> DsM CoreExpr
 
 mkErrorAppDs err_id ty msg = do
     src_loc <- getSrcSpanDs
     let
-        full_msg = showSDoc (hcat [ppr src_loc, text "|", text msg])
+        full_msg = showSDoc (hcat [ppr src_loc, text "|", msg])
         core_msg = Lit (mkMachString full_msg)
         -- mkMachString returns a result of type String#
     return (mkApps (Var err_id) [Type ty, core_msg])
@@ -458,7 +456,7 @@ mkSelectorBinds pat val_expr
 
         -- For the error message we make one error-app, to avoid duplication.
         -- But we need it at different types... so we use coerce for that
-      err_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID  unitTy (showSDoc (ppr pat))
+      err_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID  unitTy (ppr pat)
       err_var <- newSysLocalDs unitTy
       binds <- mapM (mk_bind val_var err_var) binders
       return ( (val_var, val_expr) : 
@@ -467,7 +465,7 @@ mkSelectorBinds pat val_expr
 
 
   | otherwise = do
-      error_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID   tuple_ty (showSDoc (ppr pat))
+      error_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID   tuple_ty (ppr pat)
       tuple_expr <- matchSimply val_expr PatBindRhs pat local_tuple error_expr
       tuple_var <- newSysLocalDs tuple_ty
       let