Commit 8ed8b037 authored by Ryan Scott's avatar Ryan Scott Committed by Ben Gamari

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
parent 85309a3c
......@@ -45,8 +45,6 @@ module BasicTypes(
TopLevelFlag(..), isTopLevel, isNotTopLevel,
DerivStrategy(..),
OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe,
hasOverlappingFlag, hasOverlappableFlag, hasIncoherentFlag,
......@@ -542,31 +540,6 @@ instance Outputable Origin where
ppr FromSource = text "FromSource"
ppr Generated = text "Generated"
{-
************************************************************************
* *
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"
{-
************************************************************************
* *
......
......@@ -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)
......
......@@ -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"
......
......@@ -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',
......@@ -1808,6 +1820,50 @@ instance (p ~ GhcPass pass, OutputableBndrId p)
, ppr ty ]
ppr (XDerivDecl x) = ppr x
{-
************************************************************************
* *
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"
{-
************************************************************************
* *
......
......@@ -384,6 +384,10 @@ type ForallXDerivDecl (c :: * -> Constraint) (x :: *) =
, c (XXDerivDecl x)
)
-- -------------------------------------
-- DerivStrategy type family
type family XViaStrategy x
-- -------------------------------------
-- DefaultDecl type families
type family XCDefaultDecl 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?
......
......@@ -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)
......
......@@ -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)
......
......@@ -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
......
......@@ -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),
......
This diff is collapsed.
......@@ -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
{-
************************************************************************
* *
......
......@@ -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
......
This diff is collapsed.
......@@ -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