)
import TcMonad
-import Inst ( lookupInst, lookupSimpleInst, LookupInstResult(..),
+import Inst ( lookupInst, LookupInstResult(..),
tyVarsOfInst, predsOfInsts, predsOfInst, newDicts,
isDict, isClassDict, isLinearInst, linearInstType,
isStdClassTyVarDict, isMethodFor, isMethod,
import TcEnv ( tcGetGlobalTyVars, tcGetInstEnv, tcLookupGlobalId )
import InstEnv ( lookupInstEnv, classInstEnv, InstLookupResult(..) )
import TcMType ( zonkTcTyVarsAndFV, tcInstTyVars, checkAmbiguity )
-import TcType ( TcTyVar, TcTyVarSet, ThetaType, PredType,
+import TcType ( TcTyVar, TcTyVarSet, ThetaType, TyVarDetails(VanillaTv),
mkClassPred, isOverloadedTy, mkTyConApp,
mkTyVarTy, tcGetTyVar, isTyVarClassPred, mkTyVarTys,
- tyVarsOfPred, getClassPredTys_maybe, isClassPred, isIPPred,
- inheritablePred, predHasFDs )
+ tyVarsOfPred, isIPPred, isInheritablePred, predHasFDs )
import Id ( idType, mkUserLocal )
import Var ( TyVar )
import Name ( getOccName, getSrcLoc )
import Class ( classBigSig )
import FunDeps ( oclose, grow, improve, pprEquationDoc )
import PrelInfo ( isNumericClass, isCreturnableClass, isCcallishClass,
- splitIdName, fstIdName, sndIdName )
+ splitName, fstName, sndName )
import Subst ( mkTopTyVarSubst, substTheta, substTy )
import TysWiredIn ( unitTy, pairTyCon )
isFreeWhenInferring :: TyVarSet -> Inst -> Bool
isFreeWhenInferring qtvs inst
= isFreeWrtTyVars qtvs inst -- Constrains no quantified vars
- && all inheritablePred (predsOfInst inst) -- And no implicit parameter involved
+ && all isInheritablePred (predsOfInst inst) -- And no implicit parameter involved
-- (see "Notes on implicit parameters")
isFreeWhenChecking :: TyVarSet -- Quantified tyvars
-- tcSimplifyCheck is used when checking expression type signatures,
-- class decls, instance decls etc.
--- Note that we psss isFree (not isFreeAndInheritable) to tcSimplCheck
--- It's important that we can float out non-inheritable predicates
--- Example: (?x :: Int) is ok!
+--
+-- NB: tcSimplifyCheck does not consult the
+-- global type variables in the environment; so you don't
+-- need to worry about setting them before calling tcSimplifyCheck
tcSimplifyCheck doc qtvs givens wanted_lie
= tcSimplCheck doc get_qtvs
givens wanted_lie `thenTc` \ (qtvs', frees, binds) ->
-- is turned into an LinRhss
[TcExpr] -- A supply of suitable RHSs
-pprAvails avails = vcat [ppr inst <+> equals <+> pprAvail avail
+pprAvails avails = vcat [sep [ppr inst, nest 2 (equals <+> pprAvail avail)]
| (inst,avail) <- fmToList avails ]
instance Outputable Avail where
where
new_binds = addBind binds w rhs
- Just (LinRhss (rhs:rhss)) -- Consume one of the Rhss
+ Just (Linear n split_inst avail) -- Transform Linear --> LinRhss
+ -> get_root irreds frees avail w `thenNF_Tc` \ (irreds', frees', root_id) ->
+ split n (instToId split_inst) root_id w `thenNF_Tc` \ (binds', rhss) ->
+ go (addToFM avails w (LinRhss rhss))
+ (binds `AndMonoBinds` binds')
+ irreds' frees' (split_inst : w : ws)
+
+ Just (LinRhss (rhs:rhss)) -- Consume one of the Rhss
-> go new_avails new_binds irreds frees ws
where
new_binds = addBind binds w rhs
new_avails = addToFM avails w (LinRhss rhss)
- Just (Linear n split_inst avail)
- -> split n (instToId split_inst) avail w `thenNF_Tc` \ (binds', (rhs:rhss), irreds') ->
- go (addToFM avails w (LinRhss rhss))
- (binds `AndMonoBinds` addBind binds' w rhs)
- (irreds' ++ irreds) frees (split_inst:ws)
-
+ get_root irreds frees (Given id _) w = returnNF_Tc (irreds, frees, id)
+ get_root irreds frees Irred w = cloneDict w `thenNF_Tc` \ w' ->
+ returnNF_Tc (w':irreds, frees, instToId w')
+ get_root irreds frees IsFree w = cloneDict w `thenNF_Tc` \ w' ->
+ returnNF_Tc (irreds, w':frees, instToId w')
add_given avails w
| instBindingRequired w = addToFM avails w (Given (instToId w) True)
-- 1 or 0 insts to add to irreds
-split :: Int -> TcId -> Avail -> Inst
- -> NF_TcM (TcDictBinds, [TcExpr], [Inst])
--- (split n split_id avail wanted) returns
+split :: Int -> TcId -> TcId -> Inst
+ -> NF_TcM (TcDictBinds, [TcExpr])
+-- (split n split_id root_id wanted) returns
-- * a list of 'n' expressions, all of which witness 'avail'
-- * a bunch of auxiliary bindings to support these expressions
-- * one or zero insts needed to witness the whole lot
-- (maybe be zero if the initial Inst is a Given)
-split n split_id avail wanted
+--
+-- NB: 'wanted' is just a template
+
+split n split_id root_id wanted
= go n
where
- ty = linearInstType wanted
+ ty = linearInstType wanted
pair_ty = mkTyConApp pairTyCon [ty,ty]
- id = instToId wanted
- occ = getOccName id
- loc = getSrcLoc id
+ id = instToId wanted
+ occ = getOccName id
+ loc = getSrcLoc id
- go 1 = case avail of
- Given id _ -> returnNF_Tc (EmptyMonoBinds, [HsVar id], [])
- Irred -> cloneDict wanted `thenNF_Tc` \ w' ->
- returnNF_Tc (EmptyMonoBinds, [HsVar (instToId w')], [w'])
+ go 1 = returnNF_Tc (EmptyMonoBinds, [HsVar root_id])
- go n = go ((n+1) `div` 2) `thenNF_Tc` \ (binds1, rhss, irred) ->
+ go n = go ((n+1) `div` 2) `thenNF_Tc` \ (binds1, rhss) ->
expand n rhss `thenNF_Tc` \ (binds2, rhss') ->
- returnNF_Tc (binds1 `AndMonoBinds` binds2, rhss', irred)
+ returnNF_Tc (binds1 `AndMonoBinds` binds2, rhss')
-- (expand n rhss)
-- Given ((n+1)/2) rhss, make n rhss, using auxiliary bindings
returnNF_Tc (andMonoBindList binds', concat rhss')
do_one rhs = tcGetUnique `thenNF_Tc` \ uniq ->
- tcLookupGlobalId fstIdName `thenNF_Tc` \ fst_id ->
- tcLookupGlobalId sndIdName `thenNF_Tc` \ snd_id ->
+ tcLookupGlobalId fstName `thenNF_Tc` \ fst_id ->
+ tcLookupGlobalId sndName `thenNF_Tc` \ snd_id ->
let
x = mkUserLocal occ uniq pair_ty loc
in
returnTc False
where
unify ((qtvs, t1, t2), doc)
- = tcAddErrCtxt doc $
- tcInstTyVars (varSetElems qtvs) `thenNF_Tc` \ (_, _, tenv) ->
+ = tcAddErrCtxt doc $
+ tcInstTyVars VanillaTv (varSetElems qtvs) `thenNF_Tc` \ (_, _, tenv) ->
unifyTauTy (substTy tenv t1) (substTy tenv t2)
\end{code}
addLinearAvailable :: Avails -> Avail -> Inst -> NF_TcM (Avails, [Inst])
addLinearAvailable avails avail wanted
- | need_split avail
- = tcLookupGlobalId splitIdName `thenNF_Tc` \ split_id ->
+ -- avails currently maps [wanted -> avail]
+ -- Extend avails to reflect a neeed for an extra copy of avail
+
+ | Just avail' <- split_avail avail
+ = returnNF_Tc (addToFM avails wanted avail', [])
+
+ | otherwise
+ = tcLookupGlobalId splitName `thenNF_Tc` \ split_id ->
newMethodAtLoc (instLoc wanted) split_id
[linearInstType wanted] `thenNF_Tc` \ (split_inst,_) ->
returnNF_Tc (addToFM avails wanted (Linear 2 split_inst avail), [split_inst])
- | otherwise
- = returnNF_Tc (addToFM avails wanted avail', [])
where
- avail' = case avail of
- Given id _ -> Given id True
- Linear n i a -> Linear (n+1) i a
-
- need_split Irred = True
- need_split (Given _ used) = used
- need_split (Linear _ _ _) = False
-
+ split_avail :: Avail -> Maybe Avail
+ -- (Just av) if there's a modified version of avail that
+ -- we can use to replace avail in avails
+ -- Nothing if there isn't, so we need to create a Linear
+ split_avail (Linear n i a) = Just (Linear (n+1) i a)
+ split_avail (Given id used) | not used = Just (Given id True)
+ | otherwise = Nothing
+ split_avail Irred = Nothing
+ split_avail IsFree = Nothing
+ split_avail other = pprPanic "addLinearAvailable" (ppr avail $$ ppr wanted $$ ppr avails)
+
-------------------------
addFree :: Avails -> Inst -> NF_TcM Avails
-- When an Inst is tossed upstairs as 'free' we nevertheless add it
-- an optimisation, and perhaps it is more trouble that it is worth,
-- as the following comments show!
--
- -- NB1: do *not* add superclasses. If we have
+ -- NB: do *not* add superclasses. If we have
-- df::Floating a
-- dn::Num a
-- but a is not bound here, then we *don't* want to derive
addWanted :: Avails -> Inst -> TcExpr -> [Inst] -> NF_TcM Avails
addWanted avails wanted rhs_expr wanteds
--- Do *not* add superclasses as well. Here's an example of why not
--- class Eq a => Foo a b
--- instance Eq a => Foo [a] a
--- If we are reducing
--- (Foo [t] t)
--- we'll first deduce that it holds (via the instance decl). We
--- must not then overwrite the Eq t constraint with a superclass selection!
--- ToDo: this isn't entirely unsatisfactory, because
--- we may also lose some entirely-legitimate sharing this way
-
- = ASSERT( not (wanted `elemFM` avails) )
- returnNF_Tc (addToFM avails wanted avail)
+ = ASSERT2( not (wanted `elemFM` avails), ppr wanted $$ ppr avails )
+ addAvailAndSCs avails wanted avail
where
avail | instBindingRequired wanted = Rhs rhs_expr wanteds
| otherwise = ASSERT( null wanteds ) NoRhs
addGiven :: Avails -> Inst -> NF_TcM Avails
addGiven state given = addAvailAndSCs state given (Given (instToId given) False)
+ -- No ASSERT( not (given `elemFM` avails) ) because in an instance
+ -- decl for Ord t we can add both Ord t and Eq t as 'givens',
+ -- so the assert isn't true
addIrred :: WantSCs -> Avails -> Inst -> NF_TcM Avails
-addIrred NoSCs state irred = returnNF_Tc (addToFM state irred Irred)
-addIrred AddSCs state irred = addAvailAndSCs state irred Irred
+addIrred NoSCs avails irred = returnNF_Tc (addToFM avails irred Irred)
+addIrred AddSCs avails irred = ASSERT2( not (irred `elemFM` avails), ppr irred $$ ppr avails )
+ addAvailAndSCs avails irred Irred
addAvailAndSCs :: Avails -> Inst -> Avail -> NF_TcM Avails
-addAvailAndSCs avails wanted avail
- = add_scs (addToFM avails wanted avail) wanted
-
-add_scs :: Avails -> Inst -> NF_TcM Avails
+addAvailAndSCs avails inst avail
+ | not (isClassDict inst) = returnNF_Tc avails1
+ | otherwise = addSCs is_loop avails1 inst
+ where
+ avails1 = addToFM avails inst avail
+ is_loop inst = inst `elem` deps -- Note: this compares by *type*, not by Unique
+ deps = findAllDeps avails avail
+
+findAllDeps :: Avails -> Avail -> [Inst]
+-- Find all the Insts that this one depends on
+-- See Note [SUPERCLASS-LOOP]
+findAllDeps avails (Rhs _ kids) = kids ++ concat (map (find_all_deps_help avails) kids)
+findAllDeps avails other = []
+
+find_all_deps_help :: Avails -> Inst -> [Inst]
+find_all_deps_help avails inst
+ = case lookupFM avails inst of
+ Just avail -> findAllDeps avails avail
+ Nothing -> []
+
+addSCs :: (Inst -> Bool) -> Avails -> Inst -> NF_TcM Avails
-- Add all the superclasses of the Inst to Avails
+ -- The first param says "dont do this because the original thing
+ -- depends on this one, so you'd build a loop"
-- Invariant: the Inst is already in Avails.
-add_scs avails dict
- | not (isClassDict dict)
- = returnNF_Tc avails
-
- | otherwise -- It is a dictionary
+addSCs is_loop avails dict
= newDictsFromOld dict sc_theta' `thenNF_Tc` \ sc_dicts ->
foldlNF_Tc add_sc avails (zipEqual "add_scs" sc_dicts sc_sels)
where
add_sc avails (sc_dict, sc_sel) -- Add it, and its superclasses
= case lookupFM avails sc_dict of
- Just (Given _ _) -> returnNF_Tc avails -- See Note [SUPER] below
- other -> addAvailAndSCs avails sc_dict avail
+ Just (Given _ _) -> returnNF_Tc avails -- Given is cheaper than
+ -- a superclass selection
+ Just other | is_loop sc_dict -> returnNF_Tc avails -- See Note [SUPERCLASS-LOOP]
+ | otherwise -> returnNF_Tc avails' -- SCs already added
+
+ Nothing -> addSCs is_loop avails' sc_dict
where
sc_sel_rhs = DictApp (TyApp (HsVar sc_sel) tys) [instToId dict]
avail = Rhs sc_sel_rhs [dict]
+ avails' = addToFM avails sc_dict avail
\end{code}
-Note [SUPER]. We have to be careful here. If we are *given* d1:Ord a,
+Note [SUPERCLASS-LOOP]: Checking for loops
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We have to be careful here. If we are *given* d1:Ord a,
and want to deduce (d2:C [a]) where
class Ord a => C a where
Then we'll use the instance decl to deduce C [a] and then add the
superclasses of C [a] to avails. But we must not overwrite the binding
for d1:Ord a (which is given) with a superclass selection or we'll just
-build a loop! Hence looking for Given. Crudely, Given is cheaper
-than a selection.
+build a loop!
+
+Here's another example
+ class Eq b => Foo a b
+ instance Eq a => Foo [a] a
+If we are reducing
+ (Foo [t] t)
+
+we'll first deduce that it holds (via the instance decl). We must not
+then overwrite the Eq t constraint with a superclass selection!
+
+At first I had a gross hack, whereby I simply did not add superclass constraints
+in addWanted, though I did for addGiven and addIrred. This was sub-optimal,
+becuase it lost legitimate superclass sharing, and it still didn't do the job:
+I found a very obscure program (now tcrun021) in which improvement meant the
+simplifier got two bites a the cherry... so something seemed to be an Irred
+first time, but reducible next time.
+
+Now we implement the Right Solution, which is to check for loops directly
+when adding superclasses. It's a bit like the occurs check in unification.
+
%************************************************************************
std_groups = equivClasses cmp_by_tyvar stds
-- Pick the ones which its worth trying to disambiguate
- (std_oks, std_bads) = partition worth_a_try std_groups
-
- -- Have a try at disambiguation
- -- if the type variable isn't bound
+ -- namely, the onese whose type variable isn't bound
-- up with one of the non-standard classes
+ (std_oks, std_bads) = partition worth_a_try std_groups
worth_a_try group@(d:_) = not (non_std_tyvars `intersectsVarSet` tyVarsOfInst d)
non_std_tyvars = unionVarSets (map tyVarsOfInst non_stds)
-- Collect together all the bad guys
- bad_guys = non_stds ++ concat std_bads
+ bad_guys = non_stds ++ concat std_bads
+ (tidy_env, tidy_dicts) = tidyInsts bad_guys
+ (bad_ips, non_ips) = partition is_ip tidy_dicts
+ (no_insts, ambigs) = partition no_inst non_ips
+ is_ip d = any isIPPred (predsOfInst d)
+ no_inst d = not (isTyVarDict d) || tyVarsOfInst d `subVarSet` fixed_tvs
+ fixed_tvs = oclose (predsOfInsts tidy_dicts) emptyVarSet
in
- -- Disambiguate the ones that look feasible
- mapTc disambigGroup std_oks `thenTc` \ binds_ambig ->
- -- And complain about the ones that don't
+ -- Report definite errors
+ mapNF_Tc (addTopInstanceErrs tidy_env) (groupInsts no_insts) `thenNF_Tc_`
+ mapNF_Tc (addTopIPErrs tidy_env) (groupInsts bad_ips) `thenNF_Tc_`
+
+ -- Deal with ambiguity errors, but only if
+ -- if there has not been an error so far; errors often
+ -- give rise to spurious ambiguous Insts
+ ifErrsTc (returnTc []) (
+
+ -- Complain about the ones that don't fall under
+ -- the Haskell rules for disambiguation
-- This group includes both non-existent instances
-- e.g. Num (IO a) and Eq (Int -> Int)
-- and ambiguous dictionaries
-- e.g. Num a
- addTopAmbigErrs bad_guys `thenNF_Tc_`
+ mapNF_Tc (addAmbigErr tidy_env) ambigs `thenNF_Tc_`
+
+ -- Disambiguate the ones that look feasible
+ mapTc disambigGroup std_oks
+ ) `thenTc` \ binds_ambig ->
returnTc (binds `andMonoBinds` andMonoBindList binds_ambig)
where
- wanteds = lieToList wanted_lie
+ wanteds = lieToList wanted_lie
- d1 `cmp_by_tyvar` d2 = get_tv d1 `compare` get_tv d2
+----------------------------------
+d1 `cmp_by_tyvar` d2 = get_tv d1 `compare` get_tv d2
get_tv d = case getDictClassTys d of
(clas, [ty]) -> tcGetTyVar "tcSimplify" ty
-> TcM ThetaType -- Needed
tcSimplifyDeriv tyvars theta
- = tcInstTyVars tyvars `thenNF_Tc` \ (tvs, _, tenv) ->
+ = tcInstTyVars VanillaTv tyvars `thenNF_Tc` \ (tvs, _, tenv) ->
-- The main loop may do unification, and that may crash if
-- it doesn't see a TcTyVar, so we have to instantiate. Sigh
-- ToDo: what if two of them do get unified?
simpl_theta = map dictPred irreds -- reduceMe squashes all non-dicts
check_pred pred
+ | isEmptyVarSet pred_tyvars -- Things like (Eq T) should be rejected
+ = addErrTc (noInstErr pred)
+
+ | not undecidable_ok && not (isTyVarClassPred pred)
-- Check that the returned dictionaries are all of form (C a b)
-- (where a, b are type variables).
- -- Unless we have -fallow-undecidable-instances.
- | not undecidable_ok && not (isTyVarClassPred pred)
+ -- We allow this if we had -fallow-undecidable-instances,
+ -- but note that risks non-termination in the 'deriving' context-inference
+ -- fixpoint loop. It is useful for situations like
+ -- data Min h a = E | M a (h a)
+ -- which gives the instance decl
+ -- instance (Eq a, Eq (h a)) => Eq (Min h a)
= addErrTc (noInstErr pred)
+ | not (pred_tyvars `subVarSet` tv_set)
-- Check for a bizarre corner case, when the derived instance decl should
-- have form instance C a b => D (T a) where ...
-- Note that 'b' isn't a parameter of T. This gives rise to all sorts
-- of problems; in particular, it's hard to compare solutions for
-- equality when finding the fixpoint. So I just rule it out for now.
- | not (tyVarsOfPred pred `subVarSet` tv_set)
= addErrTc (badDerivedPred pred)
| otherwise
= returnNF_Tc ()
+ where
+ pred_tyvars = tyVarsOfPred pred
rev_env = mkTopTyVarSubst tvs (mkTyVarTys tyvars)
-- This reverse-mapping is a Royal Pain,
loc_msg = showSDoc (pprInstLoc (instLoc inst))
is_friend friend = showSDoc (pprInstLoc (instLoc friend)) == loc_msg
-
-addTopAmbigErrs dicts
- = mapNF_Tc (addTopInstanceErrs tidy_env) (groupInsts no_insts) `thenNF_Tc_`
- mapNF_Tc (addTopIPErrs tidy_env) (groupInsts bad_ips) `thenNF_Tc_`
- mapNF_Tc (addAmbigErr tidy_env) ambigs `thenNF_Tc_`
- returnNF_Tc ()
- where
- fixed_tvs = oclose (predsOfInsts tidy_dicts) emptyVarSet
- (tidy_env, tidy_dicts) = tidyInsts dicts
- (bad_ips, non_ips) = partition is_ip tidy_dicts
- (no_insts, ambigs) = partition no_inst non_ips
- is_ip d = any isIPPred (predsOfInst d)
- no_inst d = not (isTyVarDict d) || tyVarsOfInst d `subVarSet` fixed_tvs
-
plural [x] = empty
plural xs = char 's'