collectLocatedMonoBinders )
import RdrHsSyn ( RdrNameMonoBinds )
import RnHsSyn ( RenamedHsBinds, RenamedMonoBinds, RenamedTyClDecl, RenamedHsPred )
-import CmdLineOpts ( DynFlag(..), DynFlags )
+import CmdLineOpts ( DynFlag(..) )
import TcMonad
import TcEnv ( tcSetInstEnv, newDFunName, InstInfo(..), pprInstInfo,
- tcLookupClass, tcLookupTyCon, tcExtendTyVarEnv
+ tcLookupTyCon, tcExtendTyVarEnv
)
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 RnMonad ( renameDerivedCode, thenRn, mapRn, returnRn )
-import HscTypes ( DFunId, PersistentRenamerState )
+import HscTypes ( DFunId, PersistentRenamerState, FixityEnv )
import BasicTypes ( Fixity, NewOrData(..) )
import Class ( className, classKey, classTyVars, Class )
-import ErrUtils ( dumpIfSet_dyn, Message )
+import ErrUtils ( dumpIfSet_dyn )
import MkId ( mkDictFunId )
import DataCon ( dataConRepArgTys, isNullaryDataCon, isExistentialDataCon )
import PrelInfo ( needsDataDeclCtxtClassKeys )
)
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 ListSetOps ( removeDups, assoc )
import Outputable
import Maybe ( isJust )
-import List ( nub )
import FastString ( FastString )
\end{code}
-- The Name is the name for the DFun we'll build
-- The tyvars bind all the variables in the RHS
+pprDerivEqn (n,c,tc,tvs,rhs)
+ = parens (hsep [ppr n, ppr c, ppr tc, ppr tvs] <+> equals <+> ppr rhs)
+
type DerivRhs = ThetaType
type DerivSoln = DerivRhs
\end{code}
tcDeriving :: PersistentRenamerState
-> Module -- name of module under scrutiny
-> InstEnv -- What we already know about instances
- -> (Name -> Maybe Fixity) -- used in deriving Show and Read
+ -> FixityEnv -- used in deriving Show and Read
-> [RenamedTyClDecl] -- All type constructors
-> TcM ([InstInfo], -- The generated "instance decls".
RenamedHsBinds) -- Extra generated bindings
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' ->
-- This bunch is Absolutely minimal...
solveDerivEqns inst_env_in orig_eqns
- = iterateDeriv initial_solutions
+ = iterateDeriv 1 initial_solutions
where
-- The initial solutions for the equations claim that each
-- instance has an empty context; this solution is certainly
-- compares it with the current one; finishes if they are the
-- same, otherwise recurses with the new solutions.
-- It fails if any iteration fails
- iterateDeriv :: [DerivSoln] ->TcM [DFunId]
- iterateDeriv current_solns
- = checkNoErrsTc (iterateOnce current_solns)
- `thenTc` \ (new_dfuns, new_solns) ->
+ iterateDeriv :: Int -> [DerivSoln] ->TcM [DFunId]
+ iterateDeriv n current_solns
+ | n > 20 -- Looks as if we are in an infinite loop
+ -- This can happen if we have -fallow-undecidable-instances
+ -- (See TcSimplify.tcSimplifyDeriv.)
+ = pprPanic "solveDerivEqns: probable loop"
+ (vcat (map pprDerivEqn orig_eqns) $$ ppr current_solns)
+ | otherwise
+ = 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
+ iterateDeriv (n+1) 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}
-- Generate the method bindings for the required instance
-- (paired with class name, as we need that when renaming
-- the method binds)
-gen_bind :: (Name -> Maybe Fixity) -> DFunId -> (Name, RdrNameMonoBinds)
+gen_bind :: FixityEnv -> DFunId -> (Name, RdrNameMonoBinds)
gen_bind get_fixity dfun
= (cls_nm, binds)
where
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}
projects / ghc-hetmet.git / blobdiff