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

I was working in a ghc tree that I thought was clean (i.e. was a checkout of HEAD), but evidently was not. In my other work, I needed to update lookupType_mod, but wasn't sure how to. So, I looked for use sites. When I found none, I must have gone into this ghc tree, removed the exports, and checked to make sure everything compiled. There were no problems, and I guess I forgot to undo my test change. When fixing #7681, the exports were still missing, causing the warning and validate failure. I'm happy to bring lookupType_mod back if it is expected to be needed somewhere. Richard On Feb 12, 2013, at 3:08 AM, Simon Peyton-Jones wrote:

Thanks for fixing.

You removed lookupType_mod from TrieMap. It was defined and exported but not called. How did validate spot that? I'm sure there are quite a few such functions in GHC.

Simon

| -----Original Message----- | From: ghc-commits-bounces@haskell.org [mailto:ghc-commits- | bounces@haskell.org] On Behalf Of Richard Eisenberg | Sent: 12 February 2013 04:10 | To: ghc-commits@haskell.org | Subject: [commit: ghc] master: Fix Trac #7681. (7b098b6) | | Repository : ssh://darcs.haskell.org//srv/darcs/ghc | | On branch : master | | http://hackage.haskell.org/trac/ghc/changeset/7b098b6009727a012cb1f3ff0c | a51698d302cae1 | | >--------------------------------------------------------------- | | commit 7b098b6009727a012cb1f3ff0ca51698d302cae1 | Author: Richard Eisenberg | 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 | | | | _______________________________________________ | ghc-commits mailing list | ghc-commits@haskell.org | http://www.haskell.org/mailman/listinfo/ghc-commits