#include "HsVersions.h"
-import {-# SOURCE #-} TcUnify( unifyTauTy )
-import TcEnv -- temp
+import {-# SOURCE #-} TcUnify( unifyType )
+import TypeRep ( Type(..) )
import HsSyn ( HsBind(..), HsExpr(..), LHsExpr, emptyLHsBinds )
-import TcHsSyn ( TcId, TcDictBinds, mkHsApp, mkHsTyApp, mkHsDictApp )
+import TcHsSyn ( mkHsApp, mkHsTyApp, mkHsDictApp )
import TcRnMonad
import Inst ( lookupInst, LookupInstResult(..),
tyVarsOfInst, fdPredsOfInsts, newDicts,
isDict, isClassDict, isLinearInst, linearInstType,
- isStdClassTyVarDict, isMethodFor, isMethod,
+ isMethodFor, isMethod,
instToId, tyVarsOfInsts, cloneDict,
ipNamesOfInsts, ipNamesOfInst, dictPred,
- instBindingRequired, fdPredsOfInst,
+ fdPredsOfInst,
newDictsAtLoc, tcInstClassOp,
getDictClassTys, isTyVarDict, instLoc,
zonkInst, tidyInsts, tidyMoreInsts,
- Inst, pprInsts, pprDictsInFull, pprInstInFull, tcGetInstEnvs,
+ pprInsts, pprDictsInFull, pprInstInFull, tcGetInstEnvs,
isInheritableInst, pprDictsTheta
)
-import TcEnv ( tcGetGlobalTyVars, tcLookupId, findGlobals, pprBinders )
+import TcEnv ( tcGetGlobalTyVars, tcLookupId, findGlobals, pprBinders,
+ lclEnvElts, tcMetaTy )
import InstEnv ( lookupInstEnv, classInstances, pprInstances )
-import TcMType ( zonkTcTyVarsAndFV, tcInstTyVars, checkAmbiguity )
-import TcType ( TcTyVar, TcTyVarSet, ThetaType, TcPredType,
+import TcMType ( zonkTcTyVarsAndFV, tcInstTyVars, zonkTcPredType,
+ checkAmbiguity, checkInstTermination )
+import TcType ( TcTyVar, TcTyVarSet, ThetaType, TcPredType, tidyPred,
mkClassPred, isOverloadedTy, mkTyConApp, isSkolemTyVar,
mkTyVarTy, tcGetTyVar, isTyVarClassPred, mkTyVarTys,
- tyVarsOfPred, tcEqType, pprPred, mkPredTy )
+ tyVarsOfPred, tcEqType, pprPred, mkPredTy, tcIsTyVarTy )
import TcIface ( checkWiredInTyCon )
import Id ( idType, mkUserLocal )
import Var ( TyVar )
+import TyCon ( TyCon )
import Name ( Name, getOccName, getSrcLoc )
import NameSet ( NameSet, mkNameSet, elemNameSet )
import Class ( classBigSig, classKey )
-import FunDeps ( oclose, grow, improve, pprEquationDoc )
-import PrelInfo ( isNumericClass )
+import FunDeps ( oclose, grow, improve, pprEquation )
+import PrelInfo ( isNumericClass, isStandardClass )
import PrelNames ( splitName, fstName, sndName, integerTyConName,
showClassKey, eqClassKey, ordClassKey )
import Type ( zipTopTvSubst, substTheta, substTy )
data WhatToDo
= ReduceMe WantSCs -- Try to reduce this
-- If there's no instance, behave exactly like
- -- DontReduce: add the inst to
- -- the irreductible ones, but don't
- -- produce an error message of any kind.
+ -- DontReduce: add the inst to the irreductible ones,
+ -- but don't produce an error message of any kind.
-- It might be quite legitimate such as (Eq a)!
| KeepDictWithoutSCs -- Return as irreducible; don't add its superclasses
data WantSCs = NoSCs | AddSCs -- Tells whether we should add the superclasses
-- of a predicate when adding it to the avails
+ -- The reason for this flag is entirely the super-class loop problem
+ -- Note [SUPER-CLASS LOOP 1]
\end{code}
-- e.g. those "given" in a signature
Bool -- True <=> actually consumed (splittable IPs only)
- | NoRhs -- Used for Insts like (CCallable f)
- -- where no witness is required.
- -- ToDo: remove?
-
| Rhs -- Used when there is a RHS
(LHsExpr TcId) -- The RHS
[Inst] -- Insts free in the RHS; we need these too
instance Outputable Avail where
ppr = pprAvail
-pprAvail NoRhs = text "<no rhs>"
pprAvail IsFree = text "Free"
pprAvail Irred = text "Irred"
pprAvail (Given x b) = text "Given" <+> ppr x <+>
Nothing -> pprTrace "Urk: extractResults" (ppr w) $
go avails binds irreds frees ws
- Just NoRhs -> go avails binds irreds frees ws
Just IsFree -> go (add_free avails w) binds irreds (w:frees) ws
Just Irred -> go (add_given avails w) binds (w:irreds) frees ws
get_root irreds frees IsFree w = cloneDict w `thenM` \ w' ->
returnM (irreds, w':frees, instToId w')
- add_given avails w
- | instBindingRequired w = addToFM avails w (Given (instToId w) True)
- | otherwise = addToFM avails w NoRhs
- -- NB: make sure that CCallable/CReturnable use NoRhs rather
- -- than Given, else we end up with bogus bindings.
+ add_given avails w = addToFM avails w (Given (instToId w) True)
add_free avails w | isMethod w = avails
| otherwise = add_given avails w
mappM_ unify eqns `thenM_`
returnM False
where
- unify ((qtvs, pairs), doc)
- = addErrCtxt doc $
+ unify ((qtvs, pairs), what1, what2)
+ = addErrCtxtM (mkEqnMsg what1 what2) $
tcInstTyVars (varSetElems qtvs) `thenM` \ (_, _, tenv) ->
mapM_ (unif_pr tenv) pairs
- unif_pr tenv (ty1,ty2) = unifyTauTy (substTy tenv ty1) (substTy tenv ty2)
+ unif_pr tenv (ty1,ty2) = unifyType (substTy tenv ty1) (substTy tenv ty2)
+
+pprEquationDoc (eqn, (p1,w1), (p2,w2)) = vcat [pprEquation eqn, nest 2 (ppr p1), nest 2 (ppr p2)]
+
+mkEqnMsg (pred1,from1) (pred2,from2) tidy_env
+ = do { pred1' <- zonkTcPredType pred1; pred2' <- zonkTcPredType pred2
+ ; let { pred1'' = tidyPred tidy_env pred1'; pred2'' = tidyPred tidy_env pred2' }
+ ; let msg = vcat [ptext SLIT("When using functional dependencies to combine"),
+ nest 2 (sep [ppr pred1'' <> comma, nest 2 from1]),
+ nest 2 (sep [ppr pred2'' <> comma, nest 2 from2])]
+ ; return (tidy_env, msg) }
\end{code}
The main context-reduction function is @reduce@. Here's its game plan.
#ifdef DEBUG
(if n > 8 then
pprTrace "Interesting! Context reduction stack deeper than 8:"
- (nest 2 (pprStack stack))
+ (int n $$ ifPprDebug (nest 2 (pprStack stack)))
else (\x->x))
#endif
go wanteds state
addWanted want_scs avails wanted rhs_expr wanteds
= addAvailAndSCs want_scs avails wanted avail
where
- avail | instBindingRequired wanted = Rhs rhs_expr wanteds
- | otherwise = ASSERT( null wanteds ) NoRhs
+ avail = Rhs rhs_expr wanteds
addGiven :: Avails -> Inst -> TcM Avails
addGiven avails given = addAvailAndSCs AddSCs avails given (Given (instToId given) False)
findAllDeps :: IdSet -> Avail -> IdSet
-- Find all the Insts that this one depends on
- -- See Note [SUPERCLASS-LOOP]
+ -- See Note [SUPERCLASS-LOOP 2]
-- 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 find_all so_far kids
; (frees, binds, irreds) <- simpleReduceLoop doc try_me wanteds
; let
- -- All the non-std ones are definite errors
- (stds, non_stds) = partition isStdClassTyVarDict irreds
-
- -- Group by type variable
- std_groups = equivClasses cmp_by_tyvar stds
-
- -- Pick the ones which its worth trying to disambiguate
- -- 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)
+ -- First get rid of implicit parameters
+ (non_ips, bad_ips) = partition isClassDict irreds
+
+ -- All the non-tv or multi-param ones are definite errors
+ (unary_tv_dicts, non_tvs) = partition is_unary_tyvar_dict non_ips
+ bad_tyvars = unionVarSets (map tyVarsOfInst non_tvs)
+
+ -- Group by type variable
+ tv_groups = equivClasses cmp_by_tyvar unary_tv_dicts
+
+ -- Pick the ones which its worth trying to disambiguate
+ -- namely, the ones whose type variable isn't bound
+ -- up with one of the non-tyvar classes
+ (default_gps, non_default_gps) = partition defaultable_group tv_groups
+ defaultable_group ds
+ = not (bad_tyvars `intersectsVarSet` tyVarsOfInst (head ds))
+ && defaultable_classes (map get_clas ds)
+ defaultable_classes clss
+ | is_interactive = any isInteractiveClass clss
+ | otherwise = all isStandardClass clss && any isNumericClass clss
+
+ isInteractiveClass cls = isNumericClass cls
+ || (classKey cls `elem` [showClassKey, eqClassKey, ordClassKey])
+ -- In interactive mode, we default Show a to Show ()
+ -- to avoid graututious errors on "show []"
+
-- Collect together all the bad guys
- bad_guys = non_stds ++ concat std_bads
- (non_ips, bad_ips) = partition isClassDict bad_guys
- (ambigs, no_insts) = partition isTyVarDict non_ips
+ bad_guys = non_tvs ++ concat non_default_gps
+ (ambigs, no_insts) = partition isTyVarDict bad_guys
-- If the dict has no type constructors involved, it must be ambiguous,
-- except I suppose that another error with fundeps maybe should have
-- constrained those type variables
addTopAmbigErrs ambigs
-- Disambiguate the ones that look feasible
- ; mappM (disambigGroup is_interactive) std_oks }
+ ; mappM disambigGroup default_gps }
; return (binds `unionBags` unionManyBags binds_ambig) }
----------------------------------
d1 `cmp_by_tyvar` d2 = get_tv d1 `compare` get_tv d2
+is_unary_tyvar_dict :: Inst -> Bool -- Dicts of form (C a)
+ -- Invariant: argument is a ClassDict, not IP or method
+is_unary_tyvar_dict d = case getDictClassTys d of
+ (_, [ty]) -> tcIsTyVarTy ty
+ other -> False
+
get_tv d = case getDictClassTys d of
(clas, [ty]) -> tcGetTyVar "tcSimplify" ty
get_clas d = case getDictClassTys d of
- (clas, [ty]) -> clas
+ (clas, _) -> clas
\end{code}
If a dictionary constrains a type variable which is
@void@.
\begin{code}
-disambigGroup :: Bool -- True <=> simplifying at top-level interactive loop
- -> [Inst] -- All standard classes of form (C a)
+disambigGroup :: [Inst] -- All standard classes of form (C a)
-> TcM TcDictBinds
-disambigGroup is_interactive dicts
- | any std_default_class classes -- Guaranteed all standard classes
+disambigGroup dicts
= -- THE DICTS OBEY THE DEFAULTABLE CONSTRAINT
-- SO, TRY DEFAULT TYPES IN ORDER
case mb_ty of
Left _ -> bomb_out
Right chosen_default_ty -> choose_default chosen_default_ty
-
- | otherwise -- No defaults
- = bomb_out
-
where
tyvar = get_tv (head dicts) -- Should be non-empty
classes = map get_clas dicts
- std_default_class cls
- = isNumericClass cls
- || (is_interactive &&
- classKey cls `elem` [showClassKey, eqClassKey, ordClassKey])
- -- In interactive mode, we default Show a to Show ()
- -- to avoid graututious errors on "show []"
-
choose_default default_ty -- Commit to tyvar = default_ty
= -- Bind the type variable
- unifyTauTy default_ty (mkTyVarTy tyvar) `thenM_`
+ unifyType default_ty (mkTyVarTy tyvar) `thenM_`
-- and reduce the context, for real this time
simpleReduceLoop (text "disambig" <+> ppr dicts)
reduceMe dicts `thenM` \ (frees, binds, ambigs) ->
When typechecking _ccall_s, TcExpr ensures that the external
function is only passed arguments (and in the other direction,
-results) of a restricted set of 'native' types. This is
-implemented via the help of the pseudo-type classes,
-@CReturnable@ (CR) and @CCallable@ (CC.)
+results) of a restricted set of 'native' types.
The interaction between the defaulting mechanism for numeric
values and CC & CR can be a bit puzzling to the user at times.
Haskell 1.4's default-default of (Int, Double), 'x' has type
Int.
-To try to minimise the potential for surprises here, the
-defaulting mechanism is turned off in the presence of
-CCallable and CReturnable.
-
End of aside]
instance declarations.
\begin{code}
-tcSimplifyDeriv :: [TyVar]
+tcSimplifyDeriv :: TyCon
+ -> [TyVar]
-> ThetaType -- Wanted
-> TcM ThetaType -- Needed
-tcSimplifyDeriv tyvars theta
+tcSimplifyDeriv tc tyvars theta
= tcInstTyVars tyvars `thenM` \ (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
simpleReduceLoop doc reduceMe wanteds `thenM` \ (frees, _, irreds) ->
ASSERT( null frees ) -- reduceMe never returns Free
+ doptM Opt_GlasgowExts `thenM` \ gla_exts ->
doptM Opt_AllowUndecidableInstances `thenM` \ undecidable_ok ->
let
tv_set = mkVarSet tvs
= 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 gla_exts && not (isTyVarClassPred pred))
simpl_theta = map dictPred ok_insts
weird_preds = [pred | pred <- simpl_theta
rev_env = zipTopTvSubst tvs (mkTyVarTys tyvars)
-- This reverse-mapping is a Royal Pain,
-- but the result should mention TyVars not TcTyVars
+
+ head_ty = TyConApp tc (map TyVarTy tvs)
in
addNoInstanceErrs Nothing [] bad_insts `thenM_`
mapM_ (addErrTc . badDerivedPred) weird_preds `thenM_`
checkAmbiguity tvs simpl_theta tv_set `thenM_`
+ -- Check instance termination as for user-declared instances.
+ -- unless we had -fallow-undecidable-instances (which risks
+ -- non-termination in the 'deriving' context-inference fixpoint
+ -- loop).
+ ifM (gla_exts && not undecidable_ok)
+ (checkInstTermination simpl_theta [head_ty]) `thenM_`
returnM (substTheta rev_env simpl_theta)
where
doc = ptext SLIT("deriving classes for a data type")
addInstLoc :: [Inst] -> Message -> Message
addInstLoc insts msg = msg $$ nest 2 (pprInstLoc (instLoc (head insts)))
-plural [x] = empty
-plural xs = char 's'
-
addTopIPErrs :: [Name] -> [Inst] -> TcM ()
addTopIPErrs bndrs []
= return ()
= addErrTcM (tidy_env, mk_msg tidy_ips)
where
(tidy_env, tidy_ips) = tidyInsts ips
- mk_msg ips = vcat [sep [ptext SLIT("Implicit parameters escape from the monomorphic top-level binding(s) of"),
- pprBinders bndrs <> colon],
+ mk_msg ips = vcat [sep [ptext SLIT("Implicit parameters escape from"),
+ nest 2 (ptext SLIT("the monomorphic top-level binding(s) of")
+ <+> pprBinders bndrs <> colon)],
nest 2 (vcat (map ppr_ip ips)),
monomorphism_fix]
ppr_ip ip = pprPred (dictPred ip) <+> pprInstLoc (instLoc ip)
ispecs = [ispec | (_, ispec) <- matches]
mk_probable_fix tidy_env dicts
- = returnM (tidy_env, sep [ptext SLIT("Probable fix:"), nest 2 (vcat fixes)])
+ = returnM (tidy_env, sep [ptext SLIT("Possible fix:"), nest 2 (vcat fixes)])
where
fixes = add_ors (fix1 ++ fix2)
projects / ghc-hetmet.git / blobdiff