[commit: ghc] master: A little refactoring (a5bdc6b)
git at git.haskell.org
git at git.haskell.org
Wed Sep 18 14:06:59 CEST 2013
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/a5bdc6b58e7bb561c77f4762edcac3350ca26651/ghc
>---------------------------------------------------------------
commit a5bdc6b58e7bb561c77f4762edcac3350ca26651
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date: Tue Sep 17 20:47:21 2013 +0100
A little refactoring
* Make isCFunEqCan_maybe return Maybe (TyCon, [Type])
* Add insertTM, deleteTM to TrieMap
>---------------------------------------------------------------
a5bdc6b58e7bb561c77f4762edcac3350ca26651
compiler/coreSyn/TrieMap.lhs | 8 +++++++-
compiler/typecheck/TcRnTypes.lhs | 8 ++++----
compiler/typecheck/TcSMonad.lhs | 41 +++++++++++++++++++-------------------
3 files changed, 32 insertions(+), 25 deletions(-)
diff --git a/compiler/coreSyn/TrieMap.lhs b/compiler/coreSyn/TrieMap.lhs
index 255ab89..b9c01a0 100644
--- a/compiler/coreSyn/TrieMap.lhs
+++ b/compiler/coreSyn/TrieMap.lhs
@@ -18,7 +18,7 @@ module TrieMap(
CoercionMap,
MaybeMap,
ListMap,
- TrieMap(..),
+ TrieMap(..), insertTM, deleteTM,
lookupTypeMapTyCon
) where
@@ -72,6 +72,12 @@ class TrieMap m where
-- it easy to compose calls to foldTM;
-- see for example fdE below
+insertTM :: TrieMap m => Key m -> a -> m a -> m a
+insertTM k v m = alterTM k (\_ -> Just v) m
+
+deleteTM :: TrieMap m => Key m -> m a -> m a
+deleteTM k m = alterTM k (\_ -> Nothing) m
+
----------------------
-- Recall that
-- Control.Monad.(>=>) :: (a -> Maybe b) -> (b -> Maybe c) -> a -> Maybe c
diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs
index 4305f2b..da0c916 100644
--- a/compiler/typecheck/TcRnTypes.lhs
+++ b/compiler/typecheck/TcRnTypes.lhs
@@ -44,7 +44,7 @@ module TcRnTypes(
-- Canonical constraints
Xi, Ct(..), Cts, emptyCts, andCts, andManyCts, dropDerivedWC,
singleCt, extendCts, isEmptyCts, isCTyEqCan, isCFunEqCan,
- isCDictCan_Maybe, isCFunEqCan_Maybe,
+ isCDictCan_Maybe, isCFunEqCan_maybe,
isCIrredEvCan, isCNonCanonical, isWantedCt, isDerivedCt,
isGivenCt, isHoleCt,
ctEvidence,
@@ -1080,9 +1080,9 @@ isCIrredEvCan :: Ct -> Bool
isCIrredEvCan (CIrredEvCan {}) = True
isCIrredEvCan _ = False
-isCFunEqCan_Maybe :: Ct -> Maybe TyCon
-isCFunEqCan_Maybe (CFunEqCan { cc_fun = tc }) = Just tc
-isCFunEqCan_Maybe _ = Nothing
+isCFunEqCan_maybe :: Ct -> Maybe (TyCon, [Type])
+isCFunEqCan_maybe (CFunEqCan { cc_fun = tc, cc_tyargs = xis }) = Just (tc, xis)
+isCFunEqCan_maybe _ = Nothing
isCFunEqCan :: Ct -> Bool
isCFunEqCan (CFunEqCan {}) = True
diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs
index f7f1a3a..65a6784 100644
--- a/compiler/typecheck/TcSMonad.lhs
+++ b/compiler/typecheck/TcSMonad.lhs
@@ -237,7 +237,7 @@ workListSize (WorkList { wl_eqs = eqs, wl_funeqs = funeqs, wl_rest = rest })
extendWorkListEq :: Ct -> WorkList -> WorkList
-- Extension by equality
extendWorkListEq ct wl
- | Just {} <- isCFunEqCan_Maybe ct
+ | Just {} <- isCFunEqCan_maybe ct
= extendWorkListFunEq ct wl
| otherwise
= wl { wl_eqs = ct : wl_eqs wl }
@@ -418,10 +418,10 @@ lookupFamHead :: FamHeadMap a -> TcType -> Maybe a
lookupFamHead (FamHeadMap m) key = lookupTM key m
insertFamHead :: FamHeadMap a -> TcType -> a -> FamHeadMap a
-insertFamHead (FamHeadMap m) key value = FamHeadMap (alterTM key (const (Just value)) m)
+insertFamHead (FamHeadMap m) key value = FamHeadMap (insertTM key value m)
delFamHead :: FamHeadMap a -> TcType -> FamHeadMap a
-delFamHead (FamHeadMap m) key = FamHeadMap (alterTM key (const Nothing) m)
+delFamHead (FamHeadMap m) key = FamHeadMap (deleteTM key m)
anyFamHeadMap :: (Ct -> Bool) -> CtFamHeadMap -> Bool
anyFamHeadMap f ctmap = foldTM ((||) . f) (unFamHeadMap ctmap) False
@@ -429,22 +429,24 @@ anyFamHeadMap f ctmap = foldTM ((||) . f) (unFamHeadMap ctmap) False
partCtFamHeadMap :: (Ct -> Bool)
-> CtFamHeadMap
-> (Cts, CtFamHeadMap)
-partCtFamHeadMap f ctmap
- = let (cts,tymap_final) = foldTM upd_acc tymap_inside (emptyBag, tymap_inside)
+partCtFamHeadMap f (FamHeadMap ctmap)
+ = let (cts, tymap_final) = foldTM upd_acc ctmap (emptyBag, ctmap)
in (cts, FamHeadMap tymap_final)
where
- tymap_inside = unFamHeadMap ctmap
upd_acc ct (cts,acc_map)
- | f ct = (extendCts cts ct, alterTM ct_key (\_ -> Nothing) acc_map)
+ | f ct = (extendCts cts ct, deleteTM fam_head acc_map)
| otherwise = (cts,acc_map)
- where ct_key | EqPred ty1 _ <- classifyPredType (ctPred ct)
- = ty1
- | otherwise
- = panic "partCtFamHeadMap, encountered non equality!"
+ where
+ fam_head = funEqHead ct
+
+funEqHead :: Ct -> Type
+funEqHead ct = case isCFunEqCan_maybe ct of
+ Just (tc,tys) -> mkTyConApp tc tys
+ Nothing -> pprPanic "funEqHead" (ppr ct)
filterSolved :: (CtEvidence -> Bool) -> PredMap CtEvidence -> PredMap CtEvidence
filterSolved p (PredMap mp) = PredMap (foldTM upd mp emptyTM)
- where upd a m = if p a then alterTM (ctEvPred a) (\_ -> Just a) m
+ where upd a m = if p a then insertTM (ctEvPred a) a m
else m
\end{code}
@@ -657,8 +659,8 @@ insertInertItem item is
| Just cls <- isCDictCan_Maybe item -- Dictionary
= ics { inert_dicts = updCCanMap (cls,item) (inert_dicts ics) }
- | Just _tc <- isCFunEqCan_Maybe item -- Function equality
- = let fam_head = mkTyConApp (cc_fun item) (cc_tyargs item)
+ | Just (tc,tys) <- isCFunEqCan_maybe item -- Function equality
+ = let fam_head = mkTyConApp tc tys
upd_funeqs Nothing = Just item
upd_funeqs (Just _already_there)
= panic "insertInertItem: item already there!"
@@ -691,10 +693,9 @@ addSolvedDict item
; updInertTcS upd_solved_dicts }
where
upd_solved_dicts is
- = is { inert_solved_dicts = PredMap $ alterTM pred upd_solved $
+ = is { inert_solved_dicts = PredMap $ insertTM pred item $
unPredMap $ inert_solved_dicts is }
pred = ctEvPred item
- upd_solved _ = Just item
addSolvedFunEq :: TcType -> CtEvidence -> TcType -> TcS ()
addSolvedFunEq fam_ty ev rhs_ty
@@ -862,13 +863,13 @@ extractRelevantInerts wi
let (cts,dict_map) = getRelevantCts cl (inert_dicts ics)
in (cts, ics { inert_dicts = dict_map })
- extract_ics_relevants ct@(CFunEqCan {}) ics@(IC { inert_funeqs = funeq_map })
- | Just ct <- lookupFamHead funeq_map fam_head
+ extract_ics_relevants ct ics@(IC { inert_funeqs = funeq_map })
+ | Just (tc,tys) <- isCFunEqCan_maybe ct
+ , let fam_head = mkTyConApp tc tys
+ , Just ct <- lookupFamHead funeq_map fam_head
= (singleCt ct, ics { inert_funeqs = delFamHead funeq_map fam_head })
| otherwise
= (emptyCts, ics)
- where
- fam_head = mkTyConApp (cc_fun ct) (cc_tyargs ct)
extract_ics_relevants (CHoleCan {}) ics
= pprPanic "extractRelevantInerts" (ppr wi)
More information about the ghc-commits
mailing list