Commit 40888e1d authored by simonpj's avatar simonpj

[project @ 2004-04-02 16:46:57 by simonpj]

Extend the "newtype deriving" feature a little bit more
(at the request of Wolfgang Jeltsch)

Here's the example:
    class C a b
    instance C [a] Char
    newtype T = T Char deriving( C [a] )

Perfectly sensible, and no reason it should not work.
Fixing this required me to generalise the abstract syntax of
a 'deriving' item, hence the non-local effects.
parent f216dd01
......@@ -288,7 +288,7 @@ repBangTy (L _ (BangType str ty)) = do
-- 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 ;
......@@ -296,8 +296,8 @@ repDerivs (Just (L _ 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"
-------------------------------------------------------
......
......@@ -306,9 +306,13 @@ data TyClDecl name
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
......@@ -433,8 +437,7 @@ pp_tydecl pp_head pp_decl_rhs derivings
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
......
......@@ -123,7 +123,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _))
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 {})
......
......@@ -723,9 +723,9 @@ opt_asig :: { Maybe (LHsType RdrName) }
: {- 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) }
......@@ -785,6 +785,10 @@ atype :: { LHsType RdrName }
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 -} { [] }
......@@ -894,9 +898,10 @@ strict_mark :: { Located HsBang }
: '!' { 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
......@@ -953,7 +958,7 @@ sigdecl :: { Located (OrdList (LHsDecl RdrName)) }
{ 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 '#-}'
......
......@@ -636,7 +636,7 @@ checkPred (L spn ty)
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
......
......@@ -17,7 +17,7 @@ import RdrName ( RdrName, isRdrDataCon, rdrNameOcc, elemLocalRdrEnv )
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,
......@@ -506,8 +506,8 @@ rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = tycon,
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' ->
......
......@@ -4,7 +4,7 @@
\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
......@@ -174,7 +174,7 @@ rnForAll :: SDoc -> HsExplicitForAll -> [LHsTyVarBndr RdrName] -> LHsContext Rdr
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
......
......@@ -21,7 +21,7 @@ import TcEnv ( newDFunName, pprInstInfoDetails,
)
import TcGenDeriv -- Deriv stuff
import InstEnv ( simpleDFunClassTyCon, extendInstEnv )
import TcHsType ( tcHsPred )
import TcHsType ( tcHsDeriv )
import TcSimplify ( tcSimplifyDeriv )
import RnBinds ( rnMethodBinds, rnTopBinds )
......@@ -45,7 +45,7 @@ import TyCon ( tyConTyVars, tyConDataCons, tyConArity, tyConHasGenerics,
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 )
......@@ -313,39 +313,40 @@ makeDerivEqns tycl_decls
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_`
......@@ -353,7 +354,7 @@ makeDerivEqns tycl_decls
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
......@@ -390,20 +391,19 @@ makeDerivEqns tycl_decls
-- 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
......@@ -439,11 +439,12 @@ makeDerivEqns tycl_decls
-- 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
......@@ -563,9 +564,9 @@ mkDataTypeEqn tycon clas
-- 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
......@@ -921,8 +922,6 @@ derivingThingErr clas tys tycon tyvars why
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)
......
......@@ -5,7 +5,7 @@
\begin{code}
module TcHsType (
tcHsSigType, tcHsPred,
tcHsSigType, tcHsDeriv,
UserTypeCtxt(..),
-- Kind checking
......@@ -50,7 +50,7 @@ import Inst ( Inst, InstOrigin(..), newMethod, instToId )
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 )
......@@ -155,12 +155,27 @@ tcHsSigType ctxt hs_ty
; 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
......@@ -299,18 +314,19 @@ kc_hs_type (HsPredTy pred)
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
......
......@@ -508,7 +508,7 @@ allDistinctTyVars (ty:tys) acc
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
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment