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

3 files changed, 60 insertions, 32 deletions

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") }