Commit a5bdc6b5 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

A little refactoring

* Make isCFunEqCan_maybe return Maybe (TyCon, [Type])
* Add insertTM, deleteTM to TrieMap
parent 7a4c15a0
......@@ -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
......
......@@ -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
......
......@@ -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)
......
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