Add DerivingVia support

Addresses one part of #419.

Author: RyanGlScott

src/Language/Haskell/Exts/ExactPrint.hs

@@ -1211,6 +1211,9 @@ instance ExactP DerivStrategy where
     printString "anyclass"
   exactP (DerivNewtype _) =
     printString "newtype"
+  exactP (DerivVia _ ty) = do
+    printString "via"
+    exactP ty
 
 instance ExactP ClassDecl where
   exactP cdecl = case cdecl of

src/Language/Haskell/Exts/Extension.hs

@@ -552,6 +552,10 @@ data KnownExtension =
 
   | StrictData
 
+  -- | Enable deriving instances via types of the same runtime representation.
+  -- Implies 'DerivingStrategies'.
+  | DerivingVia
+
   deriving (Show, Read, Eq, Ord, Enum, Bounded, Data, Typeable)
 
 -- | Certain extensions imply other extensions, and this function

src/Language/Haskell/Exts/InternalLexer.hs

@@ -197,6 +197,7 @@ data Token
         | KW_Pattern
         | KW_Stock
         | KW_Anyclass
+        | KW_Via
 
                 -- FFI
         | KW_Foreign
@@ -297,6 +298,7 @@ reserved_ids = [
  ( "pattern",   (KW_Pattern,    Just (Any [PatternSynonyms]))),
  ( "stock",     (KW_Stock,      Nothing)),
  ( "anyclass",  (KW_Anyclass,   Nothing)),
+ ( "via",       (KW_Via,        Nothing)),
 
 -- FFI
  ( "foreign",   (KW_Foreign,    Just (Any [ForeignFunctionInterface])) )
@@ -1446,5 +1448,6 @@ showToken t = case t of
   KW_Pattern    -> "pattern"
   KW_Stock      -> "stock"
   KW_Anyclass   -> "anyclass"
+  KW_Via        -> "via"
 
   EOF           -> "EOF"

src/Language/Haskell/Exts/InternalParser.ly

@@ -260,6 +260,7 @@ Reserved Ids
 >       'pattern'       { Loc $$ KW_Pattern }
 >       'stock'         { Loc $$ KW_Stock }    -- for DerivingStrategies extension
 >       'anyclass'      { Loc $$ KW_Anyclass } -- for DerivingStrategies extension
+>       'via'           { Loc $$ KW_Via }      -- for DerivingStrategies extension
 
 Pragmas
 
@@ -648,7 +649,7 @@ This style requires both TypeFamilies and GADTs, the latter is handled in gadtli
 >                        return (InstDecl (nIS $1 <++> ann $3 <+?> minf <** ($1:ss)) $2 ih mis) } }
 
 Requires the StandaloneDeriving extension enabled.
->       | 'deriving' deriv_strategy 'instance' optoverlap ctype
+>       | 'deriving' deriv_standalone_strategy 'instance' optoverlap ctype
 >                {% do { checkEnabled StandaloneDeriving ;
 >                        ih <- checkInstHeader $5;
 >                        let {l = nIS $1 <++> ann $5 <** [$1,$3]};
@@ -1220,22 +1221,28 @@ as qcon and then check separately that they are truly unqualified.
 >       | deriving                      { [$1] }
 
 > deriving :: { Deriving L }
->       : 'deriving' deriv_strategy qtycls1
->                                       { let l = nIS $1 <++> ann $3 <** [$1] in Deriving l $2 [IRule (ann $3) Nothing Nothing $3] }
->       | 'deriving' deriv_strategy '(' ')'
->                                       { Deriving ($1 <^^> $4 <** [$1,$3,$4]) $2 [] }
->       | 'deriving' deriv_strategy '(' dclasses ')'
->                                       { -- Distinguish deriving (Show) from deriving Show (#189)
->                                         case fst $4 of
->                                           [ts] -> Deriving ($1 <^^> $5 <** [$1]) $2 [IParen ($3 <^^> $5 <** [$3,$5]) ts]
->                                           tss  -> Deriving ($1 <^^> $5 <** $1:$3: reverse (snd $4) ++ [$5]) $2 (reverse tss)}
+>       : 'deriving' deriv_clause_types
+>             { let (ihs, last_ss, sss) = $2
+>               in Deriving ($1 <^^> last_ss <** $1:sss) Nothing ihs }
+>       | 'deriving' deriv_strategy_no_via deriv_clause_types
+>             { let (ihs, last_ss, sss) = $3
+>               in Deriving ($1 <^^> last_ss <** $1:sss) (Just $2) ihs }
+>       | 'deriving' deriv_clause_types deriv_strategy_via
+>             { let (ihs, last_ss, sss) = $2
+>               in Deriving ($1 <^^> last_ss <** $1:sss) (Just $3) ihs }
 
 > dclasses :: { ([InstRule L],[S]) }
 >       : types1                        {% checkDeriving (fst $1) >>= \ds -> return (ds, snd $1) }
 
 > qtycls1 :: { InstHead L }
 >       : qconid                        { IHCon (ann $1) $1 }
 
+> deriv_clause_types :: { ([InstRule L], SrcSpan, [SrcSpan]) }
+>       : qtycls1                       { [IRule (ann $1) Nothing Nothing $1], srcInfoSpan (ann $1), [] }
+>       | '(' ')'                       { [], $2, [$1, $2] }
+>       | '(' dclasses ')'              { case fst $2 of
+>                                           [ts] -> ([IParen ($1 <^^> $3 <** [$1,$3]) ts], $3, [])
+>                                           tss  -> (reverse tss, $3, $1: reverse (snd $2) ++ [$3]) }
 
 -----------------------------------------------------------------------------
 Kinds
@@ -2141,15 +2148,24 @@ Pattern Synonyms
 -----------------------------------------------------------------------------
 Deriving strategies
 
-> deriv_strategy :: { Maybe (DerivStrategy L) }
+> deriv_strategy_no_via :: { DerivStrategy L }
 >       : 'stock'               {% do { checkEnabled DerivingStrategies
->                                     ; return (Just (DerivStock (nIS $1))) } }
+>                                     ; return (DerivStock (nIS $1)) } }
 >       | 'anyclass'            {% do { checkEnabled DerivingStrategies
 >                                     ; checkEnabled DeriveAnyClass
->                                     ; return (Just (DerivAnyclass (nIS $1))) } }
+>                                     ; return (DerivAnyclass (nIS $1)) } }
 >       | 'newtype'             {% do { checkEnabled DerivingStrategies
 >                                     ; checkEnabled GeneralizedNewtypeDeriving
->                                     ; return (Just (DerivNewtype (nIS $1))) } }
+>                                     ; return (DerivNewtype (nIS $1)) } }
+
+> deriv_strategy_via :: { DerivStrategy L }
+>       : 'via' truedtype       {% do { checkEnabled DerivingVia
+>                                     ; checkEnabled DerivingStrategies
+>                                     ; return (DerivVia (nIS $1) $2) } }
+
+> deriv_standalone_strategy :: { Maybe (DerivStrategy L) }
+>       : deriv_strategy_no_via { Just $1 }
+>       | deriv_strategy_via    { Just $1 }
 >       | {- empty -}           { Nothing }
 
 -----------------------------------------------------------------------------

src/Language/Haskell/Exts/Pretty.hs

@@ -807,15 +807,31 @@ instance Pretty (Unpackedness l) where
         pretty NoUnpackPragma {} = empty
 
 instance Pretty (Deriving l) where
-  pretty (Deriving _ mds [d]) = text "deriving" <+> maybePP pretty mds <+> pretty d
-  pretty (Deriving _ mds d)   = text "deriving" <+> maybePP pretty mds <+> parenList (map pretty d)
+  pretty (Deriving _ mds d) =
+    hsep [ text "deriving"
+         , pp_strat_before
+         , pp_dct
+         , pp_strat_after ]
+    where
+      pp_dct =
+        case d of
+          [d'] -> pretty d'
+          _    -> parenList (map pretty d)
+
+      -- @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 mds of
+          Just (via@DerivVia{}) -> (empty, pretty via)
+          _                     -> (maybePP pretty mds, empty)
 
 instance Pretty (DerivStrategy l) where
-  pretty ds = text $
+  pretty ds =
     case ds of
-      DerivStock _    -> "stock"
-      DerivAnyclass _ -> "anyclass"
-      DerivNewtype _  -> "newtype"
+      DerivStock _    -> text "stock"
+      DerivAnyclass _ -> text "anyclass"
+      DerivNewtype _  -> text "newtype"
+      DerivVia _ ty   -> text "via" <+> pretty ty
 
 ------------------------- Types -------------------------
 ppBType :: Type l -> Doc

src/Language/Haskell/Exts/Syntax.hs

@@ -104,7 +104,7 @@ module Language.Haskell.Exts.Syntax (
     export_name, safe_name, unsafe_name, interruptible_name, threadsafe_name,
     stdcall_name, ccall_name, cplusplus_name, dotnet_name, jvm_name, js_name,
     javascript_name, capi_name, forall_name, family_name, role_name, hole_name,
-    stock_name, anyclass_name,
+    stock_name, anyclass_name, via_name,
     -- ** Type constructors
     unit_tycon_name, fun_tycon_name, list_tycon_name, tuple_tycon_name, unboxed_singleton_tycon_name,
     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]
 
 -- | Which technique the user explicitly requested when deriving an instance.
 data DerivStrategy l
-  = DerivStock l    -- ^ 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.)
-  | DerivAnyclass l -- ^ @-XDeriveAnyClass@
-  | DerivNewtype l  -- ^ @-XGeneralizedNewtypeDeriving@
+  = DerivStock l        -- ^ 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.)
+  | DerivAnyclass l     -- ^ @-XDeriveAnyClass@
+  | DerivNewtype l      -- ^ @-XGeneralizedNewtypeDeriving@
+  | DerivVia l (Type l) -- ^ @-XDerivingVia@
   deriving (Eq,Ord,Show,Typeable,Data,Foldable,Traversable,Functor,Generic)
 
 -- | A binding group inside a @let@ or @where@ clause.
@@ -1052,7 +1053,7 @@ hole_name      l = Special l (ExprHole l)
 export_name, safe_name, unsafe_name, interruptible_name, threadsafe_name,
   stdcall_name, ccall_name, cplusplus_name, dotnet_name,
   jvm_name, js_name, javascript_name, capi_name, forall_name,
-  family_name, role_name, stock_name, anyclass_name :: l -> Name l
+  family_name, role_name, stock_name, anyclass_name, via_name :: l -> Name l
 export_name     l = Ident l "export"
 safe_name       l = Ident l "safe"
 unsafe_name     l = Ident l "unsafe"
@@ -1071,6 +1072,7 @@ family_name     l = Ident l "family"
 role_name       l = Ident l "role"
 stock_name      l = Ident l "stock"
 anyclass_name   l = Ident l "anyclass"
+via_name        l = Ident l "via"
 
 unit_tycon_name, fun_tycon_name, list_tycon_name, unboxed_singleton_tycon_name :: l -> QName l
 unit_tycon_name l = unit_con_name l
@@ -1249,7 +1251,12 @@ instance Annotated DerivStrategy where
     ann (DerivStock l)    = l
     ann (DerivAnyclass l) = l
     ann (DerivNewtype l)  = l
-    amap = fmap
+    ann (DerivVia l _)    = l
+
+    amap f (DerivStock l)    = DerivStock (f l)
+    amap f (DerivAnyclass l) = DerivAnyclass (f l)
+    amap f (DerivNewtype l)  = DerivNewtype (f l)
+    amap f (DerivVia l t)    = DerivVia (f l) t
 
 instance Annotated TypeEqn where
     ann (TypeEqn l _ _) = l