Skip to content

Commit e482d80

Browse files
RyanGlScottmpickering
RyanGlScott
authored and
mpickering
committed
Add DerivingVia support
Addresses one part of #419.
1 parent 99876aa commit e482d80

16 files changed

+36005
-29
lines changed

Diff for: ‎src/Language/Haskell/Exts/ExactPrint.hs

+3
Original file line numberDiff line numberDiff line change
@@ -1211,6 +1211,9 @@ instance ExactP DerivStrategy where
12111211
printString "anyclass"
12121212
exactP (DerivNewtype _) =
12131213
printString "newtype"
1214+
exactP (DerivVia _ ty) = do
1215+
printString "via"
1216+
exactP ty
12141217

12151218
instance ExactP ClassDecl where
12161219
exactP cdecl = case cdecl of

Diff for: ‎src/Language/Haskell/Exts/Extension.hs

+4
Original file line numberDiff line numberDiff line change
@@ -552,6 +552,10 @@ data KnownExtension =
552552

553553
| StrictData
554554

555+
-- | Enable deriving instances via types of the same runtime representation.
556+
-- Implies 'DerivingStrategies'.
557+
| DerivingVia
558+
555559
deriving (Show, Read, Eq, Ord, Enum, Bounded, Data, Typeable)
556560

557561
-- | Certain extensions imply other extensions, and this function

Diff for: ‎src/Language/Haskell/Exts/InternalLexer.hs

+3
Original file line numberDiff line numberDiff line change
@@ -197,6 +197,7 @@ data Token
197197
| KW_Pattern
198198
| KW_Stock
199199
| KW_Anyclass
200+
| KW_Via
200201

201202
-- FFI
202203
| KW_Foreign
@@ -297,6 +298,7 @@ reserved_ids = [
297298
( "pattern", (KW_Pattern, Just (Any [PatternSynonyms]))),
298299
( "stock", (KW_Stock, Nothing)),
299300
( "anyclass", (KW_Anyclass, Nothing)),
301+
( "via", (KW_Via, Nothing)),
300302

301303
-- FFI
302304
( "foreign", (KW_Foreign, Just (Any [ForeignFunctionInterface])) )
@@ -1446,5 +1448,6 @@ showToken t = case t of
14461448
KW_Pattern -> "pattern"
14471449
KW_Stock -> "stock"
14481450
KW_Anyclass -> "anyclass"
1451+
KW_Via -> "via"
14491452

14501453
EOF -> "EOF"

Diff for: ‎src/Language/Haskell/Exts/InternalParser.ly

+30-14
Original file line numberDiff line numberDiff line change
@@ -260,6 +260,7 @@ Reserved Ids
260260
> 'pattern' { Loc $$ KW_Pattern }
261261
> 'stock' { Loc $$ KW_Stock } -- for DerivingStrategies extension
262262
> 'anyclass' { Loc $$ KW_Anyclass } -- for DerivingStrategies extension
263+
> 'via' { Loc $$ KW_Via } -- for DerivingStrategies extension
263264

264265
Pragmas
265266

@@ -648,7 +649,7 @@ This style requires both TypeFamilies and GADTs, the latter is handled in gadtli
648649
> return (InstDecl (nIS $1 <++> ann $3 <+?> minf <** ($1:ss)) $2 ih mis) } }
649650

650651
Requires the StandaloneDeriving extension enabled.
651-
> | 'deriving' deriv_strategy 'instance' optoverlap ctype
652+
> | 'deriving' deriv_standalone_strategy 'instance' optoverlap ctype
652653
> {% do { checkEnabled StandaloneDeriving ;
653654
> ih <- checkInstHeader $5;
654655
> let {l = nIS $1 <++> ann $5 <** [$1,$3]};
@@ -1220,22 +1221,28 @@ as qcon and then check separately that they are truly unqualified.
12201221
> | deriving { [$1] }
12211222

12221223
> deriving :: { Deriving L }
1223-
> : 'deriving' deriv_strategy qtycls1
1224-
> { let l = nIS $1 <++> ann $3 <** [$1] in Deriving l $2 [IRule (ann $3) Nothing Nothing $3] }
1225-
> | 'deriving' deriv_strategy '(' ')'
1226-
> { Deriving ($1 <^^> $4 <** [$1,$3,$4]) $2 [] }
1227-
> | 'deriving' deriv_strategy '(' dclasses ')'
1228-
> { -- Distinguish deriving (Show) from deriving Show (#189)
1229-
> case fst $4 of
1230-
> [ts] -> Deriving ($1 <^^> $5 <** [$1]) $2 [IParen ($3 <^^> $5 <** [$3,$5]) ts]
1231-
> tss -> Deriving ($1 <^^> $5 <** $1:$3: reverse (snd $4) ++ [$5]) $2 (reverse tss)}
1224+
> : 'deriving' deriv_clause_types
1225+
> { let (ihs, last_ss, sss) = $2
1226+
> in Deriving ($1 <^^> last_ss <** $1:sss) Nothing ihs }
1227+
> | 'deriving' deriv_strategy_no_via deriv_clause_types
1228+
> { let (ihs, last_ss, sss) = $3
1229+
> in Deriving ($1 <^^> last_ss <** $1:sss) (Just $2) ihs }
1230+
> | 'deriving' deriv_clause_types deriv_strategy_via
1231+
> { let (ihs, last_ss, sss) = $2
1232+
> in Deriving ($1 <^^> last_ss <** $1:sss) (Just $3) ihs }
12321233

12331234
> dclasses :: { ([InstRule L],[S]) }
12341235
> : types1 {% checkDeriving (fst $1) >>= \ds -> return (ds, snd $1) }
12351236

12361237
> qtycls1 :: { InstHead L }
12371238
> : qconid { IHCon (ann $1) $1 }
12381239

1240+
> deriv_clause_types :: { ([InstRule L], SrcSpan, [SrcSpan]) }
1241+
> : qtycls1 { [IRule (ann $1) Nothing Nothing $1], srcInfoSpan (ann $1), [] }
1242+
> | '(' ')' { [], $2, [$1, $2] }
1243+
> | '(' dclasses ')' { case fst $2 of
1244+
> [ts] -> ([IParen ($1 <^^> $3 <** [$1,$3]) ts], $3, [])
1245+
> tss -> (reverse tss, $3, $1: reverse (snd $2) ++ [$3]) }
12391246

12401247
-----------------------------------------------------------------------------
12411248
Kinds
@@ -2141,15 +2148,24 @@ Pattern Synonyms
21412148
-----------------------------------------------------------------------------
21422149
Deriving strategies
21432150

2144-
> deriv_strategy :: { Maybe (DerivStrategy L) }
2151+
> deriv_strategy_no_via :: { DerivStrategy L }
21452152
> : 'stock' {% do { checkEnabled DerivingStrategies
2146-
> ; return (Just (DerivStock (nIS $1))) } }
2153+
> ; return (DerivStock (nIS $1)) } }
21472154
> | 'anyclass' {% do { checkEnabled DerivingStrategies
21482155
> ; checkEnabled DeriveAnyClass
2149-
> ; return (Just (DerivAnyclass (nIS $1))) } }
2156+
> ; return (DerivAnyclass (nIS $1)) } }
21502157
> | 'newtype' {% do { checkEnabled DerivingStrategies
21512158
> ; checkEnabled GeneralizedNewtypeDeriving
2152-
> ; return (Just (DerivNewtype (nIS $1))) } }
2159+
> ; return (DerivNewtype (nIS $1)) } }
2160+
2161+
> deriv_strategy_via :: { DerivStrategy L }
2162+
> : 'via' truedtype {% do { checkEnabled DerivingVia
2163+
> ; checkEnabled DerivingStrategies
2164+
> ; return (DerivVia (nIS $1) $2) } }
2165+
2166+
> deriv_standalone_strategy :: { Maybe (DerivStrategy L) }
2167+
> : deriv_strategy_no_via { Just $1 }
2168+
> | deriv_strategy_via { Just $1 }
21532169
> | {- empty -} { Nothing }
21542170

21552171
-----------------------------------------------------------------------------

Diff for: ‎src/Language/Haskell/Exts/Pretty.hs

+22-6
Original file line numberDiff line numberDiff line change
@@ -807,15 +807,31 @@ instance Pretty (Unpackedness l) where
807807
pretty NoUnpackPragma {} = empty
808808

809809
instance Pretty (Deriving l) where
810-
pretty (Deriving _ mds [d]) = text "deriving" <+> maybePP pretty mds <+> pretty d
811-
pretty (Deriving _ mds d) = text "deriving" <+> maybePP pretty mds <+> parenList (map pretty d)
810+
pretty (Deriving _ mds d) =
811+
hsep [ text "deriving"
812+
, pp_strat_before
813+
, pp_dct
814+
, pp_strat_after ]
815+
where
816+
pp_dct =
817+
case d of
818+
[d'] -> pretty d'
819+
_ -> parenList (map pretty d)
820+
821+
-- @via@ is unique in that in comes /after/ the class being derived,
822+
-- so we must special-case it.
823+
(pp_strat_before, pp_strat_after) =
824+
case mds of
825+
Just (via@DerivVia{}) -> (empty, pretty via)
826+
_ -> (maybePP pretty mds, empty)
812827

813828
instance Pretty (DerivStrategy l) where
814-
pretty ds = text $
829+
pretty ds =
815830
case ds of
816-
DerivStock _ -> "stock"
817-
DerivAnyclass _ -> "anyclass"
818-
DerivNewtype _ -> "newtype"
831+
DerivStock _ -> text "stock"
832+
DerivAnyclass _ -> text "anyclass"
833+
DerivNewtype _ -> text "newtype"
834+
DerivVia _ ty -> text "via" <+> pretty ty
819835

820836
------------------------- Types -------------------------
821837
ppBType :: Type l -> Doc

Diff for: ‎src/Language/Haskell/Exts/Syntax.hs

+16-9
Original file line numberDiff line numberDiff line change
@@ -104,7 +104,7 @@ module Language.Haskell.Exts.Syntax (
104104
export_name, safe_name, unsafe_name, interruptible_name, threadsafe_name,
105105
stdcall_name, ccall_name, cplusplus_name, dotnet_name, jvm_name, js_name,
106106
javascript_name, capi_name, forall_name, family_name, role_name, hole_name,
107-
stock_name, anyclass_name,
107+
stock_name, anyclass_name, via_name,
108108
-- ** Type constructors
109109
unit_tycon_name, fun_tycon_name, list_tycon_name, tuple_tycon_name, unboxed_singleton_tycon_name,
110110
unit_tycon, fun_tycon, list_tycon, tuple_tycon, unboxed_singleton_tycon,
@@ -487,12 +487,13 @@ data Deriving l = Deriving l (Maybe (DerivStrategy l)) [InstRule l]
487487

488488
-- | Which technique the user explicitly requested when deriving an instance.
489489
data DerivStrategy l
490-
= DerivStock l -- ^ GHC's \"standard\" strategy, which is to implement a
491-
-- custom instance for the data type. This only works for
492-
-- certain types that GHC knows about (e.g., 'Eq', 'Show',
493-
-- 'Functor' when @-XDeriveFunctor@ is enabled, etc.)
494-
| DerivAnyclass l -- ^ @-XDeriveAnyClass@
495-
| DerivNewtype l -- ^ @-XGeneralizedNewtypeDeriving@
490+
= DerivStock l -- ^ GHC's \"standard\" strategy, which is to implement a
491+
-- custom instance for the data type. This only works for
492+
-- certain types that GHC knows about (e.g., 'Eq', 'Show',
493+
-- 'Functor' when @-XDeriveFunctor@ is enabled, etc.)
494+
| DerivAnyclass l -- ^ @-XDeriveAnyClass@
495+
| DerivNewtype l -- ^ @-XGeneralizedNewtypeDeriving@
496+
| DerivVia l (Type l) -- ^ @-XDerivingVia@
496497
deriving (Eq,Ord,Show,Typeable,Data,Foldable,Traversable,Functor,Generic)
497498

498499
-- | A binding group inside a @let@ or @where@ clause.
@@ -1052,7 +1053,7 @@ hole_name l = Special l (ExprHole l)
10521053
export_name, safe_name, unsafe_name, interruptible_name, threadsafe_name,
10531054
stdcall_name, ccall_name, cplusplus_name, dotnet_name,
10541055
jvm_name, js_name, javascript_name, capi_name, forall_name,
1055-
family_name, role_name, stock_name, anyclass_name :: l -> Name l
1056+
family_name, role_name, stock_name, anyclass_name, via_name :: l -> Name l
10561057
export_name l = Ident l "export"
10571058
safe_name l = Ident l "safe"
10581059
unsafe_name l = Ident l "unsafe"
@@ -1071,6 +1072,7 @@ family_name l = Ident l "family"
10711072
role_name l = Ident l "role"
10721073
stock_name l = Ident l "stock"
10731074
anyclass_name l = Ident l "anyclass"
1075+
via_name l = Ident l "via"
10741076

10751077
unit_tycon_name, fun_tycon_name, list_tycon_name, unboxed_singleton_tycon_name :: l -> QName l
10761078
unit_tycon_name l = unit_con_name l
@@ -1249,7 +1251,12 @@ instance Annotated DerivStrategy where
12491251
ann (DerivStock l) = l
12501252
ann (DerivAnyclass l) = l
12511253
ann (DerivNewtype l) = l
1252-
amap = fmap
1254+
ann (DerivVia l _) = l
1255+
1256+
amap f (DerivStock l) = DerivStock (f l)
1257+
amap f (DerivAnyclass l) = DerivAnyclass (f l)
1258+
amap f (DerivNewtype l) = DerivNewtype (f l)
1259+
amap f (DerivVia l t) = DerivVia (f l) t
12531260

12541261
instance Annotated TypeEqn where
12551262
ann (TypeEqn l _ _) = l

0 commit comments

Comments
 (0)