import TcGenDeriv -- Deriv stuff
import InstEnv ( InstEnv, simpleDFunClassTyCon, extendInstEnv )
import TcMonoType ( tcHsPred )
-import TcSimplify ( tcSimplifyThetas )
+import TcSimplify ( tcSimplifyDeriv )
import RnBinds ( rnMethodBinds, rnTopMonoBinds )
import RnEnv ( bindLocatedLocalsRn )
)
import TcType ( TcType, ThetaType, mkTyVarTys, mkTyConApp, getClassPredTys_maybe,
isUnLiftedType, mkClassPred, tyVarsOfTypes, tcSplitFunTys,
- tcSplitTyConApp_maybe, tcEqTypes )
+ tcSplitTyConApp_maybe, tcEqTypes, tyVarsOfTheta )
import Var ( TyVar, tyVarKind )
import VarSet ( mkVarSet, subVarSet )
import PrelNames
-import Util ( zipWithEqual, sortLt )
+import Util ( zipWithEqual, sortLt, eqListBy )
import ListSetOps ( removeDups, assoc )
import Outputable
import Maybe ( isJust )
mk_eqn (new_or_data, tycon_name, pred)
= tcLookupTyCon tycon_name `thenNF_Tc` \ tycon ->
tcAddSrcLoc (getSrcLoc tycon) $
- tcAddErrCtxt (derivCtxt tycon) $
+ tcAddErrCtxt (derivCtxt Nothing tycon) $
tcExtendTyVarEnv (tyConTyVars tycon) $ -- Deriving preds may (now) mention
-- the type variables for the type constructor
tcHsPred pred `thenTc` \ pred' ->
-- It fails if any iteration fails
iterateDeriv :: [DerivSoln] ->TcM [DFunId]
iterateDeriv current_solns
- = checkNoErrsTc (iterateOnce current_solns)
- `thenTc` \ (new_dfuns, new_solns) ->
+ = getDOptsTc `thenNF_Tc` \ dflags ->
+ let
+ dfuns = zipWithEqual "add_solns" mk_deriv_dfun orig_eqns current_solns
+ inst_env = extend_inst_env dflags inst_env_in dfuns
+ in
+ checkNoErrsTc (
+ -- Extend the inst info from the explicit instance decls
+ -- with the current set of solutions, and simplify each RHS
+ tcSetInstEnv inst_env $
+ mapTc gen_soln orig_eqns
+ ) `thenTc` \ new_solns ->
if (current_solns == new_solns) then
- returnTc new_dfuns
+ returnTc dfuns
else
iterateDeriv new_solns
------------------------------------------------------------------
- iterateOnce current_solns
- = -- Extend the inst info from the explicit instance decls
- -- with the current set of solutions, giving a
- getDOptsTc `thenNF_Tc` \ dflags ->
- let
- new_dfuns = zipWithEqual "add_solns" mk_deriv_dfun orig_eqns current_solns
- inst_env = extend_inst_env dflags inst_env_in new_dfuns
- -- the eqns and solns move "in lockstep"; we have the eqns
- -- because we need the LHS info for addClassInstance.
- in
- -- Simplify each RHS
- tcSetInstEnv inst_env (
- listTc [ tcAddSrcLoc (getSrcLoc tc) $
- tcAddErrCtxt (derivCtxt tc) $
- tcSimplifyThetas deriv_rhs
- | (_, _,tc,_,deriv_rhs) <- orig_eqns ]
- ) `thenTc` \ next_solns ->
-
- -- Canonicalise the solutions, so they compare nicely
- let canonicalised_next_solns = [ sortLt (<) next_soln | next_soln <- next_solns ]
- in
- returnTc (new_dfuns, canonicalised_next_solns)
+
+ gen_soln (_, clas, tc,tyvars,deriv_rhs)
+ = tcAddSrcLoc (getSrcLoc tc) $
+ tcAddErrCtxt (derivCtxt (Just clas) tc) $
+ tcSimplifyDeriv tyvars deriv_rhs `thenTc` \ theta ->
+ returnTc (sortLt (<) theta) -- Canonicalise before returning the soluction
\end{code}
\begin{code}
malformedPredErr tycon pred = ptext SLIT("Illegal deriving item") <+> ppr pred
-derivCtxt tycon
- = ptext SLIT("When deriving classes for") <+> quotes (ppr tycon)
+derivCtxt :: Maybe Class -> TyCon -> SDoc
+derivCtxt maybe_cls tycon
+ = ptext SLIT("When deriving") <+> cls <+> ptext SLIT("for type") <+> quotes (ppr tycon)
+ where
+ cls = case maybe_cls of
+ Nothing -> ptext SLIT("instances")
+ Just c -> ptext SLIT("the") <+> quotes (ppr c) <+> ptext SLIT("instance")
\end{code}
-- Checking type validity
Rank, UserTypeCtxt(..), checkValidType, pprUserTypeCtxt,
SourceTyCtxt(..), checkValidTheta,
- checkValidInstHead, instTypeErr,
+ checkValidInstHead, instTypeErr, checkAmbiguity,
--------------------------------
-- Zonking
in
check_valid_theta SigmaCtxt theta `thenTc_`
check_tau_type (decRank rank) False tau `thenTc_`
- checkAmbiguity tvs theta tau
+ checkFreeness tvs theta `thenTc_`
+ checkAmbiguity tvs theta (tyVarsOfType tau)
----------------------------------------
check_arg_type :: Type -> TcM ()
----------------------------------------
check_note (FTVNote _) = returnTc ()
check_note (SynNote ty) = check_tau_type (Rank 0) False ty
+
+----------------------------------------
+forAllTyErr ty = ptext SLIT("Illegal polymorphic type:") <+> ppr_ty ty
+usageTyErr ty = ptext SLIT("Illegal usage type:") <+> ppr_ty ty
+unliftedArgErr ty = ptext SLIT("Illegal unlifted type argument:") <+> ppr_ty ty
+ubxArgTyErr ty = ptext SLIT("Illegal unboxed tuple type as function argument:") <+> ppr_ty ty
+kindErr kind = ptext SLIT("Expecting an ordinary type, but found a type of kind") <+> ppr kind
\end{code}
Check for ambiguity
forall x y. (C x y) => x
is not ambiguous because x is mentioned and x determines y
-NOTE: In addition, GHC insists that at least one type variable
-in each constraint is in V. So we disallow a type like
- forall a. Eq b => b -> b
-even in a scope where b is in scope.
-This is the is_free test below.
-
NB; the ambiguity check is only used for *user* types, not for types
coming from inteface files. The latter can legitimately have
ambiguous types. Example
(see is_ambig).
\begin{code}
-checkAmbiguity :: [TyVar] -> ThetaType -> Type -> TcM ()
-checkAmbiguity forall_tyvars theta tau
- = mapTc_ check_pred theta `thenTc_`
- returnTc ()
+checkAmbiguity :: [TyVar] -> ThetaType -> TyVarSet -> TcM ()
+checkAmbiguity forall_tyvars theta tau_tyvars
+ = mapTc_ complain (filter is_ambig theta)
where
- tau_vars = tyVarsOfType tau
- extended_tau_vars = grow theta tau_vars
+ complain pred = addErrTc (ambigErr pred)
+ extended_tau_vars = grow theta tau_tyvars
+ is_ambig pred = any ambig_var (varSetElems (tyVarsOfPred pred))
- is_ambig ct_var = (ct_var `elem` forall_tyvars) &&
+ ambig_var ct_var = (ct_var `elem` forall_tyvars) &&
not (ct_var `elemVarSet` extended_tau_vars)
+
is_free ct_var = not (ct_var `elem` forall_tyvars)
-
- check_pred pred = checkTc (not any_ambig) (ambigErr pred) `thenTc_`
- checkTc (isIPPred pred || not all_free) (freeErr pred)
- where
- ct_vars = varSetElems (tyVarsOfPred pred)
- all_free = all is_free ct_vars
- any_ambig = any is_ambig ct_vars
-\end{code}
-\begin{code}
ambigErr pred
= sep [ptext SLIT("Ambiguous constraint") <+> quotes (pprPred pred),
nest 4 (ptext SLIT("At least one of the forall'd type variables mentioned by the constraint") $$
ptext SLIT("must be reachable from the type after the '=>'"))]
+\end{code}
+
+In addition, GHC insists that at least one type variable
+in each constraint is in V. So we disallow a type like
+ forall a. Eq b => b -> b
+even in a scope where b is in scope.
+\begin{code}
+checkFreeness forall_tyvars theta
+ = mapTc_ complain (filter is_free theta)
+ where
+ is_free pred = not (isIPPred pred)
+ && not (any bound_var (varSetElems (tyVarsOfPred pred)))
+ bound_var ct_var = ct_var `elem` forall_tyvars
+ complain pred = addErrTc (freeErr pred)
freeErr pred
= sep [ptext SLIT("All of the type variables in the constraint") <+> quotes (pprPred pred) <+>
ptext SLIT("are already in scope"),
nest 4 (ptext SLIT("At least one must be universally quantified here"))
]
-
-forAllTyErr ty = ptext SLIT("Illegal polymorphic type:") <+> ppr_ty ty
-usageTyErr ty = ptext SLIT("Illegal usage type:") <+> ppr_ty ty
-unliftedArgErr ty = ptext SLIT("Illegal unlifted type argument:") <+> ppr_ty ty
-ubxArgTyErr ty = ptext SLIT("Illegal unboxed tuple type as function argument:") <+> ppr_ty ty
-kindErr kind = ptext SLIT("Expecting an ordinary type, but found a type of kind") <+> ppr kind
\end{code}
+
%************************************************************************
%* *
\subsection{Checking a theta or source type}
tcSimplifyCheck, tcSimplifyRestricted,
tcSimplifyToDicts, tcSimplifyIPs, tcSimplifyTop,
- tcSimplifyThetas, tcSimplifyCheckThetas,
+ tcSimplifyDeriv, tcSimplifyDefault,
bindInstsOfLocalFuns
) where
import TcMonad
import Inst ( lookupInst, lookupSimpleInst, LookupInstResult(..),
- tyVarsOfInst, predsOfInsts, predsOfInst,
+ tyVarsOfInst, predsOfInsts, predsOfInst, newDicts,
isDict, isClassDict, isLinearInst, linearInstType,
isStdClassTyVarDict, isMethodFor, isMethod,
instToId, tyVarsOfInsts, cloneDict,
- ipNamesOfInsts, ipNamesOfInst,
+ ipNamesOfInsts, ipNamesOfInst, dictPred,
instBindingRequired, instCanBeGeneralised,
newDictsFromOld, newMethodAtLoc,
getDictClassTys, isTyVarDict,
)
import TcEnv ( tcGetGlobalTyVars, tcGetInstEnv, tcLookupGlobalId )
import InstEnv ( lookupInstEnv, classInstEnv, InstLookupResult(..) )
-import TcMType ( zonkTcTyVarsAndFV, tcInstTyVars )
+import TcMType ( zonkTcTyVarsAndFV, tcInstTyVars, checkAmbiguity )
import TcType ( TcTyVar, TcTyVarSet, ThetaType, PredType,
mkClassPred, isOverloadedTy, mkTyConApp,
- mkTyVarTy, tcGetTyVar, isTyVarClassPred,
+ mkTyVarTy, tcGetTyVar, isTyVarClassPred, mkTyVarTys,
tyVarsOfPred, getClassPredTys_maybe, isClassPred, isIPPred,
inheritablePred, predHasFDs )
import Id ( idType, mkUserLocal )
+import Var ( TyVar )
import Name ( getOccName, getSrcLoc )
import NameSet ( NameSet, mkNameSet, elemNameSet )
import Class ( classBigSig )
| Free -- Return as free
+reduceMe :: Inst -> WhatToDo
+reduceMe inst = ReduceMe
+
data WantSCs = NoSCs | AddSCs -- Tells whether we should add the superclasses
-- of a predicate when adding it to the avails
\end{code}
%************************************************************************
-If a dictionary constrains a type variable which is
- * not mentioned in the environment
- * and not mentioned in the type of the expression
-then it is ambiguous. No further information will arise to instantiate
-the type variable; nor will it be generalised and turned into an extra
-parameter to a function.
-
-It is an error for this to occur, except that Haskell provided for
-certain rules to be applied in the special case of numeric types.
-Specifically, if
- * at least one of its classes is a numeric class, and
- * all of its classes are numeric or standard
-then the type variable can be defaulted to the first type in the
-default-type list which is an instance of all the offending classes.
-
-So here is the function which does the work. It takes the ambiguous
-dictionaries and either resolves them (producing bindings) or
-complains. It works by splitting the dictionary list by type
-variable, and using @disambigOne@ to do the real business.
-
@tcSimplifyTop@ is called once per module to simplify all the constant
and ambiguous Insts.
\begin{code}
tcSimplifyTop :: LIE -> TcM TcDictBinds
tcSimplifyTop wanted_lie
- = simpleReduceLoop (text "tcSimplTop") try_me wanteds `thenTc` \ (frees, binds, irreds) ->
+ = simpleReduceLoop (text "tcSimplTop") reduceMe wanteds `thenTc` \ (frees, binds, irreds) ->
ASSERT( null frees )
let
returnTc (binds `andMonoBinds` andMonoBindList binds_ambig)
where
wanteds = lieToList wanted_lie
- try_me inst = ReduceMe
d1 `cmp_by_tyvar` d2 = get_tv d1 `compare` get_tv d2
(clas, [ty]) -> clas
\end{code}
+If a dictionary constrains a type variable which is
+ * not mentioned in the environment
+ * and not mentioned in the type of the expression
+then it is ambiguous. No further information will arise to instantiate
+the type variable; nor will it be generalised and turned into an extra
+parameter to a function.
+
+It is an error for this to occur, except that Haskell provided for
+certain rules to be applied in the special case of numeric types.
+Specifically, if
+ * at least one of its classes is a numeric class, and
+ * all of its classes are numeric or standard
+then the type variable can be defaulted to the first type in the
+default-type list which is an instance of all the offending classes.
+
+So here is the function which does the work. It takes the ambiguous
+dictionaries and either resolves them (producing bindings) or
+complains. It works by splitting the dictionary list by type
+variable, and using @disambigOne@ to do the real business.
+
@disambigOne@ assumes that its arguments dictionaries constrain all
the same type variable.
try_default (default_ty : default_tys)
= tryTc_ (try_default default_tys) $ -- If default_ty fails, we try
-- default_tys instead
- tcSimplifyCheckThetas [] theta `thenTc` \ _ ->
+ tcSimplifyDefault theta `thenTc` \ _ ->
returnTc default_ty
where
theta = [mkClassPred clas [default_ty] | clas <- classes]
-- Bind the type variable and reduce the context, for real this time
unifyTauTy chosen_default_ty (mkTyVarTy tyvar) `thenTc_`
simpleReduceLoop (text "disambig" <+> ppr dicts)
- try_me dicts `thenTc` \ (frees, binds, ambigs) ->
+ reduceMe dicts `thenTc` \ (frees, binds, ambigs) ->
WARN( not (null frees && null ambigs), ppr frees $$ ppr ambigs )
warnDefault dicts chosen_default_ty `thenTc_`
returnTc binds
returnTc EmptyMonoBinds
where
- try_me inst = ReduceMe -- This reduce should not fail
tyvar = get_tv (head dicts) -- Should be non-empty
classes = map get_clas dicts
\end{code}
instance declarations.
\begin{code}
-tcSimplifyThetas :: ThetaType -- Wanted
- -> TcM ThetaType -- Needed
-
-tcSimplifyThetas wanteds
- = doptsTc Opt_GlasgowExts `thenNF_Tc` \ glaExts ->
- reduceSimple [] wanteds `thenNF_Tc` \ irreds ->
+tcSimplifyDeriv :: [TyVar]
+ -> ThetaType -- Wanted
+ -> TcM ThetaType -- Needed
+
+tcSimplifyDeriv tyvars theta
+ = tcInstTyVars 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?
+ newDicts DataDeclOrigin (substTheta tenv theta) `thenNF_Tc` \ wanteds ->
+ simpleReduceLoop doc reduceMe wanteds `thenTc` \ (frees, _, irreds) ->
+ ASSERT( null frees ) -- reduceMe never returns Free
+
+ doptsTc Opt_AllowUndecidableInstances `thenNF_Tc` \ undecidable_ok ->
let
- -- For multi-param Haskell, check that the returned dictionaries
- -- don't have any of the form (C Int Bool) for which
- -- we expect an instance here
- -- For Haskell 98, check that all the constraints are of the form C a,
- -- where a is a type variable
- bad_guys | glaExts = [pred | pred <- irreds,
- isEmptyVarSet (tyVarsOfPred pred)]
- | otherwise = [pred | pred <- irreds,
- not (isTyVarClassPred pred)]
+ tv_set = mkVarSet tvs
+ simpl_theta = map dictPred irreds -- reduceMe squashes all non-dicts
+
+ check_pred 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)
+ = addErrTc (noInstErr pred)
+
+ -- 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 ()
+
+ rev_env = mkTopTyVarSubst tvs (mkTyVarTys tyvars)
+ -- This reverse-mapping is a Royal Pain,
+ -- but the result should mention TyVars not TcTyVars
in
- if null bad_guys then
- returnTc irreds
- else
- mapNF_Tc addNoInstErr bad_guys `thenNF_Tc_`
- failTc
+
+ mapNF_Tc check_pred simpl_theta `thenNF_Tc_`
+ checkAmbiguity tvs simpl_theta tv_set `thenTc_`
+ returnTc (substTheta rev_env simpl_theta)
+ where
+ doc = ptext SLIT("deriving classes for a data type")
\end{code}
-@tcSimplifyCheckThetas@ just checks class-type constraints, essentially;
+@tcSimplifyDefault@ just checks class-type constraints, essentially;
used with \tr{default} declarations. We are only interested in
whether it worked or not.
\begin{code}
-tcSimplifyCheckThetas :: ThetaType -- Given
- -> ThetaType -- Wanted
- -> TcM ()
-
-tcSimplifyCheckThetas givens wanteds
- = reduceSimple givens wanteds `thenNF_Tc` \ irreds ->
+tcSimplifyDefault :: ThetaType -- Wanted; has no type variables in it
+ -> TcM ()
+
+tcSimplifyDefault theta
+ = newDicts DataDeclOrigin theta `thenNF_Tc` \ wanteds ->
+ simpleReduceLoop doc reduceMe wanteds `thenTc` \ (frees, _, irreds) ->
+ ASSERT( null frees ) -- try_me never returns Free
+ mapNF_Tc (addErrTc . noInstErr) irreds `thenNF_Tc_`
if null irreds then
- returnTc ()
+ returnTc ()
else
- mapNF_Tc addNoInstErr irreds `thenNF_Tc_`
- failTc
-\end{code}
-
-
-\begin{code}
-type AvailsSimple = FiniteMap PredType Bool
- -- True => irreducible
- -- False => given, or can be derived from a given or from an irreducible
-
-reduceSimple :: ThetaType -- Given
- -> ThetaType -- Wanted
- -> NF_TcM ThetaType -- Irreducible
-
-reduceSimple givens wanteds
- = reduce_simple (0,[]) givens_fm wanteds `thenNF_Tc` \ givens_fm' ->
- returnNF_Tc [pred | (pred,True) <- fmToList givens_fm']
- where
- givens_fm = foldl addNonIrred emptyFM givens
-
-reduce_simple :: (Int,ThetaType) -- Stack
- -> AvailsSimple
- -> ThetaType
- -> NF_TcM AvailsSimple
-
-reduce_simple (n,stack) avails wanteds
- = go avails wanteds
+ failTc
where
- go avails [] = returnNF_Tc avails
- go avails (w:ws) = reduce_simple_help (n+1,w:stack) avails w `thenNF_Tc` \ avails' ->
- go avails' ws
-
-reduce_simple_help stack givens wanted
- | wanted `elemFM` givens
- = returnNF_Tc givens
-
- | Just (clas, tys) <- getClassPredTys_maybe wanted
- = lookupSimpleInst clas tys `thenNF_Tc` \ maybe_theta ->
- case maybe_theta of
- Nothing -> returnNF_Tc (addSimpleIrred givens wanted)
- Just theta -> reduce_simple stack (addNonIrred givens wanted) theta
-
- | otherwise
- = returnNF_Tc (addSimpleIrred givens wanted)
-
-addSimpleIrred :: AvailsSimple -> PredType -> AvailsSimple
-addSimpleIrred givens pred
- = addSCs (addToFM givens pred True) pred
-
-addNonIrred :: AvailsSimple -> PredType -> AvailsSimple
-addNonIrred givens pred
- = addSCs (addToFM givens pred False) pred
-
-addSCs givens pred
- | not (isClassPred pred) = givens
- | otherwise = foldl add givens sc_theta
- where
- Just (clas,tys) = getClassPredTys_maybe pred
- (tyvars, sc_theta_tmpl, _, _) = classBigSig clas
- sc_theta = substTheta (mkTopTyVarSubst tyvars tys) sc_theta_tmpl
-
- add givens ct
- = case lookupFM givens ct of
- Nothing -> -- Add it and its superclasses
- addSCs (addToFM givens ct False) ct
-
- Just True -> -- Set its flag to False; superclasses already done
- addToFM givens ct False
-
- Just False -> -- Already done
- givens
-
+ doc = ptext SLIT("default declaration")
\end{code}
addInstErrTcM (instLoc (head dicts)) (tidy_env2, doc)
-- Used for the ...Thetas variants; all top level
-addNoInstErr pred
- = addErrTc (ptext SLIT("No instance for") <+> quotes (ppr pred))
+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"),
+ nest 2 (ptext SLIT("Offending constraint:") <+> ppr pred)]
reduceDepthErr n stack
= vcat [ptext SLIT("Context reduction stack overflow; size =") <+> int n,
projects / ghc-hetmet.git / commitdiff