From 914e7d90e2afe1f72b72fb41d293fb56bd35edb5 Mon Sep 17 00:00:00 2001 From: Ian Lynagh Date: Fri, 10 Aug 2007 22:37:28 +0000 Subject: [PATCH] Change standalone deriving syntax and semantics; fixes trac #1481 You now say deriving instance Cxt => Head --- compiler/parser/Lexer.x | 3 -- compiler/parser/Parser.y.pp | 4 +-- compiler/typecheck/TcDeriv.lhs | 64 +++++++++++++++++++++++++++------------- 3 files changed, 44 insertions(+), 27 deletions(-) diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 96f1ad2..8ae3cd9 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -405,7 +405,6 @@ data Token | ITdata | ITdefault | ITderiving - | ITderive | ITdo | ITelse | IThiding @@ -559,7 +558,6 @@ isSpecial :: Token -> Bool -- not as a keyword. isSpecial ITas = True isSpecial IThiding = True -isSpecial ITderive = True isSpecial ITqualified = True isSpecial ITforall = True isSpecial ITexport = True @@ -590,7 +588,6 @@ reservedWordsFM = listToUFM $ ( "data", ITdata, 0 ), ( "default", ITdefault, 0 ), ( "deriving", ITderiving, 0 ), - ( "derive", ITderive, 0 ), ( "do", ITdo, 0 ), ( "else", ITelse, 0 ), ( "hiding", IThiding, 0 ), diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index adabb75..4567e07 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -200,7 +200,6 @@ incorrect. 'data' { L _ ITdata } 'default' { L _ ITdefault } 'deriving' { L _ ITderiving } - 'derive' { L _ ITderive } 'do' { L _ ITdo } 'else' { L _ ITelse } 'hiding' { L _ IThiding } @@ -754,7 +753,7 @@ tycl_hdr :: { Located (LHsContext RdrName, -- Glasgow extension: stand-alone deriving declarations stand_alone_deriving :: { LDerivDecl RdrName } - : 'derive' 'instance' inst_type {% checkDerivDecl (LL (DerivDecl $3)) } + : 'deriving' 'instance' inst_type {% checkDerivDecl (LL (DerivDecl $3)) } ----------------------------------------------------------------------------- -- Nested declarations @@ -1756,7 +1755,6 @@ special_id : 'as' { L1 FSLIT("as") } | 'qualified' { L1 FSLIT("qualified") } | 'hiding' { L1 FSLIT("hiding") } - | 'derive' { L1 FSLIT("derive") } | 'export' { L1 FSLIT("export") } | 'label' { L1 FSLIT("label") } | 'dynamic' { L1 FSLIT("dynamic") } diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index 0acf31c..c9b3967 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -363,17 +363,27 @@ makeDerivEqns tycl_decls inst_decls deriv_decls ------------------------------------------------------------------ deriveStandalone :: LDerivDecl Name -> TcM (Maybe DerivEqn, Maybe InstInfo) -- Standalone deriving declarations --- e.g. derive instance Show T +-- e.g. deriving instance show a => Show (T a) -- Rather like tcLocalInstDecl deriveStandalone (L loc (DerivDecl deriv_ty)) = setSrcSpan loc $ addErrCtxt (standaloneCtxt deriv_ty) $ - do { (tvs, theta, tau) <- tcHsInstHead deriv_ty - ; (cls, inst_tys) <- checkValidInstHead tau - ; let cls_tys = take (length inst_tys - 1) inst_tys - inst_ty = last inst_tys - - ; mkEqnHelp StandAloneDerivOrigin tvs cls cls_tys inst_ty } + do { traceTc (text "standalone deriving decl for" <+> ppr deriv_ty) + ; (tvs, theta, tau) <- tcHsInstHead deriv_ty + ; traceTc (text "standalone deriving;" + <+> text "tvs:" <+> ppr tvs + <+> text "theta:" <+> ppr theta + <+> text "tau:" <+> ppr tau) + ; (cls, inst_tys) <- checkValidInstHead tau + ; let cls_tys = take (length inst_tys - 1) inst_tys + inst_ty = last inst_tys + + ; traceTc (text "standalone deriving;" + <+> text "class:" <+> ppr cls + <+> text "class types:" <+> ppr cls_tys + <+> text "type:" <+> ppr inst_ty) + ; mkEqnHelp StandAloneDerivOrigin tvs cls cls_tys inst_ty + (Just theta) } ------------------------------------------------------------------ deriveTyData :: (LHsType Name, LTyClDecl Name) -> TcM (Maybe DerivEqn, Maybe InstInfo) @@ -392,12 +402,15 @@ deriveTyData (deriv_pred, L loc decl@(TyData { tcdLName = L _ tycon_name, do { (deriv_tvs, cls, cls_tys) <- tcHsDeriv deriv_pred -- The "deriv_pred" is a LHsType to take account of the fact that for -- newtype deriving we allow deriving (forall a. C [a]). - ; mkEqnHelp DerivOrigin (tvs++deriv_tvs) cls cls_tys tc_app } } + ; mkEqnHelp DerivOrigin (tvs++deriv_tvs) cls cls_tys tc_app Nothing } } deriveTyData (deriv_pred, other_decl) = panic "derivTyData" -- Caller ensures that only TyData can happen ------------------------------------------------------------------ -mkEqnHelp orig tvs cls cls_tys tc_app +mkEqnHelp :: InstOrigin -> [TyVar] -> Class -> [Type] -> Type + -> Maybe DerivRhs + -> TcRn (Maybe DerivEqn, Maybe InstInfo) +mkEqnHelp orig tvs cls cls_tys tc_app mtheta | Just (tycon, tc_args) <- tcSplitTyConApp_maybe tc_app = do { -- Make tc_app saturated, because that's what the -- mkDataTypeEqn things expect @@ -417,11 +430,11 @@ mkEqnHelp orig tvs cls cls_tys tc_app -- to check the instance tycon, not the family tycon ; if isDataTyCon rep_tc then mkDataTypeEqn orig mayDeriveDataTypeable full_tvs cls cls_tys - tycon full_tc_args rep_tc rep_tc_args + tycon full_tc_args rep_tc rep_tc_args mtheta else mkNewTypeEqn orig mayDeriveDataTypeable newtype_deriving overlap_flag full_tvs cls cls_tys - tycon full_tc_args rep_tc rep_tc_args } + tycon full_tc_args rep_tc rep_tc_args mtheta } | otherwise = baleOut (derivingThingErr cls cls_tys tc_app (ptext SLIT("Last argument of the instance must be a type application"))) @@ -458,8 +471,11 @@ tcLookupFamInstExact tycon tys %************************************************************************ \begin{code} +mkDataTypeEqn :: InstOrigin -> Bool -> [Var] -> Class -> [Type] + -> TyCon -> [Type] -> TyCon -> [Type] -> Maybe DerivRhs + -> TcRn (Maybe DerivEqn, Maybe InstInfo) mkDataTypeEqn orig mayDeriveDataTypeable tvs cls cls_tys - tycon tc_args rep_tc rep_tc_args + tycon tc_args rep_tc rep_tc_args mtheta | Just err <- checkSideConditions mayDeriveDataTypeable cls cls_tys rep_tc -- NB: pass the *representation* tycon to checkSideConditions = baleOut (derivingThingErr cls cls_tys (mkTyConApp tycon tc_args) err) @@ -467,12 +483,14 @@ mkDataTypeEqn orig mayDeriveDataTypeable tvs cls cls_tys | otherwise = ASSERT( null cls_tys ) do { loc <- getSrcSpanM - ; eqn <- mk_data_eqn loc orig tvs cls tycon tc_args rep_tc rep_tc_args + ; eqn <- mk_data_eqn loc orig tvs cls tycon tc_args rep_tc + rep_tc_args mtheta ; return (Just eqn, Nothing) } mk_data_eqn :: SrcSpan -> InstOrigin -> [TyVar] -> Class - -> TyCon -> [TcType] -> TyCon -> [TcType] -> TcM DerivEqn -mk_data_eqn loc orig tvs cls tycon tc_args rep_tc rep_tc_args + -> TyCon -> [TcType] -> TyCon -> [TcType] -> Maybe DerivRhs + -> TcM DerivEqn +mk_data_eqn loc orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta | cls `hasKey` typeableClassKey = -- The Typeable class is special in several ways -- data T a b = ... deriving( Typeable ) @@ -485,7 +503,9 @@ mk_data_eqn loc orig tvs cls tycon tc_args rep_tc rep_tc_args -- Typeable; it depends on the arity of the type do { real_clas <- tcLookupClass (typeableClassNames !! tyConArity tycon) ; dfun_name <- new_dfun_name real_clas tycon - ; return (loc, orig, dfun_name, [], real_clas, mkTyConApp tycon [], []) } + ; let theta = fromMaybe [] mtheta + ; return (loc, orig, dfun_name, [], real_clas, mkTyConApp tycon [], theta) + } | otherwise = do { dfun_name <- new_dfun_name cls tycon @@ -495,13 +515,14 @@ mk_data_eqn loc orig tvs cls tycon tc_args rep_tc rep_tc_args arg_ty <- ASSERT( isVanillaDataCon data_con ) dataConInstOrigArgTys data_con rep_tc_args, not (isUnLiftedType arg_ty) ] -- No constraints for unlifted types? + theta = fromMaybe ordinary_constraints mtheta tiresome_subst = zipTopTvSubst (tyConTyVars rep_tc) rep_tc_args stupid_constraints = substTheta tiresome_subst (tyConStupidTheta rep_tc) -- see note [Data decl contexts] above ; return (loc, orig, dfun_name, tvs, cls, mkTyConApp tycon tc_args, - stupid_constraints ++ ordinary_constraints) + stupid_constraints ++ theta) } ------------------------------------------------------------------ @@ -634,10 +655,10 @@ new_dfun_name clas tycon -- Just a simple wrapper \begin{code} mkNewTypeEqn :: InstOrigin -> Bool -> Bool -> OverlapFlag -> [Var] -> Class -> [Type] -> TyCon -> [Type] -> TyCon -> [Type] + -> Maybe DerivRhs -> TcRn (Maybe DerivEqn, Maybe InstInfo) -mkNewTypeEqn orig mayDeriveDataTypeable newtype_deriving overlap_flag tvs cls cls_tys - tycon tc_args - rep_tycon rep_tc_args +mkNewTypeEqn orig mayDeriveDataTypeable newtype_deriving overlap_flag tvs + cls cls_tys tycon tc_args rep_tycon rep_tc_args mtheta | can_derive_via_isomorphism && (newtype_deriving || std_class_via_iso cls) = do { traceTc (text "newtype deriving:" <+> ppr tycon <+> ppr rep_tys) ; -- Go ahead and use the isomorphism @@ -647,7 +668,8 @@ mkNewTypeEqn orig mayDeriveDataTypeable newtype_deriving overlap_flag tvs cls cl | isNothing mb_std_err -- Use the standard H98 method = do { loc <- getSrcSpanM - ; eqn <- mk_data_eqn loc orig tvs cls tycon tc_args rep_tycon rep_tc_args + ; eqn <- mk_data_eqn loc orig tvs cls tycon tc_args rep_tycon + rep_tc_args mtheta ; return (Just eqn, Nothing) } -- Otherwise we can't derive -- 1.7.10.4