-- Deriving clause
-------------------------------------------------------
-repDerivs :: Maybe (LHsContext Name) -> DsM (Core [TH.Name])
+repDerivs :: Maybe [LHsType Name] -> DsM (Core [TH.Name])
repDerivs Nothing = coreList nameTyConName []
repDerivs (Just (L _ ctxt))
= do { strs <- mapM rep_deriv ctxt ;
where
rep_deriv :: LHsPred Name -> DsM (Core TH.Name)
-- Deriving clauses must have the simple H98 form
- rep_deriv (L _ (HsClassP cls [])) = lookupOcc cls
- rep_deriv other = panic "rep_deriv"
+ rep_deriv (L _ (HsPredTy (L _ (HsClassP cls [])))) = lookupOcc cls
+ rep_deriv other = panic "rep_deriv"
-------------------------------------------------------
tcdLName :: Located name, -- Type constructor
tcdTyVars :: [LHsTyVarBndr name], -- Type variables
tcdCons :: [LConDecl name], -- Data constructors
- tcdDerivs :: Maybe (LHsContext name)
+ tcdDerivs :: Maybe [LHsType name]
-- Derivings; Nothing => not specified
-- Just [] => derive exactly what is asked
+ -- These "types" must be of form
+ -- forall ab. C ty1 ty2
+ -- Typically the foralls and ty args are empty, but they
+ -- are non-empty for the newtype-deriving case
}
| TySynonym { tcdLName :: Located name, -- type constructor
pp_decl_rhs,
case derivings of
Nothing -> empty
- Just ds -> hsep [ptext SLIT("deriving"),
- ppr_hs_context (unLoc ds)]
+ Just ds -> hsep [ptext SLIT("deriving"), parens (interpp'SP ds)]
])
instance Outputable NewOrData where
data_info (TyData {tcdCons = cs, tcdDerivs = derivs})
= (length cs, case derivs of Nothing -> 0
- Just ds -> length (unLoc ds))
+ Just ds -> length ds)
data_info other = (0,0)
class_info decl@(ClassDecl {})
: {- empty -} { Nothing }
| '::' atype { Just $2 }
-sigtypes :: { [LHsType RdrName] }
+sigtypes1 :: { [LHsType RdrName] }
: sigtype { [ $1 ] }
- | sigtypes ',' sigtype { $3 : $1 }
+ | sigtype ',' sigtypes1 { $1 : $3 }
sigtype :: { LHsType RdrName }
: ctype { L1 (mkImplicitHsForAllTy (noLoc []) $1) }
inst_type :: { LHsType RdrName }
: ctype {% checkInstType $1 }
+inst_types1 :: { [LHsType RdrName] }
+ : inst_type { [$1] }
+ | inst_type ',' inst_types1 { $1 : $3 }
+
comma_types0 :: { [LHsType RdrName] }
: comma_types1 { $1 }
| {- empty -} { [] }
: '!' { L1 HsStrict }
| '{-# UNPACK' '#-}' '!' { LL HsUnbox }
-deriving :: { Located (Maybe (LHsContext RdrName)) }
- : {- empty -} { noLoc Nothing }
- | 'deriving' context { LL (Just $2) }
+deriving :: { Located (Maybe [LHsType RdrName]) }
+ : {- empty -} { noLoc Nothing }
+ | 'deriving' '(' ')' { LL (Just []) }
+ | 'deriving' '(' inst_types1 ')' { LL (Just $3) }
-- Glasgow extension: allow partial
-- applications in derivings
{ LL $ unitOL (LL $ SigD (InlineSig True $3 $2)) }
| '{-# NOINLINE' inverse_activation qvar '#-}'
{ LL $ unitOL (LL $ SigD (InlineSig False $3 $2)) }
- | '{-# SPECIALISE' qvar '::' sigtypes '#-}'
+ | '{-# SPECIALISE' qvar '::' sigtypes1 '#-}'
{ LL $ toOL [ LL $ SigD (SpecSig $2 t)
| t <- $4] }
| '{-# SPECIALISE' 'instance' inst_type '#-}'
checkDictTy :: LHsType RdrName -> P (LHsType RdrName)
checkDictTy (L spn ty) = check ty []
where
- check (HsTyVar t) args@(_:_) | not (isRdrTyVar t)
+ check (HsTyVar t) args | not (isRdrTyVar t)
= return (L spn (HsPredTy (L spn (HsClassP t args))))
check (HsAppTy l r) args = check (unLoc l) (r:args)
check (HsParTy t) args = check (unLoc t) args
import RdrHsSyn ( extractGenericPatTyVars )
import RnHsSyn
import RnExpr ( rnLExpr, checkTH )
-import RnTypes ( rnLHsType, rnHsSigType, rnHsTypeFVs, rnContext )
+import RnTypes ( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext )
import RnBinds ( rnTopBinds, rnBinds, rnMethodBinds,
rnBindsAndThen, renameSigs, checkSigs )
import RnEnv ( lookupTopBndrRn, lookupTopFixSigNames,
con_names = [ n | L _ (ConDecl n _ _ _) <- condecls ]
rn_derivs Nothing = returnM (Nothing, emptyFVs)
- rn_derivs (Just ds) = rnContext data_doc ds `thenM` \ ds' ->
- returnM (Just ds', extractHsCtxtTyNames ds')
+ rn_derivs (Just ds) = rnLHsTypes data_doc ds `thenM` \ ds' ->
+ returnM (Just ds', extractHsTyNames_s ds')
rnTyClDecl (TySynonym {tcdLName = name, tcdTyVars = tyvars, tcdSynRhs = ty})
= lookupLocatedTopBndrRn name `thenM` \ name' ->
\section[RnSource]{Main pass of renamer}
\begin{code}
-module RnTypes ( rnHsType, rnLHsType, rnContext,
+module RnTypes ( rnHsType, rnLHsType, rnLHsTypes, rnContext,
rnHsSigType, rnHsTypeFVs,
rnLPat, rnPat, rnPatsAndThen, -- Here because it's not part
rnLit, rnOverLit, -- of any mutual recursion
rnForAll doc exp [] (L _ []) (L _ ty) = rnHsType doc ty
-- One reason for this case is that a type like Int#
- -- starts of as (HsForAllTy Nothing [] Int), in case
+ -- starts off as (HsForAllTy Nothing [] Int), in case
-- there is some quantification. Now that we have quantified
-- and discovered there are no type variables, it's nicer to turn
-- it into plain Int. If it were Int# instead of Int, we'd actually
)
import TcGenDeriv -- Deriv stuff
import InstEnv ( simpleDFunClassTyCon, extendInstEnv )
-import TcHsType ( tcHsPred )
+import TcHsType ( tcHsDeriv )
import TcSimplify ( tcSimplifyDeriv )
import RnBinds ( rnMethodBinds, rnTopBinds )
isEnumerationTyCon, isRecursiveTyCon, TyCon
)
import TcType ( TcType, ThetaType, mkTyVarTys, mkTyConApp,
- getClassPredTys_maybe, tcTyConAppTyCon,
+ tcSplitForAllTys, tcSplitPredTy_maybe, getClassPredTys_maybe, tcTyConAppTyCon,
isUnLiftedType, mkClassPred, tyVarsOfTypes, isArgTypeKind,
tcEqTypes, tcSplitAppTys, mkAppTys, tcSplitDFunTy )
import Var ( TyVar, tyVarKind, idType, varName )
returnM (catMaybes maybe_ordinaries, catMaybes maybe_newtypes)
where
------------------------------------------------------------------
- derive_these :: [(NewOrData, Name, LHsPred Name)]
+ derive_these :: [(NewOrData, Name, LHsType Name)]
-- Find the (nd, TyCon, Pred) pairs that must be `derived'
derive_these = [ (nd, tycon, pred)
| L _ (TyData { tcdND = nd, tcdLName = L _ tycon,
- tcdDerivs = Just (L _ preds) }) <- tycl_decls,
+ tcdDerivs = Just preds }) <- tycl_decls,
pred <- preds ]
------------------------------------------------------------------
- mk_eqn :: (NewOrData, Name, LHsPred Name) -> TcM (Maybe DerivEqn, Maybe InstInfo)
+ mk_eqn :: (NewOrData, Name, LHsType Name) -> TcM (Maybe DerivEqn, Maybe InstInfo)
-- We swizzle the tyvars and datacons out of the tycon
-- to make the rest of the equation
+ --
+ -- The "deriv_ty" is a LHsType to take account of the fact that for newtype derivign
+ -- we allow deriving (forall a. C [a]).
- mk_eqn (new_or_data, tycon_name, pred)
+ mk_eqn (new_or_data, tycon_name, hs_deriv_ty)
= tcLookupTyCon tycon_name `thenM` \ tycon ->
addSrcSpan (srcLocSpan (getSrcLoc tycon)) $
addErrCtxt (derivCtxt Nothing tycon) $
tcExtendTyVarEnv (tyConTyVars tycon) $ -- Deriving preds may (now) mention
-- the type variables for the type constructor
- tcHsPred pred `thenM` \ pred' ->
- case getClassPredTys_maybe pred' of
- Nothing -> bale_out (malformedPredErr tycon pred)
- Just (clas, tys) -> doptM Opt_GlasgowExts `thenM` \ gla_exts ->
- mk_eqn_help gla_exts new_or_data tycon clas tys
+ tcHsDeriv hs_deriv_ty `thenM` \ (deriv_tvs, clas, tys) ->
+ doptM Opt_GlasgowExts `thenM` \ gla_exts ->
+ mk_eqn_help gla_exts new_or_data tycon deriv_tvs clas tys
------------------------------------------------------------------
- mk_eqn_help gla_exts DataType tycon clas tys
- | Just err <- checkSideConditions gla_exts clas tycon tys
+ mk_eqn_help gla_exts DataType tycon deriv_tvs clas tys
+ | Just err <- checkSideConditions gla_exts tycon deriv_tvs clas tys
= bale_out (derivingThingErr clas tys tycon (tyConTyVars tycon) err)
| otherwise
= do { eqn <- mkDataTypeEqn tycon clas
; returnM (Just eqn, Nothing) }
- mk_eqn_help gla_exts NewType tycon clas tys
+ mk_eqn_help gla_exts NewType tycon deriv_tvs clas tys
| can_derive_via_isomorphism && (gla_exts || std_class_via_iso clas)
= -- Go ahead and use the isomorphism
traceTc (text "newtype deriving:" <+> ppr tycon <+> ppr rep_tys) `thenM_`
returnM (Nothing, Just (InstInfo { iDFunId = mk_dfun dfun_name,
iBinds = NewTypeDerived rep_tys }))
| std_class gla_exts clas
- = mk_eqn_help gla_exts DataType tycon clas tys -- Go via bale-out route
+ = mk_eqn_help gla_exts DataType tycon deriv_tvs clas tys -- Go via bale-out route
| otherwise -- Non-standard instance
= bale_out (if gla_exts then
-- to get instance Monad (ST s) => Monad (T s)
-- Note [newtype representation]
- -- We must not use newTyConRep to get the representation
- -- type, because that looks through all intermediate newtypes
- -- To get the RHS of *this* newtype, just look at the data
- -- constructor. For example
+ -- Need newTyConRhs *not* newTyConRep to get the representation
+ -- type, because the latter looks through all intermediate newtypes
+ -- For example
-- newtype B = MkB Int
-- newtype A = MkA B deriving( Num )
-- We want the Num instance of B, *not* the Num instance of Int,
-- when making the Num instance of A!
- (tyvars, rep_ty) = newTyConRhs tycon
+ (tc_tvs, rep_ty) = newTyConRhs tycon
(rep_fn, rep_ty_args) = tcSplitAppTys rep_ty
n_tyvars_to_keep = tyConArity tycon - n_args_to_drop
- tyvars_to_drop = drop n_tyvars_to_keep tyvars
- tyvars_to_keep = take n_tyvars_to_keep tyvars
+ tyvars_to_drop = drop n_tyvars_to_keep tc_tvs
+ tyvars_to_keep = take n_tyvars_to_keep tc_tvs
n_args_to_keep = length rep_ty_args - n_args_to_drop
args_to_drop = drop n_args_to_keep rep_ty_args
-- If there are no tyvars, there's no need
-- to abstract over the dictionaries we need
- dict_args | null tyvars = []
- | otherwise = rep_pred : sc_theta
+ dict_tvs = deriv_tvs ++ tc_tvs
+ dict_args | null dict_tvs = []
+ | otherwise = rep_pred : sc_theta
-- Finally! Here's where we build the dictionary Id
- mk_dfun dfun_name = mkDictFunId dfun_name tyvars dict_args clas inst_tys
+ mk_dfun dfun_name = mkDictFunId dfun_name dict_tvs dict_args clas inst_tys
-------------------------------------------------------------------
-- Figuring out whether we can only do this newtype-deriving thing
-- Check side conditions that dis-allow derivability for particular classes
-- This is *apart* from the newtype-deriving mechanism
-checkSideConditions :: Bool -> Class -> TyCon -> [TcType] -> Maybe SDoc
-checkSideConditions gla_exts clas tycon tys
- | notNull tys
+checkSideConditions :: Bool -> TyCon -> [TyVar] -> Class -> [TcType] -> Maybe SDoc
+checkSideConditions gla_exts tycon deriv_tvs clas tys
+ | notNull deriv_tvs || notNull tys
= Just ty_args_why -- e.g. deriving( Foo s )
| otherwise
= case [cond | (key,cond) <- sideConditions, key == getUnique clas] of
where
pred = mkClassPred clas (tys ++ [mkTyConApp tycon (mkTyVarTys tyvars)])
-malformedPredErr tycon pred = ptext SLIT("Illegal deriving item") <+> ppr pred
-
derivCtxt :: Maybe Class -> TyCon -> SDoc
derivCtxt maybe_cls tycon
= ptext SLIT("When deriving") <+> cls <+> ptext SLIT("for type") <+> quotes (ppr tycon)
\begin{code}
module TcHsType (
- tcHsSigType, tcHsPred,
+ tcHsSigType, tcHsDeriv,
UserTypeCtxt(..),
-- Kind checking
import Id ( mkLocalId, idName, idType )
import Var ( TyVar, mkTyVar, tyVarKind )
import TyCon ( TyCon, tyConKind )
-import Class ( classTyCon )
+import Class ( Class, classTyCon )
import Name ( Name )
import NameSet
import PrelNames ( genUnitTyConName )
; checkValidType ctxt ty
; returnM ty }
--- tcHsPred is happy with a partial application, e.g. (ST s)
--- Used from TcDeriv
-tcHsPred pred
- = do { (kinded_pred,_) <- wrapLocFstM kc_pred pred -- kc_pred rather than kcHsPred
- -- to avoid the partial application check
- ; dsHsPred kinded_pred }
+-- Used for the deriving(...) items
+tcHsDeriv :: LHsType Name -> TcM ([TyVar], Class, [Type])
+tcHsDeriv = addLocM (tc_hs_deriv [])
+
+tc_hs_deriv tv_names (HsPredTy (L _ (HsClassP cls_name hs_tys)))
+ = kcHsTyVars tv_names $ \ tv_names' ->
+ do { cls_kind <- kcClass cls_name
+ ; (tys, res_kind) <- kcApps cls_kind (ppr cls_name) hs_tys
+ ; tcTyVarBndrs tv_names' $ \ tyvars ->
+ do { arg_tys <- dsHsTypes tys
+ ; cls <- tcLookupClass cls_name
+ ; return (tyvars, cls, arg_tys) }}
+
+tc_hs_deriv tv_names1 (HsForAllTy _ tv_names2 (L _ []) (L _ ty))
+ = -- Funny newtype deriving form
+ -- forall a. C [a]
+ -- where C has arity 2. Hence can't use regular functions
+ tc_hs_deriv (tv_names1 ++ tv_names2) ty
+
+tc_hs_deriv _ other
+ = failWithTc (ptext SLIT("Illegal deriving item") <+> ppr other)
\end{code}
These functions are used during knot-tying in
kc_hs_type (HsForAllTy exp tv_names context ty)
= kcHsTyVars tv_names $ \ tv_names' ->
kcHsContext context `thenM` \ ctxt' ->
- kcLiftedType ty `thenM` \ ty' ->
- -- The body of a forall must be a type, but in principle
+ kcHsType ty `thenM` \ (ty', kind) ->
+ -- The body of a forall is usually a type, but in principle
-- there's no reason to prohibit *unlifted* types.
-- In fact, GHC can itself construct a function with an
-- unboxed tuple inside a for-all (via CPR analyis; see
-- typecheck/should_compile/tc170)
--
- -- Still, that's only for internal interfaces, which aren't
- -- kind-checked, and it's a bit inconvenient to use kcTypeType
- -- here (because it doesn't return the result kind), so I'm
- -- leaving it as lifted types for now.
- returnM (HsForAllTy exp tv_names' ctxt' ty', liftedTypeKind)
+ -- Furthermore, in newtype deriving we allow
+ -- deriving( forall a. C [a] )
+ -- where C :: *->*->*, so it's awkward to prohibit higher-kinded
+ -- bodies. In any case, if there is a higher-kinded body
+ -- and we propagate that up, the caller will find any bugs.
+ returnM (HsForAllTy exp tv_names' ctxt' ty', kind)
---------------------------
kcApps :: TcKind -- Function kind
tcSplitPredTy_maybe :: Type -> Maybe PredType
-- Returns Just for predicates only
tcSplitPredTy_maybe (NoteTy _ ty) = tcSplitPredTy_maybe ty
-tcSplitPredTy_maybe (PredTy p) = Just p
+tcSplitPredTy_maybe (PredTy p) = Just p
tcSplitPredTy_maybe other = Nothing
predTyUnique :: PredType -> Unique
projects / ghc-hetmet.git / commitdiff