#include "HsVersions.h"
import HsSyn
-import CmdLineOpts ( DynFlag(..) )
+import DynFlags ( DynFlag(..) )
import Generics ( mkTyConGenericBinds )
import TcRnMonad
import TcEnv ( newDFunName, pprInstInfoDetails,
- InstInfo(..), InstBindings(..),
+ InstInfo(..), InstBindings(..), simpleInstInfoClsTy,
tcLookupClass, tcLookupTyCon, tcExtendTyVarEnv
)
import TcGenDeriv -- Deriv stuff
-import InstEnv ( simpleDFunClassTyCon, extendInstEnv )
+import InstEnv ( Instance, OverlapFlag, mkLocalInstance, instanceHead, extendInstEnvList )
+import Inst ( getOverlapFlag )
import TcHsType ( tcHsDeriv )
import TcSimplify ( tcSimplifyDeriv )
import RnBinds ( rnMethodBinds, rnTopBinds )
import RnEnv ( bindLocalNames )
-import HscTypes ( DFunId, FixityEnv )
+import HscTypes ( FixityEnv )
import Class ( className, classArity, classKey, classTyVars, classSCTheta, Class )
-import Subst ( mkTyVarSubst, substTheta )
+import Type ( zipOpenTvSubst, substTheta )
import ErrUtils ( dumpIfSet_dyn )
import MkId ( mkDictFunId )
-import DataCon ( isNullaryDataCon, isExistentialDataCon, dataConOrigArgTys )
+import DataCon ( isNullarySrcDataCon, isVanillaDataCon, dataConOrigArgTys )
import Maybes ( catMaybes )
import RdrName ( RdrName )
import Name ( Name, getSrcLoc )
-import NameSet ( NameSet, emptyNameSet, duDefs )
+import NameSet ( duDefs )
import Kind ( splitKindFunTys )
import TyCon ( tyConTyVars, tyConDataCons, tyConArity, tyConHasGenerics,
- tyConTheta, isProductTyCon, isDataTyCon, newTyConRhs,
+ tyConStupidTheta, isProductTyCon, isDataTyCon, newTyConRhs,
isEnumerationTyCon, isRecursiveTyCon, TyCon
)
import TcType ( TcType, ThetaType, mkTyVarTys, mkTyConApp, tcTyConAppTyCon,
isUnLiftedType, mkClassPred, tyVarsOfTypes, isArgTypeKind,
- tcEqTypes, tcSplitAppTys, mkAppTys, tcSplitDFunTy )
-import Var ( TyVar, tyVarKind, idType, varName )
+ tcEqTypes, tcSplitAppTys, mkAppTys )
+import Var ( TyVar, tyVarKind, varName )
import VarSet ( mkVarSet, subVarSet )
import PrelNames
import SrcLoc ( srcLocSpan, Located(..) )
-import Util ( zipWithEqual, sortLt, notNull )
+import Util ( zipWithEqual, sortLe, notNull )
import ListSetOps ( removeDups, assocMaybe )
import Outputable
import Bag
\begin{code}
tcDeriving :: [LTyClDecl Name] -- All type constructors
-> TcM ([InstInfo], -- The generated "instance decls"
- [HsBindGroup Name], -- Extra generated top-level bindings
- NameSet) -- Binders to keep alive
+ HsValBinds Name) -- Extra generated top-level bindings
tcDeriving tycl_decls
- = recoverM (returnM ([], [], emptyNameSet)) $
+ = recoverM (returnM ([], emptyValBindsOut)) $
do { -- Fish the "deriving"-related information out of the TcEnv
-- and make the necessary "equations".
- ; (ordinary_eqns, newtype_inst_info) <- makeDerivEqns tycl_decls
+ overlap_flag <- getOverlapFlag
+ ; (ordinary_eqns, newtype_inst_info) <- makeDerivEqns overlap_flag tycl_decls
; (ordinary_inst_info, deriv_binds)
- <- extendLocalInstEnv (map iDFunId newtype_inst_info) $
- deriveOrdinaryStuff ordinary_eqns
+ <- extendLocalInstEnv (map iSpec newtype_inst_info) $
+ deriveOrdinaryStuff overlap_flag ordinary_eqns
-- Add the newtype-derived instances to the inst env
-- before tacking the "ordinary" ones
+ ; let inst_info = newtype_inst_info ++ ordinary_inst_info
+
+ -- If we are compiling a hs-boot file,
+ -- don't generate any derived bindings
+ ; is_boot <- tcIsHsBoot
+ ; if is_boot then
+ return (inst_info, emptyValBindsOut)
+ else do
+ {
+
-- Generate the generic to/from functions from each type declaration
; gen_binds <- mkGenericBinds tycl_decls
- ; let inst_info = newtype_inst_info ++ ordinary_inst_info
-- Rename these extra bindings, discarding warnings about unused bindings etc
-- Set -fglasgow exts so that we can have type signatures in patterns,
-- which is used in the generic binds
- ; (rn_binds, gen_bndrs)
+ ; rn_binds
<- discardWarnings $ setOptM Opt_GlasgowExts $ do
- { (rn_deriv, _dus1) <- rnTopBinds deriv_binds []
- ; (rn_gen, dus_gen) <- rnTopBinds gen_binds []
- ; return (rn_deriv ++ rn_gen, duDefs dus_gen) }
+ { (rn_deriv, _dus1) <- rnTopBinds (ValBindsIn deriv_binds [])
+ ; (rn_gen, dus_gen) <- rnTopBinds (ValBindsIn gen_binds [])
+ ; keepAliveSetTc (duDefs dus_gen) -- Mark these guys to
+ -- be kept alive
+ ; return (rn_deriv `plusHsValBinds` rn_gen) }
; dflags <- getDOpts
; ioToTcRn (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
(ddump_deriving inst_info rn_binds))
- ; returnM (inst_info, rn_binds, gen_bndrs)
- }
+ ; returnM (inst_info, rn_binds)
+ }}
where
- ddump_deriving :: [InstInfo] -> [HsBindGroup Name] -> SDoc
+ ddump_deriving :: [InstInfo] -> HsValBinds Name -> SDoc
ddump_deriving inst_infos extra_binds
- = vcat (map pprInstInfoDetails inst_infos) $$ vcat (map ppr extra_binds)
+ = vcat (map pprInstInfoDetails inst_infos) $$ ppr extra_binds
-----------------------------------------
-deriveOrdinaryStuff [] -- Short cut
- = returnM ([], emptyBag)
+deriveOrdinaryStuff overlap_flag [] -- Short cut
+ = returnM ([], emptyLHsBinds)
-deriveOrdinaryStuff eqns
+deriveOrdinaryStuff overlap_flag eqns
= do { -- Take the equation list and solve it, to deliver a list of
-- solutions, a.k.a. the contexts for the instance decls
-- required for the corresponding equations.
- ; new_dfuns <- solveDerivEqns eqns
+ inst_specs <- solveDerivEqns overlap_flag eqns
-- Generate the InstInfo for each dfun,
-- plus any auxiliary bindings it needs
- ; (inst_infos, aux_binds_s) <- mapAndUnzipM genInst new_dfuns
+ ; (inst_infos, aux_binds_s) <- mapAndUnzipM genInst inst_specs
-- Generate any extra not-one-inst-decl-specific binds,
-- notably "con2tag" and/or "tag2con" functions.
- ; extra_binds <- genTaggeryBinds new_dfuns
+ ; extra_binds <- genTaggeryBinds inst_infos
-- Done
; returnM (inst_infos, unionManyBags (extra_binds : aux_binds_s))
all those.
\begin{code}
-makeDerivEqns :: [LTyClDecl Name]
+makeDerivEqns :: OverlapFlag
+ -> [LTyClDecl Name]
-> TcM ([DerivEqn], -- Ordinary derivings
[InstInfo]) -- Special newtype derivings
-makeDerivEqns tycl_decls
+makeDerivEqns overlap_flag tycl_decls
= mapAndUnzipM mk_eqn derive_these `thenM` \ (maybe_ordinaries, maybe_newtypes) ->
returnM (catMaybes maybe_ordinaries, catMaybes maybe_newtypes)
where
mk_eqn (new_or_data, tycon_name, hs_deriv_ty)
= tcLookupTyCon tycon_name `thenM` \ tycon ->
- addSrcSpan (srcLocSpan (getSrcLoc tycon)) $
+ setSrcSpan (srcLocSpan (getSrcLoc tycon)) $
addErrCtxt (derivCtxt Nothing tycon) $
tcExtendTyVarEnv (tyConTyVars tycon) $ -- Deriving preds may (now) mention
-- the type variables for the type constructor
= -- Go ahead and use the isomorphism
traceTc (text "newtype deriving:" <+> ppr tycon <+> ppr rep_tys) `thenM_`
new_dfun_name clas tycon `thenM` \ dfun_name ->
- returnM (Nothing, Just (InstInfo { iDFunId = mk_dfun dfun_name,
+ returnM (Nothing, Just (InstInfo { iSpec = mk_inst_spec dfun_name,
iBinds = NewTypeDerived rep_tys }))
| std_class gla_exts clas
= mk_eqn_help gla_exts DataType tycon deriv_tvs clas tys -- Go via bale-out route
-- There's no 'corece' needed because after the type checker newtypes
-- are transparent.
- sc_theta = substTheta (mkTyVarSubst clas_tyvars inst_tys)
+ sc_theta = substTheta (zipOpenTvSubst clas_tyvars inst_tys)
(classSCTheta clas)
-- If there are no tyvars, there's no need
| otherwise = rep_pred : sc_theta
-- Finally! Here's where we build the dictionary Id
- mk_dfun dfun_name = mkDictFunId dfun_name dict_tvs dict_args clas inst_tys
+ mk_inst_spec dfun_name
+ = mkLocalInstance dfun overlap_flag
+ where
+ dfun = mkDictFunId dfun_name dict_tvs dict_args clas inst_tys
-------------------------------------------------------------------
-- Figuring out whether we can only do this newtype-deriving thing
where
tyvars = tyConTyVars tycon
constraints = extra_constraints ++ ordinary_constraints
- extra_constraints = tyConTheta tycon
+ extra_constraints = tyConStupidTheta tycon
-- "extra_constraints": see note [Data decl contexts] above
ordinary_constraints
= [ mkClassPred clas [arg_ty]
| data_con <- tyConDataCons tycon,
arg_ty <- dataConOrigArgTys data_con,
- -- Use the same type variables
- -- as the type constructor,
- -- hence no need to instantiate
not (isUnLiftedType arg_ty) -- No constraints for unlifted types?
]
cond_std :: Condition
cond_std (gla_exts, tycon)
- | any isExistentialDataCon data_cons = Just existential_why
- | null data_cons = Just no_cons_why
- | otherwise = Nothing
+ | any (not . isVanillaDataCon) data_cons = Just existential_why
+ | null data_cons = Just no_cons_why
+ | otherwise = Nothing
where
data_cons = tyConDataCons tycon
no_cons_why = quotes (ppr tycon) <+> ptext SLIT("has no data constructors")
- existential_why = quotes (ppr tycon) <+> ptext SLIT("has existentially-quantified constructor(s)")
+ existential_why = quotes (ppr tycon) <+> ptext SLIT("has non-Haskell-98 constructor(s)")
cond_isEnumeration :: Condition
cond_isEnumeration (gla_exts, tycon)
\end{itemize}
\begin{code}
-solveDerivEqns :: [DerivEqn]
- -> TcM [DFunId] -- Solns in same order as eqns.
+solveDerivEqns :: OverlapFlag
+ -> [DerivEqn]
+ -> TcM [Instance]-- Solns in same order as eqns.
-- This bunch is Absolutely minimal...
-solveDerivEqns orig_eqns
+solveDerivEqns overlap_flag orig_eqns
= iterateDeriv 1 initial_solutions
where
-- The initial solutions for the equations claim that each
-- 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 :: Int -> [DerivSoln] ->TcM [DFunId]
+ iterateDeriv :: Int -> [DerivSoln] -> TcM [Instance]
iterateDeriv n current_solns
| n > 20 -- Looks as if we are in an infinite loop
-- This can happen if we have -fallow-undecidable-instances
(vcat (map pprDerivEqn orig_eqns) $$ ppr current_solns)
| otherwise
= let
- dfuns = zipWithEqual "add_solns" mk_deriv_dfun orig_eqns current_solns
+ inst_specs = zipWithEqual "add_solns" mk_inst_spec
+ orig_eqns current_solns
in
checkNoErrs (
-- Extend the inst info from the explicit instance decls
-- with the current set of solutions, and simplify each RHS
- extendLocalInstEnv dfuns $
+ extendLocalInstEnv inst_specs $
mappM gen_soln orig_eqns
) `thenM` \ new_solns ->
if (current_solns == new_solns) then
- returnM dfuns
+ returnM inst_specs
else
iterateDeriv (n+1) new_solns
------------------------------------------------------------------
-
gen_soln (_, clas, tc,tyvars,deriv_rhs)
- = addSrcSpan (srcLocSpan (getSrcLoc tc)) $
+ = setSrcSpan (srcLocSpan (getSrcLoc tc)) $
addErrCtxt (derivCtxt (Just clas) tc) $
- tcSimplifyDeriv tyvars deriv_rhs `thenM` \ theta ->
- returnM (sortLt (<) theta) -- Canonicalise before returning the soluction
+ tcSimplifyDeriv tc tyvars deriv_rhs `thenM` \ theta ->
+ returnM (sortLe (<=) theta) -- Canonicalise before returning the soluction
-mk_deriv_dfun (dfun_name, clas, tycon, tyvars, _) theta
- = mkDictFunId dfun_name tyvars theta
- clas [mkTyConApp tycon (mkTyVarTys tyvars)]
-
-extendLocalInstEnv :: [DFunId] -> TcM a -> TcM a
--- Add new locall-defined instances; don't bother to check
+ ------------------------------------------------------------------
+ mk_inst_spec (dfun_name, clas, tycon, tyvars, _) theta
+ = mkLocalInstance dfun overlap_flag
+ where
+ dfun = mkDictFunId dfun_name tyvars theta clas
+ [mkTyConApp tycon (mkTyVarTys tyvars)]
+
+extendLocalInstEnv :: [Instance] -> TcM a -> TcM a
+-- Add new locally-defined instances; don't bother to check
-- for functional dependency errors -- that'll happen in TcInstDcls
extendLocalInstEnv dfuns thing_inside
= do { env <- getGblEnv
- ; let inst_env' = foldl extendInstEnv (tcg_inst_env env) dfuns
+ ; let inst_env' = extendInstEnvList (tcg_inst_env env) dfuns
env' = env { tcg_inst_env = inst_env' }
; setGblEnv env' thing_inside }
\end{code}
\begin{code}
-- Generate the InstInfo for the required instance,
-- plus any auxiliary bindings required
-genInst :: DFunId -> TcM (InstInfo, LHsBinds RdrName)
-genInst dfun
- = getFixityEnv `thenM` \ fix_env ->
- let
- (tyvars,_,clas,[ty]) = tcSplitDFunTy (idType dfun)
- clas_nm = className clas
- tycon = tcTyConAppTyCon ty
- (meth_binds, aux_binds) = genDerivBinds clas fix_env tycon
- in
+genInst :: Instance -> TcM (InstInfo, LHsBinds RdrName)
+genInst spec
+ = do { fix_env <- getFixityEnv
+ ; let
+ (tyvars,_,clas,[ty]) = instanceHead spec
+ clas_nm = className clas
+ tycon = tcTyConAppTyCon ty
+ (meth_binds, aux_binds) = genDerivBinds clas fix_env tycon
+
-- Bring the right type variables into
-- scope, and rename the method binds
- bindLocalNames (map varName tyvars) $
- rnMethodBinds clas_nm [] meth_binds `thenM` \ (rn_meth_binds, _fvs) ->
+ -- It's a bit yukky that we return *renamed* InstInfo, but
+ -- *non-renamed* auxiliary bindings
+ ; (rn_meth_binds, _fvs) <- discardWarnings $
+ bindLocalNames (map varName tyvars) $
+ rnMethodBinds clas_nm [] meth_binds
-- Build the InstInfo
- returnM (InstInfo { iDFunId = dfun, iBinds = VanillaInst rn_meth_binds [] },
- aux_binds)
+ ; return (InstInfo { iSpec = spec,
+ iBinds = VanillaInst rn_meth_binds [] },
+ aux_binds)
+ }
genDerivBinds clas fix_env tycon
| className clas `elem` typeableClassNames
- = (gen_Typeable_binds tycon, emptyBag)
+ = (gen_Typeable_binds tycon, emptyLHsBinds)
| otherwise
= case assocMaybe gen_list (getUnique clas) of
-- no_aux_binds is used for generators that don't
-- need to produce any auxiliary bindings
- no_aux_binds f fix_env tc = (f fix_env tc, emptyBag)
+ no_aux_binds f fix_env tc = (f fix_env tc, emptyLHsBinds)
ignore_fix_env f fix_env tc = f tc
\end{code}
If we have a @tag2con@ function, we also generate a @maxtag@ constant.
\begin{code}
-genTaggeryBinds :: [DFunId] -> TcM (LHsBinds RdrName)
-genTaggeryBinds dfuns
+genTaggeryBinds :: [InstInfo] -> TcM (LHsBinds RdrName)
+genTaggeryBinds infos
= do { names_so_far <- foldlM do_con2tag [] tycons_of_interest
; nm_alist_etc <- foldlM do_tag2con names_so_far tycons_of_interest
; return (listToBag (map gen_tag_n_con_monobind nm_alist_etc)) }
where
- all_CTs = map simpleDFunClassTyCon dfuns
+ all_CTs = [ (cls, tcTyConAppTyCon ty)
+ | info <- infos,
+ let (cls,ty) = simpleInstInfoClsTy info ]
all_tycons = map snd all_CTs
(tycons_of_interest, _) = removeDups compare all_tycons
do_con2tag acc_Names tycon
| isDataTyCon tycon &&
((we_are_deriving eqClassKey tycon
- && any isNullaryDataCon (tyConDataCons tycon))
+ && any isNullarySrcDataCon (tyConDataCons tycon))
|| (we_are_deriving ordClassKey tycon
&& not (isProductTyCon tycon))
|| (we_are_deriving enumClassKey tycon)
projects / ghc-hetmet.git / blobdiff