More explicit foralls (GHC Proposal 0007)

Allow the user to explicitly bind type/kind variables in type and data
family instances (including associated instances), closed type family
equations, and RULES pragmas. Follows the specification of GHC
Proposal 0007, also fixes #2600. Advised by Richard Eisenberg.

This modifies the Template Haskell AST -- old code may break!

Other Changes:
- convert HsRule to a record
- make rnHsSigWcType more general
- add repMaybe to DsMeta

Includes submodule update for Haddock.

Test Plan: validate

Reviewers: goldfire, bgamari, alanz

Subscribers: simonpj, RyanGlScott, goldfire, rwbarton,
             thomie, mpickering, carter

GHC Trac Issues: #2600, #14268

Differential Revision: https://phabricator.haskell.org/D4894

4 files changed, 85 insertions, 46 deletions

diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib.hs b/libraries/template-haskell/Language/Haskell/TH/Lib.hs
index 778e6c0553..67a8773ecc 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Lib.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Lib.hs
@@ -126,11 +126,13 @@ import Language.Haskell.TH.Lib.Internal hiding
   , dataD
   , newtypeD
   , classD
+  , pragRuleD
   , dataInstD
   , newtypeInstD
   , dataFamilyD
   , openTypeFamilyD
   , closedTypeFamilyD
+  , tySynEqn
   , forallC
 
   , forallT
@@ -192,6 +194,14 @@ classD ctxt cls tvs fds decs =
     ctxt1 <- ctxt
     return $ ClassD ctxt1 cls tvs fds decs1
 
+pragRuleD :: String -> [RuleBndrQ] -> ExpQ -> ExpQ -> Phases -> DecQ
+pragRuleD n bndrs lhs rhs phases
+  = do
+      bndrs1 <- sequence bndrs
+      lhs1   <- lhs
+      rhs1   <- rhs
+      return $ PragmaD $ RuleP n Nothing bndrs1 lhs1 rhs1 phases
+
 dataInstD :: CxtQ -> Name -> [TypeQ] -> Maybe Kind -> [ConQ] -> [DerivClauseQ]
           -> DecQ
 dataInstD ctxt tc tys ksig cons derivs =
@@ -200,7 +210,7 @@ dataInstD ctxt tc tys ksig cons derivs =
     tys1  <- sequence tys
     cons1 <- sequence cons
     derivs1 <- sequence derivs
-    return (DataInstD ctxt1 tc tys1 ksig cons1 derivs1)
+    return (DataInstD ctxt1 tc Nothing tys1 ksig cons1 derivs1)
 
 newtypeInstD :: CxtQ -> Name -> [TypeQ] -> Maybe Kind -> ConQ -> [DerivClauseQ]
              -> DecQ
@@ -210,7 +220,7 @@ newtypeInstD ctxt tc tys ksig con derivs =
     tys1  <- sequence tys
     con1  <- con
     derivs1 <- sequence derivs
-    return (NewtypeInstD ctxt1 tc tys1 ksig con1 derivs1)
+    return (NewtypeInstD ctxt1 tc Nothing tys1 ksig con1 derivs1)
 
 dataFamilyD :: Name -> [TyVarBndr] -> Maybe Kind -> DecQ
 dataFamilyD tc tvs kind
@@ -227,6 +237,13 @@ closedTypeFamilyD tc tvs result injectivity eqns =
   do eqns1 <- sequence eqns
      return (ClosedTypeFamilyD (TypeFamilyHead tc tvs result injectivity) eqns1)
 
+tySynEqn :: [TypeQ] -> TypeQ -> TySynEqnQ
+tySynEqn lhs rhs =
+  do
+    lhs1 <- sequence lhs
+    rhs1 <- rhs
+    return (TySynEqn Nothing lhs1 rhs1)
+
 forallC :: [TyVarBndr] -> CxtQ -> ConQ -> ConQ
 forallC ns ctxt con = liftM2 (ForallC ns) ctxt con
 
diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
index 989e8168ba..11391da95f 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
@@ -469,13 +469,15 @@ pragSpecInstD ty
       ty1    <- ty
       return $ PragmaD $ SpecialiseInstP ty1
 
-pragRuleD :: String -> [RuleBndrQ] -> ExpQ -> ExpQ -> Phases -> DecQ
-pragRuleD n bndrs lhs rhs phases
+pragRuleD :: String -> Maybe [TyVarBndrQ] -> [RuleBndrQ] -> ExpQ -> ExpQ
+          -> Phases -> DecQ
+pragRuleD n ty_bndrs tm_bndrs lhs rhs phases
   = do
-      bndrs1 <- sequence bndrs
+      ty_bndrs1 <- traverse sequence ty_bndrs
+      tm_bndrs1 <- sequence tm_bndrs
       lhs1   <- lhs
       rhs1   <- rhs
-      return $ PragmaD $ RuleP n bndrs1 lhs1 rhs1 phases
+      return $ PragmaD $ RuleP n ty_bndrs1 tm_bndrs1 lhs1 rhs1 phases
 
 pragAnnD :: AnnTarget -> ExpQ -> DecQ
 pragAnnD target expr
@@ -489,27 +491,29 @@ pragLineD line file = return $ PragmaD $ LineP line file
 pragCompleteD :: [Name] -> Maybe Name -> DecQ
 pragCompleteD cls mty = return $ PragmaD $ CompleteP cls mty
 
-dataInstD :: CxtQ -> Name -> [TypeQ] -> Maybe KindQ -> [ConQ]
-          -> [DerivClauseQ] -> DecQ
-dataInstD ctxt tc tys ksig cons derivs =
+dataInstD :: CxtQ -> Name -> (Maybe [TyVarBndrQ]) -> [TypeQ] -> Maybe KindQ
+          -> [ConQ] -> [DerivClauseQ] -> DecQ
+dataInstD ctxt tc mb_bndrs tys ksig cons derivs =
   do
-    ctxt1   <- ctxt
-    tys1    <- sequenceA tys
-    ksig1   <- sequenceA ksig
-    cons1   <- sequenceA cons
-    derivs1 <- sequenceA derivs
-    return (DataInstD ctxt1 tc tys1 ksig1 cons1 derivs1)
-
-newtypeInstD :: CxtQ -> Name -> [TypeQ] -> Maybe KindQ -> ConQ
-             -> [DerivClauseQ] -> DecQ
-newtypeInstD ctxt tc tys ksig con derivs =
+    ctxt1     <- ctxt
+    mb_bndrs1 <- traverse sequence mb_bndrs
+    tys1      <- sequenceA tys
+    ksig1     <- sequenceA ksig
+    cons1     <- sequenceA cons
+    derivs1   <- sequenceA derivs
+    return (DataInstD ctxt1 tc mb_bndrs1 tys1 ksig1 cons1 derivs1)
+
+newtypeInstD :: CxtQ -> Name -> (Maybe [TyVarBndrQ]) -> [TypeQ] -> Maybe KindQ
+             -> ConQ -> [DerivClauseQ] -> DecQ
+newtypeInstD ctxt tc mb_bndrs tys ksig con derivs =
   do
-    ctxt1   <- ctxt
-    tys1    <- sequenceA tys
-    ksig1   <- sequenceA ksig
-    con1    <- con
-    derivs1 <- sequence derivs
-    return (NewtypeInstD ctxt1 tc tys1 ksig1 con1 derivs1)
+    ctxt1     <- ctxt
+    mb_bndrs1 <- traverse sequence mb_bndrs
+    tys1      <- sequenceA tys
+    ksig1     <- sequenceA ksig
+    con1      <- con
+    derivs1   <- sequence derivs
+    return (NewtypeInstD ctxt1 tc mb_bndrs1 tys1 ksig1 con1 derivs1)
 
 tySynInstD :: Name -> TySynEqnQ -> DecQ
 tySynInstD tc eqn =
@@ -580,12 +584,13 @@ implicitParamBindD n e =
     e' <- e
     return $ ImplicitParamBindD n e'
 
-tySynEqn :: [TypeQ] -> TypeQ -> TySynEqnQ
-tySynEqn lhs rhs =
+tySynEqn :: (Maybe [TyVarBndrQ]) -> [TypeQ] -> TypeQ -> TySynEqnQ
+tySynEqn mb_bndrs lhs rhs =
   do
+    mb_bndrs1 <- traverse sequence mb_bndrs
     lhs1 <- sequence lhs
     rhs1 <- rhs
-    return (TySynEqn lhs1 rhs1)
+    return (TySynEqn mb_bndrs1 lhs1 rhs1)
 
 cxt :: [PredQ] -> CxtQ
 cxt = sequence
diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
index 7df8c98643..138cf62b24 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
@@ -347,18 +347,21 @@ ppr_dec isTop (DataFamilyD tc tvs kind)
                 | otherwise = empty
     maybeKind | (Just k') <- kind = dcolon <+> ppr k'
               | otherwise = empty
-ppr_dec isTop (DataInstD ctxt tc tys ksig cs decs)
-  = ppr_data maybeInst ctxt tc (sep (map pprParendType tys)) ksig cs decs
+ppr_dec isTop (DataInstD ctxt tc bndrs tys ksig cs decs)
+  = ppr_data (maybeInst <+> ppr_bndrs bndrs) ctxt tc
+             (sep (map pprParendType tys)) ksig cs decs
   where
     maybeInst | isTop     = text "instance"
               | otherwise = empty
-ppr_dec isTop (NewtypeInstD ctxt tc tys ksig c decs)
-  = ppr_newtype maybeInst ctxt tc (sep (map pprParendType tys)) ksig c decs
+ppr_dec isTop (NewtypeInstD ctxt tc bndrs tys ksig c decs)
+  = ppr_newtype (maybeInst <+> ppr_bndrs bndrs) ctxt tc
+                (sep (map pprParendType tys)) ksig c decs
   where
     maybeInst | isTop     = text "instance"
               | otherwise = empty
-ppr_dec isTop (TySynInstD tc (TySynEqn tys rhs))
-  = ppr_tySyn maybeInst tc (sep (map pprParendType tys)) rhs
+ppr_dec isTop (TySynInstD tc (TySynEqn mb_bndrs tys rhs))
+  = ppr_tySyn (maybeInst <+> ppr_bndrs mb_bndrs) tc
+              (sep (map pprParendType tys)) rhs
   where
     maybeInst | isTop     = text "instance"
               | otherwise = empty
@@ -371,8 +374,9 @@ ppr_dec _ (ClosedTypeFamilyD tfhead@(TypeFamilyHead tc _ _ _) eqns)
   = hang (text "type family" <+> ppr_tf_head tfhead <+> text "where")
       nestDepth (vcat (map ppr_eqn eqns))
   where
-    ppr_eqn (TySynEqn lhs rhs)
-      = ppr tc <+> sep (map pprParendType lhs) <+> text "=" <+> ppr rhs
+    ppr_eqn (TySynEqn mb_bndrs lhs rhs)
+      = ppr_bndrs mb_bndrs <+> ppr tc <+> sep (map pprParendType lhs)
+        <+> text "=" <+> ppr rhs
 ppr_dec _ (RoleAnnotD name roles)
   = hsep [ text "type role", ppr name ] <+> hsep (map ppr roles)
 ppr_dec _ (StandaloneDerivD ds cxt ty)
@@ -484,6 +488,10 @@ ppr_tf_head (TypeFamilyHead tc tvs res inj)
     maybeInj | (Just inj') <- inj = ppr inj'
              | otherwise          = empty
 
+ppr_bndrs :: Maybe [TyVarBndr] -> Doc
+ppr_bndrs (Just bndrs) = text "forall" <+> sep (map ppr bndrs) <> text "."
+ppr_bndrs Nothing = empty
+
 ------------------------------
 instance Ppr FunDep where
     ppr (FunDep xs ys) = hsep (map ppr xs) <+> text "->" <+> hsep (map ppr ys)
@@ -535,14 +543,19 @@ instance Ppr Pragma where
        <+> text "#-}"
     ppr (SpecialiseInstP inst)
        = text "{-# SPECIALISE instance" <+> ppr inst <+> text "#-}"
-    ppr (RuleP n bndrs lhs rhs phases)
+    ppr (RuleP n ty_bndrs tm_bndrs lhs rhs phases)
        = sep [ text "{-# RULES" <+> pprString n <+> ppr phases
-             , nest 4 $ ppr_forall <+> ppr lhs
+             , nest 4 $ ppr_ty_forall ty_bndrs <+> ppr_tm_forall ty_bndrs
+                                               <+> ppr lhs
              , nest 4 $ char '=' <+> ppr rhs <+> text "#-}" ]
-      where ppr_forall | null bndrs =   empty
-                       | otherwise  =   text "forall"
-                                    <+> fsep (map ppr bndrs)
-                                    <+> char '.'
+      where ppr_ty_forall Nothing      = empty
+            ppr_ty_forall (Just bndrs) = text "forall"
+                                         <+> fsep (map ppr bndrs)
+                                         <+> char '.'
+            ppr_tm_forall Nothing | null tm_bndrs = empty
+            ppr_tm_forall _ = text "forall"
+                              <+> fsep (map ppr tm_bndrs)
+                              <+> char '.'
     ppr (AnnP tgt expr)
        = text "{-# ANN" <+> target1 tgt <+> ppr expr <+> text "#-}"
       where target1 ModuleAnnotation    = text "module"
diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
index 7ee81c8d6e..b75a04867b 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
@@ -1711,14 +1711,18 @@ data Dec
                (Maybe Kind)
          -- ^ @{ data family T a b c :: * }@
 
-  | DataInstD Cxt Name [Type]
+  | DataInstD Cxt Name
+             (Maybe [TyVarBndr])  -- Quantified type vars
+             [Type]
              (Maybe Kind)         -- Kind signature
              [Con] [DerivClause]  -- ^ @{ data instance Cxt x => T [x]
                                   --       = A x | B (T x)
                                   --       deriving (Z,W)
                                   --       deriving stock Eq }@
 
-  | NewtypeInstD Cxt Name [Type]
+  | NewtypeInstD Cxt Name
+                 (Maybe [TyVarBndr])  -- Quantified type vars
+                 [Type]
                  (Maybe Kind)      -- Kind signature
                  Con [DerivClause] -- ^ @{ newtype instance Cxt x => T [x]
                                    --        = A (B x)
@@ -1837,7 +1841,7 @@ data TypeFamilyHead =
 -- | One equation of a type family instance or closed type family. The
 -- arguments are the left-hand-side type patterns and the right-hand-side
 -- result.
-data TySynEqn = TySynEqn [Type] Type
+data TySynEqn = TySynEqn (Maybe [TyVarBndr]) [Type] Type
   deriving( Show, Eq, Ord, Data, Generic )
 
 data FunDep = FunDep [Name] [Name]
@@ -1857,7 +1861,7 @@ data Safety = Unsafe | Safe | Interruptible
 data Pragma = InlineP         Name Inline RuleMatch Phases
             | SpecialiseP     Name Type (Maybe Inline) Phases
             | SpecialiseInstP Type
-            | RuleP           String [RuleBndr] Exp Exp Phases
+            | RuleP           String (Maybe [TyVarBndr]) [RuleBndr] Exp Exp Phases
             | AnnP            AnnTarget Exp
             | LineP           Int String
             | CompleteP       [Name] (Maybe Name)