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 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 BasicTypes ( 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, tyVarsOfTheta )
+ tcSplitTyConApp_maybe, tcEqTypes )
import Var ( TyVar, tyVarKind )
import VarSet ( mkVarSet, subVarSet )
import PrelNames
-import Util ( zipWithEqual, sortLt, eqListBy )
+import Util ( zipWithEqual, sortLt )
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
-- 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
+ 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
if (current_solns == new_solns) then
returnTc dfuns
else
- iterateDeriv new_solns
+ iterateDeriv (n+1) new_solns
------------------------------------------------------------------
-- 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