diff options
| author | Ryan Scott <ryan.gl.scott@gmail.com> | 2018-06-04 21:20:02 -0400 |
|---|---|---|
| committer | Ben Gamari <ben@smart-cactus.org> | 2018-06-04 22:37:19 -0400 |
| commit | 8ed8b037fee9611b1c4ef49adb6cf50bbd929a27 (patch) | |
| tree | ff3907f0412085a78e694597c1bdba700740403f | |
| parent | 85309a3cda367425cca727dfa45e5e6c63b47391 (diff) | |
| download | haskell-8ed8b037fee9611b1c4ef49adb6cf50bbd929a27.tar.gz | |
Introduce DerivingVia
This implements the `DerivingVia` proposal put forth in
https://github.com/ghc-proposals/ghc-proposals/pull/120.
This introduces the `DerivingVia` deriving strategy. This is a
generalization of `GeneralizedNewtypeDeriving` that permits the user
to specify the type to `coerce` from.
The major change in this patch is the introduction of the
`ViaStrategy` constructor to `DerivStrategy`, which takes a type
as a field. As a result, `DerivStrategy` is no longer a simple
enumeration type, but rather something that must be renamed and
typechecked. The process by which this is done is explained more
thoroughly in section 3 of this paper
( https://www.kosmikus.org/DerivingVia/deriving-via-paper.pdf ),
although I have inlined the relevant parts into Notes where possible.
There are some knock-on changes as well. I took the opportunity to
do some refactoring of code in `TcDeriv`, especially the
`mkNewTypeEqn` function, since it was bundling all of the logic for
(1) deriving instances for newtypes and
(2) `GeneralizedNewtypeDeriving`
into one huge broth. `DerivingVia` reuses much of part (2), so that
was factored out as much as possible.
Bumps the Haddock submodule.
Test Plan: ./validate
Reviewers: simonpj, bgamari, goldfire, alanz
Subscribers: alanz, goldfire, rwbarton, thomie, mpickering, carter
GHC Trac Issues: #15178
Differential Revision: https://phabricator.haskell.org/D4684
38 files changed, 1608 insertions, 381 deletions
diff --git a/compiler/basicTypes/BasicTypes.hs b/compiler/basicTypes/BasicTypes.hs index 6dfa37e52c..93010b75f9 100644 --- a/compiler/basicTypes/BasicTypes.hs +++ b/compiler/basicTypes/BasicTypes.hs @@ -45,8 +45,6 @@ module BasicTypes( TopLevelFlag(..), isTopLevel, isNotTopLevel, - DerivStrategy(..), - OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe, hasOverlappingFlag, hasOverlappableFlag, hasIncoherentFlag, @@ -545,31 +543,6 @@ instance Outputable Origin where {- ************************************************************************ * * - Deriving strategies -* * -************************************************************************ --} - --- | Which technique the user explicitly requested when deriving an instance. -data DerivStrategy - -- See Note [Deriving strategies] in TcDeriv - = StockStrategy -- ^ GHC's \"standard\" strategy, which is to implement a - -- custom instance for the data type. This only works - -- for certain types that GHC knows about (e.g., 'Eq', - -- 'Show', 'Functor' when @-XDeriveFunctor@ is enabled, - -- etc.) - | AnyclassStrategy -- ^ @-XDeriveAnyClass@ - | NewtypeStrategy -- ^ @-XGeneralizedNewtypeDeriving@ - deriving (Eq, Data) - -instance Outputable DerivStrategy where - ppr StockStrategy = text "stock" - ppr AnyclassStrategy = text "anyclass" - ppr NewtypeStrategy = text "newtype" - -{- -************************************************************************ -* * Instance overlap flag * * ************************************************************************ diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index cc1bd3d799..8ec181c430 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -2131,19 +2131,34 @@ repInst :: Core (Maybe TH.Overlap) -> repInst (MkC o) (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceWithOverlapDName [o, cxt, ty, ds] -repDerivStrategy :: Maybe (Located DerivStrategy) - -> DsM (Core (Maybe TH.DerivStrategy)) +repDerivStrategy :: Maybe (LDerivStrategy GhcRn) + -> DsM (Core (Maybe TH.DerivStrategyQ)) repDerivStrategy mds = case mds of Nothing -> nothing Just (L _ ds) -> case ds of - StockStrategy -> just =<< dataCon stockStrategyDataConName - AnyclassStrategy -> just =<< dataCon anyclassStrategyDataConName - NewtypeStrategy -> just =<< dataCon newtypeStrategyDataConName + StockStrategy -> just =<< repStockStrategy + AnyclassStrategy -> just =<< repAnyclassStrategy + NewtypeStrategy -> just =<< repNewtypeStrategy + ViaStrategy ty -> do ty' <- repLTy (hsSigType ty) + via_strat <- repViaStrategy ty' + just via_strat where - nothing = coreNothing derivStrategyTyConName - just = coreJust derivStrategyTyConName + nothing = coreNothing derivStrategyQTyConName + just = coreJust derivStrategyQTyConName + +repStockStrategy :: DsM (Core TH.DerivStrategyQ) +repStockStrategy = rep2 stockStrategyName [] + +repAnyclassStrategy :: DsM (Core TH.DerivStrategyQ) +repAnyclassStrategy = rep2 anyclassStrategyName [] + +repNewtypeStrategy :: DsM (Core TH.DerivStrategyQ) +repNewtypeStrategy = rep2 newtypeStrategyName [] + +repViaStrategy :: Core TH.TypeQ -> DsM (Core TH.DerivStrategyQ) +repViaStrategy (MkC t) = rep2 viaStrategyName [t] repOverlap :: Maybe OverlapMode -> DsM (Core (Maybe TH.Overlap)) repOverlap mb = @@ -2167,7 +2182,7 @@ repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndrQ] repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds) = rep2 classDName [cxt, cls, tvs, fds, ds] -repDeriv :: Core (Maybe TH.DerivStrategy) +repDeriv :: Core (Maybe TH.DerivStrategyQ) -> Core TH.CxtQ -> Core TH.TypeQ -> DsM (Core TH.DecQ) repDeriv (MkC ds) (MkC cxt) (MkC ty) diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs index 9063d1f773..71cf5a6c34 100644 --- a/compiler/hsSyn/Convert.hs +++ b/compiler/hsSyn/Convert.hs @@ -359,11 +359,12 @@ cvtDec (TH.RoleAnnotD tc roles) cvtDec (TH.StandaloneDerivD ds cxt ty) = do { cxt' <- cvtContext cxt + ; ds' <- traverse cvtDerivStrategy ds ; L loc ty' <- cvtType ty ; let inst_ty' = mkHsQualTy cxt loc cxt' $ L loc ty' ; returnJustL $ DerivD noExt $ DerivDecl { deriv_ext =noExt - , deriv_strategy = fmap (L loc . cvtDerivStrategy) ds + , deriv_strategy = ds' , deriv_type = mkLHsSigWcType inst_ty' , deriv_overlap_mode = Nothing } } @@ -1229,14 +1230,17 @@ cvtPred = cvtType cvtDerivClause :: TH.DerivClause -> CvtM (LHsDerivingClause GhcPs) cvtDerivClause (TH.DerivClause ds ctxt) - = do { ctxt'@(L loc _) <- fmap (map mkLHsSigType) <$> cvtContext ctxt - ; let ds' = fmap (L loc . cvtDerivStrategy) ds + = do { ctxt' <- fmap (map mkLHsSigType) <$> cvtContext ctxt + ; ds' <- traverse cvtDerivStrategy ds ; returnL $ HsDerivingClause noExt ds' ctxt' } -cvtDerivStrategy :: TH.DerivStrategy -> Hs.DerivStrategy -cvtDerivStrategy TH.StockStrategy = Hs.StockStrategy -cvtDerivStrategy TH.AnyclassStrategy = Hs.AnyclassStrategy -cvtDerivStrategy TH.NewtypeStrategy = Hs.NewtypeStrategy +cvtDerivStrategy :: TH.DerivStrategy -> CvtM (Hs.LDerivStrategy GhcPs) +cvtDerivStrategy TH.StockStrategy = returnL Hs.StockStrategy +cvtDerivStrategy TH.AnyclassStrategy = returnL Hs.AnyclassStrategy +cvtDerivStrategy TH.NewtypeStrategy = returnL Hs.NewtypeStrategy +cvtDerivStrategy (TH.ViaStrategy ty) = do + ty' <- cvtType ty + returnL $ Hs.ViaStrategy (mkLHsSigType ty') cvtType :: TH.Type -> CvtM (LHsType GhcPs) cvtType = cvtTypeKind "type" diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs index d389f61e86..076c590f0b 100644 --- a/compiler/hsSyn/HsDecls.hs +++ b/compiler/hsSyn/HsDecls.hs @@ -45,6 +45,8 @@ module HsDecls ( -- ** Standalone deriving declarations DerivDecl(..), LDerivDecl, + -- ** Deriving strategies + DerivStrategy(..), LDerivStrategy, derivStrategyName, -- ** @RULE@ declarations LRuleDecls,RuleDecls(..),RuleDecl(..), LRuleDecl, HsRuleRn(..), RuleBndr(..),LRuleBndr, @@ -103,6 +105,7 @@ import Class import Outputable import Util import SrcLoc +import Type import Bag import Maybes @@ -1143,7 +1146,7 @@ data HsDerivingClause pass -- See Note [Deriving strategies] in TcDeriv = HsDerivingClause { deriv_clause_ext :: XCHsDerivingClause pass - , deriv_clause_strategy :: Maybe (Located DerivStrategy) + , deriv_clause_strategy :: Maybe (LDerivStrategy pass) -- ^ The user-specified strategy (if any) to use when deriving -- 'deriv_clause_tys'. , deriv_clause_tys :: Located [LHsSigType pass] @@ -1166,8 +1169,9 @@ instance (p ~ GhcPass pass, OutputableBndrId p) ppr (HsDerivingClause { deriv_clause_strategy = dcs , deriv_clause_tys = L _ dct }) = hsep [ text "deriving" - , ppDerivStrategy dcs - , pp_dct dct ] + , pp_strat_before + , pp_dct dct + , pp_strat_after ] where -- This complexity is to distinguish between -- deriving Show @@ -1175,6 +1179,13 @@ instance (p ~ GhcPass pass, OutputableBndrId p) pp_dct [HsIB { hsib_body = ty }] = ppr (parenthesizeHsType appPrec ty) pp_dct _ = parens (interpp'SP dct) + + -- @via@ is unique in that in comes /after/ the class being derived, + -- so we must special-case it. + (pp_strat_before, pp_strat_after) = + case dcs of + Just (L _ via@ViaStrategy{}) -> (empty, ppr via) + _ -> (ppDerivStrategy dcs, empty) ppr (XHsDerivingClause x) = ppr x data NewOrData @@ -1717,7 +1728,8 @@ instance (p ~ GhcPass pass, OutputableBndrId p) <+> ppr inst_ty ppr (XClsInstDecl x) = ppr x -ppDerivStrategy :: Maybe (Located DerivStrategy) -> SDoc +ppDerivStrategy :: (p ~ GhcPass pass, OutputableBndrId p) + => Maybe (LDerivStrategy p) -> SDoc ppDerivStrategy mb = case mb of Nothing -> empty @@ -1782,7 +1794,7 @@ data DerivDecl pass = DerivDecl -- See Note [Inferring the instance context] in TcDerivInfer. - , deriv_strategy :: Maybe (Located DerivStrategy) + , deriv_strategy :: Maybe (LDerivStrategy pass) , deriv_overlap_mode :: Maybe (Located OverlapMode) -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDeriving', -- 'ApiAnnotation.AnnInstance', 'ApiAnnotation.AnnStock', @@ -1811,6 +1823,50 @@ instance (p ~ GhcPass pass, OutputableBndrId p) {- ************************************************************************ * * + Deriving strategies +* * +************************************************************************ +-} + +-- | A 'Located' 'DerivStrategy'. +type LDerivStrategy pass = Located (DerivStrategy pass) + +-- | Which technique the user explicitly requested when deriving an instance. +data DerivStrategy pass + -- See Note [Deriving strategies] in TcDeriv + = StockStrategy -- ^ GHC's \"standard\" strategy, which is to implement a + -- custom instance for the data type. This only works + -- for certain types that GHC knows about (e.g., 'Eq', + -- 'Show', 'Functor' when @-XDeriveFunctor@ is enabled, + -- etc.) + | AnyclassStrategy -- ^ @-XDeriveAnyClass@ + | NewtypeStrategy -- ^ @-XGeneralizedNewtypeDeriving@ + | ViaStrategy (XViaStrategy pass) + -- ^ @-XDerivingVia@ + +type instance XViaStrategy GhcPs = LHsSigType GhcPs +type instance XViaStrategy GhcRn = LHsSigType GhcRn +type instance XViaStrategy GhcTc = Type + +instance (p ~ GhcPass pass, OutputableBndrId p) + => Outputable (DerivStrategy p) where + ppr StockStrategy = text "stock" + ppr AnyclassStrategy = text "anyclass" + ppr NewtypeStrategy = text "newtype" + ppr (ViaStrategy ty) = text "via" <+> ppr ty + +-- | A short description of a @DerivStrategy'@. +derivStrategyName :: DerivStrategy a -> SDoc +derivStrategyName = text . go + where + go StockStrategy = "stock" + go AnyclassStrategy = "anyclass" + go NewtypeStrategy = "newtype" + go (ViaStrategy {}) = "via" + +{- +************************************************************************ +* * \subsection[DefaultDecl]{A @default@ declaration} * * ************************************************************************ diff --git a/compiler/hsSyn/HsExtension.hs b/compiler/hsSyn/HsExtension.hs index 4898e36e3b..eb56d3b24e 100644 --- a/compiler/hsSyn/HsExtension.hs +++ b/compiler/hsSyn/HsExtension.hs @@ -385,6 +385,10 @@ type ForallXDerivDecl (c :: * -> Constraint) (x :: *) = ) -- ------------------------------------- +-- DerivStrategy type family +type family XViaStrategy x + +-- ------------------------------------- -- DefaultDecl type families type family XCDefaultDecl x type family XXDefaultDecl x @@ -1100,6 +1104,10 @@ type OutputableX p = -- See Note [OutputableX] , Outputable (XAppTypeE p) , Outputable (XAppTypeE GhcRn) + + , Outputable (XViaStrategy p) + , Outputable (XViaStrategy GhcRn) + ) -- TODO: Should OutputableX be included in OutputableBndrId? diff --git a/compiler/hsSyn/HsInstances.hs b/compiler/hsSyn/HsInstances.hs index be72ec7939..70336d87e5 100644 --- a/compiler/hsSyn/HsInstances.hs +++ b/compiler/hsSyn/HsInstances.hs @@ -184,6 +184,11 @@ deriving instance Data (DerivDecl GhcPs) deriving instance Data (DerivDecl GhcRn) deriving instance Data (DerivDecl GhcTc) +-- deriving instance (DataIdLR p p) => Data (DerivStrategy p) +deriving instance Data (DerivStrategy GhcPs) +deriving instance Data (DerivStrategy GhcRn) +deriving instance Data (DerivStrategy GhcTc) + -- deriving instance (DataIdLR p p) => Data (DefaultDecl p) deriving instance Data (DefaultDecl GhcPs) deriving instance Data (DefaultDecl GhcRn) diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 306a15a15b..09481591ce 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -4113,6 +4113,7 @@ xFlagsDeps = [ flagSpec "DeriveLift" LangExt.DeriveLift, flagSpec "DeriveTraversable" LangExt.DeriveTraversable, flagSpec "DerivingStrategies" LangExt.DerivingStrategies, + flagSpec "DerivingVia" LangExt.DerivingVia, flagSpec "DisambiguateRecordFields" LangExt.DisambiguateRecordFields, flagSpec "DoAndIfThenElse" LangExt.DoAndIfThenElse, flagSpec "BlockArguments" LangExt.BlockArguments, @@ -4321,6 +4322,8 @@ impliedXFlags , (LangExt.RebindableSyntax, turnOff, LangExt.ImplicitPrelude) -- NB: turn off! + , (LangExt.DerivingVia, turnOn, LangExt.DerivingStrategies) + , (LangExt.GADTs, turnOn, LangExt.GADTSyntax) , (LangExt.GADTs, turnOn, LangExt.MonoLocalBinds) , (LangExt.TypeFamilies, turnOn, LangExt.MonoLocalBinds) diff --git a/compiler/parser/ApiAnnotation.hs b/compiler/parser/ApiAnnotation.hs index 4d1758ff3c..6ae01d6fe0 100644 --- a/compiler/parser/ApiAnnotation.hs +++ b/compiler/parser/ApiAnnotation.hs @@ -286,6 +286,7 @@ data AnnKeywordId | AnnVal -- ^ e.g. INTEGER | AnnValStr -- ^ String value, will need quotes when output | AnnVbar -- ^ '|' + | AnnVia -- ^ 'via' | AnnWhere | Annlarrowtail -- ^ '-<' | AnnlarrowtailU -- ^ '-<', unicode variant diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 006faccf11..69dc0992c8 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -632,6 +632,7 @@ data Token | ITstatic | ITstock | ITanyclass + | ITvia -- Backpack tokens | ITunit @@ -829,6 +830,7 @@ reservedWordsFM = listToUFM $ ( "static", ITstatic, 0 ), ( "stock", ITstock, 0 ), ( "anyclass", ITanyclass, 0 ), + ( "via", ITvia, 0 ), ( "group", ITgroup, xbit TransformComprehensionsBit), ( "by", ITby, xbit TransformComprehensionsBit), ( "using", ITusing, xbit TransformComprehensionsBit), diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index af8c95fb2b..6fc233ed42 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -88,9 +88,9 @@ import GhcPrelude import qualified GHC.LanguageExtensions as LangExt } -%expect 229 -- shift/reduce conflicts +%expect 233 -- shift/reduce conflicts -{- Last updated: 14 Apr 2018 +{- Last updated: 04 June 2018 If you modify this parser and add a conflict, please update this comment. You can learn more about the conflicts by passing 'happy' the -i flag: @@ -121,7 +121,7 @@ follows. Shift parses as if the 'module' keyword follows. ------------------------------------------------------------------------------- -state 56 contains 2 shift/reduce conflicts. +state 57 contains 2 shift/reduce conflicts. *** strict_mark -> unpackedness . strict_mark -> unpackedness . strictness @@ -130,7 +130,7 @@ state 56 contains 2 shift/reduce conflicts. ------------------------------------------------------------------------------- -state 60 contains 1 shift/reduce conflict. +state 61 contains 1 shift/reduce conflict. context -> btype . *** type -> btype . @@ -140,7 +140,7 @@ state 60 contains 1 shift/reduce conflict. ------------------------------------------------------------------------------- -state 61 contains 45 shift/reduce conflicts. +state 62 contains 46 shift/reduce conflicts. *** btype -> tyapps . tyapps -> tyapps . tyapp @@ -158,7 +158,7 @@ Shift parses as (per longest-parse rule): ------------------------------------------------------------------------------- -state 142 contains 14 shift/reduce conflicts. +state 143 contains 14 shift/reduce conflicts. exp -> infixexp . '::' sigtype exp -> infixexp . '-<' exp @@ -183,7 +183,7 @@ Shift parses as (per longest-parse rule): ------------------------------------------------------------------------------- -state 147 contains 67 shift/reduce conflicts. +state 148 contains 68 shift/reduce conflicts. *** exp10 -> fexp . fexp -> fexp . aexp @@ -201,7 +201,7 @@ Shift parses as (per longest-parse rule): ------------------------------------------------------------------------------- -state 203 contains 27 shift/reduce conflicts. +state 204 contains 28 shift/reduce conflicts. aexp2 -> TH_TY_QUOTE . tyvar aexp2 -> TH_TY_QUOTE . gtycon @@ -220,7 +220,7 @@ Shift parses as (per longest-parse rule): ------------------------------------------------------------------------------- -state 307 contains 1 shift/reduce conflicts. +state 308 contains 1 shift/reduce conflicts. rule -> STRING . rule_activation rule_forall infixexp '=' exp @@ -238,18 +238,18 @@ a rule instructing how to rewrite the expression '[0] f'. ------------------------------------------------------------------------------- -state 317 contains 1 shift/reduce conflict. +state 318 contains 1 shift/reduce conflict. *** type -> btype . type -> btype . '->' ctype Conflict: '->' -Same as state 60 but without contexts. +Same as state 61 but without contexts. ------------------------------------------------------------------------------- -state 359 contains 1 shift/reduce conflicts. +state 362 contains 1 shift/reduce conflicts. tup_exprs -> commas . tup_tail sysdcon_nolist -> '(' commas . ')' @@ -264,7 +264,7 @@ if -XTupleSections is not specified. ------------------------------------------------------------------------------- -state 415 contains 1 shift/reduce conflicts. +state 418 contains 1 shift/reduce conflicts. tup_exprs -> commas . tup_tail sysdcon_nolist -> '(#' commas . '#)' @@ -272,21 +272,21 @@ state 415 contains 1 shift/reduce conflicts. Conflict: '#)' (empty tup_tail reduces) -Same as State 357 for unboxed tuples. +Same as State 362 for unboxed tuples. ------------------------------------------------------------------------------- -state 426 contains 67 shift/reduce conflicts. +state 429 contains 68 shift/reduce conflicts. *** exp10 -> '-' fexp . fexp -> fexp . aexp fexp -> fexp . TYPEAPP atype -Same as 147 but with a unary minus. +Same as 148 but with a unary minus. ------------------------------------------------------------------------------- -state 490 contains 1 shift/reduce conflict. +state 493 contains 1 shift/reduce conflict. oqtycon -> '(' qtyconsym . ')' *** qtyconop -> qtyconsym . @@ -300,7 +300,7 @@ parenthesized infix type expression of length 1. ------------------------------------------------------------------------------- -state 691 contains 1 shift/reduce conflicts. +state 694 contains 1 shift/reduce conflicts. *** aexp2 -> ipvar . dbind -> ipvar . '=' exp @@ -315,7 +315,7 @@ sensible meaning, namely the lhs of an implicit binding. ------------------------------------------------------------------------------- -state 767 contains 1 shift/reduce conflicts. +state 771 contains 1 shift/reduce conflicts. rule -> STRING rule_activation . rule_forall infixexp '=' exp @@ -332,7 +332,7 @@ doesn't include 'forall'. ------------------------------------------------------------------------------- -state 1015 contains 1 shift/reduce conflicts. +state 1019 contains 1 shift/reduce conflicts. transformqual -> 'then' 'group' . 'using' exp transformqual -> 'then' 'group' . 'by' exp 'using' exp @@ -342,7 +342,7 @@ state 1015 contains 1 shift/reduce conflicts. ------------------------------------------------------------------------------- -state 1393 contains 1 shift/reduce conflict. +state 1404 contains 1 shift/reduce conflict. *** atype -> tyvar . tv_bndr -> '(' tyvar . '::' kind ')' @@ -484,6 +484,7 @@ are the most common patterns, rewritten as regular expressions for clarity: 'static' { L _ ITstatic } -- for static pointers extension 'stock' { L _ ITstock } -- for DerivingStrategies extension 'anyclass' { L _ ITanyclass } -- for DerivingStrategies extension + 'via' { L _ ITvia } -- for DerivingStrategies extension 'unit' { L _ ITunit } 'signature' { L _ ITsignature } @@ -1150,13 +1151,30 @@ overlap_pragma :: { Maybe (Located OverlapMode) } [mo $1,mc $2] } | {- empty -} { Nothing } -deriv_strategy :: { Maybe (Located DerivStrategy) } +deriv_strategy_no_via :: { LDerivStrategy GhcPs } + : 'stock' {% ams (sL1 $1 StockStrategy) + [mj AnnStock $1] } + | 'anyclass' {% ams (sL1 $1 AnyclassStrategy) + [mj AnnAnyclass $1] } + | 'newtype' {% ams (sL1 $1 NewtypeStrategy) + [mj AnnNewtype $1] } + +deriv_strategy_via :: { LDerivStrategy GhcPs } + : 'via' tyapp {% splitTildeApps [$2] >>= \tys -> let + ty :: LHsType GhcPs + ty = sL1 $1 $ mkHsAppsTy tys + + in ams (sLL $1 $> (ViaStrategy (mkLHsSigType ty))) + [mj AnnVia $1] } + +deriv_standalone_strategy :: { Maybe (LDerivStrategy GhcPs) } : 'stock' {% ajs (Just (sL1 $1 StockStrategy)) [mj AnnStock $1] } | 'anyclass' {% ajs (Just (sL1 $1 AnyclassStrategy)) [mj AnnAnyclass $1] } | 'newtype' {% ajs (Just (sL1 $1 NewtypeStrategy)) [mj AnnNewtype $1] } + | deriv_strategy_via { Just $1 } | {- empty -} { Nothing } -- Injective type families @@ -1363,7 +1381,7 @@ capi_ctype : '{-# CTYPE' STRING STRING '#-}' -- Glasgow extension: stand-alone deriving declarations stand_alone_deriving :: { LDerivDecl GhcPs } - : 'deriving' deriv_strategy 'instance' overlap_pragma inst_type + : 'deriving' deriv_standalone_strategy 'instance' overlap_pragma inst_type {% do { let { err = text "in the stand-alone deriving instance" <> colon <+> quotes (ppr $5) } ; ams (sLL $1 (hsSigType $>) @@ -2204,21 +2222,27 @@ derivings :: { HsDeriving GhcPs } -- The outer Located is just to allow the caller to -- know the rightmost extremity of the 'deriving' clause deriving :: { LHsDerivingClause GhcPs } - : 'deriving' deriv_strategy qtycondoc + : 'deriving' deriv_clause_types {% let { full_loc = comb2 $1 $> } - in ams (L full_loc $ HsDerivingClause noExt $2 $ L full_loc - [mkLHsSigType $3]) + in ams (L full_loc $ HsDerivingClause noExt Nothing $2) [mj AnnDeriving $1] } - | 'deriving' deriv_strategy '(' ')' + | 'deriving' deriv_strategy_no_via deriv_clause_types {% let { full_loc = comb2 $1 $> } - in ams (L full_loc $ HsDerivingClause noExt $2 $ L full_loc []) - [mj AnnDeriving $1,mop $3,mcp $4] } + in ams (L full_loc $ HsDerivingClause noExt (Just $2) $3) + [mj AnnDeriving $1] } - | 'deriving' deriv_strategy '(' deriv_types ')' + | 'deriving' deriv_clause_types deriv_strategy_via {% let { full_loc = comb2 $1 $> } - in ams (L full_loc $ HsDerivingClause noExt $2 $ L full_loc $4) - [mj AnnDeriving $1,mop $3,mcp $5] } + in ams (L full_loc $ HsDerivingClause noExt (Just $3) $2) + [mj AnnDeriving $1] } + +deriv_clause_types :: { Located [LHsSigType GhcPs] } + : qtycondoc { sL1 $1 [mkLHsSigType $1] } + | '(' ')' {% ams (sLL $1 $> []) + [mop $1,mcp $2] } + | '(' deriv_types ')' {% ams (sLL $1 $> $2) + [mop $1,mcp $3] } -- Glasgow extension: allow partial -- applications in derivings @@ -3329,6 +3353,7 @@ special_id | 'group' { sL1 $1 (fsLit "group") } | 'stock' { sL1 $1 (fsLit "stock") } | 'anyclass' { sL1 $1 (fsLit "anyclass") } + | 'via' { sL1 $1 (fsLit "via") } | 'unit' { sL1 $1 (fsLit "unit") } | 'dependency' { sL1 $1 (fsLit "dependency") } | 'signature' { sL1 $1 (fsLit "signature") } diff --git a/compiler/prelude/THNames.hs b/compiler/prelude/THNames.hs index f45b3b53e9..8c526d59ec 100644 --- a/compiler/prelude/THNames.hs +++ b/compiler/prelude/THNames.hs @@ -129,8 +129,8 @@ templateHaskellNames = [ overlappableDataConName, overlappingDataConName, overlapsDataConName, incoherentDataConName, -- DerivStrategy - stockStrategyDataConName, anyclassStrategyDataConName, - newtypeStrategyDataConName, + stockStrategyName, anyclassStrategyName, + newtypeStrategyName, viaStrategyName, -- TExp tExpDataConName, -- RuleBndr @@ -156,7 +156,7 @@ templateHaskellNames = [ patQTyConName, fieldPatQTyConName, fieldExpQTyConName, funDepTyConName, predQTyConName, decsQTyConName, ruleBndrQTyConName, tySynEqnQTyConName, roleTyConName, tExpTyConName, injAnnTyConName, kindQTyConName, - overlapTyConName, derivClauseQTyConName, derivStrategyTyConName, + overlapTyConName, derivClauseQTyConName, derivStrategyQTyConName, -- Quasiquoting quoteDecName, quoteTypeName, quoteExpName, quotePatName] @@ -185,8 +185,7 @@ liftClassName = thCls (fsLit "Lift") liftClassKey qTyConName, nameTyConName, fieldExpTyConName, patTyConName, fieldPatTyConName, expTyConName, decTyConName, typeTyConName, matchTyConName, clauseTyConName, funDepTyConName, predTyConName, - tExpTyConName, injAnnTyConName, overlapTyConName, - derivStrategyTyConName :: Name + tExpTyConName, injAnnTyConName, overlapTyConName :: Name qTyConName = thTc (fsLit "Q") qTyConKey nameTyConName = thTc (fsLit "Name") nameTyConKey fieldExpTyConName = thTc (fsLit "FieldExp") fieldExpTyConKey @@ -202,7 +201,6 @@ predTyConName = thTc (fsLit "Pred") predTyConKey tExpTyConName = thTc (fsLit "TExp") tExpTyConKey injAnnTyConName = thTc (fsLit "InjectivityAnn") injAnnTyConKey overlapTyConName = thTc (fsLit "Overlap") overlapTyConKey -derivStrategyTyConName = thTc (fsLit "DerivStrategy") derivStrategyTyConKey returnQName, bindQName, sequenceQName, newNameName, liftName, mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, @@ -529,12 +527,21 @@ moduleAnnotationName = libFun (fsLit "moduleAnnotation") moduleAnnotationIdKey derivClauseName :: Name derivClauseName = libFun (fsLit "derivClause") derivClauseIdKey +-- data DerivStrategy = ... +stockStrategyName, anyclassStrategyName, newtypeStrategyName, + viaStrategyName :: Name +stockStrategyName = libFun (fsLit "stockStrategy") stockStrategyIdKey +anyclassStrategyName = libFun (fsLit "anyclassStrategy") anyclassStrategyIdKey +newtypeStrategyName = libFun (fsLit "newtypeStrategy") newtypeStrategyIdKey +viaStrategyName = libFun (fsLit "viaStrategy") viaStrategyIdKey + matchQTyConName, clauseQTyConName, expQTyConName, stmtQTyConName, decQTyConName, conQTyConName, bangTypeQTyConName, varBangTypeQTyConName, typeQTyConName, fieldExpQTyConName, patQTyConName, fieldPatQTyConName, predQTyConName, decsQTyConName, ruleBndrQTyConName, tySynEqnQTyConName, roleTyConName, - derivClauseQTyConName, kindQTyConName, tyVarBndrQTyConName :: Name + derivClauseQTyConName, kindQTyConName, tyVarBndrQTyConName, + derivStrategyQTyConName :: Name matchQTyConName = libTc (fsLit "MatchQ") matchQTyConKey clauseQTyConName = libTc (fsLit "ClauseQ") clauseQTyConKey expQTyConName = libTc (fsLit "ExpQ") expQTyConKey @@ -555,6 +562,7 @@ roleTyConName = libTc (fsLit "Role") roleTyConKey derivClauseQTyConName = libTc (fsLit "DerivClauseQ") derivClauseQTyConKey kindQTyConName = libTc (fsLit "KindQ") kindQTyConKey tyVarBndrQTyConName = libTc (fsLit "TyVarBndrQ") tyVarBndrQTyConKey +derivStrategyQTyConName = libTc (fsLit "DerivStrategyQ") derivStrategyQTyConKey -- quasiquoting quoteExpName, quotePatName, quoteDecName, quoteTypeName :: Name @@ -590,13 +598,6 @@ overlappingDataConName = thCon (fsLit "Overlapping") overlappingDataConKey overlapsDataConName = thCon (fsLit "Overlaps") overlapsDataConKey incoherentDataConName = thCon (fsLit "Incoherent") incoherentDataConKey --- data DerivStrategy = ... -stockStrategyDataConName, anyclassStrategyDataConName, - newtypeStrategyDataConName :: Name -stockStrategyDataConName = thCon (fsLit "StockStrategy") stockDataConKey -anyclassStrategyDataConName = thCon (fsLit "AnyclassStrategy") anyclassDataConKey -newtypeStrategyDataConName = thCon (fsLit "NewtypeStrategy") newtypeDataConKey - {- ********************************************************************* * * Class keys @@ -626,7 +627,7 @@ expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey, fieldPatQTyConKey, fieldExpQTyConKey, funDepTyConKey, predTyConKey, predQTyConKey, decsQTyConKey, ruleBndrQTyConKey, tySynEqnQTyConKey, roleTyConKey, tExpTyConKey, injAnnTyConKey, kindQTyConKey, - overlapTyConKey, derivClauseQTyConKey, derivStrategyTyConKey :: Unique + overlapTyConKey, derivClauseQTyConKey, derivStrategyQTyConKey :: Unique expTyConKey = mkPreludeTyConUnique 200 matchTyConKey = mkPreludeTyConUnique 201 clauseTyConKey = mkPreludeTyConUnique 202 @@ -662,7 +663,7 @@ injAnnTyConKey = mkPreludeTyConUnique 231 kindQTyConKey = mkPreludeTyConUnique 232 overlapTyConKey = mkPreludeTyConUnique 233 derivClauseQTyConKey = mkPreludeTyConUnique 234 -derivStrategyTyConKey = mkPreludeTyConUnique 235 +derivStrategyQTyConKey = mkPreludeTyConUnique 235 {- ********************************************************************* * * @@ -704,12 +705,6 @@ overlappingDataConKey = mkPreludeDataConUnique 210 overlapsDataConKey = mkPreludeDataConUnique 211 incoherentDataConKey = mkPreludeDataConUnique 212 --- data DerivStrategy = ... -stockDataConKey, anyclassDataConKey, newtypeDataConKey :: Unique -stockDataConKey = mkPreludeDataConUnique 213 -anyclassDataConKey = mkPreludeDataConUnique 214 -newtypeDataConKey = mkPreludeDataConUnique 215 - {- ********************************************************************* * * Id keys @@ -1050,6 +1045,14 @@ moduleAnnotationIdKey = mkPreludeMiscIdUnique 492 derivClauseIdKey :: Unique derivClauseIdKey = mkPreludeMiscIdUnique 493 +-- data DerivStrategy = ... +stockStrategyIdKey, anyclassStrategyIdKey, newtypeStrategyIdKey, + viaStrategyIdKey :: Unique +stockStrategyIdKey = mkPreludeDataConUnique 494 +anyclassStrategyIdKey = mkPreludeDataConUnique 495 +newtypeStrategyIdKey = mkPreludeDataConUnique 496 +viaStrategyIdKey = mkPreludeDataConUnique 497 + {- ************************************************************************ * * diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs index 5e01f285b4..a53adf2cba 100644 --- a/compiler/rename/RnSource.hs +++ b/compiler/rename/RnSource.hs @@ -51,7 +51,7 @@ import NameEnv import Avail import Outputable import Bag -import BasicTypes ( DerivStrategy, RuleName, pprRuleName ) +import BasicTypes ( RuleName, pprRuleName ) import FastString import SrcLoc import DynFlags @@ -68,7 +68,6 @@ import Control.Arrow ( first ) import Data.List ( mapAccumL ) import qualified Data.List.NonEmpty as NE import Data.List.NonEmpty ( NonEmpty(..) ) -import Data.Maybe ( isJust ) import qualified Data.Set as Set ( difference, fromList, toList, null ) {- | @rnSourceDecl@ "renames" declarations. @@ -956,14 +955,16 @@ Here 'k' is in scope in the kind signature, just like 'x'. -} rnSrcDerivDecl :: DerivDecl GhcPs -> RnM (DerivDecl GhcRn, FreeVars) -rnSrcDerivDecl (DerivDecl _ ty deriv_strat overlap) +rnSrcDerivDecl (DerivDecl _ ty mds overlap) = do { standalone_deriv_ok <- xoptM LangExt.StandaloneDeriving - ; deriv_strats_ok <- xoptM LangExt.DerivingStrategies ; unless standalone_deriv_ok (addErr standaloneDerivErr) - ; failIfTc (isJust deriv_strat && not deriv_strats_ok) $ - illegalDerivStrategyErr $ fmap unLoc deriv_strat - ; (ty', fvs) <- rnHsSigWcType DerivDeclCtx ty - ; return (DerivDecl noExt ty' deriv_strat overlap, fvs) } + ; (mds', ty', fvs) + <- rnLDerivStrategy DerivDeclCtx mds $ \strat_tvs ppr_via_ty -> + rnAndReportFloatingViaTvs strat_tvs loc ppr_via_ty "instance" $ + rnHsSigWcType DerivDeclCtx ty + ; return (DerivDecl noExt ty' mds' overlap, fvs) } + where + loc = getLoc $ hsib_body $ hswc_body ty rnSrcDerivDecl (XDerivDecl _) = panic "rnSrcDerivDecl" standaloneDerivErr :: SDoc @@ -1632,35 +1633,148 @@ rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType = do { deriv_strats_ok <- xoptM LangExt.DerivingStrategies ; failIfTc (lengthExceeds ds 1 && not deriv_strats_ok) multipleDerivClausesErr - ; (ds', fvs) <- mapFvRn (rnLHsDerivingClause deriv_strats_ok doc) ds + ; (ds', fvs) <- mapFvRn (rnLHsDerivingClause doc) ds ; return (L loc ds', fvs) } rnDataDefn _ (XHsDataDefn _) = panic "rnDataDefn" -rnLHsDerivingClause :: Bool -> HsDocContext -> LHsDerivingClause GhcPs +rnLHsDerivingClause :: HsDocContext -> LHsDerivingClause GhcPs -> RnM (LHsDerivingClause GhcRn, FreeVars) -rnLHsDerivingClause deriv_strats_ok doc +rnLHsDerivingClause doc (L loc (HsDerivingClause { deriv_clause_ext = noExt , deriv_clause_strategy = dcs , deriv_clause_tys = L loc' dct })) - = do { failIfTc (isJust dcs && not deriv_strats_ok) $ - illegalDerivStrategyErr $ fmap unLoc dcs - ; (dct', fvs) <- mapFvRn (rnHsSigType doc) dct - ; return ( L loc (HsDerivingClause { deriv_clause_ext = noExt - , deriv_clause_strategy = dcs - , deriv_clause_tys = L loc' dct' }) - , fvs ) } -rnLHsDerivingClause _ _ (L _ (XHsDerivingClause _)) + = do { (dcs', dct', fvs) + <- rnLDerivStrategy doc dcs $ \strat_tvs ppr_via_ty -> + mapFvRn (rn_deriv_ty strat_tvs ppr_via_ty) dct + ; pure ( L loc (HsDerivingClause { deriv_clause_ext = noExt + , deriv_clause_strategy = dcs' + , deriv_clause_tys = L loc' dct' }) + , fvs ) } + where + rn_deriv_ty :: [Name] -> SDoc -> LHsSigType GhcPs + -> RnM (LHsSigType GhcRn, FreeVars) + rn_deriv_ty strat_tvs ppr_via_ty deriv_ty@(HsIB {hsib_body = L loc _}) = + rnAndReportFloatingViaTvs strat_tvs loc ppr_via_ty "class" $ + rnHsSigType doc deriv_ty + rn_deriv_ty _ _ (XHsImplicitBndrs _) = panic "rn_deriv_ty" +rnLHsDerivingClause _ (L _ (XHsDerivingClause _)) = panic "rnLHsDerivingClause" +rnLDerivStrategy :: forall a. + HsDocContext + -> Maybe (LDerivStrategy GhcPs) + -> ([Name] -- The tyvars bound by the via type + -> SDoc -- The pretty-printed via type (used for + -- error message reporting) + -> RnM (a, FreeVars)) + -> RnM (Maybe (LDerivStrategy GhcRn), a, FreeVars) +rnLDerivStrategy doc mds thing_inside + = case mds of + Nothing -> boring_case Nothing + Just ds -> do (ds', thing, fvs) <- rn_deriv_strat ds + pure (Just ds', thing, fvs) + where + rn_deriv_strat :: LDerivStrategy GhcPs + -> RnM (LDerivStrategy GhcRn, a, FreeVars) + rn_deriv_strat (L loc ds) = do + let extNeeded :: LangExt.Extension + extNeeded + | ViaStrategy{} <- ds + = LangExt.DerivingVia + | otherwise + = LangExt.DerivingStrategies + + unlessXOptM extNeeded $ + failWith $ illegalDerivStrategyErr ds + + case ds of + StockStrategy -> boring_case (L loc StockStrategy) + AnyclassStrategy -> boring_case (L loc AnyclassStrategy) + NewtypeStrategy -> boring_case (L loc NewtypeStrategy) + ViaStrategy via_ty -> + do (via_ty', fvs1) <- rnHsSigType doc via_ty + let HsIB { hsib_ext = HsIBRn { hsib_vars = via_imp_tvs } + , hsib_body = via_body } = via_ty' + (via_exp_tv_bndrs, _, _) = splitLHsSigmaTy via_body + via_exp_tvs = map hsLTyVarName via_exp_tv_bndrs + via_tvs = via_imp_tvs ++ via_exp_tvs + (thing, fvs2) <- extendTyVarEnvFVRn via_tvs $ + thing_inside via_tvs (ppr via_ty') + pure (L loc (ViaStrategy via_ty'), thing, fvs1 `plusFV` fvs2) + + boring_case :: mds + -> RnM (mds, a, FreeVars) + boring_case mds = do + (thing, fvs) <- thing_inside [] empty + pure (mds, thing, fvs) + +-- | Errors if a @via@ type binds any floating type variables. +-- See @Note [Floating `via` type variables]@ +rnAndReportFloatingViaTvs + :: forall a. Outputable a + => [Name] -- ^ The bound type variables from a @via@ type. + -> SrcSpan -- ^ The source span (for error reporting only). + -> SDoc -- ^ The pretty-printed @via@ type (for error reporting only). + -> String -- ^ A description of what the @via@ type scopes over + -- (for error reporting only). + -> RnM (a, FreeVars) -- ^ The thing the @via@ type scopes over. + -> RnM (a, FreeVars) +rnAndReportFloatingViaTvs tv_names loc ppr_via_ty via_scope_desc thing_inside + = do (thing, thing_fvs) <- thing_inside + setSrcSpan loc $ mapM_ (report_floating_via_tv thing thing_fvs) tv_names + pure (thing, thing_fvs) + where + report_floating_via_tv :: a -> FreeVars -> Name -> RnM () + report_floating_via_tv thing used_names tv_name + = unless (tv_name `elemNameSet` used_names) $ addErr $ vcat + [ text "Type variable" <+> quotes (ppr tv_name) <+> + text "is bound in the" <+> quotes (text "via") <+> + text "type" <+> quotes ppr_via_ty + , text "but is not mentioned in the derived" <+> + text via_scope_desc <+> quotes (ppr thing) <> + text ", which is illegal" ] + +{- +Note [Floating `via` type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Imagine the following `deriving via` clause: + + data Quux + deriving Eq via (Const a Quux) + +This should be rejected. Why? Because it would generate the following instance: + + instance Eq Quux where + (==) = coerce @(Quux -> Quux -> Bool) + @(Const a Quux -> Const a Quux -> Bool) + (==) + +This instance is ill-formed, as the `a` in `Const a Quux` is unbound. The +problem is that `a` is never used anywhere in the derived class `Eq`. Since +`a` is bound but has no use sites, we refer to it as "floating". + +We use the rnAndReportFloatingViaTvs function to check that any type renamed +within the context of the `via` deriving strategy actually uses all bound +`via` type variables, and if it doesn't, it throws an error. +-} + badGadtStupidTheta :: HsDocContext -> SDoc badGadtStupidTheta _ = vcat [text "No context is allowed on a GADT-style data declaration", text "(You can put a context on each constructor, though.)"] -illegalDerivStrategyErr :: Maybe DerivStrategy -> SDoc +illegalDerivStrategyErr :: DerivStrategy GhcPs -> SDoc illegalDerivStrategyErr ds - = vcat [ text "Illegal deriving strategy" <> colon <+> maybe empty ppr ds - , text "Use DerivingStrategies to enable this extension" ] + = vcat [ text "Illegal deriving strategy" <> colon <+> derivStrategyName ds + , text enableStrategy ] + + where + enableStrategy :: String + enableStrategy + | ViaStrategy{} <- ds + = "Use DerivingVia to enable this extension" + | otherwise + = "Use DerivingStrategies to enable this extension" multipleDerivClausesErr :: SDoc multipleDerivClausesErr diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs index b6a8185526..327876804a 100644 --- a/compiler/typecheck/TcDeriv.hs +++ b/compiler/typecheck/TcDeriv.hs @@ -31,6 +31,7 @@ import InstEnv import Inst import FamInstEnv import TcHsType +import TyCoRep import RnNames( extendGlobalRdrEnvRn ) import RnBinds @@ -40,7 +41,6 @@ import RnSource ( addTcgDUs ) import Avail import Unify( tcUnifyTy ) -import BasicTypes ( DerivStrategy(..) ) import Class import Type import ErrUtils @@ -584,7 +584,8 @@ same set of clause-derived classes. ------------------------------------------------------------------ -- | Process a single class in a `deriving` clause. -deriveClause :: TyCon -> Maybe DerivStrategy -> LHsSigType GhcRn -> SDoc +deriveClause :: TyCon -> Maybe (DerivStrategy GhcRn) + -> LHsSigType GhcRn -> SDoc -> TcM (Maybe EarlyDerivSpec) deriveClause rep_tc mb_strat pred err_ctxt = addErrCtxt err_ctxt $ @@ -607,32 +608,70 @@ deriveStandalone :: LDerivDecl GhcRn -> TcM (Maybe EarlyDerivSpec) -- -- This returns a Maybe because the user might try to derive Typeable, which is -- a no-op nowadays. -deriveStandalone (L loc (DerivDecl _ deriv_ty deriv_strat' overlap_mode)) +deriveStandalone (L loc (DerivDecl _ deriv_ty mbl_deriv_strat overlap_mode)) = setSrcSpan loc $ addErrCtxt (standaloneCtxt deriv_ty) $ do { traceTc "Standalone deriving decl for" (ppr deriv_ty) - ; let deriv_strat = fmap unLoc deriv_strat' + ; let mb_deriv_strat = fmap unLoc mbl_deriv_strat ; traceTc "Deriving strategy (standalone deriving)" $ - vcat [ppr deriv_strat, ppr deriv_ty] - ; (tvs, deriv_ctxt, cls, inst_tys) - <- tcStandaloneDerivInstType deriv_ty + vcat [ppr mb_deriv_strat, ppr deriv_ty] + ; (mb_deriv_strat', tvs', (deriv_ctxt', cls, inst_tys')) + <- tcDerivStrategy TcType.InstDeclCtxt mb_deriv_strat $ do + (tvs, deriv_ctxt, cls, inst_tys) + <- tcStandaloneDerivInstType deriv_ty + pure (tvs, (deriv_ctxt, cls, inst_tys)) + ; checkTc (not (null inst_tys')) derivingNullaryErr + ; let inst_ty' = last inst_tys' + -- See Note [Unify kinds in deriving] + ; (tvs, deriv_ctxt, inst_tys) <- + case mb_deriv_strat' of + -- Perform an additional unification with the kind of the `via` + -- type and the result of the previous kind unification. + Just (ViaStrategy via_ty) -> do + let via_kind = typeKind via_ty + inst_ty_kind = typeKind inst_ty' + mb_match = tcUnifyTy inst_ty_kind via_kind + + checkTc (isJust mb_match) + (derivingViaKindErr cls inst_ty_kind + via_ty via_kind) + + let Just kind_subst = mb_match + ki_subst_range = getTCvSubstRangeFVs kind_subst + -- See Note [Unification of two kind variables in deriving] + unmapped_tkvs = filter (\v -> v `notElemTCvSubst` kind_subst + && not (v `elemVarSet` ki_subst_range)) + tvs' + (subst, _) = mapAccumL substTyVarBndr + kind_subst unmapped_tkvs + (final_deriv_ctxt, final_deriv_ctxt_tys) + = case deriv_ctxt' of + InferContext wc -> (InferContext wc, []) + SupplyContext theta -> + let final_theta = substTheta subst theta + in (SupplyContext final_theta, final_theta) + final_inst_tys = substTys subst inst_tys' + final_tvs = tyCoVarsOfTypesWellScoped $ + final_deriv_ctxt_tys ++ final_inst_tys + pure (final_tvs, final_deriv_ctxt, final_inst_tys) + + _ -> pure (tvs', deriv_ctxt', inst_tys') + ; let cls_tys = take (length inst_tys - 1) inst_tys + inst_ty = last inst_tys ; traceTc "Standalone deriving;" $ vcat [ text "tvs:" <+> ppr tvs + , text "mb_deriv_strat:" <+> ppr mb_deriv_strat' , text "deriv_ctxt:" <+> ppr deriv_ctxt , text "cls:" <+> ppr cls , text "tys:" <+> ppr inst_tys ] -- C.f. TcInstDcls.tcLocalInstDecl1 - ; checkTc (not (null inst_tys)) derivingNullaryErr - - ; let cls_tys = take (length inst_tys - 1) inst_tys - inst_ty = last inst_tys ; traceTc "Standalone deriving:" $ vcat [ text "class:" <+> ppr cls , text "class types:" <+> ppr cls_tys , text "type:" <+> ppr inst_ty ] ; let bale_out msg = failWithTc (derivingThingErr False cls cls_tys - inst_ty deriv_strat msg) + inst_ty mb_deriv_strat' msg) ; case tcSplitTyConApp_maybe inst_ty of Just (tc, tc_args) @@ -643,7 +682,7 @@ deriveStandalone (L loc (DerivDecl _ deriv_ty deriv_strat' overlap_mode)) | otherwise -> Just <$> mkEqnHelp (fmap unLoc overlap_mode) tvs cls cls_tys tc tc_args - deriv_ctxt deriv_strat + deriv_ctxt mb_deriv_strat' _ -> -- Complain about functions, primitive types, etc, bale_out $ @@ -712,23 +751,22 @@ warnUselessTypeable ------------------------------------------------------------------ deriveTyData :: [TyVar] -> TyCon -> [Type] -- LHS of data or data instance -- Can be a data instance, hence [Type] args - -> Maybe DerivStrategy -- The optional deriving strategy - -> LHsSigType GhcRn -- The deriving predicate + -> Maybe (DerivStrategy GhcRn) -- The optional deriving strategy + -> LHsSigType GhcRn -- The deriving predicate -> TcM (Maybe EarlyDerivSpec) -- The deriving clause of a data or newtype declaration -- I.e. not standalone deriving -- -- This returns a Maybe because the user might try to derive Typeable, which is -- a no-op nowadays. -deriveTyData tvs tc tc_args deriv_strat deriv_pred +deriveTyData tvs tc tc_args mb_deriv_strat deriv_pred = setSrcSpan (getLoc (hsSigType deriv_pred)) $ -- Use loc of the 'deriving' item - do { (deriv_tvs, cls, cls_tys, cls_arg_kinds) + do { (mb_deriv_strat', deriv_tvs, (cls, cls_tys, cls_arg_kinds)) -- Why not scopeTyVars? Because these are *TyVar*s, not TcTyVars. -- Their kinds are fully settled. No need to worry about skolem -- escape. <- tcExtendTyVarEnv tvs $ - tcHsDeriv deriv_pred -- Deriving preds may (now) mention -- the type variables for the type constructor, hence tcExtendTyVarenv -- The "deriv_pred" is a LHsType to take account of the fact that for @@ -737,6 +775,9 @@ deriveTyData tvs tc tc_args deriv_strat deriv_pred -- Typeable is special, because Typeable :: forall k. k -> Constraint -- so the argument kind 'k' is not decomposable by splitKindFunTys -- as is the case for all other derivable type classes + tcDerivStrategy TcType.DerivClauseCtxt mb_deriv_strat $ + tcHsDeriv deriv_pred + ; when (cls_arg_kinds `lengthIsNot` 1) $ failWithTc (nonUnaryErr deriv_pred) ; let [cls_arg_kind] = cls_arg_kinds @@ -764,25 +805,57 @@ deriveTyData tvs tc tc_args deriv_strat deriv_pred ; checkTc (enough_args && isJust mb_match) (derivingKindErr tc cls cls_tys cls_arg_kind enough_args) - ; let Just kind_subst = mb_match - ki_subst_range = getTCvSubstRangeFVs kind_subst - all_tkvs = toposortTyVars $ - fvVarList $ unionFV - (tyCoFVsOfTypes tc_args_to_keep) - (FV.mkFVs deriv_tvs) - -- See Note [Unification of two kind variables in deriving] - unmapped_tkvs = filter (\v -> v `notElemTCvSubst` kind_subst - && not (v `elemVarSet` ki_subst_range)) - all_tkvs - (subst, _) = mapAccumL substTyVarBndr - kind_subst unmapped_tkvs - final_tc_args = substTys subst tc_args_to_keep - final_cls_tys = substTys subst cls_tys - tkvs = tyCoVarsOfTypesWellScoped $ - final_cls_tys ++ final_tc_args + ; let propagate_subst kind_subst tkvs' cls_tys' tc_args' + = (final_tkvs, final_cls_tys, final_tc_args) + where + ki_subst_range = getTCvSubstRangeFVs kind_subst + -- See Note [Unification of two kind variables in deriving] + unmapped_tkvs = filter (\v -> v `notElemTCvSubst` kind_subst + && not (v `elemVarSet` ki_subst_range)) + tkvs' + (subst, _) = mapAccumL substTyVarBndr + kind_subst unmapped_tkvs + final_tc_args = substTys subst tc_args' + final_cls_tys = substTys subst cls_tys' + final_tkvs = tyCoVarsOfTypesWellScoped $ + final_cls_tys ++ final_tc_args + + ; let tkvs = toposortTyVars $ fvVarList $ + unionFV (tyCoFVsOfTypes tc_args_to_keep) + (FV.mkFVs deriv_tvs) + Just kind_subst = mb_match + (tkvs', final_cls_tys', final_tc_args') + = propagate_subst kind_subst tkvs cls_tys tc_args_to_keep + + -- See Note [Unify kinds in deriving] + ; (tkvs, final_cls_tys, final_tc_args, final_mb_deriv_strat) <- + case mb_deriv_strat' of + -- Perform an additional unification with the kind of the `via` + -- type and the result of the previous kind unification. + Just (ViaStrategy via_ty) -> do + let final_via_ty = via_ty + final_via_kind = typeKind final_via_ty + final_inst_ty_kind + = typeKind (mkTyConApp tc final_tc_args') + via_match = tcUnifyTy final_inst_ty_kind final_via_kind + + checkTc (isJust via_match) + (derivingViaKindErr cls final_inst_ty_kind + final_via_ty final_via_kind) + + let Just via_subst = via_match + (final_tkvs, final_cls_tys, final_tc_args) + = propagate_subst via_subst tkvs' + final_cls_tys' final_tc_args' + pure ( final_tkvs, final_cls_tys, final_tc_args + , Just $ ViaStrategy $ substTy via_subst via_ty + ) + + _ -> pure ( tkvs', final_cls_tys', final_tc_args' + , mb_deriv_strat' ) ; traceTc "Deriving strategy (deriving clause)" $ - vcat [ppr deriv_strat, ppr deriv_pred] + vcat [ppr final_mb_deriv_strat, ppr deriv_pred] ; traceTc "derivTyData1" (vcat [ pprTyVars tvs, ppr tc, ppr tc_args , ppr deriv_pred @@ -818,7 +891,7 @@ deriveTyData tvs tc tc_args deriv_strat deriv_pred ; spec <- mkEqnHelp Nothing tkvs cls final_cls_tys tc final_tc_args - (InferContext Nothing) deriv_strat + (InferContext Nothing) final_mb_deriv_strat ; traceTc "derivTyData" (ppr spec) ; return $ Just spec } } @@ -928,6 +1001,20 @@ Even though we requested a derived instance of the form (Cat k Fun), the kind unification will actually generate (Cat * Fun) (i.e., the same thing as if the user wrote deriving (Cat *)). +What happens with DerivingVia, when you have yet another type? Consider: + + newtype Foo (a :: Type) = MkFoo (Proxy a) + deriving Functor via Proxy + +As before, we unify the kind of Foo (* -> *) with the kind of the argument to +Functor (* -> *). But that's not enough: the `via` type, Proxy, has the kind +(k -> *), which is more general than what we want. So we must additionally +unify (k -> *) with (* -> *). + +Currently, all of this unification is implemented kludgily with the pure +unifier, which is rather tiresome. Trac #14331 lays out a plan for how this +might be made cleaner. + Note [Unification of two kind variables in deriving] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ As a special case of the Note above, it is possible to derive an instance of @@ -1000,7 +1087,7 @@ mkEqnHelp :: Maybe OverlapMode -- SupplyContext => context supplied (standalone deriving) -- InferContext => context inferred (deriving on data decl, or -- standalone deriving decl with a wildcard) - -> Maybe DerivStrategy + -> Maybe (DerivStrategy GhcTc) -> TcRn EarlyDerivSpec -- Make the EarlyDerivSpec for an instance -- forall tvs. theta => cls (tys ++ [ty]) @@ -1103,25 +1190,31 @@ See Note [Eta reduction for data families] in FamInstEnv ************************************************************************ -} +-- | Derive an instance for a data type (i.e., non-newtype). mkDataTypeEqn :: DerivM EarlyDerivSpec mkDataTypeEqn = do mb_strat <- asks denv_strat let bale_out msg = do err <- derivingThingErrM False msg lift $ failWithTc err case mb_strat of - Just StockStrategy -> mk_eqn_stock mk_data_eqn bale_out - Just AnyclassStrategy -> mk_eqn_anyclass mk_data_eqn bale_out + Just StockStrategy -> mk_eqn_stock mk_originative_eqn bale_out + Just AnyclassStrategy -> mk_eqn_anyclass mk_originative_eqn bale_out + Just (ViaStrategy ty) -> mk_eqn_via ty -- GeneralizedNewtypeDeriving makes no sense for non-newtypes Just NewtypeStrategy -> bale_out gndNonNewtypeErr -- Lacking a user-requested deriving strategy, we will try to pick -- between the stock or anyclass strategies - Nothing -> mk_eqn_no_mechanism mk_data_eqn bale_out + Nothing -> mk_eqn_no_mechanism mk_originative_eqn bale_out -mk_data_eqn :: DerivSpecMechanism -- How GHC should proceed attempting to - -- derive this instance, determined in - -- mkDataTypeEqn/mkNewTypeEqn - -> DerivM EarlyDerivSpec -mk_data_eqn mechanism +-- Derive an instance by way of an originative deriving strategy +-- (stock or anyclass). +-- +-- See Note [Deriving strategies] +mk_originative_eqn + :: DerivSpecMechanism -- Invariant: This will be DerivSpecStock or + -- DerivSpecAnyclass + -> DerivM EarlyDerivSpec +mk_originative_eqn mechanism = do DerivEnv { denv_overlap_mode = overlap_mode , denv_tvs = tvs , denv_tc = tc @@ -1160,6 +1253,151 @@ mk_data_eqn mechanism , ds_standalone_wildcard = Nothing , ds_mechanism = mechanism } +-- Derive an instance by way of a coerce-based deriving strategy +-- (newtype or via). +-- +-- See Note [Deriving strategies] +mk_coerce_based_eqn + :: (Type -> DerivSpecMechanism) -- Invariant: This will be DerivSpecNewtype + -- or DerivSpecVia + -> Type -- The type to coerce + -> DerivM EarlyDerivSpec +mk_coerce_based_eqn mk_mechanism coerced_ty + = do DerivEnv { denv_overlap_mode = overlap_mode + , denv_tvs = tvs + , denv_tc = tycon + , denv_tc_args = tc_args + , denv_rep_tc = rep_tycon + , denv_cls = cls + , denv_cls_tys = cls_tys + , denv_ctxt = deriv_ctxt } <- ask + sa_wildcard <- isStandaloneWildcardDeriv + let -- The following functions are polymorphic over the representation + -- type, since we might either give it the underlying type of a + -- newtype (for GeneralizedNewtypeDeriving) or a @via@ type + -- (for DerivingVia). + rep_tys ty = cls_tys ++ [ty] + rep_pred ty = mkClassPred cls (rep_tys ty) + rep_pred_o ty = mkPredOrigin deriv_origin TypeLevel (rep_pred ty) + -- rep_pred is the representation dictionary, from where + -- we are going to get all the methods for the final + -- dictionary + + -- Next we figure out what superclass dictionaries to use + -- See Note [Newtype deriving superclasses] above + sc_preds :: [PredOrigin] + cls_tyvars = classTyVars cls + inst_ty = mkTyConApp tycon tc_args + inst_tys = cls_tys ++ [inst_ty] + sc_preds = map (mkPredOrigin deriv_origin TypeLevel) $ + substTheta (zipTvSubst cls_tyvars inst_tys) $ + classSCTheta cls + deriv_origin = mkDerivOrigin sa_wildcard + + -- Next we collect constraints for the class methods + -- If there are no methods, we don't need any constraints + -- Otherwise we need (C rep_ty), for the representation methods, + -- and constraints to coerce each individual method + meth_preds :: Type -> [PredOrigin] + meths = classMethods cls + meth_preds ty + | null meths = [] -- No methods => no constraints + -- (Trac #12814) + | otherwise = rep_pred_o ty : coercible_constraints ty + coercible_constraints ty + = [ mkPredOrigin (DerivOriginCoerce meth t1 t2 sa_wildcard) + TypeLevel (mkReprPrimEqPred t1 t2) + | meth <- meths + , let (Pair t1 t2) = mkCoerceClassMethEqn cls tvs + inst_tys ty meth ] + + all_thetas :: Type -> [ThetaOrigin] + all_thetas ty = [mkThetaOriginFromPreds $ meth_preds ty ++ sc_preds] + + inferred_thetas = all_thetas coerced_ty + lift $ traceTc "newtype deriving:" $ + ppr tycon <+> ppr (rep_tys coerced_ty) <+> ppr inferred_thetas + let mechanism = mk_mechanism coerced_ty + bale_out msg = do err <- derivingThingErrMechanism mechanism msg + lift $ failWithTc err + atf_coerce_based_error_checks cls bale_out + doDerivInstErrorChecks1 mechanism + dfun_name <- lift $ newDFunName' cls tycon + loc <- lift getSrcSpanM + case deriv_ctxt of + SupplyContext theta -> return $ GivenTheta $ DS + { ds_loc = loc + , ds_name = dfun_name, ds_tvs = tvs + , ds_cls = cls, ds_tys = inst_tys + , ds_tc = rep_tycon + , ds_theta = theta + , ds_overlap = overlap_mode + , ds_standalone_wildcard = Nothing + , ds_mechanism = mechanism } + InferContext wildcard -> return $ InferTheta $ DS + { ds_loc = loc + , ds_name = dfun_name, ds_tvs = tvs + , ds_cls = cls, ds_tys = inst_tys + , ds_tc = rep_tycon + , ds_theta = inferred_thetas + , ds_overlap = overlap_mode + , ds_standalone_wildcard = wildcard + , ds_mechanism = mechanism } + +-- Ensure that a class's associated type variables are suitable for +-- GeneralizedNewtypeDeriving or DerivingVia. +-- +-- See Note [GND and associated type families] +atf_coerce_based_error_checks + :: Class + -> (SDoc -> DerivM ()) + -> DerivM () +atf_coerce_based_error_checks cls bale_out + = let cls_tyvars = classTyVars cls + + ats_look_sensible + = -- Check (a) from Note [GND and associated type families] + no_adfs + -- Check (b) from Note [GND and associated type families] + && isNothing at_without_last_cls_tv + -- Check (d) from Note [GND and associated type families] + && isNothing at_last_cls_tv_in_kinds + + (adf_tcs, atf_tcs) = partition isDataFamilyTyCon at_tcs + no_adfs = null adf_tcs + -- We cannot newtype-derive data family instances + + at_without_last_cls_tv + = find (\tc -> last_cls_tv `notElem` tyConTyVars tc) atf_tcs + at_last_cls_tv_in_kinds + = find (\tc -> any (at_last_cls_tv_in_kind . tyVarKind) + (tyConTyVars tc) + || at_last_cls_tv_in_kind (tyConResKind tc)) atf_tcs + at_last_cls_tv_in_kind kind + = last_cls_tv `elemVarSet` exactTyCoVarsOfType kind + at_tcs = classATs cls + last_cls_tv = ASSERT( notNull cls_tyvars ) + last cls_tyvars + + cant_derive_err + = vcat [ ppUnless no_adfs adfs_msg + , maybe empty at_without_last_cls_tv_msg + at_without_last_cls_tv + , maybe empty at_last_cls_tv_in_kinds_msg + at_last_cls_tv_in_kinds + ] + adfs_msg = text "the class has associated data types" + at_without_last_cls_tv_msg at_tc = hang + (text "the associated type" <+> quotes (ppr at_tc) + <+> text "is not parameterized over the last type variable") + 2 (text "of the class" <+> quotes (ppr cls)) + at_last_cls_tv_in_kinds_msg at_tc = hang + (text "the associated type" <+> quotes (ppr at_tc) + <+> text "contains the last type variable") + 2 (text "of the class" <+> quotes (ppr cls) + <+> text "in a kind, which is not (yet) allowed") + in unless ats_look_sensible $ bale_out cant_derive_err + mk_eqn_stock :: (DerivSpecMechanism -> DerivM EarlyDerivSpec) -> (SDoc -> DerivM EarlyDerivSpec) -> DerivM EarlyDerivSpec @@ -1170,10 +1408,11 @@ mk_eqn_stock go_for_it bale_out , denv_cls_tys = cls_tys , denv_ctxt = deriv_ctxt } <- ask dflags <- getDynFlags - case checkSideConditions dflags deriv_ctxt cls cls_tys tc rep_tc of - CanDerive gen_fn -> go_for_it $ DerivSpecStock gen_fn - DerivableClassError msg -> bale_out msg - _ -> bale_out (nonStdErr cls) + case checkOriginativeSideConditions dflags deriv_ctxt cls cls_tys + tc rep_tc of + CanDeriveStock gen_fn -> go_for_it $ DerivSpecStock gen_fn + StockClassError msg -> bale_out msg + _ -> bale_out (nonStdErr cls) mk_eqn_anyclass :: (DerivSpecMechanism -> DerivM EarlyDerivSpec) -> (SDoc -> DerivM EarlyDerivSpec) @@ -1184,6 +1423,14 @@ mk_eqn_anyclass go_for_it bale_out IsValid -> go_for_it DerivSpecAnyClass NotValid msg -> bale_out msg +mk_eqn_newtype :: Type -- The newtype's representation type + -> DerivM EarlyDerivSpec +mk_eqn_newtype = mk_coerce_based_eqn DerivSpecNewtype + +mk_eqn_via :: Type -- The @via@ type + -> DerivM EarlyDerivSpec +mk_eqn_via = mk_coerce_based_eqn DerivSpecVia + mk_eqn_no_mechanism :: (DerivSpecMechanism -> DerivM EarlyDerivSpec) -> (SDoc -> DerivM EarlyDerivSpec) -> DerivM EarlyDerivSpec @@ -1204,65 +1451,38 @@ mk_eqn_no_mechanism go_for_it bale_out | otherwise = nonStdErr cls $$ msg - case checkSideConditions dflags deriv_ctxt cls cls_tys tc rep_tc of - -- NB: pass the *representation* tycon to checkSideConditions + case checkOriginativeSideConditions dflags deriv_ctxt cls cls_tys + tc rep_tc of + -- NB: pass the *representation* tycon to + -- checkOriginativeSideConditions NonDerivableClass msg -> bale_out (dac_error msg) - DerivableClassError msg -> bale_out msg - CanDerive gen_fn -> go_for_it $ DerivSpecStock gen_fn - DerivableViaInstance -> go_for_it DerivSpecAnyClass + StockClassError msg -> bale_out msg + CanDeriveStock gen_fn -> go_for_it $ DerivSpecStock gen_fn + CanDeriveAnyClass -> go_for_it DerivSpecAnyClass {- ************************************************************************ * * - Deriving newtypes + GeneralizedNewtypeDeriving and DerivingVia * * ************************************************************************ -} +-- | Derive an instance for a newtype. mkNewTypeEqn :: DerivM EarlyDerivSpec mkNewTypeEqn -- Want: instance (...) => cls (cls_tys ++ [tycon tc_args]) where ... - = do DerivEnv { denv_overlap_mode = overlap_mode - , denv_tvs = tvs - , denv_tc = tycon - , denv_tc_args = tc_args + = do DerivEnv { denv_tc = tycon , denv_rep_tc = rep_tycon , denv_rep_tc_args = rep_tc_args , denv_cls = cls , denv_cls_tys = cls_tys , denv_ctxt = deriv_ctxt , denv_strat = mb_strat } <- ask - sa_wildcard <- isStandaloneWildcardDeriv dflags <- getDynFlags let newtype_deriving = xopt LangExt.GeneralizedNewtypeDeriving dflags deriveAnyClass = xopt LangExt.DeriveAnyClass dflags - go_for_it_gnd = do - lift $ traceTc "newtype deriving:" $ - ppr tycon <+> ppr rep_tys <+> ppr all_thetas - let mechanism = DerivSpecNewtype rep_inst_ty - doDerivInstErrorChecks1 mechanism - dfun_name <- lift $ newDFunName' cls tycon - loc <- lift getSrcSpanM - case deriv_ctxt of - SupplyContext theta -> return $ GivenTheta $ DS - { ds_loc = loc - , ds_name = dfun_name, ds_tvs = tvs - , ds_cls = cls, ds_tys = inst_tys - , ds_tc = rep_tycon - , ds_theta = theta - , ds_overlap = overlap_mode - , ds_standalone_wildcard = Nothing - , ds_mechanism = mechanism } - InferContext wildcard -> return $ InferTheta $ DS - { ds_loc = loc - , ds_name = dfun_name, ds_tvs = tvs - , ds_cls = cls, ds_tys = inst_tys - , ds_tc = rep_tycon - , ds_theta = all_thetas - , ds_overlap = overlap_mode - , ds_standalone_wildcard = wildcard - , ds_mechanism = mechanism } bale_out = bale_out' newtype_deriving bale_out' b msg = do err <- derivingThingErrM b msg lift $ failWithTc err @@ -1319,59 +1539,15 @@ mkNewTypeEqn -- We want the Num instance of B, *not* the Num instance of Int, -- when making the Num instance of A! rep_inst_ty = newTyConInstRhs rep_tycon rep_tc_args - rep_tys = cls_tys ++ [rep_inst_ty] - rep_pred = mkClassPred cls rep_tys - rep_pred_o = mkPredOrigin deriv_origin TypeLevel rep_pred - -- rep_pred is the representation dictionary, from where - -- we are gong to get all the methods for the newtype - -- dictionary - - -- Next we figure out what superclass dictionaries to use - -- See Note [Newtype deriving superclasses] above - sc_preds :: [PredOrigin] - cls_tyvars = classTyVars cls - inst_ty = mkTyConApp tycon tc_args - inst_tys = cls_tys ++ [inst_ty] - sc_preds = map (mkPredOrigin deriv_origin TypeLevel) $ - substTheta (zipTvSubst cls_tyvars inst_tys) $ - classSCTheta cls - deriv_origin = mkDerivOrigin sa_wildcard - - -- Next we collect constraints for the class methods - -- If there are no methods, we don't need any constraints - -- Otherwise we need (C rep_ty), for the representation methods, - -- and constraints to coerce each individual method - meth_preds :: [PredOrigin] - meths = classMethods cls - meth_preds | null meths = [] -- No methods => no constraints - -- (Trac #12814) - | otherwise = rep_pred_o : coercible_constraints - coercible_constraints - = [ mkPredOrigin (DerivOriginCoerce meth t1 t2 sa_wildcard) - TypeLevel (mkReprPrimEqPred t1 t2) - | meth <- meths - , let (Pair t1 t2) = mkCoerceClassMethEqn cls tvs - inst_tys rep_inst_ty meth ] - - all_thetas :: [ThetaOrigin] - all_thetas = [mkThetaOriginFromPreds $ meth_preds ++ sc_preds] ------------------------------------------------------------------- -- Figuring out whether we can only do this newtype-deriving thing -- See Note [Determining whether newtype-deriving is appropriate] - might_derive_via_coercible + might_be_newtype_derivable = not (non_coercible_class cls) - && coercion_looks_sensible + && eta_ok -- && not (isRecursiveTyCon tycon) -- Note [Recursive newtypes] - coercion_looks_sensible - = eta_ok - -- Check (a) from Note [GND and associated type families] - && ats_ok - -- Check (b) from Note [GND and associated type families] - && isNothing at_without_last_cls_tv - -- Check (d) from Note [GND and associated type families] - && isNothing at_last_cls_tv_in_kinds -- Check that eta reduction is OK eta_ok = rep_tc_args `lengthAtLeast` nt_eta_arity @@ -1382,46 +1558,13 @@ mkNewTypeEqn -- And the [a] must not mention 'b'. That's all handled -- by nt_eta_rity. - (adf_tcs, atf_tcs) = partition isDataFamilyTyCon at_tcs - ats_ok = null adf_tcs - -- We cannot newtype-derive data family instances - - at_without_last_cls_tv - = find (\tc -> last_cls_tv `notElem` tyConTyVars tc) atf_tcs - at_last_cls_tv_in_kinds - = find (\tc -> any (at_last_cls_tv_in_kind . tyVarKind) - (tyConTyVars tc) - || at_last_cls_tv_in_kind (tyConResKind tc)) atf_tcs - at_last_cls_tv_in_kind kind - = last_cls_tv `elemVarSet` exactTyCoVarsOfType kind - at_tcs = classATs cls - last_cls_tv = ASSERT( notNull cls_tyvars ) - last cls_tyvars - - cant_derive_err - = vcat [ ppUnless eta_ok eta_msg - , ppUnless ats_ok ats_msg - , maybe empty at_without_last_cls_tv_msg - at_without_last_cls_tv - , maybe empty at_last_cls_tv_in_kinds_msg - at_last_cls_tv_in_kinds - ] - eta_msg = text "cannot eta-reduce the representation type enough" - ats_msg = text "the class has associated data types" - at_without_last_cls_tv_msg at_tc = hang - (text "the associated type" <+> quotes (ppr at_tc) - <+> text "is not parameterized over the last type variable") - 2 (text "of the class" <+> quotes (ppr cls)) - at_last_cls_tv_in_kinds_msg at_tc = hang - (text "the associated type" <+> quotes (ppr at_tc) - <+> text "contains the last type variable") - 2 (text "of the class" <+> quotes (ppr cls) - <+> text "in a kind, which is not (yet) allowed") + cant_derive_err = ppUnless eta_ok eta_msg + eta_msg = text "cannot eta-reduce the representation type enough" MASSERT( cls_tys `lengthIs` (classArity cls - 1) ) case mb_strat of - Just StockStrategy -> mk_eqn_stock mk_data_eqn bale_out - Just AnyclassStrategy -> mk_eqn_anyclass mk_data_eqn bale_out + Just StockStrategy -> mk_eqn_stock mk_originative_eqn bale_out + Just AnyclassStrategy -> mk_eqn_anyclass mk_originative_eqn bale_out Just NewtypeStrategy -> -- Since the user explicitly asked for GeneralizedNewtypeDeriving, -- we don't need to perform all of the checks we normally would, @@ -1429,19 +1572,23 @@ mkNewTypeEqn -- coercions (e.g., Traversable), since we can just derive the -- instance and let it error if need be. -- See Note [Determining whether newtype-deriving is appropriate] - if coercion_looks_sensible && newtype_deriving - then go_for_it_gnd + if eta_ok && newtype_deriving + then mk_eqn_newtype rep_inst_ty else bale_out (cant_derive_err $$ if newtype_deriving then empty else suggest_gnd) + Just (ViaStrategy via_ty) -> + -- NB: For DerivingVia, we don't need to any eta-reduction checking, + -- since the @via@ type is already "eta-reduced". + mk_eqn_via via_ty Nothing - | might_derive_via_coercible + | might_be_newtype_derivable && ((newtype_deriving && not deriveAnyClass) || std_class_via_coercible cls) - -> go_for_it_gnd + -> mk_eqn_newtype rep_inst_ty | otherwise - -> case checkSideConditions dflags deriv_ctxt cls cls_tys - tycon rep_tycon of - DerivableClassError msg + -> case checkOriginativeSideConditions dflags deriv_ctxt cls cls_tys + tycon rep_tycon of + StockClassError msg -- There's a particular corner case where -- -- 1. -XGeneralizedNewtypeDeriving and -XDeriveAnyClass are @@ -1451,10 +1598,10 @@ mkNewTypeEqn -- -- and the previous cases won't catch it. This fixes the bug -- reported in Trac #10598. - | might_derive_via_coercible && newtype_deriving - -> go_for_it_gnd + | might_be_newtype_derivable && newtype_deriving + -> mk_eqn_newtype rep_inst_ty -- Otherwise, throw an error for a stock class - | might_derive_via_coercible && not newtype_deriving + | might_be_newtype_derivable && not newtype_deriving -> bale_out (msg $$ suggest_gnd) | otherwise -> bale_out msg @@ -1468,8 +1615,8 @@ mkNewTypeEqn -- where it may not be applicable. See Trac #9600. | otherwise -> bale_out (non_std $$ suggest_gnd) - -- DerivableViaInstance - DerivableViaInstance -> do + -- DeriveAnyClass + CanDeriveAnyClass -> do -- If both DeriveAnyClass and GeneralizedNewtypeDeriving are -- enabled, we take the diplomatic approach of defaulting to -- DeriveAnyClass, but emitting a warning about the choice. @@ -1480,9 +1627,10 @@ mkNewTypeEqn <+> text "GeneralizedNewtypeDeriving are enabled" , text "Defaulting to the DeriveAnyClass strategy" <+> text "for instantiating" <+> ppr cls ] - mk_data_eqn DerivSpecAnyClass - -- CanDerive - CanDerive gen_fn -> mk_data_eqn $ DerivSpecStock gen_fn + mk_originative_eqn DerivSpecAnyClass + -- CanDeriveStock + CanDeriveStock gen_fn -> mk_originative_eqn $ + DerivSpecStock gen_fn {- Note [Recursive newtypes] @@ -1624,6 +1772,8 @@ However, we must watch out for three things: type at the Core level. See #14728, comment:3 for a sketch of how this might work. Until then, we disallow this featurette wholesale. +The same criteria apply to DerivingVia. + ************************************************************************ * * \subsection[TcDeriv-normal-binds]{Bindings for the various classes} @@ -1722,7 +1872,7 @@ genInst spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon where extensions :: [LangExt.Extension] extensions - | isDerivSpecNewtype mechanism + | isDerivSpecNewtype mechanism || isDerivSpecVia mechanism -- Both these flags are needed for higher-rank uses of coerce -- See Note [Newtype-deriving instances] in TcGenDeriv = [LangExt.ImpredicativeTypes, LangExt.RankNTypes] @@ -1738,6 +1888,7 @@ doDerivInstErrorChecks1 mechanism = do , denv_rep_tc = rep_tc } <- ask standalone <- isStandaloneDeriv let anyclass_strategy = isDerivSpecAnyClass mechanism + via_strategy = isDerivSpecVia mechanism bale_out msg = do err <- derivingThingErrMechanism mechanism msg lift $ failWithTc err @@ -1754,8 +1905,10 @@ doDerivInstErrorChecks1 mechanism = do -- ...however, we don't perform this check if we're using DeriveAnyClass, -- since it doesn't generate any code that requires use of a data - -- constructor. - unless (anyclass_strategy || not standalone || not hidden_data_cons) $ + -- constructor. Nor do we perform this check with @deriving via@, as it + -- doesn't explicitly require the constructors to be in scope. + unless (anyclass_strategy || via_strategy + || not standalone || not hidden_data_cons) $ bale_out $ derivingHiddenErr tc doDerivInstErrorChecks2 :: Class -> ClsInst -> ThetaType -> Maybe SrcSpan @@ -1784,9 +1937,7 @@ doDerivInstErrorChecks2 clas clas_inst theta wildcard mechanism do { failIfTc (safeLanguageOn dflags) gen_inst_err ; when (safeInferOn dflags) (recordUnsafeInfer emptyBag) } } where - exotic_mechanism = case mechanism of - DerivSpecStock{} -> False - _ -> True + exotic_mechanism = not $ isDerivSpecStock mechanism partial_sig_msg = text "Found type wildcard" <+> quotes (char '_') <+> text "standing for" <+> quotes (pprTheta theta) @@ -1803,15 +1954,12 @@ genDerivStuff :: DerivSpecMechanism -> SrcSpan -> Class genDerivStuff mechanism loc clas tycon inst_tys tyvars = case mechanism of -- See Note [Bindings for Generalised Newtype Deriving] - DerivSpecNewtype rhs_ty -> do - (binds, faminsts) <- gen_Newtype_binds loc clas tyvars inst_tys rhs_ty - return (binds, faminsts, maybeToList unusedConName) + DerivSpecNewtype rhs_ty -> gen_newtype_or_via rhs_ty -- Try a stock deriver DerivSpecStock gen_fn -> gen_fn loc tycon inst_tys - -- If there isn't a stock deriver, our last resort is -XDeriveAnyClass - -- (since -XGeneralizedNewtypeDeriving fell through). + -- Try DeriveAnyClass DerivSpecAnyClass -> do let mini_env = mkVarEnv (classTyVars clas `zip` inst_tys) mini_subst = mkTvSubst (mkInScopeSet (mkVarSet tyvars)) mini_env @@ -1829,7 +1977,14 @@ genDerivStuff mechanism loc clas tycon inst_tys tyvars -- family default instances. -- See Note [DeriveAnyClass and default family instances] , [] ) + + -- Try DerivingVia + DerivSpecVia via_ty -> gen_newtype_or_via via_ty where + gen_newtype_or_via ty = do + (binds, faminsts) <- gen_Newtype_binds loc clas tyvars inst_tys ty + return (binds, faminsts, maybeToList unusedConName) + unusedConName :: Maybe Name unusedConName | isDerivSpecNewtype mechanism @@ -1921,6 +2076,14 @@ Currently, the deriving strategies are: * newtype: Use -XGeneralizedNewtypeDeriving +* via: Use -XDerivingVia + +The latter two strategies (newtype and via) are referred to as the +"coerce-based" strategies, since they generate code that relies on the `coerce` +function. The former two strategies (stock and anyclass), in contrast, are +referred to as the "originative" strategies, since they create "original" +instances instead of "reusing" old instances (by way of `coerce`). + If an explicit deriving strategy is not given, GHC has an algorithm it uses to determine which strategy it will actually use. The algorithm is quite long, so it lives in the Haskell wiki at @@ -1990,6 +2153,15 @@ derivingKindErr tc cls cls_tys cls_kind enough_args = text "(Perhaps you intended to use PolyKinds)" | otherwise = Outputable.empty +derivingViaKindErr :: Class -> Kind -> Type -> Kind -> MsgDoc +derivingViaKindErr cls cls_kind via_ty via_kind + = hang (text "Cannot derive instance via" <+> quotes (pprType via_ty)) + 2 (text "Class" <+> quotes (ppr cls) + <+> text "expects an argument of kind" + <+> quotes (pprKind cls_kind) <> char ',' + $+$ text "but" <+> quotes (pprType via_ty) + <+> text "has kind" <+> quotes (pprKind via_kind)) + derivingEtaErr :: Class -> [Type] -> Type -> MsgDoc derivingEtaErr cls cls_tys inst_ty = sep [text "Cannot eta-reduce to an instance of form", @@ -1997,10 +2169,10 @@ derivingEtaErr cls cls_tys inst_ty <+> pprClassPred cls (cls_tys ++ [inst_ty]))] derivingThingErr :: Bool -> Class -> [Type] -> Type - -> Maybe DerivStrategy -> MsgDoc -> MsgDoc + -> Maybe (DerivStrategy GhcTc) -> MsgDoc -> MsgDoc derivingThingErr newtype_deriving cls cls_tys inst_ty mb_strat why = derivingThingErr' newtype_deriving cls cls_tys inst_ty mb_strat - (maybe empty ppr mb_strat) why + (maybe empty derivStrategyName mb_strat) why derivingThingErrM :: Bool -> MsgDoc -> DerivM MsgDoc derivingThingErrM newtype_deriving why @@ -2020,10 +2192,12 @@ derivingThingErrMechanism mechanism why , denv_cls_tys = cls_tys , denv_strat = mb_strat } <- ask pure $ derivingThingErr' (isDerivSpecNewtype mechanism) cls cls_tys - (mkTyConApp tc tc_args) mb_strat (ppr mechanism) why + (mkTyConApp tc tc_args) mb_strat + (derivStrategyName $ derivSpecMechanismToStrategy mechanism) + why derivingThingErr' :: Bool -> Class -> [Type] -> Type - -> Maybe DerivStrategy -> MsgDoc -> MsgDoc -> MsgDoc + -> Maybe (DerivStrategy GhcTc) -> MsgDoc -> MsgDoc -> MsgDoc derivingThingErr' newtype_deriving cls cls_tys inst_ty mb_strat strat_msg why = sep [(hang (text "Can't make a derived instance of") 2 (quotes (ppr pred) <+> via_mechanism) diff --git a/compiler/typecheck/TcDerivUtils.hs b/compiler/typecheck/TcDerivUtils.hs index c10b0b87d6..86205de5fd 100644 --- a/compiler/typecheck/TcDerivUtils.hs +++ b/compiler/typecheck/TcDerivUtils.hs @@ -10,13 +10,14 @@ Error-checking and other utilities for @deriving@ clauses or declarations. module TcDerivUtils ( DerivM, DerivEnv(..), - DerivSpec(..), pprDerivSpec, DerivSpecMechanism(..), - isDerivSpecStock, isDerivSpecNewtype, isDerivSpecAnyClass, - DerivContext(..), DerivStatus(..), + DerivSpec(..), pprDerivSpec, + DerivSpecMechanism(..), derivSpecMechanismToStrategy, isDerivSpecStock, + isDerivSpecNewtype, isDerivSpecAnyClass, isDerivSpecVia, + DerivContext(..), OriginativeDerivStatus(..), isStandaloneDeriv, isStandaloneWildcardDeriv, mkDerivOrigin, PredOrigin(..), ThetaOrigin(..), mkPredOrigin, mkThetaOrigin, mkThetaOriginFromPreds, substPredOrigin, - checkSideConditions, hasStockDeriving, + checkOriginativeSideConditions, hasStockDeriving, canDeriveAnyClass, std_class_via_coercible, non_coercible_class, newDerivClsInst, extendLocalInstEnv @@ -114,7 +115,7 @@ data DerivEnv = DerivEnv -- 'InferContext' for @deriving@ clauses, or for standalone deriving that -- uses a wildcard constraint. -- See @Note [Inferring the instance context]@. - , denv_strat :: Maybe DerivStrategy + , denv_strat :: Maybe (DerivStrategy GhcTc) -- ^ 'Just' if user requests a particular deriving strategy. -- Otherwise, 'Nothing'. } @@ -224,7 +225,17 @@ data DerivSpecMechanism | DerivSpecAnyClass -- -XDeriveAnyClass -isDerivSpecStock, isDerivSpecNewtype, isDerivSpecAnyClass + | DerivSpecVia -- -XDerivingVia + Type -- The @via@ type + +-- | Convert a 'DerivSpecMechanism' to its corresponding 'DerivStrategy'. +derivSpecMechanismToStrategy :: DerivSpecMechanism -> DerivStrategy GhcTc +derivSpecMechanismToStrategy DerivSpecStock{} = StockStrategy +derivSpecMechanismToStrategy DerivSpecNewtype{} = NewtypeStrategy +derivSpecMechanismToStrategy DerivSpecAnyClass = AnyclassStrategy +derivSpecMechanismToStrategy (DerivSpecVia t) = ViaStrategy t + +isDerivSpecStock, isDerivSpecNewtype, isDerivSpecAnyClass, isDerivSpecVia :: DerivSpecMechanism -> Bool isDerivSpecStock (DerivSpecStock{}) = True isDerivSpecStock _ = False @@ -232,17 +243,17 @@ isDerivSpecStock _ = False isDerivSpecNewtype (DerivSpecNewtype{}) = True isDerivSpecNewtype _ = False -isDerivSpecAnyClass (DerivSpecAnyClass{}) = True -isDerivSpecAnyClass _ = False +isDerivSpecAnyClass DerivSpecAnyClass = True +isDerivSpecAnyClass _ = False --- A DerivSpecMechanism can be losslessly converted to a DerivStrategy. -mechanismToStrategy :: DerivSpecMechanism -> DerivStrategy -mechanismToStrategy (DerivSpecStock{}) = StockStrategy -mechanismToStrategy (DerivSpecNewtype{}) = NewtypeStrategy -mechanismToStrategy (DerivSpecAnyClass{}) = AnyclassStrategy +isDerivSpecVia (DerivSpecVia{}) = True +isDerivSpecVia _ = False instance Outputable DerivSpecMechanism where - ppr = ppr . mechanismToStrategy + ppr (DerivSpecStock{}) = text "DerivSpecStock" + ppr (DerivSpecNewtype t) = text "DerivSpecNewtype" <> colon <+> ppr t + ppr DerivSpecAnyClass = text "DerivSpecAnyClass" + ppr (DerivSpecVia t) = text "DerivSpecVia" <> colon <+> ppr t -- | Whether GHC is processing a @deriving@ clause or a standalone deriving -- declaration. @@ -268,16 +279,21 @@ instance Outputable DerivContext where ppr (InferContext standalone) = text "InferContext" <+> ppr standalone ppr (SupplyContext theta) = text "SupplyContext" <+> ppr theta -data DerivStatus = CanDerive -- Stock class, can derive - (SrcSpan -> TyCon -> [Type] - -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name])) - | DerivableClassError SDoc -- Stock class, but can't do it - | DerivableViaInstance -- See Note [Deriving any class] - | NonDerivableClass SDoc -- Non-stock class +-- | Records whether a particular class can be derived by way of an +-- /originative/ deriving strategy (i.e., @stock@ or @anyclass@). +-- +-- See @Note [Deriving strategies]@ in "TcDeriv". +data OriginativeDerivStatus + = CanDeriveStock -- Stock class, can derive + (SrcSpan -> TyCon -> [Type] + -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name])) + | StockClassError SDoc -- Stock class, but can't do it + | CanDeriveAnyClass -- See Note [Deriving any class] + | NonDerivableClass SDoc -- Cannot derive with either stock or anyclass -- A stock class is one either defined in the Haskell report or for which GHC -- otherwise knows how to generate code for (possibly requiring the use of a --- language extension), such as Eq, Ord, Ix, Data, Generic, etc. +-- language extension), such as Eq, Ord, Ix, Data, Generic, etc.) -- | A 'PredType' annotated with the origin of the constraint 'CtOrigin', -- and whether or the constraint deals in types or kinds. @@ -395,9 +411,9 @@ substPredOrigin subst (PredOrigin pred origin t_or_k) Only certain blessed classes can be used in a deriving clause (without the assistance of GeneralizedNewtypeDeriving or DeriveAnyClass). These classes -are listed below in the definition of hasStockDeriving. The sideConditions +are listed below in the definition of hasStockDeriving. The stockSideConditions function determines the criteria that needs to be met in order for a particular -class to be able to be derived successfully. +stock class to be able to be derived successfully. A class might be able to be used in a deriving clause if -XDeriveAnyClass is willing to support it. The canDeriveAnyClass function checks if this is the @@ -503,20 +519,26 @@ getDataConFixityFun tc doc = text "Data con fixities for" <+> ppr name ------------------------------------------------------------------ --- Check side conditions that dis-allow derivability for particular classes --- This is *apart* from the newtype-deriving mechanism +-- Check side conditions that dis-allow derivability for the originative +-- deriving strategies (stock and anyclass). +-- See Note [Deriving strategies] in TcDeriv for an explanation of what +-- "originative" means. +-- +-- This is *apart* from the coerce-based strategies, newtype and via. -- -- Here we get the representation tycon in case of family instances as it has -- the data constructors - but we need to be careful to fall back to the -- family tycon (with indexes) in error messages. -checkSideConditions :: DynFlags -> DerivContext -> Class -> [TcType] - -> TyCon -> TyCon - -> DerivStatus -checkSideConditions dflags deriv_ctxt cls cls_tys tc rep_tc - | Just cond <- sideConditions deriv_ctxt cls +checkOriginativeSideConditions + :: DynFlags -> DerivContext -> Class -> [TcType] + -> TyCon -> TyCon + -> OriginativeDerivStatus +checkOriginativeSideConditions dflags deriv_ctxt cls cls_tys tc rep_tc + -- First, check if stock deriving is possible... + | Just cond <- stockSideConditions deriv_ctxt cls = case (cond dflags tc rep_tc) of - NotValid err -> DerivableClassError err -- Class-specific error + NotValid err -> StockClassError err -- Class-specific error IsValid | null (filterOutInvisibleTypes (classTyCon cls) cls_tys) -- All stock derivable classes are unary in the sense that -- there should be not types in cls_tys (i.e., no type args @@ -524,15 +546,16 @@ checkSideConditions dflags deriv_ctxt cls cls_tys tc rep_tc -- invisible types as well (e.g., for Generic1, which is -- poly-kinded), so make sure those are not counted. , Just gen_fn <- hasStockDeriving cls - -> CanDerive gen_fn - | otherwise -> DerivableClassError (classArgsErr cls cls_tys) + -> CanDeriveStock gen_fn + | otherwise -> StockClassError (classArgsErr cls cls_tys) -- e.g. deriving( Eq s ) + -- ...if not, try falling back on DeriveAnyClass. | NotValid err <- canDeriveAnyClass dflags - = NonDerivableClass err -- DeriveAnyClass does not work + = NonDerivableClass err -- Neither anyclass nor stock work | otherwise - = DerivableViaInstance -- DeriveAnyClass should work + = CanDeriveAnyClass -- DeriveAnyClass should work classArgsErr :: Class -> [Type] -> SDoc classArgsErr cls cls_tys = quotes (ppr (mkClassPred cls cls_tys)) <+> text "is not a class" @@ -542,8 +565,8 @@ classArgsErr cls cls_tys = quotes (ppr (mkClassPred cls cls_tys)) <+> text "is n -- mechanism on certain classes (as opposed to classes that require -- GeneralizedNewtypeDeriving or DeriveAnyClass). Returns Nothing for a -- class for which stock deriving isn't possible. -sideConditions :: DerivContext -> Class -> Maybe Condition -sideConditions deriv_ctxt cls +stockSideConditions :: DerivContext -> Class -> Maybe Condition +stockSideConditions deriv_ctxt cls | cls_key == eqClassKey = Just (cond_std `andCond` cond_args cls) | cls_key == ordClassKey = Just (cond_std `andCond` cond_args cls) | cls_key == showClassKey = Just (cond_std `andCond` cond_args cls) diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs index 40f617a421..fb8f62fa27 100644 --- a/compiler/typecheck/TcHsType.hs +++ b/compiler/typecheck/TcHsType.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE CPP, TupleSections, MultiWayIf, RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} module TcHsType ( -- Type signatures @@ -15,7 +16,7 @@ module TcHsType ( funsSigCtxt, addSigCtxt, pprSigCtxt, tcHsClsInstType, - tcHsDeriv, + tcHsDeriv, tcDerivStrategy, tcHsTypeApp, UserTypeCtxt(..), tcImplicitTKBndrs, tcImplicitTKBndrsX, @@ -274,7 +275,7 @@ tc_hs_sig_type skol_info (HsIB { hsib_ext = HsIBRn { hsib_vars = sig_vars } tc_hs_sig_type _ (XHsImplicitBndrs _) _ = panic "tc_hs_sig_type" ----------------- -tcHsDeriv :: LHsSigType GhcRn -> TcM ([TyVar], Class, [Type], [Kind]) +tcHsDeriv :: LHsSigType GhcRn -> TcM ([TyVar], (Class, [Type], [Kind])) -- Like tcHsSigType, but for the ...deriving( C t1 ty2 ) clause -- Returns the C, [ty1, ty2, and the kinds of C's remaining arguments -- E.g. class C (a::*) (b::k->k) @@ -291,9 +292,55 @@ tcHsDeriv hs_ty ; let (tvs, pred) = splitForAllTys ty ; let (args, _) = splitFunTys cls_kind ; case getClassPredTys_maybe pred of - Just (cls, tys) -> return (tvs, cls, tys, args) + Just (cls, tys) -> return (tvs, (cls, tys, args)) Nothing -> failWithTc (text "Illegal deriving item" <+> quotes (ppr hs_ty)) } +-- | Typecheck something within the context of a deriving strategy. +-- This is of particular importance when the deriving strategy is @via@. +-- For instance: +-- +-- @ +-- deriving via (S a) instance C (T a) +-- @ +-- +-- We need to typecheck @S a@, and moreover, we need to extend the tyvar +-- environment with @a@ before typechecking @C (T a)@, since @S a@ quantified +-- the type variable @a@. +tcDerivStrategy + :: forall a. + UserTypeCtxt + -> Maybe (DerivStrategy GhcRn) -- ^ The deriving strategy + -> TcM ([TyVar], a) -- ^ The thing to typecheck within the context of the + -- deriving strategy, which might quantify some type + -- variables of its own. + -> TcM (Maybe (DerivStrategy GhcTc), [TyVar], a) + -- ^ The typechecked deriving strategy, all quantified tyvars, and + -- the payload of the typechecked thing. +tcDerivStrategy user_ctxt mds thing_inside + = case mds of + Nothing -> boring_case Nothing + Just ds -> do (ds', tvs, thing) <- tc_deriv_strategy ds + pure (Just ds', tvs, thing) + where + tc_deriv_strategy :: DerivStrategy GhcRn + -> TcM (DerivStrategy GhcTc, [TyVar], a) + tc_deriv_strategy StockStrategy = boring_case StockStrategy + tc_deriv_strategy AnyclassStrategy = boring_case AnyclassStrategy + tc_deriv_strategy NewtypeStrategy = boring_case NewtypeStrategy + tc_deriv_strategy (ViaStrategy ty) = do + cls_kind <- newMetaKindVar + ty' <- checkNoErrs $ + tc_hs_sig_type_and_gen (SigTypeSkol user_ctxt) ty cls_kind + let (via_tvs, via_pred) = splitForAllTys ty' + tcExtendTyVarEnv via_tvs $ do + (thing_tvs, thing) <- thing_inside + pure (ViaStrategy via_pred, via_tvs ++ thing_tvs, thing) + + boring_case :: mds -> TcM (mds, [TyVar], a) + boring_case mds = do + (thing_tvs, thing) <- thing_inside + pure (mds, thing_tvs, thing) + tcHsClsInstType :: UserTypeCtxt -- InstDeclCtxt or SpecInstCtxt -> LHsSigType GhcRn -> TcM ([TyVar], ThetaType, Class, [Type]) diff --git a/docs/users_guide/8.6.1-notes.rst b/docs/users_guide/8.6.1-notes.rst index fc2b1d2cfd..366e94bae0 100644 --- a/docs/users_guide/8.6.1-notes.rst +++ b/docs/users_guide/8.6.1-notes.rst @@ -28,6 +28,14 @@ Full details Language ~~~~~~~~ +- A new :extension:`DerivingVia` language extension has been added which allows + the use of the ``via`` deriving strategy. For instance: :: + + newtype T = MkT Int + deriving Monoid via (Sum Int) + + See :ref:`deriving-via` for more information. + - GHC now permits the use of a wildcard type as the context of a standalone ``deriving`` declaration with the use of the :extension:`PartialTypeSignatures` language extension. For instance, this diff --git a/docs/users_guide/glasgow_exts.rst b/docs/users_guide/glasgow_exts.rst index 9395cbbe55..95b2256b3a 100644 --- a/docs/users_guide/glasgow_exts.rst +++ b/docs/users_guide/glasgow_exts.rst @@ -4102,7 +4102,7 @@ causes the generated code to be ill-typed. As a general rule, if a data type has a derived ``Functor`` instance and its last type parameter occurs on the right-hand side of the data declaration, then -either it must (1) occur bare (e.g., ``newtype Id a = a``), or (2) occur as the +either it must (1) occur bare (e.g., ``newtype Id a = Id a``), or (2) occur as the last argument of a type constructor (as in ``Right`` above). There are two exceptions to this rule: @@ -4613,6 +4613,9 @@ It is particularly galling that, since the constructor doesn't appear at run-time, this instance declaration defines a dictionary which is *wholly equivalent* to the ``Int`` dictionary, only slower! +:extension:`DerivingVia` (see :ref:`deriving-via`) is a generalization of +this idea. + .. _generalized-newtype-deriving: Generalising the deriving clause @@ -4940,6 +4943,11 @@ isn't sophisticated enough to determine this, so you'll need to enable you do go down this route, make sure you can convince yourself that all of the type family instances you're deriving will eventually terminate if used! +Note that :extension:`DerivingVia` (see :ref:`deriving-via`) uses essentially +the same specification to derive instances of associated type families as well +(except that it uses the ``via`` type instead of the underlying ``rep-type`` +of a newtype). + .. _derive-any-class: Deriving any other class @@ -5143,10 +5151,12 @@ Currently, the deriving strategies are: - ``stock``: Have GHC implement a "standard" instance for a data type, if possible (e.g., ``Eq``, ``Ord``, ``Generic``, ``Data``, ``Functor``, etc.) -- ``anyclass``: Use :extension:`DeriveAnyClass` +- ``anyclass``: Use :extension:`DeriveAnyClass` (see :ref:`derive-any-class`) - ``newtype``: Use :extension:`GeneralizedNewtypeDeriving` + (see :ref:`newtype-deriving`) +- ``via``: Use :extension:`DerivingVia` (see :ref:`deriving-via`) .. _default-deriving-strategy: @@ -5180,6 +5190,118 @@ In that case, GHC chooses the strategy as follows: user is warned about the ambiguity. The warning can be avoided by explicitly stating the desired deriving strategy. +.. _deriving-via: + +Deriving via +------------ + +.. extension:: DerivingVia + :shortdesc: Enable deriving instances ``via`` types of the same runtime + representation. + Implies :extension:`DerivingStrategies`. + + :implies: :extension:`DerivingStrategies` + + :since: 8.6.1 + +This allows ``deriving`` a class instance for a type by specifying +another type of equal runtime representation (such that there exists a +``Coercible`` instance between the two: see :ref:`coercible`) that is +already an instance of the that class. + +:extension:`DerivingVia` is indicated by the use of the ``via`` +deriving strategy. ``via`` requires specifying another type (the ``via`` type) +to ``coerce`` through. For example, this code: :: + + {-# LANGUAGE DerivingVia #-} + + import Numeric + + newtype Hex a = Hex a + + instance (Integral a, Show a) => Show (Hex a) where + show (Hex a) = "0x" ++ showHex a "" + + newtype Unicode = U Int + deriving Show + via (Hex Int) + + -- >>> euroSign + -- 0x20ac + euroSign :: Unicode + euroSign = U 0x20ac + +Generates the following instance :: + + instance Show Unicode where + show :: Unicode -> String + show = Data.Coerce.coerce + @(Hex Int -> String) + @(Unicode -> String) + show + +This extension generalizes :extension:`GeneralizedNewtypeDeriving`. To +derive ``Num Unicode`` with GND (``deriving newtype Num``) it must +reuse the ``Num Int`` instance. With ``DerivingVia``, we can explicitly +specify the representation type ``Int``: :: + + newtype Unicode = U Int + deriving Num + via Int + + deriving Show + via (Hex Int) + + euroSign :: Unicode + euroSign = 0x20ac + +Code duplication is common in instance declarations. A familiar +pattern is lifting operations over an ``Applicative`` functor. +Instead of having catch-all instances for ``f a`` which overlap +with all other such instances, like so: :: + + instance (Applicative f, Semigroup a) => Semigroup (f a) .. + instance (Applicative f, Monoid a) => Monoid (f a) .. + +We can instead create a newtype ``App`` +(where ``App f a`` and ``f a`` are represented the same in memory) +and use :extension:`DerivingVia` to explicitly enable uses of this +pattern: :: + + {-# LANGUAGE DerivingVia, DeriveFunctor, GeneralizedNewtypeDeriving #-} + + import Control.Applicative + + newtype App f a = App (f a) deriving newtype (Functor, Applicative) + + instance (Applicative f, Semigroup a) => Semigroup (App f a) where + (<>) = liftA2 (<>) + + instance (Applicative f, Monoid a) => Monoid (App f a) where + mempty = pure mempty + + data Pair a = MkPair a a + deriving stock + Functor + + deriving (Semigroup, Monoid) + via (App Pair a) + + instance Applicative Pair where + pure a = MkPair a a + + MkPair f g <*> MkPair a b = MkPair (f a) (g b) + +Note that the ``via`` type does not have to be a ``newtype``. +The only restriction is that it is coercible with the +original data type. This means there can be arbitrary nesting of newtypes, +as in the following example: :: + + newtype Kleisli m a b = (a -> m b) + deriving (Semigroup, Monoid) + via (a -> App m b) + +Here we make use of the ``Monoid ((->) a)`` instance. .. _pattern-synonyms: @@ -9116,7 +9238,7 @@ variables. These variables may depend on each other, even in the same the body of the ``forall``. Here are some examples:: data Proxy k (a :: k) = MkProxy -- just to use below - + f :: forall k a. Proxy k a -- This is just fine. We see that (a :: k). f = undefined @@ -15694,7 +15816,7 @@ Roles single: roles Using :extension:`GeneralizedNewtypeDeriving` -(:ref:`generalized-newtype-deriving`), a programmer can take existing +(:ref:`newtype-deriving`), a programmer can take existing instances of classes and "lift" these into instances of that class for a newtype. However, this is not always safe. For example, consider the following: diff --git a/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs b/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs index e98c871ce4..518491783f 100644 --- a/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs +++ b/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs @@ -82,6 +82,7 @@ data Extension | DeriveAnyClass -- Allow deriving any class | DeriveLift -- Allow deriving Lift | DerivingStrategies + | DerivingVia -- Derive through equal representation | TypeSynonymInstances | FlexibleContexts diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib.hs b/libraries/template-haskell/Language/Haskell/TH/Lib.hs index dbf01f11df..b7966cefac 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Lib.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Lib.hs @@ -21,7 +21,7 @@ module Language.Haskell.TH.Lib ( StmtQ, RangeQ, SourceStrictnessQ, SourceUnpackednessQ, BangQ, BangTypeQ, VarBangTypeQ, StrictTypeQ, VarStrictTypeQ, FieldExpQ, PatQ, FieldPatQ, RuleBndrQ, TySynEqnQ, PatSynDirQ, PatSynArgsQ, - FamilyResultSigQ, + FamilyResultSigQ, DerivStrategyQ, -- ** Constructors lifted to 'Q' -- *** Literals @@ -79,7 +79,9 @@ module Language.Haskell.TH.Lib ( -- *** Top Level Declarations -- **** Data valD, funD, tySynD, dataD, newtypeD, - derivClause, DerivClause(..), DerivStrategy(..), + derivClause, DerivClause(..), + stockStrategy, anyclassStrategy, newtypeStrategy, + viaStrategy, DerivStrategy(..), -- **** Class classD, instanceD, instanceWithOverlapD, Overlap(..), sigD, standaloneDerivD, standaloneDerivWithStrategyD, defaultSigD, @@ -140,6 +142,9 @@ import Language.Haskell.TH.Lib.Internal hiding , kindSig , tyVarSig + , derivClause + , standaloneDerivWithStrategyD + , Role , InjectivityAnn ) @@ -262,3 +267,17 @@ kindSig = KindSig tyVarSig :: TyVarBndr -> FamilyResultSig tyVarSig = TyVarSig + +------------------------------------------------------------------------------- +-- * Top Level Declarations + +derivClause :: Maybe DerivStrategy -> [PredQ] -> DerivClauseQ +derivClause mds p = do + p' <- cxt p + return $ DerivClause mds p' + +standaloneDerivWithStrategyD :: Maybe DerivStrategy -> CxtQ -> TypeQ -> DecQ +standaloneDerivWithStrategyD mds ctxt ty = do + ctxt' <- ctxt + ty' <- ty + return $ StandaloneDerivD mds ctxt' ty' diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs index 4496ecda25..cac8ea8643 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs @@ -57,6 +57,7 @@ type TySynEqnQ = Q TySynEqn type PatSynDirQ = Q PatSynDir type PatSynArgsQ = Q PatSynArgs type FamilyResultSigQ = Q FamilyResultSig +type DerivStrategyQ = Q DerivStrategy -- must be defined here for DsMeta to find it type Role = TH.Role @@ -533,12 +534,13 @@ roleAnnotD name roles = return $ RoleAnnotD name roles standaloneDerivD :: CxtQ -> TypeQ -> DecQ standaloneDerivD = standaloneDerivWithStrategyD Nothing -standaloneDerivWithStrategyD :: Maybe DerivStrategy -> CxtQ -> TypeQ -> DecQ -standaloneDerivWithStrategyD ds ctxtq tyq = +standaloneDerivWithStrategyD :: Maybe DerivStrategyQ -> CxtQ -> TypeQ -> DecQ +standaloneDerivWithStrategyD mdsq ctxtq tyq = do + mds <- sequenceA mdsq ctxt <- ctxtq ty <- tyq - return $ StandaloneDerivD ds ctxt ty + return $ StandaloneDerivD mds ctxt ty defaultSigD :: Name -> TypeQ -> DecQ defaultSigD n tyq = @@ -570,9 +572,22 @@ tySynEqn lhs rhs = cxt :: [PredQ] -> CxtQ cxt = sequence -derivClause :: Maybe DerivStrategy -> [PredQ] -> DerivClauseQ -derivClause ds p = do p' <- cxt p - return $ DerivClause ds p' +derivClause :: Maybe DerivStrategyQ -> [PredQ] -> DerivClauseQ +derivClause mds p = do mds' <- sequenceA mds + p' <- cxt p + return $ DerivClause mds' p' + +stockStrategy :: DerivStrategyQ +stockStrategy = pure StockStrategy + +anyclassStrategy :: DerivStrategyQ +anyclassStrategy = pure AnyclassStrategy + +newtypeStrategy :: DerivStrategyQ +newtypeStrategy = pure NewtypeStrategy + +viaStrategy :: TypeQ -> DerivStrategyQ +viaStrategy = fmap ViaStrategy normalC :: Name -> [BangTypeQ] -> ConQ normalC con strtys = liftM (NormalC con) $ sequence strtys diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs index 46f4dc0444..7edc15c696 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs @@ -388,11 +388,12 @@ ppr_dec _ (PatSynSigD name ty) = pprPatSynSig name ty ppr_deriv_strategy :: DerivStrategy -> Doc -ppr_deriv_strategy ds = text $ +ppr_deriv_strategy ds = case ds of - StockStrategy -> "stock" - AnyclassStrategy -> "anyclass" - NewtypeStrategy -> "newtype" + StockStrategy -> text "stock" + AnyclassStrategy -> text "anyclass" + NewtypeStrategy -> text "newtype" + ViaStrategy ty -> text "via" <+> pprParendType ty ppr_overlap :: Overlap -> Doc ppr_overlap o = text $ @@ -452,8 +453,16 @@ ppr_newtype maybeInst ctxt t argsDoc ksig c decs ppr_deriv_clause :: DerivClause -> Doc ppr_deriv_clause (DerivClause ds ctxt) - = text "deriving" <+> maybe empty ppr_deriv_strategy ds + = text "deriving" <+> pp_strat_before <+> ppr_cxt_preds ctxt + <+> pp_strat_after + where + -- @via@ is unique in that in comes /after/ the class being derived, + -- so we must special-case it. + (pp_strat_before, pp_strat_after) = + case ds of + Just (via@ViaStrategy{}) -> (empty, ppr_deriv_strategy via) + _ -> (maybe empty ppr_deriv_strategy ds, empty) ppr_tySyn :: Doc -> Name -> Doc -> Type -> Doc ppr_tySyn maybeInst t argsDoc rhs diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs index 3a3cf60349..95ece50bcc 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs @@ -1743,6 +1743,7 @@ data DerivClause = DerivClause (Maybe DerivStrategy) Cxt data DerivStrategy = StockStrategy -- ^ A \"standard\" derived instance | AnyclassStrategy -- ^ @-XDeriveAnyClass@ | NewtypeStrategy -- ^ @-XGeneralizedNewtypeDeriving@ + | ViaStrategy Type -- ^ @-XDerivingVia@ deriving( Show, Eq, Ord, Data, Generic ) -- | A Pattern synonym's type. Note that a pattern synonym's *fully* diff --git a/libraries/template-haskell/changelog.md b/libraries/template-haskell/changelog.md index 41b7eea26c..f60bb6ec52 100644 --- a/libraries/template-haskell/changelog.md +++ b/libraries/template-haskell/changelog.md @@ -16,6 +16,8 @@ `qAddTempFile` method to `Quasi`, which requests a temporary file of a given suffix. + * Add a `ViaStrategy` constructor to `DerivStrategy`. + ## 2.13.0.0 *March 2018* * Bundled with GHC 8.4.1 diff --git a/testsuite/tests/deriving/should_compile/all.T b/testsuite/tests/deriving/should_compile/all.T index 0e0494f7e2..61b888ea01 100644 --- a/testsuite/tests/deriving/should_compile/all.T +++ b/testsuite/tests/deriving/should_compile/all.T @@ -36,6 +36,8 @@ test('T5939', normal, compile, ['']) test('drv-functor1', normal, compile, ['']) test('drv-functor2', normal, compile, ['']) test('drv-foldable-traversable1', normal, compile, ['']) +test('deriving-via-compile', normal, compile, ['']) +test('deriving-via-standalone', normal, compile, ['']) test('T6031', [], multimod_compile, ['T6031', '-v0 -O']) # Adding -O on T6031 to expose Trac #11245 regardless of way test('T1133', [], run_command, ['$MAKE --no-print-directory -s T1133']) diff --git a/testsuite/tests/deriving/should_compile/deriving-via-compile.hs b/testsuite/tests/deriving/should_compile/deriving-via-compile.hs new file mode 100644 index 0000000000..b679acb8cd --- /dev/null +++ b/testsuite/tests/deriving/should_compile/deriving-via-compile.hs @@ -0,0 +1,459 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +module DerivingViaCompile where + +import Data.Void +import Data.Complex +import Data.Functor.Const +import Data.Functor.Identity +import Data.Ratio +import Control.Monad.Reader +import Control.Monad.State +import Control.Monad.Writer +import Control.Applicative hiding (WrappedMonad(..)) + +import Data.Bifunctor +import Data.Monoid +import Data.Kind + +type f ~> g = forall xx. f xx -> g xx + +----- +-- Simple example +----- + +data Foo a = MkFoo a a + deriving Show + via (Identity (Foo a)) + +----- +-- Eta reduction at work +----- + +newtype Flip p a b = Flip { runFlip :: p b a } + +instance Bifunctor p => Bifunctor (Flip p) where + bimap f g = Flip . bimap g f . runFlip + +instance Bifunctor p => Functor (Flip p a) where + fmap f = Flip . first f . runFlip + +newtype Bar a = MkBar (Either a Int) + deriving Functor + via (Flip Either Int) + +----- +-- Monad transformers +----- + +type MTrans = (Type -> Type) -> (Type -> Type) + +-- From `constraints' +data Dict c where + Dict :: c => Dict c + +newtype a :- b = Sub (a => Dict b) + +infixl 1 \\ +(\\) :: a => (b => r) -> (a :- b) -> r +r \\ Sub Dict = r + +-- With `-XQuantifiedConstraints' this just becomes +-- +-- type Lifting cls trans = forall mm. cls mm => cls (trans mm) +-- +-- type LiftingMonad trans = Lifting Monad trans +-- +class LiftingMonad (trans :: MTrans) where + proof :: Monad m :- Monad (trans m) + +instance LiftingMonad (StateT s :: MTrans) where + proof :: Monad m :- Monad (StateT s m) + proof = Sub Dict + +instance Monoid w => LiftingMonad (WriterT w :: MTrans) where + proof :: Monad m :- Monad (WriterT w m) + proof = Sub Dict + +instance (LiftingMonad trans, LiftingMonad trans') => LiftingMonad (ComposeT trans trans' :: MTrans) where + proof :: forall m. Monad m :- Monad (ComposeT trans trans' m) + proof = Sub (Dict \\ proof @trans @(trans' m) \\ proof @trans' @m) + +newtype Stack :: MTrans where + Stack :: ReaderT Int (StateT Bool (WriterT String m)) a -> Stack m a + deriving newtype + ( Functor + , Applicative + , Monad + , MonadReader Int + , MonadState Bool + , MonadWriter String + ) + deriving (MonadTrans, MFunctor) + via (ReaderT Int `ComposeT` StateT Bool `ComposeT` WriterT String) + +class MFunctor (trans :: MTrans) where + hoist :: Monad m => (m ~> m') -> (trans m ~> trans m') + +instance MFunctor (ReaderT r :: MTrans) where + hoist :: Monad m => (m ~> m') -> (ReaderT r m ~> ReaderT r m') + hoist nat = ReaderT . fmap nat . runReaderT + +instance MFunctor (StateT s :: MTrans) where + hoist :: Monad m => (m ~> m') -> (StateT s m ~> StateT s m') + hoist nat = StateT . fmap nat . runStateT + +instance MFunctor (WriterT w :: MTrans) where + hoist :: Monad m => (m ~> m') -> (WriterT w m ~> WriterT w m') + hoist nat = WriterT . nat . runWriterT + +infixr 9 `ComposeT` +newtype ComposeT :: MTrans -> MTrans -> MTrans where + ComposeT :: { getComposeT :: f (g m) a } -> ComposeT f g m a + deriving newtype (Functor, Applicative, Monad) + +instance (MonadTrans f, MonadTrans g, LiftingMonad g) => MonadTrans (ComposeT f g) where + lift :: forall m. Monad m => m ~> ComposeT f g m + lift = ComposeT . lift . lift + \\ proof @g @m + +instance (MFunctor f, MFunctor g, LiftingMonad g) => MFunctor (ComposeT f g) where + hoist :: forall m m'. Monad m => (m ~> m') -> (ComposeT f g m ~> ComposeT f g m') + hoist f = ComposeT . hoist (hoist f) . getComposeT + \\ proof @g @m + +----- +-- Using tuples in a `via` type +----- + +newtype X a = X (a, a) + deriving (Semigroup, Monoid) + via (Product a, Sum a) + + deriving (Show, Eq) + via (a, a) + +----- +-- Abstract data types +----- + +class C f where + c :: f a -> Int + +newtype X2 f a = X2 (f a) + +instance C (X2 f) where + c = const 0 + +deriving via (X2 IO) instance C IO + +---- +-- Testing parser +---- + +newtype P0 a = P0 a deriving Show via a +newtype P1 a = P1 [a] deriving Show via [a] +newtype P2 a = P2 (a, a) deriving Show via (a, a) +newtype P3 a = P3 (Maybe a) deriving Show via (First a) +newtype P4 a = P4 (Maybe a) deriving Show via (First $ a) +newtype P5 a = P5 a deriving Show via (Identity $ a) +newtype P6 a = P6 [a] deriving Show via ([] $ a) +newtype P7 a = P7 (a, a) deriving Show via (Identity $ (a, a)) +newtype P8 a = P8 (Either () a) deriving Functor via (($) (Either ())) + +newtype f $ a = APP (f a) deriving newtype Show deriving newtype Functor + +---- +-- From Baldur's notes +---- + +---- +-- 1 +---- +newtype WrapApplicative f a = WrappedApplicative (f a) + deriving (Functor, Applicative) + +instance (Applicative f, Num a) => Num (WrapApplicative f a) where + (+) = liftA2 (+) + (*) = liftA2 (*) + negate = fmap negate + fromInteger = pure . fromInteger + abs = fmap abs + signum = fmap signum + +instance (Applicative f, Fractional a) => Fractional (WrapApplicative f a) where + recip = fmap recip + fromRational = pure . fromRational + +instance (Applicative f, Floating a) => Floating (WrapApplicative f a) where + pi = pure pi + sqrt = fmap sqrt + exp = fmap exp + log = fmap log + sin = fmap sin + cos = fmap cos + asin = fmap asin + atan = fmap atan + acos = fmap acos + sinh = fmap sinh + cosh = fmap cosh + asinh = fmap asinh + atanh = fmap atanh + acosh = fmap acosh + +instance (Applicative f, Semigroup s) => Semigroup (WrapApplicative f s) where + (<>) = liftA2 (<>) + +instance (Applicative f, Monoid m) => Monoid (WrapApplicative f m) where + mempty = pure mempty + +---- +-- 2 +---- +class Pointed p where + pointed :: a -> p a + +newtype WrapMonad f a = WrappedMonad (f a) + deriving newtype (Pointed, Monad) + +instance (Monad m, Pointed m) => Functor (WrapMonad m) where + fmap = liftM + +instance (Monad m, Pointed m) => Applicative (WrapMonad m) where + pure = pointed + (<*>) = ap + +-- data +data Sorted a = Sorted a a a + deriving (Functor, Applicative) + via (WrapMonad Sorted) + deriving (Num, Fractional, Floating, Semigroup, Monoid) + via (WrapApplicative Sorted a) + + +instance Monad Sorted where + (>>=) :: Sorted a -> (a -> Sorted b) -> Sorted b + Sorted a b c >>= f = Sorted a' b' c' where + Sorted a' _ _ = f a + Sorted _ b' _ = f b + Sorted _ _ c' = f c + +instance Pointed Sorted where + pointed :: a -> Sorted a + pointed a = Sorted a a a + +---- +-- 3 +---- +class IsZero a where + isZero :: a -> Bool + +newtype WrappedNumEq a = WrappedNumEq a +newtype WrappedShow a = WrappedShow a +newtype WrappedNumEq2 a = WrappedNumEq2 a + +instance (Num a, Eq a) => IsZero (WrappedNumEq a) where + isZero :: WrappedNumEq a -> Bool + isZero (WrappedNumEq a) = 0 == a + +instance Show a => IsZero (WrappedShow a) where + isZero :: WrappedShow a -> Bool + isZero (WrappedShow a) = "0" == show a + +instance (Num a, Eq a) => IsZero (WrappedNumEq2 a) where + isZero :: WrappedNumEq2 a -> Bool + isZero (WrappedNumEq2 a) = a + a == a + +newtype INT = INT Int + deriving newtype Show + deriving IsZero via (WrappedNumEq Int) + +newtype VOID = VOID Void deriving IsZero via (WrappedShow Void) + +---- +-- 4 +---- +class Bifunctor p => Biapplicative p where + bipure :: a -> b -> p a b + + biliftA2 + :: (a -> b -> c) + -> (a' -> b' -> c') + -> p a a' + -> p b b' + -> p c c' + +instance Biapplicative (,) where + bipure = (,) + + biliftA2 f f' (a, a') (b, b') = + (f a b, f' a' b') + +newtype WrapBiapp p a b = WrapBiap (p a b) + deriving newtype (Bifunctor, Biapplicative, Eq) + +instance (Biapplicative p, Num a, Num b) => Num (WrapBiapp p a b) where + (+) = biliftA2 (+) (+) + (-) = biliftA2 (*) (*) + (*) = biliftA2 (*) (*) + negate = bimap negate negate + abs = bimap abs abs + signum = bimap signum signum + fromInteger n = fromInteger n `bipure` fromInteger n + +newtype INT2 = INT2 (Int, Int) + deriving IsZero via (WrappedNumEq2 (WrapBiapp (,) Int Int)) + +---- +-- 5 +---- +class Monoid a => MonoidNull a where + null :: a -> Bool + +newtype WrpMonNull a = WRM a deriving (Eq, Semigroup, Monoid) + +instance (Eq a, Monoid a) => MonoidNull (WrpMonNull a) where + null :: WrpMonNull a -> Bool + null = (== mempty) + +deriving via (WrpMonNull Any) instance MonoidNull Any +deriving via () instance MonoidNull () +deriving via Ordering instance MonoidNull Ordering + +---- +-- 6 +---- +-- https://github.com/mikeizbicki/subhask/blob/f53fd8f465747681c88276c7dabe3646fbdf7d50/src/SubHask/Algebra.hs#L635 + +class Lattice a where + sup :: a -> a -> a + (.>=) :: a -> a -> Bool + (.>) :: a -> a -> Bool + +newtype WrapOrd a = WrappedOrd a + deriving newtype (Eq, Ord) + +instance Ord a => Lattice (WrapOrd a) where + sup = max + (.>=) = (>=) + (.>) = (>) + +deriving via [a] instance Ord a => Lattice [a] +deriving via (a, b) instance (Ord a, Ord b) => Lattice (a, b) +--mkLattice_(Bool) +deriving via Bool instance Lattice Bool +--mkLattice_(Char) +deriving via Char instance Lattice Char +--mkLattice_(Int) +deriving via Int instance Lattice Int +--mkLattice_(Integer) +deriving via Integer instance Lattice Integer +--mkLattice_(Float) +deriving via Float instance Lattice Float +--mkLattice_(Double) +deriving via Double instance Lattice Double +--mkLattice_(Rational) +deriving via Rational instance Lattice Rational + +---- +-- 7 +---- +-- https://hackage.haskell.org/package/linear-1.20.7/docs/src/Linear-Affine.html + +class Functor f => Additive f where + zero :: Num a => f a + (^+^) :: Num a => f a -> f a -> f a + (^+^) = liftU2 (+) + (^-^) :: Num a => f a -> f a -> f a + x ^-^ y = x ^+^ fmap negate y + liftU2 :: (a -> a -> a) -> f a -> f a -> f a + +instance Additive [] where + zero = [] + liftU2 f = go where + go (x:xs) (y:ys) = f x y : go xs ys + go [] ys = ys + go xs [] = xs + +instance Additive Maybe where + zero = Nothing + liftU2 f (Just a) (Just b) = Just (f a b) + liftU2 _ Nothing ys = ys + liftU2 _ xs Nothing = xs + +instance Applicative f => Additive (WrapApplicative f) where + zero = pure 0 + liftU2 = liftA2 + +deriving via (WrapApplicative ((->) a)) instance Additive ((->) a) +deriving via (WrapApplicative Complex) instance Additive Complex +deriving via (WrapApplicative Identity) instance Additive Identity + +instance Additive ZipList where + zero = ZipList [] + liftU2 f (ZipList xs) (ZipList ys) = ZipList (liftU2 f xs ys) + +class Additive (Diff p) => Affine p where + type Diff p :: Type -> Type + + (.-.) :: Num a => p a -> p a -> Diff p a + (.+^) :: Num a => p a -> Diff p a -> p a + (.-^) :: Num a => p a -> Diff p a -> p a + p .-^ v = p .+^ fmap negate v + +-- #define ADDITIVEC(CTX,T) instance CTX => Affine T where type Diff T = T ; \ +-- (.-.) = (^-^) ; {-# INLINE (.-.) #-} ; (.+^) = (^+^) ; {-# INLINE (.+^) #-} ; \ +-- (.-^) = (^-^) ; {-# INLINE (.-^) #-} +-- #define ADDITIVE(T) ADDITIVEC((), T) +newtype WrapAdditive f a = WrappedAdditive (f a) + +instance Additive f => Affine (WrapAdditive f) where + type Diff (WrapAdditive f) = f + + WrappedAdditive a .-. WrappedAdditive b = a ^-^ b + WrappedAdditive a .+^ b = WrappedAdditive (a ^+^ b) + WrappedAdditive a .-^ b = WrappedAdditive (a ^-^ b) + +-- ADDITIVE(((->) a)) +deriving via (WrapAdditive ((->) a)) instance Affine ((->) a) +-- ADDITIVE([]) +deriving via (WrapAdditive []) instance Affine [] +-- ADDITIVE(Complex) +deriving via (WrapAdditive Complex) instance Affine Complex +-- ADDITIVE(Maybe) +deriving via (WrapAdditive Maybe) instance Affine Maybe +-- ADDITIVE(ZipList) +deriving via (WrapAdditive ZipList) instance Affine ZipList +-- ADDITIVE(Identity) +deriving via (WrapAdditive Identity) instance Affine Identity + +---- +-- 8 +---- + +class C2 a b c where + c2 :: a -> b -> c + +instance C2 a b (Const a b) where + c2 x _ = Const x + +newtype Fweemp a = Fweemp a + deriving (C2 a b) + via (Const a (b :: Type)) diff --git a/testsuite/tests/deriving/should_compile/deriving-via-standalone.hs b/testsuite/tests/deriving/should_compile/deriving-via-standalone.hs new file mode 100644 index 0000000000..0fa71d7e36 --- /dev/null +++ b/testsuite/tests/deriving/should_compile/deriving-via-standalone.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} +module DerivingViaStandalone where + +import Control.Applicative +import Data.Functor.Compose +import Data.Proxy +import Data.Semigroup + +newtype App (f :: * -> *) a = App (f a) + deriving newtype + (Functor, Applicative) + +instance (Applicative f, Semigroup a) => Semigroup (App f a) where + (<>) = liftA2 (<>) + +deriving via (App (Compose (f :: * -> *) g) a) + instance (Applicative f, Applicative g, Semigroup a) + => Semigroup (Compose f g a) + +class C (a :: k -> *) +instance C Proxy + +newtype MyProxy a = MyProxy (Proxy a) +deriving via (Proxy :: * -> *) instance C MyProxy + +class Z a b +data T a +data X1 a +data X2 a +data X3 a + +deriving via (forall a. T a) instance Z a (X1 b) +deriving via (T a) instance forall b. Z a (X2 b) +deriving via (forall a. T a) instance forall b. Z a (X3 b) diff --git a/testsuite/tests/deriving/should_fail/all.T b/testsuite/tests/deriving/should_fail/all.T index f1d8261e4b..0cc85ea4aa 100644 --- a/testsuite/tests/deriving/should_fail/all.T +++ b/testsuite/tests/deriving/should_fail/all.T @@ -74,3 +74,7 @@ test('T14728b', normal, compile_fail, ['']) test('T14916', normal, compile_fail, ['']) test('T15073', [extra_files(['T15073a.hs'])], multimod_compile_fail, ['T15073', '-v0']) +test('deriving-via-fail', normal, compile_fail, ['']) +test('deriving-via-fail2', normal, compile_fail, ['']) +test('deriving-via-fail3', normal, compile_fail, ['']) +test('deriving-via-fail4', normal, compile_fail, ['']) diff --git a/testsuite/tests/deriving/should_fail/deriving-via-fail.hs b/testsuite/tests/deriving/should_fail/deriving-via-fail.hs new file mode 100644 index 0000000000..fbae1e7d13 --- /dev/null +++ b/testsuite/tests/deriving/should_fail/deriving-via-fail.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +module DerivingViaFail where + +import Control.Category +import Data.Functor.Identity + +newtype Foo1 a = Foo1 a deriving Show via (Identity b) + +newtype Foo2 a b = Foo2 (a -> b) + deriving Category + via fooo + +data Foo3 deriving Eq via (forall a. a) + +newtype Foo4 a = Foo4 a +deriving via (Identity b) + instance Show (Foo4 a) diff --git a/testsuite/tests/deriving/should_fail/deriving-via-fail.stderr b/testsuite/tests/deriving/should_fail/deriving-via-fail.stderr new file mode 100644 index 0000000000..51907e02cf --- /dev/null +++ b/testsuite/tests/deriving/should_fail/deriving-via-fail.stderr @@ -0,0 +1,16 @@ + +deriving-via-fail.hs:9:34: error: + Type variable ‘b’ is bound in the ‘via’ type ‘(Identity b)’ + but is not mentioned in the derived class ‘Show’, which is illegal + +deriving-via-fail.hs:12:12: error: + Type variable ‘fooo’ is bound in the ‘via’ type ‘fooo’ + but is not mentioned in the derived class ‘Category’, which is illegal + +deriving-via-fail.hs:15:20: error: + Type variable ‘a’ is bound in the ‘via’ type ‘(forall a. a)’ + but is not mentioned in the derived class ‘Eq’, which is illegal + +deriving-via-fail.hs:19:12: error: + Type variable ‘b’ is bound in the ‘via’ type ‘(Identity b)’ + but is not mentioned in the derived instance ‘Show (Foo4 a)’, which is illegal diff --git a/testsuite/tests/deriving/should_fail/deriving-via-fail2.hs b/testsuite/tests/deriving/should_fail/deriving-via-fail2.hs new file mode 100644 index 0000000000..e9a456d048 --- /dev/null +++ b/testsuite/tests/deriving/should_fail/deriving-via-fail2.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE StandaloneDeriving #-} +module DerivingViaFail2 where + +class C a +data A = A +deriving via Maybe instance C A diff --git a/testsuite/tests/deriving/should_fail/deriving-via-fail2.stderr b/testsuite/tests/deriving/should_fail/deriving-via-fail2.stderr new file mode 100644 index 0000000000..d5692ad6b2 --- /dev/null +++ b/testsuite/tests/deriving/should_fail/deriving-via-fail2.stderr @@ -0,0 +1,6 @@ + +deriving-via-fail2.hs:7:1: error: + • Cannot derive instance via ‘Maybe’ + Class ‘C’ expects an argument of kind ‘*’, + but ‘Maybe’ has kind ‘* -> *’ + • In the stand-alone deriving instance for ‘C A’ diff --git a/testsuite/tests/deriving/should_fail/deriving-via-fail3.hs b/testsuite/tests/deriving/should_fail/deriving-via-fail3.hs new file mode 100644 index 0000000000..ad8e0be542 --- /dev/null +++ b/testsuite/tests/deriving/should_fail/deriving-via-fail3.hs @@ -0,0 +1,3 @@ +module DerivingViaFail3 where + +data F deriving Eq via F diff --git a/testsuite/tests/deriving/should_fail/deriving-via-fail3.stderr b/testsuite/tests/deriving/should_fail/deriving-via-fail3.stderr new file mode 100644 index 0000000000..f2af73a01f --- /dev/null +++ b/testsuite/tests/deriving/should_fail/deriving-via-fail3.stderr @@ -0,0 +1,4 @@ + +deriving-via-fail3.hs:3:1: error: + Illegal deriving strategy: via + Use DerivingVia to enable this extension diff --git a/testsuite/tests/deriving/should_fail/deriving-via-fail4.hs b/testsuite/tests/deriving/should_fail/deriving-via-fail4.hs new file mode 100644 index 0000000000..1436d994c0 --- /dev/null +++ b/testsuite/tests/deriving/should_fail/deriving-via-fail4.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +module DerivingViaFail4 where + +class C a b where + c :: a -> b -> Bool + +instance C a a where + c _ _ = True + +newtype F1 = F1 Int + deriving Eq via Char + +newtype F2 a = MkF2 a + deriving (C a) via (forall a. a) diff --git a/testsuite/tests/deriving/should_fail/deriving-via-fail4.stderr b/testsuite/tests/deriving/should_fail/deriving-via-fail4.stderr new file mode 100644 index 0000000000..caa2bfe93b --- /dev/null +++ b/testsuite/tests/deriving/should_fail/deriving-via-fail4.stderr @@ -0,0 +1,18 @@ + +deriving-via-fail4.hs:14:12: error: + • Couldn't match representation of type ‘Int’ with that of ‘Char’ + arising from the coercion of the method ‘==’ + from type ‘Char -> Char -> Bool’ to type ‘F1 -> F1 -> Bool’ + • When deriving the instance for (Eq F1) + +deriving-via-fail4.hs:17:13: error: + • Couldn't match representation of type ‘a1’ with that of ‘a’ + arising from the coercion of the method ‘c’ + from type ‘a -> a -> Bool’ to type ‘a -> F2 a1 -> Bool’ + ‘a1’ is a rigid type variable bound by + the deriving clause for ‘C a (F2 a1)’ + at deriving-via-fail4.hs:17:13-15 + ‘a’ is a rigid type variable bound by + the deriving clause for ‘C a (F2 a1)’ + at deriving-via-fail4.hs:17:13-15 + • When deriving the instance for (C a (F2 a1)) diff --git a/testsuite/tests/driver/T4437.hs b/testsuite/tests/driver/T4437.hs index 5ea91b47d6..24a46384e6 100644 --- a/testsuite/tests/driver/T4437.hs +++ b/testsuite/tests/driver/T4437.hs @@ -39,6 +39,7 @@ expectedGhcOnlyExtensions :: [String] expectedGhcOnlyExtensions = ["RelaxedLayout", "AlternativeLayoutRule", "AlternativeLayoutRuleTransitional", + "DerivingVia", "EmptyDataDeriving", "GeneralisedNewtypeDeriving", "QuantifiedConstraints"] diff --git a/testsuite/tests/ghc-api/annotations/T10312.stdout b/testsuite/tests/ghc-api/annotations/T10312.stdout index 30879b3dd1..c7b25a7996 100644 --- a/testsuite/tests/ghc-api/annotations/T10312.stdout +++ b/testsuite/tests/ghc-api/annotations/T10312.stdout @@ -119,9 +119,9 @@ ((Test10312.hs:48:5-22,AnnComma), [Test10312.hs:49:3]), ((Test10312.hs:48:5-22,AnnDcolon), [Test10312.hs:48:14-15]), ((Test10312.hs:49:5-20,AnnDcolon), [Test10312.hs:49:15-16]), -((Test10312.hs:50:5-23,AnnCloseP), [Test10312.hs:50:23]), ((Test10312.hs:50:5-23,AnnDeriving), [Test10312.hs:50:5-12]), -((Test10312.hs:50:5-23,AnnOpenP), [Test10312.hs:50:14]), +((Test10312.hs:50:14-23,AnnCloseP), [Test10312.hs:50:23]), +((Test10312.hs:50:14-23,AnnOpenP), [Test10312.hs:50:14]), ((Test10312.hs:50:15-18,AnnComma), [Test10312.hs:50:19]), ((Test10312.hs:52:1-22,AnnDcolon), [Test10312.hs:52:9-10]), ((Test10312.hs:52:1-22,AnnSemi), [Test10312.hs:53:1]), diff --git a/utils/haddock b/utils/haddock -Subproject f77c9c5cc8bb669f584d36494630589ea80eb79 +Subproject 14110449370a77195093dd3f610ab869ab9e36c |