Commit 7b098b60 authored by eir@cis.upenn.edu's avatar eir@cis.upenn.edu

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.
parent 04d7220a
......@@ -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
......
......@@ -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
......
......@@ -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
......
random @ 69bfde21
Subproject commit 0531d37602d6e7c0b2b5adbf2d5fdd2d01830216
Subproject commit 69bfde219bab869729fdbe9c1496371f912bf41e
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment