type LDerivDecl name = Located (DerivDecl name)
data DerivDecl name
- = DerivDecl (Located name) (LHsType name)
+ = DerivDecl (LHsType name) (Located name)
instance (OutputableBndr name) => Outputable (DerivDecl name) where
- ppr (DerivDecl cls ty)
- = hsep [ptext SLIT("deriving"), ppr cls, ppr ty]
+ ppr (DerivDecl ty n)
+ = hsep [ptext SLIT("deriving"), ppr ty, ptext SLIT("for"), ppr n]
\end{code}
%************************************************************************
| ITderiving
| ITdo
| ITelse
+ | ITfor
| IThiding
| ITif
| ITimport
-- not as a keyword.
isSpecial ITas = True
isSpecial IThiding = True
+isSpecial ITfor = True
isSpecial ITqualified = True
isSpecial ITforall = True
isSpecial ITexport = True
( "deriving", ITderiving, 0 ),
( "do", ITdo, 0 ),
( "else", ITelse, 0 ),
+ ( "for", ITfor, 0 ),
( "hiding", IThiding, 0 ),
( "if", ITif, 0 ),
( "import", ITimport, 0 ),
'deriving' { L _ ITderiving }
'do' { L _ ITdo }
'else' { L _ ITelse }
+ 'for' { L _ ITfor }
'hiding' { L _ IThiding }
'if' { L _ ITif }
'import' { L _ ITimport }
| type {% checkTyClHdr (noLoc []) $1 >>= return.L1 }
-----------------------------------------------------------------------------
+-- Stand-alone deriving
+
+-- Glasgow extension: stand-alone deriving declarations
+stand_alone_deriving :: { LDerivDecl RdrName }
+ : 'deriving' qtycon 'for' qtycon {% do { p <- checkInstType (fmap HsTyVar $2)
+ ; checkDerivDecl (LL (DerivDecl p $4)) } }
+
+ | 'deriving' '(' inst_type ')' 'for' qtycon {% checkDerivDecl (LL (DerivDecl $3 $6)) }
+
+-----------------------------------------------------------------------------
-- Nested declarations
-- Type declaration or value declaration
\begin{code}
rnSrcDerivDecl :: DerivDecl RdrName -> RnM (DerivDecl Name, FreeVars)
-rnSrcDerivDecl (DerivDecl cls ty)
- = do cls' <- lookupLocatedOccRn cls
- ty' <- rnLHsType (text "a deriving decl") ty
- let fvs = extractHsTyNames ty'
- return (DerivDecl cls' ty', fvs)
+rnSrcDerivDecl (DerivDecl ty n)
+ = do ty' <- rnLHsType (text "a deriving decl") ty
+ n' <- lookupLocatedOccRn n
+ let fvs = extractHsTyNames ty' `addOneFV` unLoc n'
+ return (DerivDecl ty' n', fvs)
\end{code}
%*********************************************************
import TcMType ( checkValidInstance )
import TcEnv ( newDFunName, pprInstInfoDetails,
InstInfo(..), InstBindings(..), simpleInstInfoClsTy,
- tcLookupClass, tcLookupTyCon, tcExtendTyVarEnv
+ tcLookupClass, tcLookupTyCon, tcLookupLocatedTyCon, tcExtendTyVarEnv
)
import TcGenDeriv -- Deriv stuff
import InstEnv ( Instance, OverlapFlag, mkLocalInstance, instanceHead, extendInstEnvList )
import NameSet ( duDefs )
import Type ( splitKindFunTys )
import TyCon ( tyConTyVars, tyConDataCons, tyConArity, tyConHasGenerics,
- tyConStupidTheta, isProductTyCon, isDataTyCon, newTyConRhs,
+ tyConStupidTheta, isProductTyCon, isDataTyCon, isNewTyCon, newTyConRhs,
isEnumerationTyCon, isRecursiveTyCon, TyCon
)
import TcType ( TcType, ThetaType, mkTyVarTys, mkTyConApp, tcTyConAppTyCon,
import Var ( TyVar, tyVarKind, varName )
import VarSet ( mkVarSet, disjointVarSet )
import PrelNames
-import SrcLoc ( srcLocSpan, Located(..) )
+import SrcLoc ( srcLocSpan, Located(..), unLoc )
import Util ( zipWithEqual, sortLe, notNull )
import ListSetOps ( removeDups, assocMaybe )
import Outputable
\begin{code}
tcDeriving :: [LTyClDecl Name] -- All type constructors
+ -> [LDerivDecl Name] -- All stand-alone deriving declarations
-> TcM ([InstInfo], -- The generated "instance decls"
HsValBinds Name) -- Extra generated top-level bindings
-tcDeriving tycl_decls
+tcDeriving tycl_decls deriv_decls
= recoverM (returnM ([], emptyValBindsOut)) $
do { -- Fish the "deriving"-related information out of the TcEnv
-- and make the necessary "equations".
overlap_flag <- getOverlapFlag
- ; (ordinary_eqns, newtype_inst_info) <- makeDerivEqns overlap_flag tycl_decls
+ ; (ordinary_eqns, newtype_inst_info)
+ <- makeDerivEqns overlap_flag tycl_decls deriv_decls
; (ordinary_inst_info, deriv_binds)
<- extendLocalInstEnv (map iSpec newtype_inst_info) $
\begin{code}
makeDerivEqns :: OverlapFlag
-> [LTyClDecl Name]
+ -> [LDerivDecl Name]
-> TcM ([DerivEqn], -- Ordinary derivings
[InstInfo]) -- Special newtype derivings
-makeDerivEqns overlap_flag tycl_decls
- = mapAndUnzipM mk_eqn derive_these `thenM` \ (maybe_ordinaries, maybe_newtypes) ->
- returnM (catMaybes maybe_ordinaries, catMaybes maybe_newtypes)
+makeDerivEqns overlap_flag tycl_decls deriv_decls
+ = do derive_these_top_level <- mapM top_level_deriv deriv_decls >>= return . catMaybes
+ (maybe_ordinaries, maybe_newtypes)
+ <- mapAndUnzipM mk_eqn (derive_these ++ derive_these_top_level)
+ return (catMaybes maybe_ordinaries, catMaybes maybe_newtypes)
where
------------------------------------------------------------------
derive_these :: [(NewOrData, Name, LHsType Name)]
tcdDerivs = Just preds }) <- tycl_decls,
pred <- preds ]
+ top_level_deriv :: LDerivDecl Name -> TcM (Maybe (NewOrData, Name, LHsType Name))
+ top_level_deriv d@(L l (DerivDecl inst ty_name)) = recoverM (returnM Nothing) $ setSrcSpan l $
+ do tycon <- tcLookupLocatedTyCon ty_name
+ let new_or_data = if isNewTyCon tycon then NewType else DataType
+ traceTc (text "Stand-alone deriving:" <+> ppr (new_or_data, unLoc ty_name, inst))
+ return $ Just (new_or_data, unLoc ty_name, inst)
+
------------------------------------------------------------------
+ -- takes (whether newtype or data, name of data type, partially applied type class)
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
tcInstDecls1 -- Deal with both source-code and imported instance decls
:: [LTyClDecl Name] -- For deriving stuff
-> [LInstDecl Name] -- Source code instance decls
+ -> [LDerivDecl Name] -- Source code stand-alone deriving decls
-> TcM (TcGblEnv, -- The full inst env
[InstInfo], -- Source-code instance decls to process;
-- contains all dfuns for this module
HsValBinds Name) -- Supporting bindings for derived instances
-tcInstDecls1 tycl_decls inst_decls
+tcInstDecls1 tycl_decls inst_decls deriv_decls
= checkNoErrs $
do { -- Stop if addInstInfos etc discovers any errors
-- (they recover, so that we get more than one error each
-- (3) Instances from generic class declarations
; generic_inst_info <- getGenericInstances clas_decls
- -- Next, construct the instance environment so far, consisting
- -- of
- -- a) local instance decls
- -- b) generic instances
- -- c) local family instance decls
- ; addInsts local_info $ do {
- ; addInsts generic_inst_info $ do {
- ; addFamInsts at_idx_tycon $ do {
+ -- (3) Compute instances from "deriving" clauses;
+ -- This stuff computes a context for the derived instance decl, so it
+ -- needs to know about all the instances possible; hence inst_env4
+ tcDeriving tycl_decls `thenM` \ (deriv_inst_info, deriv_binds) ->
+ addInsts deriv_inst_info $
-- (4) Compute instances from "deriving" clauses;
-- This stuff computes a context for the derived instance
-- Typecheck instance decls
; traceTc (text "Tc3")
- ; (tcg_env, inst_infos, _binds) <- tcInstDecls1 tycl_decls (hs_instds rn_group)
+ ; (tcg_env, inst_infos, _binds)
+ <- tcInstDecls1 tycl_decls (hs_instds rn_group) (hs_derivds rn_group)
; setGblEnv tcg_env $ do {
-- Typecheck value declarations
tcTopSrcDecls boot_details
(HsGroup { hs_tyclds = tycl_decls,
hs_instds = inst_decls,
+ hs_derivds = deriv_decls,
hs_fords = foreign_decls,
hs_defds = default_decls,
hs_ruleds = rule_decls,
-- Source-language instances, including derivings,
-- and import the supporting declarations
traceTc (text "Tc3") ;
- (tcg_env, inst_infos, deriv_binds) <- tcInstDecls1 tycl_decls inst_decls ;
+ (tcg_env, inst_infos, deriv_binds)
+ <- tcInstDecls1 tycl_decls inst_decls deriv_decls;
setGblEnv tcg_env $ do {
-- Foreign import declarations next. No zonking necessary
projects / ghc-hetmet.git / commitdiff