From 3ad8f84f6a75f240383e62a14472d14eb372dcd1 Mon Sep 17 00:00:00 2001 From: "bjorn@bringert.net" Date: Mon, 18 Sep 2006 23:08:54 +0000 Subject: [PATCH] New syntax for stand-alone deriving. Implemented fully. --- compiler/hsSyn/HsDecls.lhs | 6 +++--- compiler/parser/Lexer.x | 3 +++ compiler/parser/Parser.y.pp | 11 +++++++++++ compiler/rename/RnSource.lhs | 10 +++++----- compiler/typecheck/TcDeriv.lhs | 29 +++++++++++++++++++++-------- compiler/typecheck/TcInstDcls.lhs | 16 +++++++--------- compiler/typecheck/TcRnDriver.lhs | 7 +++++-- 7 files changed, 55 insertions(+), 27 deletions(-) diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs index f6beb23..9543cad 100644 --- a/compiler/hsSyn/HsDecls.lhs +++ b/compiler/hsSyn/HsDecls.lhs @@ -731,11 +731,11 @@ instDeclATs (InstDecl _ _ _ ats) = ats 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} %************************************************************************ diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index f9e74a8..15745d5 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -345,6 +345,7 @@ data Token | ITderiving | ITdo | ITelse + | ITfor | IThiding | ITif | ITimport @@ -488,6 +489,7 @@ isSpecial :: Token -> Bool -- not as a keyword. isSpecial ITas = True isSpecial IThiding = True +isSpecial ITfor = True isSpecial ITqualified = True isSpecial ITforall = True isSpecial ITexport = True @@ -521,6 +523,7 @@ reservedWordsFM = listToUFM $ ( "deriving", ITderiving, 0 ), ( "do", ITdo, 0 ), ( "else", ITelse, 0 ), + ( "for", ITfor, 0 ), ( "hiding", IThiding, 0 ), ( "if", ITif, 0 ), ( "import", ITimport, 0 ), diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index c0c783f..a72b47b 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -159,6 +159,7 @@ incorrect. 'deriving' { L _ ITderiving } 'do' { L _ ITdo } 'else' { L _ ITelse } + 'for' { L _ ITfor } 'hiding' { L _ IThiding } 'if' { L _ ITif } 'import' { L _ ITimport } @@ -662,6 +663,16 @@ tycl_hdr :: { Located (LHsContext RdrName, | 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 diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 6445b91..9a3e805 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -377,11 +377,11 @@ extendTyVarEnvForMethodBinds tyvars thing_inside \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} %********************************************************* diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index bacc25c..11ff672 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -18,7 +18,7 @@ import TcRnMonad 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 ) @@ -41,7 +41,7 @@ import Name ( Name, getSrcLoc ) 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, @@ -50,7 +50,7 @@ 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 @@ -206,15 +206,17 @@ And then translate it to: \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) $ @@ -337,12 +339,15 @@ when the dict is constructed in TcInstDcls.tcInstDecl2 \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)] @@ -352,7 +357,15 @@ makeDerivEqns overlap_flag tycl_decls 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 diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 880a0ee..3236b67 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -146,12 +146,13 @@ Gather up the instance declarations from their various sources 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 @@ -178,14 +179,11 @@ tcInstDecls1 tycl_decls inst_decls -- (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 diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index c1db86a..fefb21a 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -473,7 +473,8 @@ tcRnHsBootDecls decls -- 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 @@ -629,6 +630,7 @@ tcTopSrcDecls :: ModDetails -> HsGroup Name -> TcM (TcGblEnv, TcLclEnv) 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, @@ -649,7 +651,8 @@ tcTopSrcDecls boot_details -- 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 -- 1.7.10.4