import {-# SOURCE #-} TcUnify( unifyTauTy )
import TcEnv -- temp
-import HsSyn ( MonoBinds(..), HsExpr(..), andMonoBinds, andMonoBindList )
-import TcHsSyn ( TcExpr, TcId,
- TcMonoBinds, TcDictBinds
- )
+import HsSyn ( HsBind(..), LHsBinds, HsExpr(..), LHsExpr )
+import TcHsSyn ( TcId, TcDictBinds, mkHsApp, mkHsTyApp, mkHsDictApp )
import TcRnMonad
import Inst ( lookupInst, LookupInstResult(..),
import TcType ( TcTyVar, TcTyVarSet, ThetaType, TyVarDetails(VanillaTv),
mkClassPred, isOverloadedTy, mkTyConApp,
mkTyVarTy, tcGetTyVar, isTyVarClassPred, mkTyVarTys,
- tyVarsOfPred )
+ tyVarsOfPred, tcEqType )
import Id ( idType, mkUserLocal )
import Var ( TyVar )
import Name ( getOccName, getSrcLoc )
import VarSet
import VarEnv ( TidyEnv )
import FiniteMap
+import Bag
import Outputable
import ListSetOps ( equivClasses )
import Util ( zipEqual, isSingleton )
import List ( partition )
+import SrcLoc ( Located(..) )
import CmdLineOpts
\end{code}
-- the final qtvs might be empty. See [NO TYVARS] below.
inferLoop doc tau_tvs (irreds ++ frees) `thenM` \ (qtvs1, frees1, binds1, irreds1) ->
- returnM (qtvs1, frees1, binds `AndMonoBinds` binds1, irreds1)
+ returnM (qtvs1, frees1, binds `unionBags` binds1, irreds1)
\end{code}
Example [LOOP]
returnM (varSetElems qtvs', frees, binds, irreds)
else
check_loop givens' (irreds ++ frees) `thenM` \ (qtvs', frees1, binds1, irreds1) ->
- returnM (qtvs', frees1, binds `AndMonoBinds` binds1, irreds1)
+ returnM (qtvs', frees1, binds `unionBags` binds1, irreds1)
\end{code}
returnM (varSetElems qtvs', binds)
else
restrict_loop doc qtvs' (irreds ++ frees) `thenM` \ (qtvs1, binds1) ->
- returnM (qtvs1, binds `AndMonoBinds` binds1)
+ returnM (qtvs1, binds `unionBags` binds1)
\end{code}
doc = text "tcSimplifyToDicts"
-- Reduce methods and lits only; stop as soon as we get a dictionary
- try_me inst | isDict inst = DontReduce NoSCs
+ try_me inst | isDict inst = DontReduce NoSCs -- See notes above for why NoSCs
| otherwise = ReduceMe
\end{code}
returnM (frees, binds)
else
simpl_loop givens' (irreds ++ frees) `thenM` \ (frees1, binds1) ->
- returnM (frees1, binds `AndMonoBinds` binds1)
+ returnM (frees1, binds `unionBags` binds1)
\end{code}
@LIE@), as well as the @HsBinds@ generated.
\begin{code}
-bindInstsOfLocalFuns :: [Inst] -> [TcId] -> TcM TcMonoBinds
+bindInstsOfLocalFuns :: [Inst] -> [TcId] -> TcM (LHsBinds TcId)
bindInstsOfLocalFuns wanteds local_ids
| null overloaded_ids
-- Common case
= extendLIEs wanteds `thenM_`
- returnM EmptyMonoBinds
+ returnM emptyBag
| otherwise
= simpleReduceLoop doc try_me wanteds `thenM` \ (frees, binds, irreds) ->
-- ToDo: remove?
| Rhs -- Used when there is a RHS
- TcExpr -- The RHS
+ (LHsExpr TcId) -- The RHS
[Inst] -- Insts free in the RHS; we need these too
| Linear -- Splittable Insts only.
| LinRhss -- Splittable Insts only; this is used only internally
-- by extractResults, where a Linear
-- is turned into an LinRhss
- [TcExpr] -- A supply of suitable RHSs
+ [LHsExpr TcId] -- A supply of suitable RHSs
pprAvails avails = vcat [sep [ppr inst, nest 2 (equals <+> pprAvail avail)]
| (inst,avail) <- fmToList avails ]
extractResults :: Avails
-> [Inst] -- Wanted
-> TcM (TcDictBinds, -- Bindings
- [Inst], -- Irreducible ones
- [Inst]) -- Free ones
+ [Inst], -- Irreducible ones
+ [Inst]) -- Free ones
extractResults avails wanteds
- = go avails EmptyMonoBinds [] [] wanteds
+ = go avails emptyBag [] [] wanteds
where
go avails binds irreds frees []
= returnM (binds, irreds, frees)
Just (Given id _) -> go avails new_binds irreds frees ws
where
new_binds | id == instToId w = binds
- | otherwise = addBind binds w (HsVar id)
+ | otherwise = addBind binds w (L (instSpan w) (HsVar id))
-- The sought Id can be one of the givens, via a superclass chain
-- and then we definitely don't want to generate an x=x binding!
-> get_root irreds frees avail w `thenM` \ (irreds', frees', root_id) ->
split n (instToId split_inst) root_id w `thenM` \ (binds', rhss) ->
go (addToFM avails w (LinRhss rhss))
- (binds `AndMonoBinds` binds')
+ (binds `unionBags` binds')
irreds' frees' (split_inst : w : ws)
Just (LinRhss (rhs:rhss)) -- Consume one of the Rhss
split :: Int -> TcId -> TcId -> Inst
- -> TcM (TcDictBinds, [TcExpr])
+ -> TcM (TcDictBinds, [LHsExpr TcId])
-- (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
id = instToId wanted
occ = getOccName id
loc = getSrcLoc id
+ span = instSpan wanted
- go 1 = returnM (EmptyMonoBinds, [HsVar root_id])
+ go 1 = returnM (emptyBag, [L span $ HsVar root_id])
go n = go ((n+1) `div` 2) `thenM` \ (binds1, rhss) ->
expand n rhss `thenM` \ (binds2, rhss') ->
- returnM (binds1 `AndMonoBinds` binds2, rhss')
+ returnM (binds1 `unionBags` binds2, rhss')
-- (expand n rhss)
-- Given ((n+1)/2) rhss, make n rhss, using auxiliary bindings
returnM (binds', head rhss : rhss')
where
go rhss = mapAndUnzipM do_one rhss `thenM` \ (binds', rhss') ->
- returnM (andMonoBindList binds', concat rhss')
+ returnM (listToBag binds', concat rhss')
do_one rhs = newUnique `thenM` \ uniq ->
tcLookupId fstName `thenM` \ fst_id ->
let
x = mkUserLocal occ uniq pair_ty loc
in
- returnM (VarMonoBind x (mk_app split_id rhs),
- [mk_fs_app fst_id ty x, mk_fs_app snd_id ty x])
+ returnM (L span (VarBind x (mk_app span split_id rhs)),
+ [mk_fs_app span fst_id ty x, mk_fs_app span snd_id ty x])
-mk_fs_app id ty var = HsVar id `TyApp` [ty,ty] `HsApp` HsVar var
+mk_fs_app span id ty var = L span (HsVar id) `mkHsTyApp` [ty,ty] `mkHsApp` (L span (HsVar var))
-mk_app id rhs = HsApp (HsVar id) rhs
+mk_app span id rhs = L span (HsApp (L span (HsVar id)) rhs)
-addBind binds inst rhs = binds `AndMonoBinds` VarMonoBind (instToId inst) rhs
+addBind binds inst rhs = binds `unionBags` unitBag (L (instLocSrcSpan (instLoc inst))
+ (VarBind (instToId inst) rhs))
+instSpan wanted = instLocSrcSpan (instLoc wanted)
\end{code}
returnM (frees, binds, irreds)
else
simpleReduceLoop doc try_me (irreds ++ frees) `thenM` \ (frees1, binds1, irreds1) ->
- returnM (frees1, binds `AndMonoBinds` binds1, irreds1)
+ returnM (frees1, binds `unionBags` binds1, irreds1)
\end{code}
go ws state'
-- Base case: we're done!
-reduce stack try_me wanted state
+reduce stack try_me wanted avails
-- It's the same as an existing inst, or a superclass thereof
- | Just avail <- isAvailable state wanted
+ | Just avail <- isAvailable avails wanted
= if isLinearInst wanted then
- addLinearAvailable state avail wanted `thenM` \ (state', wanteds') ->
- reduceList stack try_me wanteds' state'
+ addLinearAvailable avails avail wanted `thenM` \ (avails', wanteds') ->
+ reduceList stack try_me wanteds' avails'
else
- returnM state -- No op for non-linear things
+ returnM avails -- No op for non-linear things
| otherwise
= case try_me wanted of {
- DontReduce want_scs -> addIrred want_scs state wanted
+ DontReduce want_scs -> addIrred want_scs avails wanted
; DontReduceUnlessConstant -> -- It's irreducible (or at least should not be reduced)
-- First, see if the inst can be reduced to a constant in one step
; ReduceMe -> -- It should be reduced
lookupInst wanted `thenM` \ lookup_result ->
case lookup_result of
- GenInst wanteds' rhs -> addWanted state wanted rhs wanteds' `thenM` \ state' ->
- reduceList stack try_me wanteds' state'
- -- Experiment with doing addWanted *before* the reduceList,
+ GenInst wanteds' rhs -> addIrred NoSCs avails wanted `thenM` \ avails1 ->
+ reduceList stack try_me wanteds' avails1 `thenM` \ avails2 ->
+ addWanted avails2 wanted rhs wanteds'
+ -- Experiment with temporarily doing addIrred *before* the reduceList,
-- which has the effect of adding the thing we are trying
-- to prove to the database before trying to prove the things it
-- needs. See note [RECURSIVE DICTIONARIES]
+ -- NB: we must not do an addWanted before, because that adds the
+ -- superclasses too, and thaat can lead to a spurious loop; see
+ -- the examples in [SUPERCLASS-LOOP]
+ -- So we do an addIrred before, and then overwrite it afterwards with addWanted
- SimpleInst rhs -> addWanted state wanted rhs []
+ SimpleInst rhs -> addWanted avails wanted rhs []
NoInstance -> -- No such instance!
-- Add it and its superclasses
- addIrred AddSCs state wanted
-
+ addIrred AddSCs avails wanted
}
where
try_simple do_this_otherwise
= lookupInst wanted `thenM` \ lookup_result ->
case lookup_result of
- SimpleInst rhs -> addWanted state wanted rhs []
- other -> do_this_otherwise state wanted
+ SimpleInst rhs -> addWanted avails wanted rhs []
+ other -> do_this_otherwise avails wanted
\end{code}
--
addFree avails free = returnM (addToFM avails free IsFree)
-addWanted :: Avails -> Inst -> TcExpr -> [Inst] -> TcM Avails
+addWanted :: Avails -> Inst -> LHsExpr TcId -> [Inst] -> TcM Avails
addWanted avails wanted rhs_expr wanteds
- = ASSERT2( not (wanted `elemFM` avails), ppr wanted $$ ppr avails )
- addAvailAndSCs avails wanted avail
+ = addAvailAndSCs avails wanted avail
where
avail | instBindingRequired wanted = Rhs rhs_expr wanteds
| otherwise = ASSERT( null wanteds ) NoRhs
addGiven :: Avails -> Inst -> TcM Avails
-addGiven state given = addAvailAndSCs state given (Given (instToId given) False)
+addGiven avails given = addAvailAndSCs avails 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
addAvailAndSCs :: Avails -> Inst -> Avail -> TcM Avails
addAvailAndSCs avails inst avail
| not (isClassDict inst) = returnM avails1
- | otherwise = addSCs is_loop avails1 inst
+ | otherwise = traceTc (text "addAvailAndSCs" <+> vcat [ppr inst, ppr deps]) `thenM_`
+ 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 -> []
+ avails1 = addToFM avails inst avail
+ is_loop inst = any (`tcEqType` idType (instToId inst)) dep_tys
+ -- Note: this compares by *type*, not by Unique
+ deps = findAllDeps emptyVarSet avail
+ dep_tys = map idType (varSetElems deps)
+
+ findAllDeps :: IdSet -> Avail -> IdSet
+ -- Find all the Insts that this one depends on
+ -- See Note [SUPERCLASS-LOOP]
+ -- Watch out, though. Since the avails may contain loops
+ -- (see Note [RECURSIVE DICTIONARIES]), so we need to track the ones we've seen so far
+ findAllDeps so_far (Rhs _ kids)
+ = foldl findAllDeps
+ (extendVarSetList so_far (map instToId kids)) -- Add the kids to so_far
+ [a | Just a <- map (lookupFM avails) kids] -- Find the kids' Avail
+ findAllDeps so_far other = so_far
+
addSCs :: (Inst -> Bool) -> Avails -> Inst -> TcM Avails
-- Add all the superclasses of the Inst to Avails
sc_theta' = substTheta (mkTopTyVarSubst tyvars tys) sc_theta
add_sc avails (sc_dict, sc_sel) -- Add it, and its superclasses
- = case lookupFM avails sc_dict of
- Just (Given _ _) -> returnM avails -- Given is cheaper than
- -- a superclass selection
- Just other | is_loop sc_dict -> returnM avails -- See Note [SUPERCLASS-LOOP]
- | otherwise -> returnM avails' -- SCs already added
-
- Nothing -> addSCs is_loop avails' sc_dict
+ | add_me sc_dict = addSCs is_loop avails' sc_dict
+ | otherwise = returnM avails
where
- sc_sel_rhs = DictApp (TyApp (HsVar sc_sel) tys) [instToId dict]
- avail = Rhs sc_sel_rhs [dict]
- avails' = addToFM avails sc_dict avail
+ sc_sel_rhs = mkHsDictApp (mkHsTyApp (L (instSpan dict) (HsVar sc_sel)) tys) [instToId dict]
+ avails' = addToFM avails sc_dict (Rhs sc_sel_rhs [dict])
+
+ add_me :: Inst -> Bool
+ add_me sc_dict
+ | is_loop sc_dict = False -- See Note [SUPERCLASS-LOOP]
+ | otherwise = case lookupFM avails sc_dict of
+ Just (Given _ _) -> False -- Given is cheaper than superclass selection
+ other -> True
\end{code}
Note [SUPERCLASS-LOOP]: Checking for loops
for d1:Ord a (which is given) with a superclass selection or we'll just
build a loop!
+Here's another variant, immortalised in tcrun020
+ class Monad m => C1 m
+ class C1 m => C2 m x
+ instance C2 Maybe Bool
+For the instance decl we need to build (C1 Maybe), and it's no good if
+we run around and add (C2 Maybe Bool) and its superclasses to the avails
+before we search for C1 Maybe.
+
Here's another example
class Eq b => Foo a b
instance Eq a => Foo [a] a
by instance decl of Eq, holds if
d3 : D []
- where d2 = dfEqList d2
+ where d2 = dfEqList d3
d1 = dfEqD d2
But now we can "tie the knot" to give
d3 = d1
- d2 = dfEqList d2
+ d2 = dfEqList d3
d1 = dfEqD d2
and it'll even run! The trick is to put the thing we are trying to prove
mappM (disambigGroup is_interactive) std_oks
) `thenM` \ binds_ambig ->
- returnM (binds `andMonoBinds` andMonoBindList binds_ambig)
+ returnM (binds `unionBags` unionManyBags binds_ambig)
----------------------------------
d1 `cmp_by_tyvar` d2 = get_tv d1 `compare` get_tv d2
returnM binds
bomb_out = addTopAmbigErrs dicts `thenM_`
- returnM EmptyMonoBinds
+ returnM emptyBag
get_default_tys
= do { mb_defaults <- getDefaultTys
| not (isClassDict dict) = (overlap_doc, dict : no_inst_dicts)
| otherwise
= case lookupInstEnv dflags inst_envs clas tys of
- ([], _) -> (overlap_doc, dict : no_inst_dicts) -- No matches
- inst_res -> (mk_overlap_msg dict inst_res $$ overlap_doc, no_inst_dicts)
+ res@(ms, _)
+ | length ms > 1 -> (mk_overlap_msg dict res $$ overlap_doc, no_inst_dicts)
+ | otherwise -> (overlap_doc, dict : no_inst_dicts) -- No match
+ -- NB: there can be exactly one match, in the case where we have
+ -- instance C a where ...
+ -- (In this case, lookupInst doesn't bother to look up,
+ -- unless -fallow-undecidable-instances is set.)
+ -- So we report this as "no instance" rather than "overlap"; the fix is
+ -- to specify -fallow-undecidable-instances, but we leave that to the programmer!
where
(clas,tys) = getDictClassTys dict
in
cmp (_,tvs1) (_,tvs2) = tvs1 `compare` tvs2
report :: [(Inst,[TcTyVar])] -> TcM ()
- report pairs@((_,tvs) : _) -- The pairs share a common set of ambiguous tyvars
+ report pairs@((inst,tvs) : _) -- The pairs share a common set of ambiguous tyvars
= mkMonomorphismMsg tidy_env dicts `thenM` \ (tidy_env, mono_msg) ->
+ addSrcSpan (instLocSrcSpan (instLoc inst)) $
+ -- the location of the first one will do for the err message
addErrTcM (tidy_env, msg $$ mono_msg)
where
dicts = map fst pairs