[commit: ghc] master: Fix Trac #7681. (7b098b6)

[Richard Eisenberg]

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/7b098b6009727a012cb1f3ff0ca51698d302cae1

>---------------------------------------------------------------

commit 7b098b6009727a012cb1f3ff0ca51698d302cae1
Author: Richard Eisenberg <eir at cis.upenn.edu>
Date:   Mon Feb 11 23:07:25 2013 -0500

    Fix Trac #7681.
    
    Removed checks for empty lists for case expressions and lambda-case.
    If -XEmptyCase is not enabled, compilation still fails (appropriately)
    in the renamer.
    
    Had to remove dead code from TrieMap to pass the validator.

>---------------------------------------------------------------

 compiler/coreSyn/TrieMap.lhs |   38 +-------------------------------------
 compiler/deSugar/DsMeta.hs   |    6 ++++--
 compiler/hsSyn/Convert.lhs   |    8 ++------
 libraries/random             |    2 +-
 4 files changed, 8 insertions(+), 46 deletions(-)

diff --git a/compiler/coreSyn/TrieMap.lhs b/compiler/coreSyn/TrieMap.lhs
index 148464b..c013b5d 100644
--- a/compiler/coreSyn/TrieMap.lhs
+++ b/compiler/coreSyn/TrieMap.lhs
@@ -14,7 +14,7 @@
 {-# LANGUAGE TypeFamilies #-}
 module TrieMap(
    CoreMap, emptyCoreMap, extendCoreMap, lookupCoreMap, foldCoreMap,
-   TypeMap, foldTypeMap, lookupTypeMap_mod,
+   TypeMap, foldTypeMap, -- lookupTypeMap_mod,
    CoercionMap, 
    MaybeMap, 
    ListMap,
@@ -32,8 +32,6 @@ import UniqFM
 import Unique( Unique )
 import FastString(FastString)
 
-import Unify ( niFixTvSubst )
-
 import qualified Data.Map    as Map
 import qualified Data.IntMap as IntMap
 import VarEnv
@@ -632,40 +630,6 @@ lkT env ty m
     go (ForAllTy tv ty)  = tm_forall >.> lkT (extendCME env tv) ty >=> lkBndr env tv
 
 
-lkT_mod :: CmEnv  
-        -> TyVarEnv Type -- TvSubstEnv 
-        -> Type
-        -> TypeMap b -> Maybe b 
-lkT_mod env s ty m
-  | EmptyTM <- m = Nothing
-  | Just ty' <- coreView ty
-  = lkT_mod env s ty' m
-  | [] <- candidates 
-  = go env s ty m
-  | otherwise
-  = Just $ snd (head candidates) -- Yikes!
-  where
-     -- Hopefully intersects is much smaller than traversing the whole vm_fvar
-    intersects = eltsUFM $
-                 intersectUFM_C (,) s (vm_fvar $ tm_var m)
-    candidates = [ (u,ct) | (u,ct) <- intersects
-                          , Type.substTy (niFixTvSubst s) u `eqType` ty ]
-                  
-    go env _s (TyVarTy v)      = tm_var    >.> lkVar env v
-    go env s (AppTy t1 t2)     = tm_app    >.> lkT_mod env s t1 >=> lkT_mod env s t2
-    go env s (FunTy t1 t2)     = tm_fun    >.> lkT_mod env s t1 >=> lkT_mod env s t2
-    go env s (TyConApp tc tys) = tm_tc_app >.> lkNamed tc >=> lkList (lkT_mod env s) tys
-    go _env _s (LitTy l)       = tm_tylit  >.> lkTyLit l
-    go _env _s (ForAllTy _tv _ty) = const Nothing
-    
-    {- DV TODO: Add proper lookup for ForAll -}
-
-lookupTypeMap_mod :: TyVarEnv a -- A substitution to be applied to the /keys/ of type map 
-                  -> (a -> Type)
-                  -> Type 
-                  -> TypeMap b -> Maybe b
-lookupTypeMap_mod s f = lkT_mod emptyCME (mapVarEnv f s)
-
 -----------------
 xtT :: CmEnv -> Type -> XT a -> TypeMap a -> TypeMap a
 xtT env ty f m
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 9a9f89d..4f5ba2d 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -920,7 +920,8 @@ repE (HsLit l)     = do { a <- repLiteral l;           repLit a }
 repE (HsLam (MG { mg_alts = [m] })) = repLambda m
 repE (HsLamCase _ (MG { mg_alts = ms }))
                    = do { ms' <- mapM repMatchTup ms
-                        ; repLamCase (nonEmptyCoreList ms') }
+                        ; core_ms <- coreList matchQTyConName ms'
+                        ; repLamCase core_ms }
 repE (HsApp x y)   = do {a <- repLE x; b <- repLE y; repApp a b}
 
 repE (OpApp e1 op _ e2) =
@@ -938,7 +939,8 @@ repE (SectionR x y)       = do { a <- repLE x; b <- repLE y; repSectionR a b }
 repE (HsCase e (MG { mg_alts = ms }))
                           = do { arg <- repLE e
                                ; ms2 <- mapM repMatchTup ms
-                               ; repCaseE arg (nonEmptyCoreList ms2) }
+                               ; core_ms2 <- coreList matchQTyConName ms2
+                               ; repCaseE arg core_ms2 }
 repE (HsIf _ x y z)         = do
 			      a <- repLE x
 			      b <- repLE y
diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index a21caf4..ce15071 100644
--- a/compiler/hsSyn/Convert.lhs
+++ b/compiler/hsSyn/Convert.lhs
@@ -524,9 +524,7 @@ cvtl e = wrapL (cvt e)
     cvt (AppE x y)     = do { x' <- cvtl x; y' <- cvtl y; return $ HsApp x' y' }
     cvt (LamE ps e)    = do { ps' <- cvtPats ps; e' <- cvtl e
                             ; return $ HsLam (mkMatchGroup [mkSimpleMatch ps' e']) }
-    cvt (LamCaseE ms)
-      | null ms        = failWith (ptext (sLit "Lambda-case expression with no alternatives"))
-      | otherwise      = do { ms' <- mapM cvtMatch ms
+    cvt (LamCaseE ms)  = do { ms' <- mapM cvtMatch ms
                             ; return $ HsLamCase placeHolderType
                                                  (mkMatchGroup ms')
                             }
@@ -543,9 +541,7 @@ cvtl e = wrapL (cvt e)
                             ; return $ HsMultiIf placeHolderType alts' }
     cvt (LetE ds e)    = do { ds' <- cvtLocalDecs (ptext (sLit "a let expression")) ds
                             ; e' <- cvtl e; return $ HsLet ds' e' }
-    cvt (CaseE e ms)
-       | null ms       = failWith (ptext (sLit "Case expression with no alternatives"))
-       | otherwise     = do { e' <- cvtl e; ms' <- mapM cvtMatch ms
+    cvt (CaseE e ms)   = do { e' <- cvtl e; ms' <- mapM cvtMatch ms
                             ; return $ HsCase e' (mkMatchGroup ms') }
     cvt (DoE ss)       = cvtHsDo DoExpr ss
     cvt (CompE ss)     = cvtHsDo ListComp ss
diff --git a/libraries/random b/libraries/random
index 0531d37..69bfde2 160000
--- a/libraries/random
+++ b/libraries/random
@@ -1 +1 @@
-Subproject commit 0531d37602d6e7c0b2b5adbf2d5fdd2d01830216
+Subproject commit 69bfde219bab869729fdbe9c1496371f912bf41e