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}
%************************************************************************
--------------------------------------
+ Notes on functional dependencies (a bug)
+ --------------------------------------
+
+| > class Foo a b | a->b
+| >
+| > class Bar a b | a->b
+| >
+| > data Obj = Obj
+| >
+| > instance Bar Obj Obj
+| >
+| > instance (Bar a b) => Foo a b
+| >
+| > foo:: (Foo a b) => a -> String
+| > foo _ = "works"
+| >
+| > runFoo:: (forall a b. (Foo a b) => a -> w) -> w
+| > runFoo f = f Obj
+|
+| *Test> runFoo foo
+|
+| <interactive>:1:
+| Could not deduce (Bar a b) from the context (Foo a b)
+| arising from use of `foo' at <interactive>:1
+| Probable fix:
+| Add (Bar a b) to the expected type of an expression
+| In the first argument of `runFoo', namely `foo'
+| In the definition of `it': it = runFoo foo
+|
+| Why all of the sudden does GHC need the constraint Bar a b? The
+| function foo didn't ask for that...
+
+The trouble is that to type (runFoo foo), GHC has to solve the problem:
+
+ Given constraint Foo a b
+ Solve constraint Foo a b'
+
+Notice that b and b' aren't the same. To solve this, just do
+improvement and then they are the same. But GHC currently does
+ simplify constraints
+ apply improvement
+ and loop
+
+That is usually fine, but it isn't here, because it sees that Foo a b is
+not the same as Foo a b', and so instead applies the instance decl for
+instance Bar a b => Foo a b. And that's where the Bar constraint comes
+from.
+
+The Right Thing is to improve whenever the constraint set changes at
+all. Not hard in principle, but it'll take a bit of fiddling to do.
+
+
+
+ --------------------------------------
Notes on quantification
--------------------------------------
--------------------------------------
+ The need for forall's in constraints
+ --------------------------------------
+
+[Exchange on Haskell Cafe 5/6 Dec 2000]
+
+ class C t where op :: t -> Bool
+ instance C [t] where op x = True
+
+ p y = (let f :: c -> Bool; f x = op (y >> return x) in f, y ++ [])
+ q y = (y ++ [], let f :: c -> Bool; f x = op (y >> return x) in f)
+
+The definitions of p and q differ only in the order of the components in
+the pair on their right-hand sides. And yet:
+
+ ghc and "Typing Haskell in Haskell" reject p, but accept q;
+ Hugs rejects q, but accepts p;
+ hbc rejects both p and q;
+ nhc98 ... (Malcolm, can you fill in the blank for us!).
+
+The type signature for f forces context reduction to take place, and
+the results of this depend on whether or not the type of y is known,
+which in turn depends on which component of the pair the type checker
+analyzes first.
+
+Solution: if y::m a, float out the constraints
+ Monad m, forall c. C (m c)
+When m is later unified with [], we can solve both constraints.
+
+
+ --------------------------------------
Notes on implicit parameters
--------------------------------------
-- 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
| 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
- | is_loop sc_dict
- = returnM avails -- See Note [SUPERCLASS-LOOP]
- | otherwise
- = case lookupFM avails sc_dict of
- Just (Given _ _) -> returnM avails -- Given is cheaper than superclass selection
- Just other -> 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
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
doptM Opt_AllowUndecidableInstances `thenM` \ undecidable_ok ->
let
tv_set = mkVarSet tvs
- 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).
- -- 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)
+
+ (bad_insts, ok_insts) = partition is_bad_inst irreds
+ is_bad_inst dict
+ = let pred = dictPred dict -- reduceMe squashes all non-dicts
+ in isEmptyVarSet (tyVarsOfPred pred)
+ -- Things like (Eq T) are bad
+ || (not undecidable_ok && not (isTyVarClassPred pred))
+ -- The returned dictionaries should be of form (C a b)
+ -- (where a, b are type variables).
+ -- We allow non-tyvar dicts 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)
- | not (pred_tyvars `subVarSet` tv_set)
+ simpl_theta = map dictPred ok_insts
+ weird_preds = [pred | pred <- simpl_theta
+ , not (tyVarsOfPred pred `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.
- = addErrTc (badDerivedPred pred)
- | otherwise
- = returnM ()
- where
- pred_tyvars = tyVarsOfPred pred
-
rev_env = mkTopTyVarSubst tvs (mkTyVarTys tyvars)
-- This reverse-mapping is a Royal Pain,
-- but the result should mention TyVars not TcTyVars
in
- mappM check_pred simpl_theta `thenM_`
- checkAmbiguity tvs simpl_theta tv_set `thenM_`
+ addNoInstanceErrs Nothing [] bad_insts `thenM_`
+ mapM_ (addErrTc . badDerivedPred) weird_preds `thenM_`
+ checkAmbiguity tvs simpl_theta tv_set `thenM_`
returnM (substTheta rev_env simpl_theta)
where
doc = ptext SLIT("deriving classes for a data type")
= newDicts DataDeclOrigin theta `thenM` \ wanteds ->
simpleReduceLoop doc reduceMe wanteds `thenM` \ (frees, _, irreds) ->
ASSERT( null frees ) -- try_me never returns Free
- mappM (addErrTc . noInstErr) irreds `thenM_`
+ addNoInstanceErrs Nothing [] irreds `thenM_`
if null irreds then
returnM ()
else
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
pprInstsInFull tidy_dicts]
-- Used for the ...Thetas variants; all top level
-noInstErr pred = ptext SLIT("No instance for") <+> quotes (ppr pred)
-
badDerivedPred pred
= vcat [ptext SLIT("Can't derive instances where the instance context mentions"),
ptext SLIT("type variables that are not data type parameters"),
projects / ghc-hetmet.git / blobdiff