More explicit foralls (GHC Proposal 0007)
authorMatthew Yacavone <matthew@yacavone.net>
Sat, 27 Oct 2018 18:01:42 +0000 (14:01 -0400)
committerRichard Eisenberg <rae@cs.brynmawr.edu>
Sat, 27 Oct 2018 18:54:56 +0000 (14:54 -0400)
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

90 files changed:
compiler/deSugar/Check.hs
compiler/deSugar/Coverage.hs
compiler/deSugar/Desugar.hs
compiler/deSugar/DsArrows.hs
compiler/deSugar/DsExpr.hs
compiler/deSugar/DsMeta.hs
compiler/deSugar/Match.hs
compiler/deSugar/PmExpr.hs
compiler/hsSyn/Convert.hs
compiler/hsSyn/HsDecls.hs
compiler/hsSyn/HsExpr.hs
compiler/hsSyn/HsExtension.hs
compiler/hsSyn/HsPat.hs
compiler/hsSyn/HsTypes.hs
compiler/hsSyn/HsUtils.hs
compiler/main/HscMain.hs
compiler/main/HscStats.hs
compiler/parser/Parser.y
compiler/parser/RdrHsSyn.hs
compiler/rename/RnBinds.hs
compiler/rename/RnExpr.hs
compiler/rename/RnPat.hs
compiler/rename/RnSource.hs
compiler/rename/RnTypes.hs
compiler/rename/RnUtils.hs
compiler/typecheck/TcAnnotations.hs
compiler/typecheck/TcEnv.hs
compiler/typecheck/TcExpr.hs
compiler/typecheck/TcGenDeriv.hs
compiler/typecheck/TcHsSyn.hs
compiler/typecheck/TcInstDcls.hs
compiler/typecheck/TcPat.hs
compiler/typecheck/TcPatSyn.hs
compiler/typecheck/TcRnDriver.hs
compiler/typecheck/TcRnTypes.hs
compiler/typecheck/TcRules.hs
compiler/typecheck/TcSplice.hs
compiler/typecheck/TcTyClsDecls.hs
docs/users_guide/glasgow_exts.rst
docs/users_guide/using-warnings.rst
ghc/GHCi/UI.hs
libraries/template-haskell/Language/Haskell/TH/Lib.hs
libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
libraries/template-haskell/Language/Haskell/TH/Ppr.hs
libraries/template-haskell/Language/Haskell/TH/Syntax.hs
libraries/template-haskell/changelog.md
testsuite/tests/ghc-api/annotations/stringSource.hs
testsuite/tests/ghc-api/annotations/t11430.hs
testsuite/tests/indexed-types/should_compile/ExplicitForAllFams1.hs [new file with mode: 0644]
testsuite/tests/indexed-types/should_compile/ExplicitForAllFams2.hs [new file with mode: 0644]
testsuite/tests/indexed-types/should_compile/ExplicitForAllFams2.stderr [new file with mode: 0644]
testsuite/tests/indexed-types/should_compile/UnusedTyVarWarnings.stderr
testsuite/tests/indexed-types/should_compile/UnusedTyVarWarningsNamedWCs.stderr
testsuite/tests/indexed-types/should_compile/all.T
testsuite/tests/indexed-types/should_fail/ExplicitForAllFams3.hs [new file with mode: 0644]
testsuite/tests/indexed-types/should_fail/ExplicitForAllFams3.stderr [new file with mode: 0644]
testsuite/tests/indexed-types/should_fail/ExplicitForAllFams4a.hs [new file with mode: 0644]
testsuite/tests/indexed-types/should_fail/ExplicitForAllFams4a.stderr [new file with mode: 0644]
testsuite/tests/indexed-types/should_fail/ExplicitForAllFams4b.hs [new file with mode: 0644]
testsuite/tests/indexed-types/should_fail/ExplicitForAllFams4b.stderr [new file with mode: 0644]
testsuite/tests/indexed-types/should_fail/all.T
testsuite/tests/parser/should_compile/DumpParsedAst.stderr
testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
testsuite/tests/parser/should_compile/KindSigs.stderr
testsuite/tests/rename/should_compile/ExplicitForAllRules1.hs [new file with mode: 0644]
testsuite/tests/rename/should_compile/ExplicitForAllRules1.stderr [new file with mode: 0644]
testsuite/tests/rename/should_compile/T2600.hs [new file with mode: 0644]
testsuite/tests/rename/should_compile/T2600.stderr [new file with mode: 0644]
testsuite/tests/rename/should_compile/all.T
testsuite/tests/rename/should_fail/ExplicitForAllRules2.hs [new file with mode: 0644]
testsuite/tests/rename/should_fail/ExplicitForAllRules2.stderr [new file with mode: 0644]
testsuite/tests/rename/should_fail/all.T
testsuite/tests/th/ClosedFam2TH.hs
testsuite/tests/th/T12503.hs
testsuite/tests/th/T12646.stderr
testsuite/tests/th/T13618.hs
testsuite/tests/th/T5886a.hs
testsuite/tests/th/T6018th.hs
testsuite/tests/th/T6018th.stderr
testsuite/tests/th/T7532a.hs
testsuite/tests/th/T8884.stderr
testsuite/tests/th/T8953.stderr
testsuite/tests/th/TH_ExplicitForAllRules.hs [new file with mode: 0644]
testsuite/tests/th/TH_ExplicitForAllRules.stdout [new file with mode: 0644]
testsuite/tests/th/TH_ExplicitForAllRules_a.hs [new file with mode: 0644]
testsuite/tests/th/TH_reifyExplicitForAllFams.hs [new file with mode: 0644]
testsuite/tests/th/TH_reifyExplicitForAllFams.stderr [new file with mode: 0644]
testsuite/tests/th/all.T
utils/ghctags/Main.hs
utils/haddock

index 4cd5601..cba86df 100644 (file)
@@ -973,7 +973,7 @@ translatePat fam_insts pat = case pat of
         g   = PmGrd [PmVar (unLoc lid)] e
     return (ps ++ [g])
 
-  SigPat _ty p -> translatePat fam_insts (unLoc p)
+  SigPat _ p _ty -> translatePat fam_insts (unLoc p)
 
   -- See Note [Translate CoPats]
   CoPat _ wrapper p ty
index 99ba967..7ca18c7 100644 (file)
@@ -500,9 +500,9 @@ addTickHsExpr (HsLamCase x mgs)    = liftM (HsLamCase x)
                                            (addTickMatchGroup True mgs)
 addTickHsExpr (HsApp x e1 e2)      = liftM2 (HsApp x) (addTickLHsExprNever e1)
                                                       (addTickLHsExpr      e2)
-addTickHsExpr (HsAppType ty e)   = liftM2 HsAppType (return ty)
-                                                    (addTickLHsExprNever e)
-
+addTickHsExpr (HsAppType x e ty)   = liftM3 HsAppType (return x)
+                                                      (addTickLHsExprNever e)
+                                                      (return ty)
 
 addTickHsExpr (OpApp fix e1 e2 e3) =
         liftM4 OpApp
@@ -578,11 +578,12 @@ addTickHsExpr expr@(RecordUpd { rupd_expr = e, rupd_flds = flds })
        ; flds' <- mapM addTickHsRecField flds
        ; return (expr { rupd_expr = e', rupd_flds = flds' }) }
 
-addTickHsExpr (ExprWithTySig ty e) =
-        liftM2 ExprWithTySig
-                (return ty)
+addTickHsExpr (ExprWithTySig x e ty) =
+        liftM3 ExprWithTySig
+                (return x)
                 (addTickLHsExprNever e) -- No need to tick the inner expression
                                         -- for expressions with signatures
+                (return ty)
 addTickHsExpr (ArithSeq ty wit arith_seq) =
         liftM3 ArithSeq
                 (return ty)
index c1e728b..c7973ca 100644 (file)
@@ -379,7 +379,11 @@ Reason
 -}
 
 dsRule :: LRuleDecl GhcTc -> DsM (Maybe CoreRule)
-dsRule (L loc (HsRule _ name rule_act vars lhs rhs))
+dsRule (L loc (HsRule { rd_name = name
+                      , rd_act  = rule_act
+                      , rd_tmvs = vars
+                      , rd_lhs  = lhs
+                      , rd_rhs  = rhs }))
   = putSrcSpanDs loc $
     do  { let bndrs' = [var | L _ (RuleBndr _ (L _ var)) <- vars]
 
@@ -497,7 +501,7 @@ switching off EnableRewriteRules.  See DsExpr.dsExplicitList.
 That keeps the desugaring of list comprehensions simple too.
 
 Nor do we want to warn of conversion identities on the LHS;
-the rule is precisly to optimise them:
+the rule is precisely to optimise them:
   {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-}
 
 Note [Desugaring coerce as cast]
index c69d749..8837eea 100644 (file)
@@ -1224,7 +1224,7 @@ collectl (L _ pat) bndrs
     go (NPat {})                  = bndrs
     go (NPlusKPat _ (L _ n) _ _ _ _) = n : bndrs
 
-    go (SigPat _ pat)             = collectl pat bndrs
+    go (SigPat _ pat _)           = collectl pat bndrs
     go (CoPat _ _ pat _)          = collectl (noLoc pat) bndrs
     go (ViewPat _ _ pat)          = collectl pat bndrs
     go p@(SplicePat {})           = pprPanic "collectl/go" (ppr p)
index f9ee3b4..bdba4e0 100644 (file)
@@ -257,7 +257,7 @@ ds_expr :: Bool   -- are we directly inside an HsWrap?
                   -- See Wrinkle in Note [Detecting forced eta expansion]
         -> HsExpr GhcTc -> DsM CoreExpr
 ds_expr _ (HsPar _ e)            = dsLExpr e
-ds_expr _ (ExprWithTySig _ e)    = dsLExpr e
+ds_expr _ (ExprWithTySig _ e _)  = dsLExpr e
 ds_expr w (HsVar _ (L _ var))    = dsHsVar w var
 ds_expr _ (HsUnboundVar {})      = panic "dsExpr: HsUnboundVar" -- Typechecker eliminates them
 ds_expr w (HsConLikeOut _ con)   = dsConLike w con
@@ -302,7 +302,7 @@ ds_expr _ e@(HsApp _ fun arg)
        ; dsWhenNoErrs (dsLExprNoLP arg)
                       (\arg' -> mkCoreAppDs (text "HsApp" <+> ppr e) fun' arg') }
 
-ds_expr _ (HsAppType _ e)
+ds_expr _ (HsAppType _ e _)
     -- ignore type arguments here; they're in the wrappers instead at this point
   = dsLExpr e
 
index d25a7cf..dfcfc3d 100644 (file)
@@ -310,7 +310,7 @@ repTyClD (L loc (SynDecl { tcdLName = tc, tcdTyVars = tvs, tcdRhs = rhs }))
 repTyClD (L loc (DataDecl { tcdLName = tc, tcdTyVars = tvs, tcdDataDefn = defn }))
   = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]
        ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
-                repDataDefn tc1 bndrs Nothing defn
+                repDataDefn tc1 (Left bndrs) defn
        ; return (Just (loc, dec)) }
 
 repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
@@ -344,11 +344,14 @@ repRoleD (L loc (RoleAnnotDecl _ tycon roles))
 repRoleD (L _ (XRoleAnnotDecl _)) = panic "repRoleD"
 
 -------------------------
-repDataDefn :: Core TH.Name -> Core [TH.TyVarBndrQ]
-            -> Maybe (Core [TH.TypeQ])
+repDataDefn :: Core TH.Name
+            -> Either (Core [TH.TyVarBndrQ])
+                        -- the repTyClD case
+                      (Core (Maybe [TH.TyVarBndrQ]), Core [TH.TypeQ])
+                        -- the repDataFamInstD case
             -> HsDataDefn GhcRn
             -> DsM (Core TH.DecQ)
-repDataDefn tc bndrs opt_tys
+repDataDefn tc opts
           (HsDataDefn { dd_ND = new_or_data, dd_ctxt = cxt, dd_kindSig = ksig
                       , dd_cons = cons, dd_derivs = mb_derivs })
   = do { cxt1     <- repLContext cxt
@@ -356,7 +359,7 @@ repDataDefn tc bndrs opt_tys
        ; case (new_or_data, cons) of
            (NewType, [con])  -> do { con'  <- repC con
                                    ; ksig' <- repMaybeLTy ksig
-                                   ; repNewtype cxt1 tc bndrs opt_tys ksig' con'
+                                   ; repNewtype cxt1 tc opts ksig' con'
                                                 derivs1 }
            (NewType, _) -> failWithDs (text "Multiple constructors for newtype:"
                                        <+> pprQuotedList
@@ -364,10 +367,10 @@ repDataDefn tc bndrs opt_tys
            (DataType, _) -> do { ksig' <- repMaybeLTy ksig
                                ; consL <- mapM repC cons
                                ; cons1 <- coreList conQTyConName consL
-                               ; repData cxt1 tc bndrs opt_tys ksig' cons1
+                               ; repData cxt1 tc opts ksig' cons1
                                          derivs1 }
        }
-repDataDefn _ _ (XHsDataDefn _) = panic "repDataDefn"
+repDataDefn _ _ (XHsDataDefn _) = panic "repDataDefn"
 
 repSynDecl :: Core TH.Name -> Core [TH.TyVarBndrQ]
            -> LHsType GhcRn
@@ -455,14 +458,17 @@ repAssocTyFamDefaults = mapM rep_deflt
      -- very like repTyFamEqn, but different in the details
     rep_deflt :: LTyFamDefltEqn GhcRn -> DsM (Core TH.DecQ)
     rep_deflt (L _ (FamEqn { feqn_tycon = tc
-                           , feqn_pats  = bndrs
+                           , feqn_bndrs = bndrs
+                           , feqn_pats  = tys
                            , feqn_rhs   = rhs }))
-      = addTyClTyVarBinds bndrs $ \ _ ->
+      = addTyClTyVarBinds tys $ \ _ ->
         do { tc1  <- lookupLOcc tc
-           ; tys1 <- repLTys (hsLTyVarBndrsToTypes bndrs)
+           ; no_bndrs <- ASSERT( isNothing bndrs )
+                         coreNothingList tyVarBndrQTyConName
+           ; tys1 <- repLTys (hsLTyVarBndrsToTypes tys)
            ; tys2 <- coreList typeQTyConName tys1
            ; rhs1 <- repLTy rhs
-           ; eqn1 <- repTySynEqn tys2 rhs1
+           ; eqn1 <- repTySynEqn no_bndrs tys2 rhs1
            ; repTySynInst tc1 eqn1 }
     rep_deflt (L _ (XFamEqn _)) = panic "repAssocTyFamDefaults"
 
@@ -544,17 +550,21 @@ repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn })
 
 repTyFamEqn :: TyFamInstEqn GhcRn -> DsM (Core TH.TySynEqnQ)
 repTyFamEqn (HsIB { hsib_ext = var_names
-                  , hsib_body = FamEqn { feqn_pats = tys
+                  , hsib_body = FamEqn { feqn_bndrs = mb_bndrs
+                                       , feqn_pats = tys
                                        , feqn_rhs  = rhs }})
   = do { let hs_tvs = HsQTvs { hsq_ext = HsQTvsRn
                                { hsq_implicit = var_names
                                , hsq_dependent = emptyNameSet }   -- Yuk
-                             , hsq_explicit = [] }
+                             , hsq_explicit = fromMaybe [] mb_bndrs }
        ; addTyClTyVarBinds hs_tvs $ \ _ ->
-         do { tys1 <- repLTys tys
+         do { mb_bndrs1 <- repMaybeList tyVarBndrQTyConName
+                                        repTyVarBndr
+                                        mb_bndrs
+            ; tys1 <- repLTys tys
             ; tys2 <- coreList typeQTyConName tys1
             ; rhs1 <- repLTy rhs
-            ; repTySynEqn tys2 rhs1 } }
+            ; repTySynEqn mb_bndrs1 tys2 rhs1 } }
 repTyFamEqn (XHsImplicitBndrs _) = panic "repTyFamEqn"
 repTyFamEqn (HsIB _ (XFamEqn _)) = panic "repTyFamEqn"
 
@@ -562,16 +572,20 @@ repDataFamInstD :: DataFamInstDecl GhcRn -> DsM (Core TH.DecQ)
 repDataFamInstD (DataFamInstDecl { dfid_eqn =
                   (HsIB { hsib_ext = var_names
                         , hsib_body = FamEqn { feqn_tycon = tc_name
+                                             , feqn_bndrs = mb_bndrs
                                              , feqn_pats  = tys
                                              , feqn_rhs   = defn }})})
   = do { tc <- lookupLOcc tc_name               -- See note [Binders and occurrences]
        ; let hs_tvs = HsQTvs { hsq_ext = HsQTvsRn
                                  { hsq_implicit = var_names
                                  , hsq_dependent = emptyNameSet }   -- Yuk
-                             , hsq_explicit = [] }
-       ; addTyClTyVarBinds hs_tvs $ \ bndrs ->
-         do { tys1 <- repList typeQTyConName repLTy tys
-            ; repDataDefn tc bndrs (Just tys1) defn } }
+                             , hsq_explicit = fromMaybe [] mb_bndrs }
+       ; addTyClTyVarBinds hs_tvs $ \ _ ->
+         do { mb_bndrs1 <- repMaybeList tyVarBndrQTyConName
+                                        repTyVarBndr
+                                        mb_bndrs
+            ; tys1 <- repList typeQTyConName repLTy tys
+            ; repDataDefn tc (Right (mb_bndrs1, tys1)) defn } }
 repDataFamInstD (DataFamInstDecl (XHsImplicitBndrs _))
   = panic "repDataFamInstD"
 repDataFamInstD (DataFamInstDecl (HsIB _ (XFamEqn _)))
@@ -633,18 +647,29 @@ repFixD (L loc (FixitySig _ names (Fixity _ prec dir)))
 repFixD (L _ (XFixitySig _)) = panic "repFixD"
 
 repRuleD :: LRuleDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
-repRuleD (L loc (HsRule _ n act bndrs lhs rhs))
-  = do { let bndr_names = concatMap ruleBndrNames bndrs
-       ; ss <- mkGenSyms bndr_names
-       ; rule1 <- addBinds ss $
-                  do { bndrs' <- repList ruleBndrQTyConName repRuleBndr bndrs
-                     ; n'   <- coreStringLit $ unpackFS $ snd $ unLoc n
-                     ; act' <- repPhases act
-                     ; lhs' <- repLE lhs
-                     ; rhs' <- repLE rhs
-                     ; repPragRule n' bndrs' lhs' rhs' act' }
-       ; rule2 <- wrapGenSyms ss rule1
-       ; return (loc, rule2) }
+repRuleD (L loc (HsRule { rd_name = n
+                        , rd_act = act
+                        , rd_tyvs = ty_bndrs
+                        , rd_tmvs = tm_bndrs
+                        , rd_lhs = lhs
+                        , rd_rhs = rhs }))
+  = do { rule <- addHsTyVarBinds (fromMaybe [] ty_bndrs) $ \ ex_bndrs ->
+         do { let tm_bndr_names = concatMap ruleBndrNames tm_bndrs
+            ; ss <- mkGenSyms tm_bndr_names
+            ; rule <- addBinds ss $
+                      do { ty_bndrs' <- case ty_bndrs of
+                             Nothing -> coreNothingList tyVarBndrQTyConName
+                             Just _  -> coreJustList tyVarBndrQTyConName ex_bndrs
+                         ; tm_bndrs' <- repList ruleBndrQTyConName
+                                                repRuleBndr
+                                                tm_bndrs
+                         ; n'   <- coreStringLit $ unpackFS $ snd $ unLoc n
+                         ; act' <- repPhases act
+                         ; lhs' <- repLE lhs
+                         ; rhs' <- repLE rhs
+                         ; repPragRule n' ty_bndrs' tm_bndrs' lhs' rhs' act' }
+           ; wrapGenSyms ss rule  }
+       ; return (loc, rule) }
 repRuleD (L _ (XRuleDecl _)) = panic "repRuleD"
 
 ruleBndrNames :: LRuleBndr GhcRn -> [Name]
@@ -936,15 +961,10 @@ rep_complete_sig :: Located [Located Name]
                  -> SrcSpan
                  -> DsM [(SrcSpan, Core TH.DecQ)]
 rep_complete_sig (L _ cls) mty loc
-  = do { mty' <- rep_maybe_name mty
+  = do { mty' <- repMaybe nameTyConName lookupLOcc mty
        ; cls' <- repList nameTyConName lookupLOcc cls
        ; sig <- repPragComplete cls' mty'
        ; return [(loc, sig)] }
-  where
-    rep_maybe_name Nothing = coreNothing nameTyConName
-    rep_maybe_name (Just n) = do
-      cn <- lookupLOcc n
-      coreJust nameTyConName cn
 
 -------------------------------------------------------
 --                      Types
@@ -1154,11 +1174,7 @@ repTyLit (HsStrTy _ s) = do { s' <- mkStringExprFS s
 -- | Represent a type wrapped in a Maybe
 repMaybeLTy :: Maybe (LHsKind GhcRn)
             -> DsM (Core (Maybe TH.TypeQ))
-repMaybeLTy Nothing =
-    do { coreNothing kindQTyConName }
-repMaybeLTy (Just ki) =
-    do { ki' <- repLTy ki
-       ; coreJust kindQTyConName ki' }
+repMaybeLTy = repMaybe kindQTyConName repLTy
 
 repRole :: Located (Maybe Role) -> DsM (Core TH.Role)
 repRole (L _ (Just Nominal))          = rep2 nominalRName []
@@ -1228,9 +1244,9 @@ repE (HsLamCase _ (MG { mg_alts = L _ ms }))
                         ; core_ms <- coreList matchQTyConName ms'
                         ; repLamCase core_ms }
 repE (HsApp _ x y)   = do {a <- repLE x; b <- repLE y; repApp a b}
-repE (HsAppType t e) = do { a <- repLE e
-                          ; s <- repLTy (hswc_body t)
-                          ; repAppType a s }
+repE (HsAppType _ e t) = do { a <- repLE e
+                            ; s <- repLTy (hswc_body t)
+                            ; repAppType a s }
 
 repE (OpApp _ e1 op e2) =
   do { arg1 <- repLE e1;
@@ -1303,7 +1319,7 @@ repE (RecordUpd { rupd_expr = e, rupd_flds = flds })
         fs <- repUpdFields flds;
         repRecUpd x fs }
 
-repE (ExprWithTySig ty e)
+repE (ExprWithTySig _ e ty)
   = do { e1 <- repLE e
        ; t1 <- repHsSigWcType ty
        ; repSigExp e1 t1 }
@@ -1772,9 +1788,9 @@ repP (ConPatIn dc details)
 repP (NPat _ (L _ l) Nothing _) = do { a <- repOverloadedLiteral l; repPlit a }
 repP (ViewPat _ e p) = do { e' <- repLE e; p' <- repLP p; repPview e' p' }
 repP p@(NPat _ _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p)
-repP (SigPat t p) = do { p' <- repLP p
-                       ; t' <- repLTy (hsSigWcType t)
-                       ; repPsig p' t' }
+repP (SigPat _ p t) = do { p' <- repLP p
+                         ; t' <- repLTy (hsSigWcType t)
+                         ; repPsig p' t' }
 repP (SplicePat _ splice) = repSplice splice
 
 repP other = notHandled "Exotic pattern" (ppr other)
@@ -2146,24 +2162,28 @@ repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds]
 repFun :: Core TH.Name -> Core [TH.ClauseQ] -> DsM (Core TH.DecQ)
 repFun (MkC nm) (MkC b) = rep2 funDName [nm, b]
 
-repData :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndrQ]
-        -> Maybe (Core [TH.TypeQ]) -> Core (Maybe TH.KindQ)
-        -> Core [TH.ConQ] -> Core [TH.DerivClauseQ] -> DsM (Core TH.DecQ)
-repData (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC ksig) (MkC cons) (MkC derivs)
+repData :: Core TH.CxtQ -> Core TH.Name
+        -> Either (Core [TH.TyVarBndrQ])
+                  (Core (Maybe [TH.TyVarBndrQ]), Core [TH.TypeQ])
+        -> Core (Maybe TH.KindQ) -> Core [TH.ConQ] -> Core [TH.DerivClauseQ]
+        -> DsM (Core TH.DecQ)
+repData (MkC cxt) (MkC nm) (Left (MkC tvs)) (MkC ksig) (MkC cons) (MkC derivs)
   = rep2 dataDName [cxt, nm, tvs, ksig, cons, derivs]
-repData (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC ksig) (MkC cons)
-        (MkC derivs)
-  = rep2 dataInstDName [cxt, nm, tys, ksig, cons, derivs]
-
-repNewtype :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndrQ]
-           -> Maybe (Core [TH.TypeQ]) -> Core (Maybe TH.KindQ)
-           -> Core TH.ConQ -> Core [TH.DerivClauseQ] -> DsM (Core TH.DecQ)
-repNewtype (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC ksig) (MkC con)
+repData (MkC cxt) (MkC nm) (Right (MkC mb_bndrs, MkC tys)) (MkC ksig)
+        (MkC cons) (MkC derivs)
+  = rep2 dataInstDName [cxt, nm, mb_bndrs, tys, ksig, cons, derivs]
+
+repNewtype :: Core TH.CxtQ -> Core TH.Name
+           -> Either (Core [TH.TyVarBndrQ])
+                     (Core (Maybe [TH.TyVarBndrQ]), Core [TH.TypeQ])
+           -> Core (Maybe TH.KindQ) -> Core TH.ConQ -> Core [TH.DerivClauseQ]
+           -> DsM (Core TH.DecQ)
+repNewtype (MkC cxt) (MkC nm) (Left (MkC tvs)) (MkC ksig) (MkC con)
            (MkC derivs)
   = rep2 newtypeDName [cxt, nm, tvs, ksig, con, derivs]
-repNewtype (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC ksig) (MkC con)
-           (MkC derivs)
-  = rep2 newtypeInstDName [cxt, nm, tys, ksig, con, derivs]
+repNewtype (MkC cxt) (MkC nm) (Right (MkC mb_bndrs, MkC tys)) (MkC ksig)
+           (MkC con) (MkC derivs)
+  = rep2 newtypeInstDName [cxt, nm, mb_bndrs, tys, ksig, con, derivs]
 
 repTySyn :: Core TH.Name -> Core [TH.TyVarBndrQ]
          -> Core TH.TypeQ -> DsM (Core TH.DecQ)
@@ -2253,10 +2273,11 @@ repPragSpecInst (MkC ty) = rep2 pragSpecInstDName [ty]
 repPragComplete :: Core [TH.Name] -> Core (Maybe TH.Name) -> DsM (Core TH.DecQ)
 repPragComplete (MkC cls) (MkC mty) = rep2 pragCompleteDName [cls, mty]
 
-repPragRule :: Core String -> Core [TH.RuleBndrQ] -> Core TH.ExpQ
-            -> Core TH.ExpQ -> Core TH.Phases -> DsM (Core TH.DecQ)
-repPragRule (MkC nm) (MkC bndrs) (MkC lhs) (MkC rhs) (MkC phases)
-  = rep2 pragRuleDName [nm, bndrs, lhs, rhs, phases]
+repPragRule :: Core String -> Core (Maybe [TH.TyVarBndrQ])
+            -> Core [TH.RuleBndrQ] -> Core TH.ExpQ -> Core TH.ExpQ
+            -> Core TH.Phases -> DsM (Core TH.DecQ)
+repPragRule (MkC nm) (MkC ty_bndrs) (MkC tm_bndrs) (MkC lhs) (MkC rhs) (MkC phases)
+  = rep2 pragRuleDName [nm, ty_bndrs, tm_bndrs, lhs, rhs, phases]
 
 repPragAnn :: Core TH.AnnTarget -> Core TH.ExpQ -> DsM (Core TH.DecQ)
 repPragAnn (MkC targ) (MkC e) = rep2 pragAnnDName [targ, e]
@@ -2287,9 +2308,10 @@ repClosedFamilyD :: Core TH.Name
 repClosedFamilyD (MkC nm) (MkC tvs) (MkC res) (MkC inj) (MkC eqns)
     = rep2 closedTypeFamilyDName [nm, tvs, res, inj, eqns]
 
-repTySynEqn :: Core [TH.TypeQ] -> Core TH.TypeQ -> DsM (Core TH.TySynEqnQ)
-repTySynEqn (MkC lhs) (MkC rhs)
-  = rep2 tySynEqnName [lhs, rhs]
+repTySynEqn :: Core (Maybe [TH.TyVarBndrQ]) ->
+               Core [TH.TypeQ] -> Core TH.TypeQ -> DsM (Core TH.TySynEqnQ)
+repTySynEqn (MkC mb_bndrs) (MkC lhs) (MkC rhs)
+  = rep2 tySynEqnName [mb_bndrs, lhs, rhs]
 
 repRoleAnnotD :: Core TH.Name -> Core [TH.Role] -> DsM (Core TH.DecQ)
 repRoleAnnotD (MkC n) (MkC roles) = rep2 roleAnnotDName [n, roles]
@@ -2591,6 +2613,11 @@ coreStringLit s = do { z <- mkStringExpr s; return(MkC z) }
 
 ------------------- Maybe ------------------
 
+repMaybe :: Name -> (a -> DsM (Core b))
+                    -> Maybe a -> DsM (Core (Maybe b))
+repMaybe tc_name _ Nothing   = coreNothing tc_name
+repMaybe tc_name f (Just es) = coreJust tc_name =<< f es
+
 -- | Construct Core expression for Nothing of a given type name
 coreNothing :: Name        -- ^ Name of the TyCon of the element type
             -> DsM (Core (Maybe a))
@@ -2613,6 +2640,26 @@ coreJust' :: Type       -- ^ The element type
           -> Core a -> Core (Maybe a)
 coreJust' elt_ty es = MkC (mkJustExpr elt_ty (unC es))
 
+------------------- Maybe Lists ------------------
+
+repMaybeList :: Name -> (a -> DsM (Core b))
+                        -> Maybe [a] -> DsM (Core (Maybe [b]))
+repMaybeList tc_name _ Nothing = coreNothingList tc_name
+repMaybeList tc_name f (Just args)
+  = do { elt_ty <- lookupType tc_name
+       ; args1 <- mapM f args
+       ; return $ coreJust' (mkListTy elt_ty) (coreList' elt_ty args1) }
+
+coreNothingList :: Name -> DsM (Core (Maybe [a]))
+coreNothingList tc_name
+  = do { elt_ty <- lookupType tc_name
+       ; return $ coreNothing' (mkListTy elt_ty) }
+
+coreJustList :: Name -> Core [a] -> DsM (Core (Maybe [a]))
+coreJustList tc_name args
+  = do { elt_ty <- lookupType tc_name
+       ; return $ coreJust' (mkListTy elt_ty) args }
+
 ------------ Literals & Variables -------------------
 
 coreIntLit :: Int -> DsM (Core Int)
index ec982f6..e4a8bad 100644 (file)
@@ -402,7 +402,7 @@ tidy1 :: Id                  -- The Id being scrutinised
 -- list patterns, etc) and returns any created bindings in the wrapper.
 
 tidy1 v (ParPat _ pat)      = tidy1 v (unLoc pat)
-tidy1 v (SigPat _ pat)      = tidy1 v (unLoc pat)
+tidy1 v (SigPat _ pat _)    = tidy1 v (unLoc pat)
 tidy1 _ (WildPat ty)        = return (idDsWrapper, WildPat ty)
 tidy1 v (BangPat _ (L l p)) = tidy_bang_pat v l p
 
@@ -480,7 +480,7 @@ tidy_bang_pat :: Id -> SrcSpan -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
 
 -- Discard par/sig under a bang
 tidy_bang_pat v _ (ParPat _ (L l p)) = tidy_bang_pat v l p
-tidy_bang_pat v _ (SigPat _ (L l p)) = tidy_bang_pat v l p
+tidy_bang_pat v _ (SigPat _ (L l p) _) = tidy_bang_pat v l p
 
 -- Push the bang-pattern inwards, in the hope that
 -- it may disappear next time
index fbacb98..7fa941a 100644 (file)
@@ -292,7 +292,7 @@ hsExprToPmExpr (HsBinTick      _ _ _ e) = lhsExprToPmExpr e
 hsExprToPmExpr (HsTickPragma _ _ _ _ e) = lhsExprToPmExpr e
 hsExprToPmExpr (HsSCC          _ _ _ e) = lhsExprToPmExpr e
 hsExprToPmExpr (HsCoreAnn      _ _ _ e) = lhsExprToPmExpr e
-hsExprToPmExpr (ExprWithTySig      _ e) = lhsExprToPmExpr e
+hsExprToPmExpr (ExprWithTySig    _ e _) = lhsExprToPmExpr e
 hsExprToPmExpr (HsWrap           _ _ e) =  hsExprToPmExpr e
 hsExprToPmExpr e = PmExprOther e -- the rest are not handled by the oracle
 
index af2c603..8b12a78 100644 (file)
@@ -294,8 +294,8 @@ cvtDec (DataFamilyD tc tvs kind)
        ; returnJustL $ TyClD noExt $ FamDecl noExt $
          FamilyDecl noExt DataFamily tc' tvs' Prefix result Nothing }
 
-cvtDec (DataInstD ctxt tc tys ksig constrs derivs)
-  = do { (ctxt', tc', typats') <- cvt_tyinst_hdr ctxt tc tys
+cvtDec (DataInstD ctxt tc bndrs tys ksig constrs derivs)
+  = do { (ctxt', tc', bndrs', typats') <- cvt_tyinst_hdr ctxt tc bndrs tys
        ; ksig' <- cvtKind `traverse` ksig
        ; cons' <- mapM cvtConstr constrs
        ; derivs' <- cvtDerivs derivs
@@ -309,12 +309,14 @@ cvtDec (DataInstD ctxt tc tys ksig constrs derivs)
            { dfid_ext = noExt
            , dfid_inst = DataFamInstDecl { dfid_eqn = mkHsImplicitBndrs $
                            FamEqn { feqn_ext = noExt
-                                  , feqn_tycon = tc', feqn_pats = typats'
+                                  , feqn_tycon = tc'
+                                  , feqn_bndrs = bndrs'
+                                  , feqn_pats = typats'
                                   , feqn_rhs = defn
                                   , feqn_fixity = Prefix } }}}
 
-cvtDec (NewtypeInstD ctxt tc tys ksig constr derivs)
-  = do { (ctxt', tc', typats') <- cvt_tyinst_hdr ctxt tc tys
+cvtDec (NewtypeInstD ctxt tc bndrs tys ksig constr derivs)
+  = do { (ctxt', tc', bndrs', typats') <- cvt_tyinst_hdr ctxt tc bndrs tys
        ; ksig' <- cvtKind `traverse` ksig
        ; con' <- cvtConstr constr
        ; derivs' <- cvtDerivs derivs
@@ -327,7 +329,9 @@ cvtDec (NewtypeInstD ctxt tc tys ksig constr derivs)
            { dfid_ext = noExt
            , dfid_inst = DataFamInstDecl { dfid_eqn = mkHsImplicitBndrs $
                            FamEqn { feqn_ext = noExt
-                                  , feqn_tycon = tc', feqn_pats = typats'
+                                  , feqn_tycon = tc'
+                                  , feqn_bndrs = bndrs'
+                                  , feqn_pats = typats'
                                   , feqn_rhs = defn
                                   , feqn_fixity = Prefix } }}}
 
@@ -407,12 +411,14 @@ cvtDec (TH.ImplicitParamBindD _ _)
 
 ----------------
 cvtTySynEqn :: Located RdrName -> TySynEqn -> CvtM (LTyFamInstEqn GhcPs)
-cvtTySynEqn tc (TySynEqn lhs rhs)
-  = do  { lhs' <- mapM (wrap_apps <=< cvtType) lhs
+cvtTySynEqn tc (TySynEqn mb_bndrs lhs rhs)
+  = do  { mb_bndrs' <- traverse (mapM cvt_tv) mb_bndrs
+        ; lhs' <- mapM (wrap_apps <=< cvtType) lhs
         ; rhs' <- cvtType rhs
         ; returnL $ mkHsImplicitBndrs
                   $ FamEqn { feqn_ext    = noExt
                            , feqn_tycon  = tc
+                           , feqn_bndrs  = mb_bndrs'
                            , feqn_pats   = lhs'
                            , feqn_fixity = Prefix
                            , feqn_rhs    = rhs' } }
@@ -450,15 +456,17 @@ cvt_tycl_hdr cxt tc tvs
        ; return (cxt', tc', tvs')
        }
 
-cvt_tyinst_hdr :: TH.Cxt -> TH.Name -> [TH.Type]
+cvt_tyinst_hdr :: TH.Cxt -> TH.Name -> Maybe [TH.TyVarBndr] -> [TH.Type]
                -> CvtM ( LHsContext GhcPs
                        , Located RdrName
+                       , Maybe [LHsTyVarBndr GhcPs]
                        , HsTyPats GhcPs)
-cvt_tyinst_hdr cxt tc tys
-  = do { cxt' <- cvtContext cxt
-       ; tc'  <- tconNameL tc
-       ; tys' <- mapM (wrap_apps <=< cvtType) tys
-       ; return (cxt', tc', tys') }
+cvt_tyinst_hdr cxt tc bndrs tys
+  = do { cxt'   <- cvtContext cxt
+       ; tc'    <- tconNameL tc
+       ; bndrs' <- traverse (mapM cvt_tv) bndrs
+       ; tys'   <- mapM (wrap_apps <=< cvtType) tys
+       ; return (cxt', tc', bndrs', tys') }
 
 ----------------
 cvt_tyfam_head :: TypeFamilyHead
@@ -707,17 +715,26 @@ cvtPragmaD (SpecialiseInstP ty)
        ; returnJustL $ Hs.SigD noExt $
          SpecInstSig noExt (SourceText "{-# SPECIALISE") (mkLHsSigType ty') }
 
-cvtPragmaD (RuleP nm bndrs lhs rhs phases)
+cvtPragmaD (RuleP nm ty_bndrs tm_bndrs lhs rhs phases)
   = do { let nm' = mkFastString nm
        ; let act = cvtPhases phases AlwaysActive
-       ; bndrs' <- mapM cvtRuleBndr bndrs
+       ; ty_bndrs' <- traverse (mapM cvt_tv) ty_bndrs
+       ; tm_bndrs' <- mapM cvtRuleBndr tm_bndrs
        ; lhs'   <- cvtl lhs
        ; rhs'   <- cvtl rhs
        ; returnJustL $ Hs.RuleD noExt
-            $ HsRules noExt (SourceText "{-# RULES")
-                      [noLoc $ HsRule noExt (noLoc (quotedSourceText nm,nm'))
-                                                  act bndrs' lhs' rhs']
-       }
+            $ HsRules { rds_ext = noExt
+                      , rds_src = SourceText "{-# RULES"
+                      , rds_rules = [noLoc $
+                          HsRule { rd_ext  = noExt
+                                 , rd_name = (noLoc (quotedSourceText nm,nm'))
+                                 , rd_act  = act
+                                 , rd_tyvs = ty_bndrs'
+                                 , rd_tmvs = tm_bndrs'
+                                 , rd_lhs  = lhs'
+                                 , rd_rhs  = rhs' }] }
+
+          }
 
 cvtPragmaD (AnnP target exp)
   = do { exp' <- cvtl exp
@@ -838,7 +855,7 @@ cvtl e = wrapL (cvt e)
                             ; t' <- cvtType t
                             ; tp <- wrap_apps t'
                             ; let tp' = parenthesizeHsType appPrec tp
-                            ; return $ HsAppType (mkHsWildCardBndrs tp') e' }
+                            ; return $ HsAppType noExt e' (mkHsWildCardBndrs tp') }
     cvt (LamE [] e)    = cvt e -- Degenerate case. We convert the body as its
                                -- own expression to avoid pretty-printing
                                -- oddities that can result from zero-argument
@@ -923,7 +940,7 @@ cvtl e = wrapL (cvt e)
     cvt (ParensE e)      = do { e' <- cvtl e; return $ HsPar noExt e' }
     cvt (SigE e t)       = do { e' <- cvtl e; t' <- cvtType t
                               ; let pe = parenthesizeHsExpr sigPrec e'
-                              ; return $ ExprWithTySig (mkLHsSigWcType t') pe }
+                              ; return $ ExprWithTySig noExt pe (mkLHsSigWcType t') }
     cvt (RecConE c flds) = do { c' <- cNameL c
                               ; flds' <- mapM (cvtFld (mkFieldOcc . noLoc)) flds
                               ; return $ mkRdrRecordCon c' (HsRecFields flds' Nothing) }
@@ -1201,7 +1218,7 @@ cvtp (ListP ps)        = do { ps' <- cvtPats ps
                             ; return
                                    $ ListPat noExt ps'}
 cvtp (SigP p t)        = do { p' <- cvtPat p; t' <- cvtType t
-                            ; return $ SigPat (mkLHsSigWcType t') p' }
+                            ; return $ SigPat noExt p' (mkLHsSigWcType t') }
 cvtp (ViewP e p)       = do { e' <- cvtl e; p' <- cvtPat p
                             ; return $ ViewPat noExt e' p'}
 
index 55f3b73..0ff36aa 100644 (file)
@@ -48,7 +48,7 @@ module HsDecls (
   -- ** Deriving strategies
   DerivStrategy(..), LDerivStrategy, derivStrategyName,
   -- ** @RULE@ declarations
-  LRuleDecls,RuleDecls(..),RuleDecl(..), LRuleDecl, HsRuleRn(..),
+  LRuleDecls,RuleDecls(..),RuleDecl(..),LRuleDecl,HsRuleRn(..),
   RuleBndr(..),LRuleBndr,
   collectRuleBndrSigTys,
   flattenRuleDecls, pprFullRuleName,
@@ -1528,9 +1528,12 @@ type HsTyPats pass = [LHsType pass]
 {- Note [Family instance declaration binders]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 For ordinary data/type family instances, the feqn_pats field of FamEqn stores
-the LHS type (and kind) patterns. These type patterns can of course contain
-type (and kind) variables, which are bound in the hsib_vars field of the
-HsImplicitBndrs in FamInstEqn. Note in particular
+the LHS type (and kind) patterns. Any type (and kind) variables contained
+in these type patterns are bound in the hsib_vars field of the HsImplicitBndrs
+in FamInstEqn depending on whether or not an explicit forall is present. In
+the case of an explicit forall, the hsib_vars only includes kind variables not
+bound in the forall. Otherwise, all type (and kind) variables are bound in
+the hsib_vars. In the latter case, note that in particular
 
 * The hsib_vars *includes* any anonymous wildcards.  For example
      type instance F a _ = a
@@ -1616,6 +1619,7 @@ data FamEqn pass pats rhs
   = FamEqn
        { feqn_ext    :: XCFamEqn pass pats rhs
        , feqn_tycon  :: Located (IdP pass)
+       , feqn_bndrs  :: Maybe [LHsTyVarBndr pass] -- ^ Optional quantified type vars
        , feqn_pats   :: pats
        , feqn_fixity :: LexicalFixity -- ^ Fixity used in the declaration
        , feqn_rhs    :: rhs
@@ -1701,10 +1705,11 @@ ppr_instance_keyword NotTopLevel = empty
 ppr_fam_inst_eqn :: (OutputableBndrId (GhcPass p))
                  => TyFamInstEqn (GhcPass p) -> SDoc
 ppr_fam_inst_eqn (HsIB { hsib_body = FamEqn { feqn_tycon  = tycon
+                                            , feqn_bndrs  = bndrs
                                             , feqn_pats   = pats
                                             , feqn_fixity = fixity
                                             , feqn_rhs    = rhs }})
-    = pprFamInstLHS tycon pats fixity [] Nothing <+> equals <+> ppr rhs
+    = pprFamInstLHS tycon bndrs pats fixity [] Nothing <+> equals <+> ppr rhs
 ppr_fam_inst_eqn (HsIB { hsib_body = XFamEqn x }) = ppr x
 ppr_fam_inst_eqn (XHsImplicitBndrs x) = ppr x
 
@@ -1726,13 +1731,14 @@ pprDataFamInstDecl :: (OutputableBndrId (GhcPass p))
                    => TopLevelFlag -> DataFamInstDecl (GhcPass p) -> SDoc
 pprDataFamInstDecl top_lvl (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
                              FamEqn { feqn_tycon  = tycon
+                                    , feqn_bndrs  = bndrs
                                     , feqn_pats   = pats
                                     , feqn_fixity = fixity
                                     , feqn_rhs    = defn }}})
   = pp_data_defn pp_hdr defn
   where
     pp_hdr ctxt = ppr_instance_keyword top_lvl
-              <+> pprFamInstLHS tycon pats fixity ctxt Nothing
+              <+> pprFamInstLHS tycon bndrs pats fixity ctxt Nothing
                     -- No need to pass an explicit kind signature to
                     -- pprFamInstLHS here, since pp_data_defn already
                     -- pretty-prints that. See #14817.
@@ -1755,14 +1761,16 @@ pprDataFamInstFlavour (DataFamInstDecl (XHsImplicitBndrs x))
 
 pprFamInstLHS :: (OutputableBndrId (GhcPass p))
    => Located (IdP (GhcPass p))
+   -> Maybe [LHsTyVarBndr (GhcPass p)]
    -> HsTyPats (GhcPass p)
    -> LexicalFixity
    -> HsContext (GhcPass p)
    -> Maybe (LHsKind (GhcPass p))
    -> SDoc
-pprFamInstLHS thing typats fixity context mb_kind_sig
+pprFamInstLHS thing bndrs typats fixity context mb_kind_sig
                                               -- explicit type patterns
-   = hsep [ pprHsContext context, pp_pats typats, pp_kind_sig ]
+   = hsep [ pprHsContext context, pprHsExplicitForAll bndrs
+          , pp_pats typats, pp_kind_sig ]
    where
      pp_pats (patl:patr:pats)
        | Infix <- fixity
@@ -2139,24 +2147,27 @@ type LRuleDecl pass = Located (RuleDecl pass)
 
 -- | Rule Declaration
 data RuleDecl pass
-  = HsRule                             -- Source rule
-        (XHsRule pass)         -- After renamer, free-vars from the LHS and RHS
-        (Located (SourceText,RuleName)) -- Rule name
-               -- Note [Pragma source text] in BasicTypes
-        Activation
-        [LRuleBndr pass]        -- Forall'd vars; after typechecking this
-                                --   includes tyvars
-        (Located (HsExpr pass)) -- LHS
-        (Located (HsExpr pass)) -- RHS
-        -- ^
-        --  - 'ApiAnnotation.AnnKeywordId' :
-        --           'ApiAnnotation.AnnOpen','ApiAnnotation.AnnTilde',
-        --           'ApiAnnotation.AnnVal',
-        --           'ApiAnnotation.AnnClose',
-        --           'ApiAnnotation.AnnForall','ApiAnnotation.AnnDot',
-        --           'ApiAnnotation.AnnEqual',
-
-        -- For details on above see note [Api annotations] in ApiAnnotation
+  = HsRule -- Source rule
+       { rd_ext  :: XHsRule pass
+           -- ^ After renamer, free-vars from the LHS and RHS
+       , rd_name :: Located (SourceText,RuleName)
+           -- ^ Note [Pragma source text] in BasicTypes
+       , rd_act  :: Activation
+       , rd_tyvs :: Maybe [LHsTyVarBndr (NoGhcTc pass)]
+           -- ^ Forall'd type vars
+       , rd_tmvs :: [LRuleBndr pass]
+           -- ^ Forall'd term vars, before typechecking; after typechecking
+           --    this includes all forall'd vars
+       , rd_lhs  :: Located (HsExpr pass)
+       , rd_rhs  :: Located (HsExpr pass)
+       }
+    -- ^
+    --  - 'ApiAnnotation.AnnKeywordId' :
+    --           'ApiAnnotation.AnnOpen','ApiAnnotation.AnnTilde',
+    --           'ApiAnnotation.AnnVal',
+    --           'ApiAnnotation.AnnClose',
+    --           'ApiAnnotation.AnnForall','ApiAnnotation.AnnDot',
+    --           'ApiAnnotation.AnnEqual',
   | XRuleDecl (XXRuleDecl pass)
 
 data HsRuleRn = HsRuleRn NameSet NameSet -- Free-vars from the LHS and RHS
@@ -2195,21 +2206,29 @@ collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ _ ty <- bndrs]
 pprFullRuleName :: Located (SourceText, RuleName) -> SDoc
 pprFullRuleName (L _ (st, n)) = pprWithSourceText st (doubleQuotes $ ftext n)
 
-instance (p ~ GhcPass pass, OutputableBndrId p)
-       => Outputable (RuleDecls p) where
-  ppr (HsRules _ st rules)
+instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (RuleDecls p) where
+  ppr (HsRules { rds_src = st
+               , rds_rules = rules })
     = pprWithSourceText st (text "{-# RULES")
           <+> vcat (punctuate semi (map ppr rules)) <+> text "#-}"
   ppr (XRuleDecls x) = ppr x
 
 instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (RuleDecl p) where
-  ppr (HsRule _ name act ns lhs rhs)
+  ppr (HsRule { rd_name = name
+              , rd_act  = act
+              , rd_tyvs = tys
+              , rd_tmvs = tms
+              , rd_lhs  = lhs
+              , rd_rhs  = rhs })
         = sep [pprFullRuleName name <+> ppr act,
-               nest 4 (pp_forall <+> pprExpr (unLoc lhs)),
+               nest 4 (pp_forall_ty tys <+> pp_forall_tm tys
+                                        <+> pprExpr (unLoc lhs)),
                nest 6 (equals <+> pprExpr (unLoc rhs)) ]
         where
-          pp_forall | null ns   = empty
-                    | otherwise = forAllLit <+> fsep (map ppr ns) <> dot
+          pp_forall_ty Nothing     = empty
+          pp_forall_ty (Just qtvs) = forAllLit <+> fsep (map ppr qtvs) <> dot
+          pp_forall_tm Nothing | null tms = empty
+          pp_forall_tm _ = forAllLit <+> fsep (map ppr tms) <> dot
   ppr (XRuleDecl x) = ppr x
 
 instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (RuleBndr p) where
index dea72c3..d887a24 100644 (file)
@@ -335,7 +335,7 @@ data HsExpr p
 
   | HsApp     (XApp p) (LHsExpr p) (LHsExpr p) -- ^ Application
 
-  | HsAppType (XAppTypeE p) (LHsExpr p)  -- ^ Visible type application
+  | HsAppType (XAppTypeE p) (LHsExpr p) (LHsWcType (NoGhcTc p))  -- ^ Visible type application
        --
        -- Explicit type argument; e.g  f @Int x y
        -- NB: Has wildcards, but no implicit quantification
@@ -499,10 +499,10 @@ data HsExpr p
 
   -- For details on above see note [Api annotations] in ApiAnnotation
   | ExprWithTySig
-                (XExprWithTySig p)   -- Retain the signature,
-                                     -- as HsSigType Name, for
-                                     -- round-tripping purposes
+                (XExprWithTySig p)
+
                 (LHsExpr p)
+                (LHsSigWcType (NoGhcTc p))
 
   -- | Arithmetic sequence
   --
@@ -723,9 +723,7 @@ type instance XLam           (GhcPass _) = NoExt
 type instance XLamCase       (GhcPass _) = NoExt
 type instance XApp           (GhcPass _) = NoExt
 
-type instance XAppTypeE      GhcPs = LHsWcType GhcPs
-type instance XAppTypeE      GhcRn = LHsWcType GhcRn
-type instance XAppTypeE      GhcTc = LHsWcType GhcRn
+type instance XAppTypeE      (GhcPass _) = NoExt
 
 type instance XOpApp         GhcPs = NoExt
 type instance XOpApp         GhcRn = Fixity
@@ -766,9 +764,7 @@ type instance XRecordUpd     GhcPs = NoExt
 type instance XRecordUpd     GhcRn = NoExt
 type instance XRecordUpd     GhcTc = RecordUpdTc
 
-type instance XExprWithTySig GhcPs = (LHsSigWcType GhcPs)
-type instance XExprWithTySig GhcRn = (LHsSigWcType GhcRn)
-type instance XExprWithTySig GhcTc = (LHsSigWcType GhcRn)
+type instance XExprWithTySig (GhcPass _) = NoExt
 
 type instance XArithSeq      GhcPs = NoExt
 type instance XArithSeq      GhcRn = NoExt
@@ -1086,7 +1082,7 @@ ppr_expr (RecordCon { rcon_con_name = con_id, rcon_flds = rbinds })
 ppr_expr (RecordUpd { rupd_expr = L _ aexp, rupd_flds = rbinds })
   = hang (ppr aexp) 2 (braces (fsep (punctuate comma (map ppr rbinds))))
 
-ppr_expr (ExprWithTySig sig expr)
+ppr_expr (ExprWithTySig _ expr sig)
   = hang (nest 2 (ppr_lexpr expr) <+> dcolon)
          4 (ppr sig)
 
@@ -1163,11 +1159,11 @@ ppr_expr (XExpr x) = ppr x
 
 ppr_apps :: (OutputableBndrId (GhcPass p))
          => HsExpr (GhcPass p)
-         -> [Either (LHsExpr (GhcPass p)) (XAppTypeE (GhcPass p))]
+         -> [Either (LHsExpr (GhcPass p)) (LHsWcType (NoGhcTc (GhcPass p)))]
          -> SDoc
 ppr_apps (HsApp _ (L _ fun) arg)        args
   = ppr_apps fun (Left arg : args)
-ppr_apps (HsAppType arg (L _ fun))    args
+ppr_apps (HsAppType _ (L _ fun) arg)    args
   = ppr_apps fun (Right arg : args)
 ppr_apps fun args = hang (ppr_expr fun) 2 (sep (map pp args))
   where
index a7c467d..43653a5 100644 (file)
@@ -27,6 +27,8 @@ import Var
 import Outputable
 import SrcLoc (Located)
 
+import Data.Kind
+
 {-
 Note [Trees that grow]
 ~~~~~~~~~~~~~~~~~~~~~~
@@ -85,6 +87,18 @@ type instance IdP GhcTc = Id
 
 type LIdP p = Located (IdP p)
 
+-- | Marks that a field uses the GhcRn variant even when the pass
+-- parameter is GhcTc. Useful for storing HsTypes in HsExprs, say, because
+-- HsType GhcTc should never occur.
+type family NoGhcTc (p :: Type) where
+    -- this way, GHC can figure out that the result is a GhcPass
+  NoGhcTc (GhcPass pass) = GhcPass (NoGhcTcPass pass)
+  NoGhcTc other          = other
+
+type family NoGhcTcPass (p :: Pass) :: Pass where
+  NoGhcTcPass 'Typechecked = 'Renamed
+  NoGhcTcPass other        = other
+
 -- =====================================================================
 -- Type families for the HsBinds extension points
 
@@ -423,12 +437,12 @@ type ForallXRuleDecls (c :: * -> Constraint) (x :: *) =
 
 -- -------------------------------------
 -- RuleDecl type families
-type family XHsRule         x
-type family XXRuleDecl      x
+type family XHsRule          x
+type family XXRuleDecl       x
 
 type ForallXRuleDecl (c :: * -> Constraint) (x :: *) =
-       ( c (XHsRule          x)
-       , c (XXRuleDecl       x)
+       ( c (XHsRule           x)
+       , c (XXRuleDecl        x)
        )
 
 -- -------------------------------------
@@ -1079,21 +1093,9 @@ type ConvertIdX a b =
 -- | Provide a summary constraint that gives all am Outputable constraint to
 -- extension points needing one
 type OutputableX p = -- See Note [OutputableX]
-  (
-    Outputable (XSigPat p)
-  , Outputable (XSigPat GhcRn)
-
-  , Outputable (XIPBinds    p)
-
-  , Outputable (XExprWithTySig p)
-  , Outputable (XExprWithTySig GhcRn)
-
-  , Outputable (XAppTypeE p)
-  , Outputable (XAppTypeE GhcRn)
-
+  ( Outputable (XIPBinds    p)
   , Outputable (XViaStrategy p)
   , Outputable (XViaStrategy GhcRn)
-
   )
 -- TODO: Should OutputableX be included in OutputableBndrId?
 
@@ -1104,5 +1106,9 @@ type OutputableX p = -- See Note [OutputableX]
 type OutputableBndrId id =
   ( OutputableBndr (NameOrRdrName (IdP id))
   , OutputableBndr (IdP id)
+  , OutputableBndr (NameOrRdrName (IdP (NoGhcTc id)))
+  , OutputableBndr (IdP (NoGhcTc id))
+  , NoGhcTc id ~ NoGhcTc (NoGhcTc id)
   , OutputableX id
+  , OutputableX (NoGhcTc id)
   )
index db323d9..5c7a6f1 100644 (file)
@@ -250,11 +250,11 @@ data Pat p
   -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon'
 
   -- For details on above see note [Api annotations] in ApiAnnotation
-  | SigPat          (XSigPat p)          -- Before typechecker
-                                         --  Signature can bind both
-                                         --  kind and type vars
-                                         -- After typechecker: Type
+  | SigPat          (XSigPat p)             -- After typechecker: Type
                     (LPat p)                -- Pattern with a type signature
+                    (LHsSigWcType (NoGhcTc p)) --  Signature can bind both
+                                               --  kind and type vars
+
     -- ^ Pattern with a type signature
 
         ------------ Pattern coercions (translation only) ---------------
@@ -319,8 +319,8 @@ type instance XNPlusKPat GhcPs = NoExt
 type instance XNPlusKPat GhcRn = NoExt
 type instance XNPlusKPat GhcTc = Type
 
-type instance XSigPat GhcPs = (LHsSigWcType GhcPs)
-type instance XSigPat GhcRn = (LHsSigWcType GhcRn)
+type instance XSigPat GhcPs = NoExt
+type instance XSigPat GhcRn = NoExt
 type instance XSigPat GhcTc = Type
 
 type instance XCoPat  (GhcPass _) = NoExt
@@ -524,7 +524,7 @@ pprPat (CoPat _ co pat _)       = pprHsWrapper co $ \parens
                                             -> if parens
                                                  then pprParendPat appPrec pat
                                                  else pprPat pat
-pprPat (SigPat ty pat)          = ppr pat <+> dcolon <+> ppr ty
+pprPat (SigPat _ pat ty)        = ppr pat <+> dcolon <+> ppr ty
 pprPat (ListPat _ pats)         = brackets (interpp'SP pats)
 pprPat (TuplePat _ pats bx)     = tupleParens (boxityTupleSort bx)
                                               (pprWithCommas ppr pats)
@@ -679,7 +679,7 @@ isIrrefutableHsPat pat
     go1 (ParPat _ pat)      = go pat
     go1 (AsPat _ _ pat)     = go pat
     go1 (ViewPat _ _ pat)   = go pat
-    go1 (SigPat _ pat)      = go pat
+    go1 (SigPat _ pat _)    = go pat
     go1 (TuplePat _ pats _) = all go pats
     go1 (SumPat {})         = False
                     -- See Note [Unboxed sum patterns aren't irrefutable]
@@ -793,7 +793,7 @@ collectEvVarsPat pat =
                                    $ unionManyBags
                                    $ map collectEvVarsLPat
                                    $ hsConPatArgs args
-    SigPat  _ p      -> collectEvVarsLPat p
+    SigPat  _ p _    -> collectEvVarsLPat p
     CoPat _ _ p _    -> collectEvVarsPat  p
     ConPatIn _  _    -> panic "foldMapPatBag: ConPatIn"
     _other_pat       -> emptyBag
index c36a54f..8200707 100644 (file)
@@ -63,7 +63,7 @@ module HsTypes (
         hsLTyVarBndrToType, hsLTyVarBndrsToTypes,
 
         -- Printing
-        pprHsType, pprHsForAll, pprHsForAllTvs, pprHsForAllExtra,
+        pprHsType, pprHsForAll, pprHsForAllExtra, pprHsExplicitForAll,
         pprHsContext, pprHsContextNoArrow, pprHsContextMaybe,
         hsTypeNeedsParens, parenthesizeHsType, parenthesizeHsContext
     ) where
@@ -1298,6 +1298,8 @@ instance Outputable HsWildCardInfo where
 pprAnonWildCard :: SDoc
 pprAnonWildCard = char '_'
 
+-- | Prints a forall; When passed an empty list, prints @forall.@ only when
+-- @-dppr-debug@
 pprHsForAll :: (OutputableBndrId (GhcPass p))
             => [LHsTyVarBndr (GhcPass p)] -> LHsContext (GhcPass p) -> SDoc
 pprHsForAll = pprHsForAllExtra Nothing
@@ -1313,15 +1315,17 @@ pprHsForAllExtra :: (OutputableBndrId (GhcPass p))
                  => Maybe SrcSpan -> [LHsTyVarBndr (GhcPass p)]
                  -> LHsContext (GhcPass p) -> SDoc
 pprHsForAllExtra extra qtvs cxt
-  = pprHsForAllTvs qtvs <+> pprHsContextExtra show_extra (unLoc cxt)
+  = pp_forall <+> pprHsContextExtra (isJust extra) (unLoc cxt)
   where
-    show_extra = isJust extra
+    pp_forall | null qtvs = whenPprDebug (forAllLit <> dot)
+              | otherwise = forAllLit <+> interppSP qtvs <> dot
 
-pprHsForAllTvs :: (OutputableBndrId (GhcPass p))
-               => [LHsTyVarBndr (GhcPass p)] -> SDoc
-pprHsForAllTvs qtvs
-  | null qtvs = whenPprDebug (forAllLit <+> dot)
-  | otherwise = forAllLit <+> interppSP qtvs <> dot
+-- | Version of 'pprHsForall' or 'pprHsForallExtra' that will always print
+-- @forall.@ when passed @Just []@. Prints nothing if passed 'Nothing'
+pprHsExplicitForAll :: (OutputableBndrId (GhcPass p))
+               => Maybe [LHsTyVarBndr (GhcPass p)] -> SDoc
+pprHsExplicitForAll (Just qtvs) = forAllLit <+> interppSP qtvs <> dot
+pprHsExplicitForAll Nothing     = empty
 
 pprHsContext :: (OutputableBndrId (GhcPass p)) => HsContext (GhcPass p) -> SDoc
 pprHsContext = maybe empty (<+> darrow) . pprHsContextMaybe
@@ -1390,7 +1394,7 @@ ppr_mono_lty ty = ppr_mono_ty (unLoc ty)
 
 ppr_mono_ty :: (OutputableBndrId (GhcPass p)) => HsType (GhcPass p) -> SDoc
 ppr_mono_ty (HsForAllTy { hst_bndrs = tvs, hst_body = ty })
-  = sep [pprHsForAllTvs tvs, ppr_mono_lty ty]
+  = sep [pprHsForAll tvs (noLoc []), ppr_mono_lty ty]
 
 ppr_mono_ty (HsQualTy { hst_ctxt = L _ ctxt, hst_body = ty })
   = sep [pprHsContextAlways ctxt, ppr_mono_lty ty]
index 431f3f0..e5e4ba6 100644 (file)
@@ -176,9 +176,9 @@ mkLocatedList ms = L (combineLocs (head ms) (last ms)) ms
 mkHsApp :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
 mkHsApp e1 e2 = addCLoc e1 e2 (HsApp noExt e1 e2)
 
-mkHsAppType :: (XAppTypeE (GhcPass id) ~ LHsWcType GhcRn)
+mkHsAppType :: (NoGhcTc (GhcPass id) ~ GhcRn)
             => LHsExpr (GhcPass id) -> LHsWcType GhcRn -> LHsExpr (GhcPass id)
-mkHsAppType e t = addCLoc e t_body (HsAppType paren_wct e)
+mkHsAppType e t = addCLoc e t_body (HsAppType noExt e paren_wct)
   where
     t_body    = hswc_body t
     paren_wct = t { hswc_body = parenthesizeHsType appPrec t_body }
@@ -1074,7 +1074,7 @@ collect_lpat (L _ pat) bndrs
     go (NPat {})                    = bndrs
     go (NPlusKPat _ (L _ n) _ _ _ _)= n : bndrs
 
-    go (SigPat _ pat)               = collect_lpat pat bndrs
+    go (SigPat _ pat _)             = collect_lpat pat bndrs
 
     go (SplicePat _ (HsSpliced _ _ (HsSplicedPat pat)))
                                   = go pat
@@ -1356,7 +1356,7 @@ lPatImplicits = hs_lpat
     hs_pat (ListPat _ pats)     = hs_lpats pats
     hs_pat (TuplePat _ pats _)  = hs_lpats pats
 
-    hs_pat (SigPat _ pat)       = hs_lpat pat
+    hs_pat (SigPat _ pat _)     = hs_lpat pat
     hs_pat (CoPat _ _ pat _)    = hs_pat pat
 
     hs_pat (ConPatIn _ ps)           = details ps
index a8a33bf..77bcd76 100644 (file)
@@ -909,7 +909,7 @@ hscCheckSafeImports tcg_env = do
               -> return tcg_env'
 
     warns dflags rules = listToBag $ map (warnRules dflags) rules
-    warnRules dflags (L loc (HsRule _ n _ _ _ _)) =
+    warnRules dflags (L loc (HsRule { rd_name = n })) =
         mkPlainWarnMsg dflags loc $
             text "Rule \"" <> ftext (snd $ unLoc n) <> text "\" ignored" $+$
             text "User defined rules are disabled under Safe Haskell"
index ce59ca1..0bd83ce 100644 (file)
@@ -4,7 +4,7 @@
 -- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
 --
 
-{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleContexts, TypeFamilies #-}
 
 module HscStats ( ppSourceStats ) where
 
@@ -181,4 +181,3 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
     sum7 = foldr add7 (0,0,0,0,0,0,0)
 
     add7 (x1,x2,x3,x4,x5,x6,x7) (y1,y2,y3,y4,y5,y6,y7) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5,x6+y6,x7+y7)
-
index 9f43e36..8a10516 100644 (file)
@@ -1,3 +1,4 @@
+
 --                                                              -*-haskell-*-
 -- ---------------------------------------------------------------------------
 -- (c) The University of Glasgow 1997-2003
@@ -81,13 +82,13 @@ import TysWiredIn       ( unitTyCon, unitDataCon, tupleTyCon, tupleDataCon, nilD
                           listTyCon_RDR, consDataCon_RDR, eqTyCon_RDR )
 
 -- compiler/utils
-import Util             ( looksLikePackageName )
+import Util             ( looksLikePackageName, fstOf3, sndOf3, thdOf3 )
 import GhcPrelude
 
 import qualified GHC.LanguageExtensions as LangExt
 }
 
-%expect 235 -- shift/reduce conflicts
+%expect 236 -- shift/reduce conflicts
 
 {- Last updated: 04 June 2018
 
@@ -120,16 +121,7 @@ follows. Shift parses as if the 'module' keyword follows.
 
 -------------------------------------------------------------------------------
 
-state 57 contains 2 shift/reduce conflicts.
-
-    *** strict_mark -> unpackedness .
-        strict_mark -> unpackedness . strictness
-
-    Conflicts: '~' '!'
-
--------------------------------------------------------------------------------
-
-state 61 contains 1 shift/reduce conflict.
+state 60 contains 1 shift/reduce conflict.
 
         context -> btype .
     *** type -> btype .
@@ -139,7 +131,7 @@ state 61 contains 1 shift/reduce conflict.
 
 -------------------------------------------------------------------------------
 
-state 62 contains 46 shift/reduce conflicts.
+state 61 contains 46 shift/reduce conflicts.
 
     *** btype -> tyapps .
         tyapps -> tyapps . tyapp
@@ -157,7 +149,7 @@ Shift parses as (per longest-parse rule):
 
 -------------------------------------------------------------------------------
 
-state 144 contains 15 shift/reduce conflicts.
+state 143 contains 15 shift/reduce conflicts.
 
         exp -> infixexp . '::' sigtype
         exp -> infixexp . '-<' exp
@@ -182,7 +174,7 @@ Shift parses as (per longest-parse rule):
 
 -------------------------------------------------------------------------------
 
-state 149 contains 67 shift/reduce conflicts.
+state 148 contains 67 shift/reduce conflicts.
 
     *** exp10 -> fexp .
         fexp -> fexp . aexp
@@ -200,7 +192,7 @@ Shift parses as (per longest-parse rule):
 
 -------------------------------------------------------------------------------
 
-state 204 contains 27 shift/reduce conflicts.
+state 203 contains 27 shift/reduce conflicts.
 
         aexp2 -> TH_TY_QUOTE . tyvar
         aexp2 -> TH_TY_QUOTE . gtycon
@@ -219,7 +211,7 @@ Shift parses as (per longest-parse rule):
 
 -------------------------------------------------------------------------------
 
-state 300 contains 1 shift/reduce conflicts.
+state 299 contains 1 shift/reduce conflicts.
 
         rule -> STRING . rule_activation rule_forall infixexp '=' exp
 
@@ -237,7 +229,7 @@ a rule instructing how to rewrite the expression '[0] f'.
 
 -------------------------------------------------------------------------------
 
-state 310 contains 1 shift/reduce conflict.
+state 309 contains 1 shift/reduce conflict.
 
     *** type -> btype .
         type -> btype . '->' ctype
@@ -248,7 +240,7 @@ Same as state 61 but without contexts.
 
 -------------------------------------------------------------------------------
 
-state 354 contains 1 shift/reduce conflicts.
+state 353 contains 1 shift/reduce conflicts.
 
         tup_exprs -> commas . tup_tail
         sysdcon_nolist -> '(' commas . ')'
@@ -263,7 +255,7 @@ if -XTupleSections is not specified.
 
 -------------------------------------------------------------------------------
 
-state 409 contains 1 shift/reduce conflicts.
+state 408 contains 1 shift/reduce conflicts.
 
         tup_exprs -> commas . tup_tail
         sysdcon_nolist -> '(#' commas . '#)'
@@ -275,7 +267,7 @@ Same as State 354 for unboxed tuples.
 
 -------------------------------------------------------------------------------
 
-state 417 contains 67 shift/reduce conflicts.
+state 416 contains 67 shift/reduce conflicts.
 
     *** exp10 -> '-' fexp .
         fexp -> fexp . aexp
@@ -299,7 +291,7 @@ parenthesized infix type expression of length 1.
 
 -------------------------------------------------------------------------------
 
-state 675 contains 1 shift/reduce conflicts.
+state 678 contains 1 shift/reduce conflicts.
 
     *** aexp2 -> ipvar .
         dbind -> ipvar . '=' exp
@@ -314,7 +306,7 @@ sensible meaning, namely the lhs of an implicit binding.
 
 -------------------------------------------------------------------------------
 
-state 752 contains 1 shift/reduce conflicts.
+state 756 contains 1 shift/reduce conflicts.
 
         rule -> STRING rule_activation . rule_forall infixexp '=' exp
 
@@ -331,7 +323,7 @@ doesn't include 'forall'.
 
 -------------------------------------------------------------------------------
 
-state 986 contains 1 shift/reduce conflicts.
+state 992 contains 1 shift/reduce conflicts.
 
         transformqual -> 'then' 'group' . 'using' exp
         transformqual -> 'then' 'group' . 'by' exp 'using' exp
@@ -341,7 +333,29 @@ state 986 contains 1 shift/reduce conflicts.
 
 -------------------------------------------------------------------------------
 
-state 1367 contains 1 shift/reduce conflict.
+state 1089 contains 1 shift/reduce conflicts.
+
+        rule_foralls -> 'forall' rule_vars '.' . 'forall' rule_vars '.'
+    *** rule_foralls -> 'forall' rule_vars '.' .
+
+    Conflict: 'forall'
+
+Example ambigutiy: '{-# RULES "name" forall a. forall ... #-}'
+
+Here the parser cannot tell whether the second 'forall' is the beginning of
+a term-level quantifier, for example:
+
+'{-# RULES "name" forall a. forall x. id @a x = x #-}'
+
+or a valid variable named 'forall', for example a function @:: Int -> Int@
+
+'{-# RULES "name" forall a. forall 0 = 0 #-}'
+
+Shift means the parser only allows the former. Also see conflict 753 above.
+
+-------------------------------------------------------------------------------
+
+state 1390 contains 1 shift/reduce conflict.
 
     *** atype -> tyvar .
         tv_bndr -> '(' tyvar . '::' kind ')'
@@ -1125,7 +1139,7 @@ inst_decl :: { LInstDecl GhcPs }
                     (mj AnnType $1:mj AnnInstance $2:(fst $ unLoc $3)) }
 
           -- data/newtype instance declaration
-        | data_or_newtype 'instance' capi_ctype tycl_hdr constrs
+        | data_or_newtype 'instance' capi_ctype tycl_hdr_inst constrs
                           maybe_derivings
             {% amms (mkDataFamInst (comb4 $1 $4 $5 $6) (snd $ unLoc $1) $3 $4
                                       Nothing (reverse (snd  $ unLoc $5))
@@ -1133,7 +1147,7 @@ inst_decl :: { LInstDecl GhcPs }
                     ((fst $ unLoc $1):mj AnnInstance $2:(fst $ unLoc $5)) }
 
           -- GADT instance declaration
-        | data_or_newtype 'instance' capi_ctype tycl_hdr opt_kind_sig
+        | data_or_newtype 'instance' capi_ctype tycl_hdr_inst opt_kind_sig
                  gadt_constrlist
                  maybe_derivings
             {% amms (mkDataFamInst (comb4 $1 $4 $6 $7) (snd $ unLoc $1) $3 $4
@@ -1223,11 +1237,16 @@ ty_fam_inst_eqns :: { Located [LTyFamInstEqn GhcPs] }
         | {- empty -}                 { noLoc [] }
 
 ty_fam_inst_eqn :: { Located ([AddAnn],TyFamInstEqn GhcPs) }
-        : type '=' ktype
-                -- Note the use of type for the head; this allows
-                -- infix type constructors and type patterns
-              {% do { (eqn,ann) <- mkTyFamInstEqn $1 $3
+        : 'forall' tv_bndrs '.' type '=' ktype
+              {% do { hintExplicitForall (getLoc $1)
+                    ; (eqn,ann) <- mkTyFamInstEqn (Just $2) $4 $6
+                    ; ams (sLL $4 $> (mj AnnEqual $5:ann, eqn))
+                          [mu AnnForall $1, mj AnnDot $3]  } }
+        | type '=' ktype
+              {% do { (eqn,ann) <- mkTyFamInstEqn Nothing $1 $3
                     ; return (sLL $1 $> (mj AnnEqual $2:ann, eqn))  } }
+              -- Note the use of type for the head; this allows
+              -- infix type constructors and type patterns
 
 -- Associated type family declarations
 --
@@ -1291,13 +1310,13 @@ at_decl_inst :: { LInstDecl GhcPs }
 
         -- data/newtype instance declaration, with optional 'instance' keyword
         -- (can't use opt_instance because you get reduce/reduce errors)
-        | data_or_newtype capi_ctype tycl_hdr constrs maybe_derivings
+        | data_or_newtype capi_ctype tycl_hdr_inst constrs maybe_derivings
                {% amms (mkDataFamInst (comb4 $1 $3 $4 $5) (snd $ unLoc $1) $2 $3
                                     Nothing (reverse (snd $ unLoc $4))
                                             (fmap reverse $5))
                        ((fst $ unLoc $1):(fst $ unLoc $4)) }
 
-        | data_or_newtype 'instance' capi_ctype tycl_hdr constrs maybe_derivings
+        | data_or_newtype 'instance' capi_ctype tycl_hdr_inst constrs maybe_derivings
                {% amms (mkDataFamInst (comb4 $1 $4 $5 $6) (snd $ unLoc $1) $3 $4
                                     Nothing (reverse (snd $ unLoc $5))
                                             (fmap reverse $6))
@@ -1305,7 +1324,7 @@ at_decl_inst :: { LInstDecl GhcPs }
 
         -- GADT instance declaration, with optional 'instance' keyword
         -- (can't use opt_instance because you get reduce/reduce errors)
-        | data_or_newtype capi_ctype tycl_hdr opt_kind_sig
+        | data_or_newtype capi_ctype tycl_hdr_inst opt_kind_sig
                  gadt_constrlist
                  maybe_derivings
                 {% amms (mkDataFamInst (comb4 $1 $3 $5 $6) (snd $ unLoc $1) $2
@@ -1313,7 +1332,7 @@ at_decl_inst :: { LInstDecl GhcPs }
                                 (fmap reverse $6))
                         ((fst $ unLoc $1):(fst $ unLoc $4)++(fst $ unLoc $5)) }
 
-        | data_or_newtype 'instance' capi_ctype tycl_hdr opt_kind_sig
+        | data_or_newtype 'instance' capi_ctype tycl_hdr_inst opt_kind_sig
                  gadt_constrlist
                  maybe_derivings
                 {% amms (mkDataFamInst (comb4 $1 $4 $6 $7) (snd $ unLoc $1) $3
@@ -1362,6 +1381,22 @@ tycl_hdr :: { Located (Maybe (LHsContext GhcPs), LHsType GhcPs) }
                                     }
         | type                      { sL1 $1 (Nothing, $1) }
 
+tycl_hdr_inst :: { Located (Maybe (LHsContext GhcPs), Maybe [LHsTyVarBndr GhcPs], LHsType GhcPs) }
+        : 'forall' tv_bndrs '.' context '=>' type   {% hintExplicitForall (getLoc $1)
+                                                       >> (addAnnotation (gl $4) (toUnicodeAnn AnnDarrow $5) (gl $5)
+                                                           >> ams (sLL $1 $> $ (Just $4, Just $2, $6))
+                                                                  [mu AnnForall $1, mj AnnDot $3])
+                                                    }
+        | 'forall' tv_bndrs '.' type   {% hintExplicitForall (getLoc $1)
+                                          >> ams (sLL $1 $> $ (Nothing, Just $2, $4))
+                                                 [mu AnnForall $1, mj AnnDot $3]
+                                       }
+        | context '=>' type         {% addAnnotation (gl $1) (toUnicodeAnn AnnDarrow $2) (gl $2)
+                                       >> (return (sLL $1 $> (Just $1, Nothing, $3)))
+                                    }
+        | type                      { sL1 $1 (Nothing, Nothing, $1) }
+
+
 capi_ctype :: { Maybe (Located CType) }
 capi_ctype : '{-# CTYPE' STRING STRING '#-}'
                        {% ajs (Just (sLL $1 $> (CType (getCTYPEs $1) (Just (Header (getSTRINGs $2) (getSTRING $2)))
@@ -1607,11 +1642,13 @@ rules   :: { OrdList (LRuleDecl GhcPs) }
         |  {- empty -}                 { nilOL }
 
 rule    :: { LRuleDecl GhcPs }
-        : STRING rule_activation rule_forall infixexp '=' exp
-         {%ams (sLL $1 $> $ (HsRule noExt (L (gl $1) (getSTRINGs $1,getSTRING $1))
-                                  ((snd $2) `orElse` AlwaysActive)
-                                  (snd $3) $4 $6))
-               (mj AnnEqual $5 : (fst $2) ++ (fst $3)) }
+        : STRING rule_activation rule_foralls infixexp '=' exp
+         {%ams (sLL $1 $> $ HsRule { rd_ext = noExt
+                                   , rd_name = L (gl $1) (getSTRINGs $1, getSTRING $1)
+                                   , rd_act = (snd $2) `orElse` AlwaysActive
+                                   , rd_tyvs = sndOf3 $3, rd_tmvs = thdOf3 $3
+                                   , rd_lhs = $4, rd_rhs = $6 })
+               (mj AnnEqual $5 : (fst $2) ++ (fstOf3 $3)) }
 
 -- Rules can be specified to be NeverActive, unlike inline/specialize pragmas
 rule_activation :: { ([AddAnn],Maybe Activation) }
@@ -1627,20 +1664,48 @@ rule_explicit_activation :: { ([AddAnn]
         | '[' '~' ']'           { ([mos $1,mj AnnTilde $2,mcs $3]
                                   ,NeverActive) }
 
-rule_forall :: { ([AddAnn],[LRuleBndr GhcPs]) }
-        : 'forall' rule_var_list '.'     { ([mu AnnForall $1,mj AnnDot $3],$2) }
-        | {- empty -}                    { ([],[]) }
-
-rule_var_list :: { [LRuleBndr GhcPs] }
-        : rule_var                              { [$1] }
-        | rule_var rule_var_list                { $1 : $2 }
-
-rule_var :: { LRuleBndr GhcPs }
-        : varid                         { sLL $1 $> (RuleBndr noExt $1) }
-        | '(' varid '::' ctype ')'      {% ams (sLL $1 $> (RuleBndrSig noExt $2
-                                                       (mkLHsSigWcType $4)))
+rule_foralls :: { ([AddAnn], Maybe [LHsTyVarBndr GhcPs], [LRuleBndr GhcPs]) }
+        : 'forall' rule_vars '.' 'forall' rule_vars '.'    {% let tyvs = mkRuleTyVarBndrs $2
+                                                              in hintExplicitForall (getLoc $1)
+                                                              >> checkRuleTyVarBndrNames (mkRuleTyVarBndrs $2)
+                                                              >> return ([mu AnnForall $1,mj AnnDot $3,
+                                                                          mu AnnForall $4,mj AnnDot $6],
+                                                                         Just (mkRuleTyVarBndrs $2), mkRuleBndrs $5) }
+        | 'forall' rule_vars '.'                           { ([mu AnnForall $1,mj AnnDot $3],
+                                                              Nothing, mkRuleBndrs $2) }
+        | {- empty -}                                      { ([], Nothing, []) }
+
+rule_vars :: { [LRuleTyTmVar] }
+        : rule_var rule_vars                    { $1 : $2 }
+        | {- empty -}                           { [] }
+
+rule_var :: { LRuleTyTmVar }
+        : varid                         { sLL $1 $> (RuleTyTmVar $1 Nothing) }
+        | '(' varid '::' ctype ')'      {% ams (sLL $1 $> (RuleTyTmVar $2 (Just $4)))
                                                [mop $1,mu AnnDcolon $3,mcp $5] }
 
+{- Note [Parsing explicit foralls in Rules]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We really want the above definition of rule_foralls to be:
+
+  rule_foralls : 'forall' tv_bndrs '.' 'forall' rule_vars '.'
+               | 'forall' rule_vars '.'
+               | {- empty -}
+
+where rule_vars (term variables) can be named "forall", "family", or "role",
+but tv_vars (type variables) cannot be. However, such a definition results
+in a reduce/reduce conflict. For example, when parsing:
+> {-# RULE "name" forall a ... #-}
+before the '...' it is impossible to determine whether we should be in the
+first or second case of the above.
+
+This is resolved by using rule_vars (which is more general) for both, and
+ensuring that type-level quantified variables do not have the names "forall",
+"family", or "role" in the function 'checkRuleTyVarBndrNames' in RdrHsSyn.hs
+Thus, whenever the definition of tyvarid (used for tv_bndrs) is changed relative
+to varid (used for rule_vars), 'checkRuleTyVarBndrNames' must be updated.
+-}
+
 -----------------------------------------------------------------------------
 -- Warnings and deprecations (c.f. rules)
 
@@ -2463,7 +2528,7 @@ quasiquote :: { Located (HsSplice GhcPs) }
                             in sL (getLoc $1) (mkHsQuasiQuote quoterId (RealSrcSpan quoteSpan) quote) }
 
 exp   :: { LHsExpr GhcPs }
-        : infixexp '::' sigtype {% ams (sLL $1 $> $ ExprWithTySig (mkLHsSigWcType $3) $1)
+        : infixexp '::' sigtype {% ams (sLL $1 $> $ ExprWithTySig noExt $1 (mkLHsSigWcType $3))
                                        [mu AnnDcolon $2] }
         | infixexp '-<' exp     {% ams (sLL $1 $> $ HsArrApp noExt $1 $3
                                                         HsFirstOrderApp True)
@@ -2561,7 +2626,7 @@ fexp    :: { LHsExpr GhcPs }
         : fexp aexp                  {% checkBlockArguments $1 >> checkBlockArguments $2 >>
                                         return (sLL $1 $> $ (HsApp noExt $1 $2)) }
         | fexp TYPEAPP atype         {% checkBlockArguments $1 >>
-                                        ams (sLL $1 $> $ HsAppType (mkHsWildCardBndrs $3) $1)
+                                        ams (sLL $1 $> $ HsAppType noExt $1 (mkHsWildCardBndrs $3))
                                             [mj AnnAt $2] }
         | 'static' aexp              {% ams (sLL $1 $> $ HsStatic noExt $2)
                                             [mj AnnStatic $1] }
@@ -3308,6 +3373,8 @@ tyvarid :: { Located RdrName }
         | 'unsafe'         { sL1 $1 $! mkUnqual tvName (fsLit "unsafe") }
         | 'safe'           { sL1 $1 $! mkUnqual tvName (fsLit "safe") }
         | 'interruptible'  { sL1 $1 $! mkUnqual tvName (fsLit "interruptible") }
+        -- If this changes relative to varid, update 'checkRuleTyVarBndrNames' in RdrHsSyn.hs
+        -- See Note [Parsing explicit foralls in Rules]
 
 -----------------------------------------------------------------------------
 -- Variables
@@ -3348,6 +3415,8 @@ varid :: { Located RdrName }
         | 'forall'         { sL1 $1 $! mkUnqual varName (fsLit "forall") }
         | 'family'         { sL1 $1 $! mkUnqual varName (fsLit "family") }
         | 'role'           { sL1 $1 $! mkUnqual varName (fsLit "role") }
+        -- If this changes relative to tyvarid, update 'checkRuleTyVarBndrNames' in RdrHsSyn.hs
+        -- See Note [Parsing explicit foralls in Rules]
 
 qvarsym :: { Located RdrName }
         : varsym                { $1 }
index 1e89d5a..9917d96 100644 (file)
@@ -54,6 +54,9 @@ module   RdrHsSyn (
         checkValDef,          -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
         checkValSigLhs,
         checkDoAndIfThenElse,
+        LRuleTyTmVar, RuleTyTmVar(..),
+        mkRuleBndrs, mkRuleTyVarBndrs,
+        checkRuleTyVarBndrNames,
         checkRecordSyntax,
         checkEmptyGADTs,
         parseErrorSDoc, hintBangPat,
@@ -174,11 +177,13 @@ mkATDefault :: LTyFamInstDecl GhcPs
 -- some necessary paren annotations to the parsing context. Naturally, this
 -- is not something that the "Convert" use cares about.
 mkATDefault (L loc (TyFamInstDecl { tfid_eqn = HsIB { hsib_body = e }}))
-      | FamEqn { feqn_tycon = tc, feqn_pats = pats, feqn_fixity = fixity
-               , feqn_rhs = rhs } <- e
+      | FamEqn { feqn_tycon = tc, feqn_bndrs = bndrs, feqn_pats = pats
+               , feqn_fixity = fixity, feqn_rhs = rhs } <- e
       = do { (tvs, anns) <- checkTyVars (text "default") equalsDots tc pats
            ; let f = L loc (FamEqn { feqn_ext    = noExt
                                    , feqn_tycon  = tc
+                                   , feqn_bndrs  = ASSERT( isNothing bndrs )
+                                                   Nothing
                                    , feqn_pats   = tvs
                                    , feqn_fixity = fixity
                                    , feqn_rhs    = rhs })
@@ -235,14 +240,16 @@ mkTySynonym loc lhs rhs
                                 , tcdFixity = fixity
                                 , tcdRhs = rhs })) }
 
-mkTyFamInstEqn :: LHsType GhcPs
+mkTyFamInstEqn :: Maybe [LHsTyVarBndr GhcPs]
+               -> LHsType GhcPs
                -> LHsType GhcPs
                -> P (TyFamInstEqn GhcPs,[AddAnn])
-mkTyFamInstEqn lhs rhs
+mkTyFamInstEqn bndrs lhs rhs
   = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
        ; return (mkHsImplicitBndrs
                   (FamEqn { feqn_ext    = noExt
                           , feqn_tycon  = tc
+                          , feqn_bndrs  = bndrs
                           , feqn_pats   = tparams
                           , feqn_fixity = fixity
                           , feqn_rhs    = rhs }),
@@ -251,18 +258,19 @@ mkTyFamInstEqn lhs rhs
 mkDataFamInst :: SrcSpan
               -> NewOrData
               -> Maybe (Located CType)
-              -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
+              -> Located (Maybe (LHsContext GhcPs), Maybe [LHsTyVarBndr GhcPs], LHsType GhcPs)
               -> Maybe (LHsKind GhcPs)
               -> [LConDecl GhcPs]
               -> HsDeriving GhcPs
               -> P (LInstDecl GhcPs)
-mkDataFamInst loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
+mkDataFamInst loc new_or_data cType (L _ (mcxt, bndrs, tycl_hdr)) ksig data_cons maybe_deriv
   = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr
        ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
        ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
        ; return (L loc (DataFamInstD noExt (DataFamInstDecl (mkHsImplicitBndrs
                   (FamEqn { feqn_ext    = noExt
                           , feqn_tycon  = tc
+                          , feqn_bndrs  = bndrs
                           , feqn_pats   = tparams
                           , feqn_fixity = fixity
                           , feqn_rhs    = defn }))))) }
@@ -844,6 +852,33 @@ checkDatatypeContext (Just (L loc c))
                  (text "Illegal datatype context (use DatatypeContexts):" <+>
                   pprHsContext c)
 
+type LRuleTyTmVar = Located RuleTyTmVar
+data RuleTyTmVar = RuleTyTmVar (Located RdrName) (Maybe (LHsType GhcPs))
+-- ^ Essentially a wrapper for a @RuleBndr GhcPs@
+
+-- turns RuleTyTmVars into RuleBnrs - this is straightforward
+mkRuleBndrs :: [LRuleTyTmVar] -> [LRuleBndr GhcPs]
+mkRuleBndrs = fmap (fmap cvt_one)
+  where cvt_one (RuleTyTmVar v Nothing)    = RuleBndr    noExt v
+        cvt_one (RuleTyTmVar v (Just sig)) = RuleBndrSig noExt v (mkLHsSigWcType sig)
+
+-- turns RuleTyTmVars into HsTyVarBndrs - this is more interesting
+mkRuleTyVarBndrs :: [LRuleTyTmVar] -> [LHsTyVarBndr GhcPs]
+mkRuleTyVarBndrs = fmap (fmap cvt_one)
+  where cvt_one (RuleTyTmVar v Nothing)    = UserTyVar   noExt (fmap tm_to_ty v)
+        cvt_one (RuleTyTmVar v (Just sig)) = KindedTyVar noExt (fmap tm_to_ty v) sig
+        -- takes something in namespace 'varName' to something in namespace 'tvName'
+        tm_to_ty (Unqual occ) = Unqual (setOccNameSpace tvName occ)
+        tm_to_ty _ = panic "mkRuleTyVarBndrs"
+
+-- See note [Parsing explicit foralls in Rules] in Parser.y
+checkRuleTyVarBndrNames :: [LHsTyVarBndr GhcPs] -> P ()
+checkRuleTyVarBndrNames = mapM_ (check . fmap hsTyVarName)
+  where check (L loc (Unqual occ)) = do
+          when ((occNameString occ ==) `any` ["forall","family","role"])
+               (parseErrorSDoc loc (text $ "parse error on input " ++ occNameString occ))
+        check _ = panic "checkRuleTyVarBndrNames"
+
 checkRecordSyntax :: Outputable a => Located a -> P (Located a)
 checkRecordSyntax lr@(L loc r)
     = do allowed <- extension traditionalRecordSyntaxEnabled
@@ -1038,8 +1073,8 @@ checkAPat msg loc e0 = do
    -- view pattern is well-formed if the pattern is
    EViewPat _ expr patE -> checkLPat msg patE >>=
                             (return . (\p -> ViewPat noExt expr p))
-   ExprWithTySig t e   -> do e <- checkLPat msg e
-                             return (SigPat t e)
+   ExprWithTySig _ e t  -> do e <- checkLPat msg e
+                              return (SigPat noExt e t)
 
    -- n+k patterns
    OpApp _ (L nloc (HsVar _ (L _ n))) (L _ (HsVar _ (L _ plus)))
@@ -1114,7 +1149,7 @@ checkValDef :: SDoc
 checkValDef msg _strictness lhs (Just sig) grhss
         -- x :: ty = rhs  parses as a *pattern* binding
   = checkPatBind msg (L (combineLocs lhs sig)
-                        (ExprWithTySig (mkLHsSigWcType sig) lhs)) grhss
+                        (ExprWithTySig noExt lhs (mkLHsSigWcType sig))) grhss
 
 checkValDef msg strictness lhs Nothing g@(L l (_,grhss))
   = do  { mb_fun <- isFunLhs lhs
index 7cd5c55..60dead0 100644 (file)
@@ -958,7 +958,7 @@ renameSig _ (IdSig _ x)
 renameSig ctxt sig@(TypeSig _ vs ty)
   = do  { new_vs <- mapM (lookupSigOccRn ctxt sig) vs
         ; let doc = TypeSigCtx (ppr_sig_bndrs vs)
-        ; (new_ty, fvs) <- rnHsSigWcType doc ty
+        ; (new_ty, fvs) <- rnHsSigWcType BindUnlessForall doc ty
         ; return (TypeSig noExt new_vs new_ty, fvs) }
 
 renameSig ctxt sig@(ClassOpSig _ is_deflt vs ty)
index ae2bdf7..46ac6b8 100644 (file)
@@ -167,10 +167,10 @@ rnExpr (HsApp x fun arg)
        ; (arg',fvArg) <- rnLExpr arg
        ; return (HsApp x fun' arg', fvFun `plusFV` fvArg) }
 
-rnExpr (HsAppType arg fun)
+rnExpr (HsAppType x fun arg)
   = do { (fun',fvFun) <- rnLExpr fun
        ; (arg',fvArg) <- rnHsWcType HsTypeCtx arg
-       ; return (HsAppType arg' fun', fvFun `plusFV` fvArg) }
+       ; return (HsAppType x fun' arg', fvFun `plusFV` fvArg) }
 
 rnExpr (OpApp _ e1 op e2)
   = do  { (e1', fv_e1) <- rnLExpr e1
@@ -310,11 +310,11 @@ rnExpr (RecordUpd { rupd_expr = expr, rupd_flds = rbinds })
                             , rupd_flds = rbinds' }
                  , fvExpr `plusFV` fvRbinds) }
 
-rnExpr (ExprWithTySig pty expr)
-  = do  { (pty', fvTy)    <- rnHsSigWcType ExprWithTySigCtx pty
+rnExpr (ExprWithTySig _ expr pty)
+  = do  { (pty', fvTy)    <- rnHsSigWcType BindUnlessForall ExprWithTySigCtx pty
         ; (expr', fvExpr) <- bindSigTyVarsFV (hsWcScopedTvs pty') $
                              rnLExpr expr
-        ; return (ExprWithTySig pty' expr', fvExpr `plusFV` fvTy) }
+        ; return (ExprWithTySig noExt expr' pty', fvExpr `plusFV` fvTy) }
 
 rnExpr (HsIf x _ p b1 b2)
   = do { (p', fvP) <- rnLExpr p
@@ -1820,7 +1820,7 @@ isStrictPattern (L _ pat) =
     AsPat _ _ p     -> isStrictPattern p
     ParPat _ p      -> isStrictPattern p
     ViewPat _ _ p   -> isStrictPattern p
-    SigPat _ p      -> isStrictPattern p
+    SigPat _ p _    -> isStrictPattern p
     BangPat{}       -> True
     ListPat{}       -> True
     TuplePat{}      -> True
@@ -1944,7 +1944,7 @@ isReturnApp monad_names (L _ e) = case e of
   _otherwise -> Nothing
  where
   is_var f (L _ (HsPar _ e)) = is_var f e
-  is_var f (L _ (HsAppType _ e)) = is_var f e
+  is_var f (L _ (HsAppType _ e _)) = is_var f e
   is_var f (L _ (HsVar _ (L _ r))) = f r
        -- TODO: I don't know how to get this right for rebindable syntax
   is_var _ _ = False
index 6195309..a80a698 100644 (file)
@@ -213,7 +213,7 @@ matchNameMaker ctxt = LamMk report_unused
                       _                     -> True
 
 rnHsSigCps :: LHsSigWcType GhcPs -> CpsRn (LHsSigWcType GhcRn)
-rnHsSigCps sig = CpsRn (rnHsSigWcTypeScoped PatCtx sig)
+rnHsSigCps sig = CpsRn (rnHsSigWcTypeScoped AlwaysBind PatCtx sig)
 
 newPatLName :: NameMaker -> Located RdrName -> CpsRn (Located Name)
 newPatLName name_maker rdr_name@(L loc _)
@@ -393,7 +393,7 @@ rnPatAndThen mk (VarPat x (L l rdr)) = do { loc <- liftCps getSrcSpanM
      -- we need to bind pattern variables for view pattern expressions
      -- (e.g. in the pattern (x, x -> y) x needs to be bound in the rhs of the tuple)
 
-rnPatAndThen mk (SigPat sig pat )
+rnPatAndThen mk (SigPat x pat sig)
   -- When renaming a pattern type signature (e.g. f (a :: T) = ...), it is
   -- important to rename its type signature _before_ renaming the rest of the
   -- pattern, so that type variables are first bound by the _outermost_ pattern
@@ -405,7 +405,7 @@ rnPatAndThen mk (SigPat sig pat )
   -- ~~~~~~~~~~~~~~~^                   the same `a' then used here
   = do { sig' <- rnHsSigCps sig
        ; pat' <- rnLPatAndThen mk pat
-       ; return (SigPat sig' pat' ) }
+       ; return (SigPat x pat' sig' ) }
 
 rnPatAndThen mk (LitPat x lit)
   | HsString src s <- lit
index 9687e72..48739cd 100644 (file)
@@ -50,7 +50,7 @@ import NameEnv
 import Avail
 import Outputable
 import Bag
-import BasicTypes       ( RuleName, pprRuleName )
+import BasicTypes       ( pprRuleName )
 import FastString
 import SrcLoc
 import DynFlags
@@ -67,6 +67,7 @@ import Control.Arrow ( first )
 import Data.List ( mapAccumL )
 import qualified Data.List.NonEmpty as NE
 import Data.List.NonEmpty ( NonEmpty(..) )
+import Data.Maybe ( isNothing, maybe, fromMaybe )
 import qualified Data.Set as Set ( difference, fromList, toList, null )
 
 {- | @rnSourceDecl@ "renames" declarations.
@@ -693,33 +694,41 @@ rnFamInstEqn :: HsDocContext
              -> RnM (FamInstEqn GhcRn rhs', FreeVars)
 rnFamInstEqn doc mb_cls rhs_kvars
     (HsIB { hsib_body = FamEqn { feqn_tycon  = tycon
+                               , feqn_bndrs  = mb_bndrs
                                , feqn_pats   = pats
                                , feqn_fixity = fixity
                                , feqn_rhs    = payload }}) rn_payload
   = do { tycon'   <- lookupFamInstName (fmap fst mb_cls) tycon
-       ; let loc = case pats of
-                     []             -> pprPanic "rnFamInstEqn" (ppr tycon)
-                     (L loc _ : []) -> loc
-                     (L loc _ : ps) -> combineSrcSpans loc (getLoc (last ps))
-
-             pat_kity_vars_with_dups = extractHsTysRdrTyVarsDups pats
-             pat_vars = freeKiTyVarsAllVars $
-                        rmDupsInRdrTyVars pat_kity_vars_with_dups
+       ; let pat_kity_vars_with_dups = extractHsTysRdrTyVarsDups pats
              -- Use the "...Dups" form because it's needed
              -- below to report unsed binder on the LHS
-       ; pat_var_names <- mapM (newTyVarNameRn mb_cls . L loc . unLoc) pat_vars
-
+       ; let pat_kity_vars = rmDupsInRdrTyVars pat_kity_vars_with_dups
+
+         -- all pat vars not explicitly bound (see extractHsTvBndrs)
+       ; let mb_imp_kity_vars = extractHsTvBndrs <$> mb_bndrs <*> pure pat_kity_vars
+             imp_vars = case mb_imp_kity_vars of
+                          -- kind vars are the only ones free if we have an explicit forall
+                          Just nbnd_kity_vars -> freeKiTyVarsKindVars nbnd_kity_vars
+                          -- all pattern vars are free otherwise
+                          Nothing             -> freeKiTyVarsAllVars pat_kity_vars
+       ; imp_var_names <- mapM (newTyVarNameRn mb_cls) imp_vars
+
+       ; let bndrs = fromMaybe [] mb_bndrs
+             bnd_vars = map hsLTyVarLocName bndrs
+             payload_kvars = filterOut (`elemRdr` (bnd_vars ++ imp_vars)) rhs_kvars
              -- Make sure to filter out the kind variables that were explicitly
              -- bound in the type patterns.
-       ; let payload_vars = filterOut (`elemRdr` pat_vars) rhs_kvars
-       ; payload_var_names <- mapM (newTyVarNameRn mb_cls) payload_vars
+       ; payload_kvar_names <- mapM (newTyVarNameRn mb_cls) payload_kvars
 
-       ; let all_var_names = pat_var_names ++ payload_var_names
+         -- all names not bound in an explict forall
+       ; let all_imp_var_names = imp_var_names ++ payload_kvar_names
 
              -- All the free vars of the family patterns
              -- with a sensible binding location
-       ; ((pats', payload'), fvs)
-              <- bindLocalNamesFV all_var_names $
+       ; ((bndrs', pats', payload'), fvs)
+              <- bindLocalNamesFV all_imp_var_names $
+                 bindLHsTyVarBndrs doc (Just $ inHsDocContext doc)
+                                   mb_cls bndrs $ \bndrs' ->
                  do { (pats', pat_fvs) <- rnLHsTypes (FamPatCtx tycon) pats
                     ; (payload', rhs_fvs) <- rn_payload doc payload
 
@@ -728,7 +737,7 @@ rnFamInstEqn doc mb_cls rhs_kvars
                     ; let groups :: [NonEmpty (Located RdrName)]
                           groups = equivClasses cmpLocated $
                                    freeKiTyVarsAllVars pat_kity_vars_with_dups
-                    ; tv_nms_dups <- mapM (lookupOccRn . unLoc) $
+                    ; nms_dups <- mapM (lookupOccRn . unLoc) $
                                      [ tv | (tv :| (_:_)) <- groups ]
                           -- Add to the used variables
                           --  a) any variables that appear *more than once* on the LHS
@@ -736,27 +745,27 @@ rnFamInstEqn doc mb_cls rhs_kvars
                           --  b) for associated instances, the variables
                           --     of the instance decl.  See
                           --     Note [Unused type variables in family instances]
-                    ; let tv_nms_used = extendNameSetList rhs_fvs $
-                                        inst_tvs ++ tv_nms_dups
+                    ; let nms_used = extendNameSetList rhs_fvs $
+                                        inst_tvs ++ nms_dups
                           inst_tvs = case mb_cls of
                                        Nothing            -> []
                                        Just (_, inst_tvs) -> inst_tvs
-                    ; warnUnusedTypePatterns pat_var_names tv_nms_used
+                          all_nms = all_imp_var_names
+                                      ++ map hsLTyVarName bndrs'
+                    ; warnUnusedTypePatterns all_nms nms_used
 
                          -- See Note [Renaming associated types]
-                    ; let bad_tvs = case mb_cls of
-                                      Nothing           -> []
-                                      Just (_,cls_tkvs) -> filter is_bad cls_tkvs
-                          var_name_set = mkNameSet all_var_names
-
+                    ; let bad_tvs = maybe [] (filter is_bad . snd) mb_cls
+                          var_name_set = mkNameSet (map hsLTyVarName bndrs'
+                                                    ++ all_imp_var_names)
                           is_bad cls_tkv = cls_tkv `elemNameSet` rhs_fvs
-                                        && not (cls_tkv `elemNameSet` var_name_set)
+                                           && not (cls_tkv `elemNameSet` var_name_set)
                     ; unless (null bad_tvs) (badAssocRhs bad_tvs)
 
-                    ; return ((pats', payload'), rhs_fvs `plusFV` pat_fvs) }
+                    ; return ((bndrs', pats', payload'), rhs_fvs `plusFV` pat_fvs) }
 
        ; let anon_wcs = concatMap collectAnonWildCards pats'
-             all_ibs  = anon_wcs ++ all_var_names
+             all_ibs  = anon_wcs ++ all_imp_var_names
                         -- all_ibs: include anonymous wildcards in the implicit
                         -- binders In a type pattern they behave just like any
                         -- other type variable except for being anoymous.  See
@@ -768,6 +777,7 @@ rnFamInstEqn doc mb_cls rhs_kvars
                       , hsib_body
                           = FamEqn { feqn_ext    = noExt
                                    , feqn_tycon  = tycon'
+                                   , feqn_bndrs  = bndrs' <$ mb_bndrs
                                    , feqn_pats   = pats'
                                    , feqn_fixity = fixity
                                    , feqn_rhs    = payload' } },
@@ -796,6 +806,7 @@ rnTyFamDefltEqn :: Name
                 -> TyFamDefltEqn GhcPs
                 -> RnM (TyFamDefltEqn GhcRn, FreeVars)
 rnTyFamDefltEqn cls (FamEqn { feqn_tycon  = tycon
+                            , feqn_bndrs  = bndrs
                             , feqn_pats   = tyvars
                             , feqn_fixity = fixity
                             , feqn_rhs    = rhs })
@@ -805,6 +816,8 @@ rnTyFamDefltEqn cls (FamEqn { feqn_tycon  = tycon
        ; (rhs', fvs) <- rnLHsType ctx rhs
        ; return (FamEqn { feqn_ext    = noExt
                         , feqn_tycon  = tycon'
+                        , feqn_bndrs  = ASSERT( isNothing bndrs )
+                                        Nothing
                         , feqn_pats   = tyvars'
                         , feqn_fixity = fixity
                         , feqn_rhs    = rhs' }, fvs) } }
@@ -959,7 +972,7 @@ rnSrcDerivDecl (DerivDecl _ ty mds overlap)
        ; (mds', ty', fvs)
            <- rnLDerivStrategy DerivDeclCtx mds $ \strat_tvs ppr_via_ty ->
               rnAndReportFloatingViaTvs strat_tvs loc ppr_via_ty "instance" $
-              rnHsSigWcType DerivDeclCtx ty
+              rnHsSigWcType BindUnlessForall DerivDeclCtx ty
        ; return (DerivDecl noExt ty' mds' overlap, fvs) }
   where
     loc = getLoc $ hsib_body $ hswc_body ty
@@ -979,51 +992,75 @@ standaloneDerivErr
 -}
 
 rnHsRuleDecls :: RuleDecls GhcPs -> RnM (RuleDecls GhcRn, FreeVars)
-rnHsRuleDecls (HsRules _ src rules)
+rnHsRuleDecls (HsRules { rds_src = src
+                       , rds_rules = rules })
   = do { (rn_rules,fvs) <- rnList rnHsRuleDecl rules
-       ; return (HsRules noExt src rn_rules,fvs) }
+       ; return (HsRules { rds_ext = noExt
+                         , rds_src = src
+                         , rds_rules = rn_rules }, fvs) }
 rnHsRuleDecls (XRuleDecls _) = panic "rnHsRuleDecls"
 
 rnHsRuleDecl :: RuleDecl GhcPs -> RnM (RuleDecl GhcRn, FreeVars)
-rnHsRuleDecl (HsRule _ rule_name act vars lhs rhs)
-  = do { let rdr_names_w_loc = map get_var vars
+rnHsRuleDecl (HsRule { rd_name = rule_name
+                     , rd_act  = act
+                     , rd_tyvs = tyvs
+                     , rd_tmvs = tmvs
+                     , rd_lhs  = lhs
+                     , rd_rhs  = rhs })
+  = do { let rdr_names_w_loc = map get_var tmvs
        ; checkDupRdrNames rdr_names_w_loc
        ; checkShadowedRdrNames rdr_names_w_loc
        ; names <- newLocalBndrsRn rdr_names_w_loc
-       ; bindHsRuleVars (snd $ unLoc rule_name) vars names $ \ vars' ->
+       ; let doc = RuleCtx (snd $ unLoc rule_name)
+       ; bindRuleTyVars doc in_rule tyvs $ \ tyvs' ->
+         bindRuleTmVars doc tyvs' tmvs names $ \ tmvs' ->
     do { (lhs', fv_lhs') <- rnLExpr lhs
        ; (rhs', fv_rhs') <- rnLExpr rhs
        ; checkValidRule (snd $ unLoc rule_name) names lhs' fv_lhs'
-       ; return (HsRule (HsRuleRn fv_lhs' fv_rhs') rule_name act vars'
-                                                                     lhs' rhs',
-                 fv_lhs' `plusFV` fv_rhs') } }
+       ; return (HsRule { rd_ext  = HsRuleRn fv_lhs' fv_rhs'
+                        , rd_name = rule_name
+                        , rd_act  = act
+                        , rd_tyvs = tyvs'
+                        , rd_tmvs = tmvs'
+                        , rd_lhs  = lhs'
+                        , rd_rhs  = rhs' }, fv_lhs' `plusFV` fv_rhs') } }
   where
     get_var (L _ (RuleBndrSig _ v _)) = v
     get_var (L _ (RuleBndr _ v)) = v
     get_var (L _ (XRuleBndr _)) = panic "rnHsRuleDecl"
+    in_rule = text "in the rule" <+> pprFullRuleName rule_name
 rnHsRuleDecl (XRuleDecl _) = panic "rnHsRuleDecl"
 
-bindHsRuleVars :: RuleName -> [LRuleBndr GhcPs] -> [Name]
+bindRuleTmVars :: HsDocContext -> Maybe ty_bndrs
+               -> [LRuleBndr GhcPs] -> [Name]
                -> ([LRuleBndr GhcRn] -> RnM (a, FreeVars))
                -> RnM (a, FreeVars)
-bindHsRuleVars rule_name vars names thing_inside
+bindRuleTmVars doc tyvs vars names thing_inside
   = go vars names $ \ vars' ->
     bindLocalNamesFV names (thing_inside vars')
   where
-    doc = RuleCtx rule_name
-
     go (L l (RuleBndr _ (L loc _)) : vars) (n : ns) thing_inside
       = go vars ns $ \ vars' ->
         thing_inside (L l (RuleBndr noExt (L loc n)) : vars')
 
     go (L l (RuleBndrSig _ (L loc _) bsig) : vars) (n : ns) thing_inside
-      = rnHsSigWcTypeScoped doc bsig $ \ bsig' ->
+      = rnHsSigWcTypeScoped bind_free_tvs doc bsig $ \ bsig' ->
         go vars ns $ \ vars' ->
         thing_inside (L l (RuleBndrSig noExt (L loc n) bsig') : vars')
 
     go [] [] thing_inside = thing_inside []
     go vars names _ = pprPanic "bindRuleVars" (ppr vars $$ ppr names)
 
+    bind_free_tvs = case tyvs of Nothing -> AlwaysBind
+                                 Just _  -> NeverBind
+
+bindRuleTyVars :: HsDocContext -> SDoc -> Maybe [LHsTyVarBndr GhcPs]
+               -> (Maybe [LHsTyVarBndr GhcRn]  -> RnM (b, FreeVars))
+               -> RnM (b, FreeVars)
+bindRuleTyVars doc in_doc (Just bndrs) thing_inside
+  = bindLHsTyVarBndrs doc (Just in_doc) Nothing bndrs (thing_inside . Just)
+bindRuleTyVars _ _ _ thing_inside = thing_inside Nothing
+
 {-
 Note [Rule LHS validity checking]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1062,7 +1099,7 @@ validRuleLhs foralls lhs
     check (OpApp _ e1 op e2)              = checkl op `mplus` checkl_e e1
                                                       `mplus` checkl_e e2
     check (HsApp _ e1 e2)                 = checkl e1 `mplus` checkl_e e2
-    check (HsAppType _ e)                 = checkl e
+    check (HsAppType _ e _)               = checkl e
     check (HsVar _ (L _ v)) | v `notElem` foralls = Nothing
     check other                           = Just other  -- Failure
 
index 33f9329..abdaaae 100644 (file)
@@ -12,7 +12,7 @@ module RnTypes (
         rnHsType, rnLHsType, rnLHsTypes, rnContext,
         rnHsKind, rnLHsKind,
         rnHsSigType, rnHsWcType,
-        rnHsSigWcType, rnHsSigWcTypeScoped,
+        HsSigWcTypeScoping(..), rnHsSigWcType, rnHsSigWcTypeScoped,
         rnLHsInstType,
         newTyVarNameRn, collectAnonWildCards,
         rnConDeclFields,
@@ -83,13 +83,29 @@ to break several loop.
 *********************************************************
 -}
 
-rnHsSigWcType :: HsDocContext -> LHsSigWcType GhcPs
-            -> RnM (LHsSigWcType GhcRn, FreeVars)
-rnHsSigWcType doc sig_ty
-  = rn_hs_sig_wc_type False doc sig_ty $ \sig_ty' ->
+data HsSigWcTypeScoping = AlwaysBind
+                          -- ^ Always bind any free tyvars of the given type,
+                          --   regardless of whether we have a forall at the top
+                        | BindUnlessForall
+                          -- ^ Unless there's forall at the top, do the same
+                          --   thing as 'AlwaysBind'
+                        | NeverBind
+                          -- ^ Never bind any free tyvars
+
+rnHsSigWcType :: HsSigWcTypeScoping -> HsDocContext -> LHsSigWcType GhcPs
+              -> RnM (LHsSigWcType GhcRn, FreeVars)
+rnHsSigWcType scoping doc sig_ty
+  = rn_hs_sig_wc_type scoping doc sig_ty $ \sig_ty' ->
     return (sig_ty', emptyFVs)
 
-rnHsSigWcTypeScoped :: HsDocContext -> LHsSigWcType GhcPs
+rnHsSigWcTypeScoped :: HsSigWcTypeScoping
+                       -- AlwaysBind: for pattern type sigs and rules we /do/ want
+                       --             to bring those type variables into scope, even
+                       --             if there's a forall at the top which usually
+                       --             stops that happening
+                       -- e.g  \ (x :: forall a. a-> b) -> e
+                       -- Here we do bring 'b' into scope
+                    -> HsDocContext -> LHsSigWcType GhcPs
                     -> (LHsSigWcType GhcRn -> RnM (a, FreeVars))
                     -> RnM (a, FreeVars)
 -- Used for
@@ -97,33 +113,26 @@ rnHsSigWcTypeScoped :: HsDocContext -> LHsSigWcType GhcPs
 --   - Pattern type signatures
 -- Wildcards are allowed
 -- type signatures on binders only allowed with ScopedTypeVariables
-rnHsSigWcTypeScoped ctx sig_ty thing_inside
+rnHsSigWcTypeScoped scoping ctx sig_ty thing_inside
   = do { ty_sig_okay <- xoptM LangExt.ScopedTypeVariables
        ; checkErr ty_sig_okay (unexpectedTypeSigErr sig_ty)
-       ; rn_hs_sig_wc_type True ctx sig_ty thing_inside
+       ; rn_hs_sig_wc_type scoping ctx sig_ty thing_inside
        }
-    -- True: for pattern type sigs and rules we /do/ want
-    --       to bring those type variables into scope, even
-    --       if there's a forall at the top which usually
-    --       stops that happening
-    -- e.g  \ (x :: forall a. a-> b) -> e
-    -- Here we do bring 'b' into scope
-
-rn_hs_sig_wc_type :: Bool   -- True <=> always bind any free tyvars of the
-                            --          type, regardless of whether it has
-                            --          a forall at the top
-                  -> HsDocContext
-                  -> LHsSigWcType GhcPs
+
+rn_hs_sig_wc_type :: HsSigWcTypeScoping -> HsDocContext -> LHsSigWcType GhcPs
                   -> (LHsSigWcType GhcRn -> RnM (a, FreeVars))
                   -> RnM (a, FreeVars)
 -- rn_hs_sig_wc_type is used for source-language type signatures
-rn_hs_sig_wc_type always_bind_free_tvs ctxt
+rn_hs_sig_wc_type scoping ctxt
                   (HsWC { hswc_body = HsIB { hsib_body = hs_ty }})
                   thing_inside
   = do { free_vars <- extractFilteredRdrTyVarsDups hs_ty
        ; (tv_rdrs, nwc_rdrs') <- partition_nwcs free_vars
        ; let nwc_rdrs = nubL nwc_rdrs'
-             bind_free_tvs = always_bind_free_tvs || not (isLHsForAllTy hs_ty)
+             bind_free_tvs = case scoping of
+                               AlwaysBind       -> True
+                               BindUnlessForall -> not (isLHsForAllTy hs_ty)
+                               NeverBind        -> False
        ; rnImplicitBndrs bind_free_tvs tv_rdrs $ \ vars ->
     do { (wcs, hs_ty', fvs1) <- rnWcBody ctxt nwc_rdrs hs_ty
        ; let sig_ty' = HsWC { hswc_ext = wcs, hswc_body = ib_ty' }
index 0451e28..2f27720 100644 (file)
@@ -244,11 +244,14 @@ warnUnused1 flag fld_env name
   = when (reportable name occ) $
     addUnusedWarning flag
                      occ (nameSrcSpan name)
-                     (text "Defined but not used")
+                     (text $ "Defined but not used" ++ opt_str)
   where
     occ = case lookupNameEnv fld_env name of
               Just (fl, _) -> mkVarOccFS fl
               Nothing      -> nameOccName name
+    opt_str = case flag of
+                Opt_WarnUnusedTypePatterns -> " on the right hand side"
+                _ -> ""
 
 warnUnusedGRE :: GlobalRdrElt -> RnM ()
 warnUnusedGRE gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = is })
index 60872f7..4d246ef 100644 (file)
@@ -7,6 +7,7 @@
 
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
 
 module TcAnnotations ( tcAnnotations, annCtxt ) where
 
index 8f4e107..946cb5c 100644 (file)
@@ -5,6 +5,7 @@
                                        -- orphan
 {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
                                       -- in module PlaceHolder
+{-# LANGUAGE TypeFamilies #-}
 
 module TcEnv(
         TyThing(..), TcTyThing(..), TcId,
index 17678a5..f27922f 100644 (file)
@@ -240,9 +240,9 @@ tcExpr e@(HsOverLabel _ mb_fromLabel l) res_ty
   lbl = mkStrLitTy l
 
   applyFromLabel loc fromLabel =
-    HsAppType
-         (mkEmptyWildCardBndrs (L loc (HsTyLit noExt (HsStrTy NoSourceText l))))
+    HsAppType noExt
          (L loc (HsVar noExt (L loc fromLabel)))
+         (mkEmptyWildCardBndrs (L loc (HsTyLit noExt (HsStrTy NoSourceText l))))
 
 tcExpr (HsLam x match) res_ty
   = do  { (match', wrap) <- tcMatchLambda herald match_ctxt match res_ty
@@ -266,12 +266,12 @@ tcExpr e@(HsLamCase x matches) res_ty
               , text "requires"]
     match_ctxt = MC { mc_what = CaseAlt, mc_body = tcBody }
 
-tcExpr e@(ExprWithTySig sig_ty expr) res_ty
+tcExpr e@(ExprWithTySig _ expr sig_ty) res_ty
   = do { let loc = getLoc (hsSigWcType sig_ty)
        ; sig_info <- checkNoErrs $  -- Avoid error cascade
                      tcUserTypeSig loc sig_ty Nothing
        ; (expr', poly_ty) <- tcExprSig expr sig_info
-       ; let expr'' = ExprWithTySig sig_ty expr'
+       ; let expr'' = ExprWithTySig noExt expr' sig_ty
        ; tcWrapResult e expr'' poly_ty res_ty }
 
 {-
@@ -1112,7 +1112,7 @@ The SrcSpan is the span of the original HsPar
 
 -}
 
-wrapHsArgs :: (XAppTypeE (GhcPass id) ~ LHsWcType GhcRn)
+wrapHsArgs :: (NoGhcTc (GhcPass id) ~ GhcRn)
            => LHsExpr (GhcPass id)
            -> [HsArg (LHsExpr (GhcPass id)) (LHsWcType GhcRn)]
            -> LHsExpr (GhcPass id)
@@ -1164,7 +1164,7 @@ tcApp m_herald (L sp (HsPar _ fun)) args res_ty
 tcApp m_herald (L _ (HsApp _ fun arg1)) args res_ty
   = tcApp m_herald fun (HsValArg arg1 : args) res_ty
 
-tcApp m_herald (L _ (HsAppType ty1 fun)) args res_ty
+tcApp m_herald (L _ (HsAppType _ fun ty1)) args res_ty
   = tcApp m_herald fun (HsTypeArg ty1 : args) res_ty
 
 tcApp m_herald fun@(L loc (HsRecFld _ fld_lbl)) args res_ty
@@ -2359,7 +2359,7 @@ lookupParents rdr
 -- the record expression in an update must be "obvious", i.e. the
 -- outermost constructor ignoring parentheses.
 obviousSig :: HsExpr GhcRn -> Maybe (LHsSigWcType GhcRn)
-obviousSig (ExprWithTySig ty _) = Just ty
+obviousSig (ExprWithTySig _ _ ty) = Just ty
 obviousSig (HsPar _ p)          = obviousSig (unLoc p)
 obviousSig _                    = Nothing
 
index 32f081b..b3a4d53 100644 (file)
@@ -1850,13 +1850,12 @@ gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty
     underlying_inst_tys = changeLast inst_tys rhs_ty
 
 nlHsAppType :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs
-nlHsAppType e s = noLoc (HsAppType hs_ty e)
+nlHsAppType e s = noLoc (HsAppType noExt e hs_ty)
   where
     hs_ty = mkHsWildCardBndrs $ parenthesizeHsType appPrec (typeToLHsType s)
 
 nlExprWithTySig :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs
-nlExprWithTySig e s = noLoc $ ExprWithTySig hs_ty
-                            $ parenthesizeHsExpr sigPrec e
+nlExprWithTySig e s = noLoc $ ExprWithTySig noExt (parenthesizeHsExpr sigPrec e) hs_ty
   where
     hs_ty = mkLHsSigWcType (typeToLHsType s)
 
index 3363aa2..a201688 100644 (file)
@@ -111,7 +111,7 @@ hsPatType (TuplePat tys _ bx)           = mkTupleTy bx tys
 hsPatType (SumPat tys _ _ _ )           = mkSumTy tys
 hsPatType (ConPatOut { pat_con = L _ con, pat_arg_tys = tys })
                                         = conLikeResTy con tys
-hsPatType (SigPat ty _)                 = ty
+hsPatType (SigPat ty _ _)               = ty
 hsPatType (NPat ty _ _ _)               = ty
 hsPatType (NPlusKPat ty _ _ _ _ _)      = ty
 hsPatType (CoPat _ _ _ ty)              = ty
@@ -751,9 +751,9 @@ zonkExpr env (HsApp x e1 e2)
        new_e2 <- zonkLExpr env e2
        return (HsApp x new_e1 new_e2)
 
-zonkExpr env (HsAppType t e)
+zonkExpr env (HsAppType x e t)
   = do new_e <- zonkLExpr env e
-       return (HsAppType t new_e)
+       return (HsAppType x new_e t)
        -- NB: the type is an HsType; can't zonk that!
 
 zonkExpr _ e@(HsRnBracketOut _ _ _)
@@ -877,9 +877,9 @@ zonkExpr env (RecordUpd { rupd_flds = rbinds
                                 , rupd_out_tys = new_out_tys
                                 , rupd_wrap = new_recwrap }}) }
 
-zonkExpr env (ExprWithTySig ty e)
+zonkExpr env (ExprWithTySig _ e ty)
   = do { e' <- zonkLExpr env e
-       ; return (ExprWithTySig ty e') }
+       ; return (ExprWithTySig noExt e' ty) }
 
 zonkExpr env (ArithSeq expr wit info)
   = do (env1, new_wit) <- zonkWit env wit
@@ -1389,10 +1389,10 @@ zonk_pat env p@(ConPatOut { pat_arg_tys = tys, pat_tvs = tyvars
 
 zonk_pat env (LitPat x lit) = return (env, LitPat x lit)
 
-zonk_pat env (SigPat ty pat)
+zonk_pat env (SigPat ty pat hs_ty)
   = do  { ty' <- zonkTcTypeToTypeX env ty
         ; (env', pat') <- zonkPat env pat
-        ; return (env', SigPat ty' pat') }
+        ; return (env', SigPat ty' pat' hs_ty) }
 
 zonk_pat env (NPat ty (L l lit) mb_neg eq_expr)
   = do  { (env1, eq_expr') <- zonkSyntaxExpr env eq_expr
@@ -1475,8 +1475,10 @@ zonkRules :: ZonkEnv -> [LRuleDecl GhcTcId] -> TcM [LRuleDecl GhcTc]
 zonkRules env rs = mapM (wrapLocM (zonkRule env)) rs
 
 zonkRule :: ZonkEnv -> RuleDecl GhcTcId -> TcM (RuleDecl GhcTc)
-zonkRule env (HsRule fvs name act (vars{-::[RuleBndr TcId]-}) lhs rhs)
-  = do { (env_inside, new_bndrs) <- mapAccumLM zonk_bndr env vars
+zonkRule env rule@(HsRule { rd_tmvs = tm_bndrs{-::[RuleBndr TcId]-}
+                          , rd_lhs = lhs
+                          , rd_rhs = rhs })
+  = do { (env_inside, new_tm_bndrs) <- mapAccumLM zonk_tm_bndr env tm_bndrs
 
        ; let env_lhs = setZonkType env_inside SkolemiseFlexi
               -- See Note [Zonking the LHS of a RULE]
@@ -1484,13 +1486,15 @@ zonkRule env (HsRule fvs name act (vars{-::[RuleBndr TcId]-}) lhs rhs)
        ; new_lhs <- zonkLExpr env_lhs    lhs
        ; new_rhs <- zonkLExpr env_inside rhs
 
-       ; return (HsRule fvs name act new_bndrs new_lhs new_rhs ) }
+       ; return $ rule { rd_tmvs = new_tm_bndrs
+                       , rd_lhs  = new_lhs
+                       , rd_rhs  = new_rhs } }
   where
-   zonk_bndr env (L l (RuleBndr x (L loc v)))
+   zonk_tm_bndr env (L l (RuleBndr x (L loc v)))
       = do { (env', v') <- zonk_it env v
            ; return (env', L l (RuleBndr x (L loc v'))) }
-   zonk_bndr _ (L _ (RuleBndrSig {})) = panic "zonk_bndr RuleBndrSig"
-   zonk_bndr _ (L _ (XRuleBndr {})) = panic "zonk_bndr XRuleBndr"
+   zonk_tm_bndr _ (L _ (RuleBndrSig {})) = panic "zonk_tm_bndr RuleBndrSig"
+   zonk_tm_bndr _ (L _ (XRuleBndr {})) = panic "zonk_tm_bndr XRuleBndr"
 
    zonk_it env v
      | isId v     = do { v' <- zonkIdBndr env v
index d69357a..c9d9dd0 100644 (file)
@@ -589,7 +589,8 @@ tcDataFamInstDecl :: Maybe ClsInstInfo
 tcDataFamInstDecl mb_clsinfo
     (L loc decl@(DataFamInstDecl { dfid_eqn = HsIB { hsib_ext = tv_names
                                                    , hsib_body =
-      FamEqn { feqn_pats   = pats
+      FamEqn { feqn_bndrs  = mb_bndrs
+             , feqn_pats   = pats
              , feqn_tycon  = fam_tc_name
              , feqn_fixity = fixity
              , feqn_rhs    = HsDataDefn { dd_ND = new_or_data
@@ -608,7 +609,7 @@ tcDataFamInstDecl mb_clsinfo
 
          -- Kind check type patterns
        ; let mb_kind_env = thdOf3 <$> mb_clsinfo
-       ; tcFamTyPats fam_tc mb_clsinfo tv_names pats
+       ; tcFamTyPats fam_tc mb_clsinfo tv_names mb_bndrs pats
                      (kcDataDefn mb_kind_env decl) $
              \tvs pats res_kind ->
     do { stupid_theta <- solveEqualities $ tcHsContext ctxt
@@ -710,7 +711,7 @@ tcDataFamInstDecl mb_clsinfo
       = go pats (tv : etad_tvs)
     go pats etad_tvs = (reverse pats, etad_tvs)
 
-    pp_hs_pats = pprFamInstLHS fam_tc_name pats fixity (unLoc ctxt) m_ksig
+    pp_hs_pats = pprFamInstLHS fam_tc_name mb_bndrs pats fixity (unLoc ctxt) m_ksig
 
 tcDataFamInstDecl _
     (L _ (DataFamInstDecl
@@ -1666,8 +1667,8 @@ mkDefMethBind clas inst_tys sel_id dm_name
        ; return (bind, inline_prags) }
   where
     mk_vta :: LHsExpr GhcRn -> Type -> LHsExpr GhcRn
-    mk_vta fun ty = noLoc (HsAppType (mkEmptyWildCardBndrs $ nlHsParTy
-                                      $ noLoc $ XHsType $ NHsCoreTy ty) fun)
+    mk_vta fun ty = noLoc (HsAppType noExt fun (mkEmptyWildCardBndrs $ nlHsParTy
+                                                $ noLoc $ XHsType $ NHsCoreTy ty))
        -- NB: use visible type application
        -- See Note [Default methods in instances]
 
index ed797d3..c8d0075 100644 (file)
@@ -406,7 +406,7 @@ tc_pat penv (ViewPat _ expr pat) overall_pat_ty thing_inside
 
 -- Type signatures in patterns
 -- See Note [Pattern coercions] below
-tc_pat penv (SigPat sig_ty pat ) pat_ty thing_inside
+tc_pat penv (SigPat _ pat sig_ty) pat_ty thing_inside
   = do  { (inner_ty, tv_binds, wcs, wrap) <- tcPatSig (inPatBind penv)
                                                             sig_ty pat_ty
                 -- Using tcExtendNameTyVarEnv is appropriate here (not scopeTyVars2)
@@ -417,7 +417,7 @@ tc_pat penv (SigPat sig_ty pat ) pat_ty thing_inside
                          tcExtendNameTyVarEnv tv_binds $
                          tc_lpat pat (mkCheckExpType inner_ty) penv thing_inside
         ; pat_ty <- readExpType pat_ty
-        ; return (mkHsWrapPat wrap (SigPat inner_ty pat') pat_ty, res) }
+        ; return (mkHsWrapPat wrap (SigPat inner_ty pat' sig_ty) pat_ty, res) }
 
 ------------------------
 -- Lists, tuples, arrays
index 8f59e39..e86ff3c 100644 (file)
@@ -1007,7 +1007,7 @@ tcPatToExpr name args pat = go pat
           InfixCon l r  -> mkPrefixConExpr con [l,r]
           RecCon fields -> mkRecordConExpr con fields
 
-    go1 (SigPat _ pat) = go1 (unLoc pat)
+    go1 (SigPat _ pat _) = go1 (unLoc pat)
         -- See Note [Type signatures and the builder expression]
 
     go1 (VarPat _ (L l var))
@@ -1188,7 +1188,7 @@ tcCollectEx pat = go pat
     go1 (ViewPat _ _ p)    = go p
     go1 con@ConPatOut{}    = merge (pat_tvs con, pat_dicts con) $
                               goConDetails $ pat_args con
-    go1 (SigPat _ p)       = go p
+    go1 (SigPat _ p _)     = go p
     go1 (CoPat _ _ p _)    = go1 p
     go1 (NPlusKPat _ n k _ geq subtract)
       = pprPanic "TODO: NPlusKPat" $ ppr n $$ ppr k $$ ppr geq $$ ppr subtract
index 4d2141b..814a580 100644 (file)
@@ -2276,7 +2276,7 @@ getGhciStepIO = do
         stepTy :: LHsSigWcType GhcRn
         stepTy = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs step_ty)
 
-    return (noLoc $ ExprWithTySig stepTy (nlHsVar ghciStepIoMName))
+    return (noLoc $ ExprWithTySig noExt (nlHsVar ghciStepIoMName) stepTy)
 
 isGHCiMonad :: HscEnv -> String -> IO (Messages, Maybe Name)
 isGHCiMonad hsc_env ty
index a411975..9d150b5 100644 (file)
@@ -3630,7 +3630,7 @@ exprCtOrigin (HsLit {})           = Shouldn'tHappenOrigin "concrete literal"
 exprCtOrigin (HsLam _ matches)    = matchesCtOrigin matches
 exprCtOrigin (HsLamCase _ ms)     = matchesCtOrigin ms
 exprCtOrigin (HsApp _ e1 _)       = lexprCtOrigin e1
-exprCtOrigin (HsAppType _ e1)     = lexprCtOrigin e1
+exprCtOrigin (HsAppType _ e1 _)   = lexprCtOrigin e1
 exprCtOrigin (OpApp _ _ op _)     = lexprCtOrigin op
 exprCtOrigin (NegApp _ e _)       = lexprCtOrigin e
 exprCtOrigin (HsPar _ e)          = lexprCtOrigin e
index 552aa38..56f3f07 100644 (file)
@@ -34,7 +34,6 @@ import SrcLoc
 import Outputable
 import FastString
 import Bag
-import Data.List( partition )
 
 {-
 Note [Typechecking rules]
@@ -52,28 +51,43 @@ an example (test simplCore/should_compile/rule2.hs) produced by Roman:
    {-# RULES "foo/bar" foo = bar #-}
 
 He wanted the rule to typecheck.
+
+Note [TcLevel in type checking rules]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Bringing type variables into scope naturally bumps the TcLevel. Thus, we type
+check the term-level binders in a bumped level, and we must accordingly bump
+the level whenever these binders are in scope.
 -}
 
 tcRules :: [LRuleDecls GhcRn] -> TcM [LRuleDecls GhcTcId]
 tcRules decls = mapM (wrapLocM tcRuleDecls) decls
 
 tcRuleDecls :: RuleDecls GhcRn -> TcM (RuleDecls GhcTcId)
-tcRuleDecls (HsRules _ src decls)
+tcRuleDecls (HsRules { rds_src = src
+                     , rds_rules = decls })
    = do { tc_decls <- mapM (wrapLocM tcRule) decls
-        ; return (HsRules noExt src tc_decls) }
+        ; return $ HsRules { rds_ext   = noExt
+                           , rds_src   = src
+                           , rds_rules = tc_decls } }
 tcRuleDecls (XRuleDecls _) = panic "tcRuleDecls"
 
 tcRule :: RuleDecl GhcRn -> TcM (RuleDecl GhcTcId)
-tcRule (HsRule fvs rname@(L _ (_,name))
-               act hs_bndrs lhs rhs)
+tcRule (HsRule { rd_ext  = ext
+               , rd_name = rname@(L _ (_,name))
+               , rd_act  = act
+               , rd_tyvs = ty_bndrs
+               , rd_tmvs = tm_bndrs
+               , rd_lhs  = lhs
+               , rd_rhs  = rhs })
   = addErrCtxt (ruleCtxt name)  $
     do { traceTc "---- Rule ------" (pprFullRuleName rname)
 
         -- Note [Typechecking rules]
-       ; (stuff, tc_lvl) <- pushTcLevelM $
-                            generateRuleConstraints hs_bndrs lhs rhs
+       ; (stuff,_) <- pushTcLevelM $
+                      generateRuleConstraints ty_bndrs tm_bndrs lhs rhs
 
-       ; let ( id_bndrs, lhs', lhs_wanted, rhs', rhs_wanted, rule_ty) = stuff
+       ; let (id_bndrs, lhs', lhs_wanted
+                      , rhs', rhs_wanted, rule_ty, tc_lvl) = stuff
 
        ; traceTc "tcRule 1" (vcat [ pprFullRuleName rname
                                   , ppr lhs_wanted
@@ -120,58 +134,80 @@ tcRule (HsRule fvs rname@(L _ (_,name))
                                          lhs_evs rhs_wanted
 
        ; emitImplications (lhs_implic `unionBags` rhs_implic)
-       ; return (HsRule fvs rname act
-                    (map (noLoc . RuleBndr noExt . noLoc) (qtkvs ++ tpl_ids))
-                    (mkHsDictLet lhs_binds lhs')
-                    (mkHsDictLet rhs_binds rhs')) }
+       ; return $ HsRule { rd_ext = ext
+                         , rd_name = rname
+                         , rd_act = act
+                         , rd_tyvs = ty_bndrs -- preserved for ppr-ing
+                         , rd_tmvs = map (noLoc . RuleBndr noExt . noLoc) (qtkvs ++ tpl_ids)
+                         , rd_lhs  = mkHsDictLet lhs_binds lhs'
+                         , rd_rhs  = mkHsDictLet rhs_binds rhs' } }
 tcRule (XRuleDecl _) = panic "tcRule"
 
-generateRuleConstraints :: [LRuleBndr GhcRn] -> LHsExpr GhcRn -> LHsExpr GhcRn
+generateRuleConstraints :: Maybe [LHsTyVarBndr GhcRn] -> [LRuleBndr GhcRn]
+                        -> LHsExpr GhcRn -> LHsExpr GhcRn
                         -> TcM ( [TcId]
                                , LHsExpr GhcTc, WantedConstraints
                                , LHsExpr GhcTc, WantedConstraints
-                               , TcType )
-generateRuleConstraints hs_bndrs lhs rhs
-  = do { (vars, bndr_wanted) <- captureConstraints $
-                                tcRuleBndrs hs_bndrs
+                               , TcType
+                               , TcLevel )
+generateRuleConstraints ty_bndrs tm_bndrs lhs rhs
+  = do { ((tv_bndrs, id_bndrs, lvl), bndr_wanted) <- captureConstraints $
+                                                     tcRuleBndrs ty_bndrs tm_bndrs
               -- bndr_wanted constraints can include wildcard hole
               -- constraints, which we should not forget about.
               -- It may mention the skolem type variables bound by
               -- the RULE.  c.f. Trac #10072
 
-       ; let (id_bndrs, tv_bndrs) = partition isId vars
-       ; tcExtendTyVarEnv tv_bndrs $
+       ; setTcLevel lvl $
+         tcExtendTyVarEnv tv_bndrs $
          tcExtendIdEnv    id_bndrs $
     do { -- See Note [Solve order for RULES]
          ((lhs', rule_ty), lhs_wanted) <- captureConstraints (tcInferRho lhs)
        ; (rhs',            rhs_wanted) <- captureConstraints $
                                           tcMonoExpr rhs (mkCheckExpType rule_ty)
        ; let all_lhs_wanted = bndr_wanted `andWC` lhs_wanted
-       ; return (id_bndrs, lhs', all_lhs_wanted, rhs', rhs_wanted, rule_ty) } }
+       ; return (id_bndrs, lhs', all_lhs_wanted
+                         , rhs', rhs_wanted, rule_ty, lvl) } }
                 -- Slightly curious that tv_bndrs is not returned
 
-
-tcRuleBndrs :: [LRuleBndr GhcRn] -> TcM [Var]
-tcRuleBndrs []
-  = return []
-tcRuleBndrs (L _ (RuleBndr _ (L _ name)) : rule_bndrs)
+-- See Note [TcLevel in type checking rules]
+tcRuleBndrs :: Maybe [LHsTyVarBndr GhcRn] -> [LRuleBndr GhcRn]
+            -> TcM ([TcTyVar],[Id],TcLevel)
+tcRuleBndrs (Just bndrs) xs
+  = do { (tys1,(tys2,tms,lvl)) <- tcExplicitTKBndrs
+                                  (ForAllSkol (pprHsExplicitForAll (Just bndrs)))
+                                  bndrs $ do { lvl <- getTcLevel
+                                             ; (tys,tms) <- tcRuleTmBndrs xs
+                                             ; return (tys,tms,lvl) }
+       ; return (tys1 ++ tys2, tms, lvl) }
+tcRuleBndrs Nothing xs
+  = do { lvl <- getTcLevel
+       ; (tys,tms) <- tcRuleTmBndrs xs
+       ; return (tys,tms,lvl) }
+
+-- See Note [TcLevel in type checking rules]
+tcRuleTmBndrs :: [LRuleBndr GhcRn] -> TcM ([TcTyVar],[Id])
+tcRuleTmBndrs [] = return ([],[])
+tcRuleTmBndrs (L _ (RuleBndr _ (L _ name)) : rule_bndrs)
   = do  { ty <- newOpenFlexiTyVarTy
-        ; vars <- tcRuleBndrs rule_bndrs
-        ; return (mkLocalId name ty : vars) }
-tcRuleBndrs (L _ (RuleBndrSig _ (L _ name) rn_ty) : rule_bndrs)
+        ; (tyvars, tmvars) <- tcRuleTmBndrs rule_bndrs
+        ; return (tyvars, mkLocalId name ty : tmvars) }
+tcRuleTmBndrs (L _ (RuleBndrSig _ (L _ name) rn_ty) : rule_bndrs)
 --  e.g         x :: a->a
 --  The tyvar 'a' is brought into scope first, just as if you'd written
 --              a::*, x :: a->a
+--  If there's an explicit forall, the renamer would have already reported an
+--   error for each out-of-scope type variable used
   = do  { let ctxt = RuleSigCtxt name
         ; (_ , tvs, id_ty) <- tcHsPatSigType ctxt rn_ty
         ; let id  = mkLocalIdOrCoVar name id_ty
                     -- See Note [Pattern signature binders] in TcHsType
 
               -- The type variables scope over subsequent bindings; yuk
-        ; vars <- tcExtendNameTyVarEnv tvs $
-                  tcRuleBndrs rule_bndrs
-        ; return (map snd tvs ++ id : vars) }
-tcRuleBndrs (L _ (XRuleBndr _) : _) = panic "tcRuleBndrs"
+        ; (tyvars, tmvars) <- tcExtendNameTyVarEnv tvs $
+                                   tcRuleTmBndrs rule_bndrs
+        ; return (map snd tvs ++ tyvars, id : tmvars) }
+tcRuleTmBndrs (L _ (XRuleBndr _) : _) = panic "tcRuleTmBndrs"
 
 ruleCtxt :: FastString -> SDoc
 ruleCtxt name = text "When checking the transformation rule" <+>
index a4f8128..9cef875 100644 (file)
@@ -1391,14 +1391,17 @@ reifyThing thing = pprPanic "reifyThing" (pprTcTyThingCategory thing)
 
 -------------------------------------------
 reifyAxBranch :: TyCon -> CoAxBranch -> TcM TH.TySynEqn
-reifyAxBranch fam_tc (CoAxBranch { cab_lhs = lhs, cab_rhs = rhs })
+reifyAxBranch fam_tc (CoAxBranch { cab_tvs = tvs
+                                 , cab_lhs = lhs
+                                 , cab_rhs = rhs })
             -- remove kind patterns (#8884)
-  = do { let lhs_types_only = filterOutInvisibleTypes fam_tc lhs
+  = do { tvs' <- reifyTyVarsToMaybe tvs
+       ; let lhs_types_only = filterOutInvisibleTypes fam_tc lhs
        ; lhs' <- reifyTypes lhs_types_only
        ; annot_th_lhs <- zipWith3M annotThType (mkIsPolyTvs fam_tvs)
                                    lhs_types_only lhs'
        ; rhs'  <- reifyType rhs
-       ; return (TH.TySynEqn annot_th_lhs rhs') }
+       ; return (TH.TySynEqn tvs' annot_th_lhs rhs') }
   where
     fam_tvs = tyConVisibleTyVars fam_tc
 
@@ -1612,7 +1615,7 @@ reifyClass cls
 
     reifyDefImpl :: TH.Name -> [TH.Name] -> Type -> TcM TH.Dec
     reifyDefImpl n args ty =
-      TH.TySynInstD n . TH.TySynEqn (map TH.VarT args) <$> reifyType ty
+      TH.TySynInstD n . TH.TySynEqn Nothing (map TH.VarT args) <$> reifyType ty
 
     tfNames :: TH.Dec -> (TH.Name, [TH.Name])
     tfNames (TH.OpenTypeFamilyD (TH.TypeFamilyHead n args _ _))
@@ -1697,13 +1700,14 @@ reifyFamilyInstance is_poly_tvs inst@(FamInst { fi_flavor = flavor
   = case flavor of
       SynFamilyInst ->
                -- remove kind patterns (#8884)
-        do { let lhs_types_only = filterOutInvisibleTypes fam_tc lhs
+        do { th_tvs <- reifyTyVarsToMaybe fam_tvs
+           ; let lhs_types_only = filterOutInvisibleTypes fam_tc lhs
            ; th_lhs <- reifyTypes lhs_types_only
            ; annot_th_lhs <- zipWith3M annotThType is_poly_tvs lhs_types_only
                                                    th_lhs
            ; th_rhs <- reifyType rhs
            ; return (TH.TySynInstD (reifyName fam)
-                                   (TH.TySynEqn annot_th_lhs th_rhs)) }
+                                   (TH.TySynEqn th_tvs annot_th_lhs th_rhs)) }
 
       DataFamilyInst rep_tc ->
         do { let rep_tvs = tyConTyVars rep_tc
@@ -1720,14 +1724,15 @@ reifyFamilyInstance is_poly_tvs inst@(FamInst { fi_flavor = flavor
                  eta_expanded_lhs = lhs `chkAppend` etad_tys
                  dataCons         = tyConDataCons rep_tc
                  isGadt           = isGadtSyntaxTyCon rep_tc
+           ; th_tvs <- reifyTyVarsToMaybe fam_tvs
            ; cons <- mapM (reifyDataCon isGadt eta_expanded_tvs) dataCons
            ; let types_only = filterOutInvisibleTypes fam_tc eta_expanded_lhs
            ; th_tys <- reifyTypes types_only
            ; annot_th_tys <- zipWith3M annotThType is_poly_tvs types_only th_tys
            ; return $
                if isNewTyCon rep_tc
-               then TH.NewtypeInstD [] fam' annot_th_tys Nothing (head cons) []
-               else TH.DataInstD    [] fam' annot_th_tys Nothing       cons  []
+               then TH.NewtypeInstD [] fam' th_tvs annot_th_tys Nothing (head cons) []
+               else TH.DataInstD    [] fam' th_tvs annot_th_tys Nothing       cons  []
            }
   where
     fam_tc = famInstTyCon inst
@@ -1815,6 +1820,10 @@ reifyTyVars tvs = mapM reify_tv tvs
         kind = tyVarKind tv
         name = reifyName tv
 
+reifyTyVarsToMaybe :: [TyVar] -> TcM (Maybe [TH.TyVarBndr])
+reifyTyVarsToMaybe []  = pure Nothing
+reifyTyVarsToMaybe tys = Just <$> reifyTyVars tys
+
 {-
 Note [Kind annotations on TyConApps]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
index 49c6082..ea12998 100644 (file)
@@ -1254,7 +1254,7 @@ tcDefaultAssocDecl fam_tc [L loc (FamEqn { feqn_tycon = L _ tc_name
           -- type default LHS can mention *different* type variables than the
           -- enclosing class. So it's treated more as a freestanding beast.
        ; (pats', rhs_ty)
-           <- tcFamTyPats fam_tc Nothing all_vars pats
+           <- tcFamTyPats fam_tc Nothing all_vars Nothing pats
               (kcTyFamEqnRhs Nothing rhs) $
               \tvs pats rhs_kind ->
               do { rhs_ty <- solveEqualities $
@@ -1274,7 +1274,7 @@ tcDefaultAssocDecl fam_tc [L loc (FamEqn { feqn_tycon = L _ tc_name
            -- in checkValidClass
      }
 tcDefaultAssocDecl _ [L _ (XFamEqn _)] = panic "tcDefaultAssocDecl"
-tcDefaultAssocDecl _ [L _ (FamEqn _ (L _ _) (XLHsQTyVars _) _ _)]
+tcDefaultAssocDecl _ [L _ (FamEqn _ (L _ _) (XLHsQTyVars _) _ _)]
   = panic "tcDefaultAssocDecl"
 
 {- Note [Type-checking default assoc decls]
@@ -1527,22 +1527,24 @@ tcDataDefn _ _ _ _ (XHsDataDefn _) = panic "tcDataDefn"
 -------------------------
 kcTyFamInstEqn :: TcTyCon -> LTyFamInstEqn GhcRn -> TcM ()
 kcTyFamInstEqn tc_fam_tc
-    (L loc (HsIB { hsib_ext = tv_names
+    (L loc (HsIB { hsib_ext = imp_vars
                  , hsib_body = FamEqn { feqn_tycon  = L _ eqn_tc_name
+                                      , feqn_bndrs  = mb_expl_bndrs
                                       , feqn_pats   = pats
                                       , feqn_rhs    = hs_ty }}))
   = setSrcSpan loc $
     do { traceTc "kcTyFamInstEqn" (vcat
            [ text "tc_name =" <+> ppr eqn_tc_name
            , text "fam_tc =" <+> ppr tc_fam_tc <+> dcolon <+> ppr (tyConKind tc_fam_tc)
-           , text "hsib_vars =" <+> ppr tv_names
+           , text "hsib_vars =" <+> ppr imp_vars
+           , text "feqn_bndrs =" <+> ppr mb_expl_bndrs
            , text "feqn_pats =" <+> ppr pats ])
        ; checkTc (fam_name == eqn_tc_name)
                  (wrongTyFamName fam_name eqn_tc_name)
           -- this check reports an arity error instead of a kind error; easier for user
        ; checkTc (pats `lengthIs` vis_arity) $
                   wrongNumberOfParmsErr vis_arity
-       ; kcFamTyPats tc_fam_tc tv_names pats $ \ rhs_kind ->
+       ; kcFamTyPats tc_fam_tc imp_vars mb_expl_bndrs pats $ \ rhs_kind ->
          discardResult $ kcTyFamEqnRhs Nothing hs_ty rhs_kind }
   where
     fam_name = tyConName tc_fam_tc
@@ -1580,13 +1582,14 @@ tcTyFamInstEqn :: TcTyCon -> Maybe ClsInstInfo -> LTyFamInstEqn GhcRn
 -- Needs to be here, not in TcInstDcls, because closed families
 -- (typechecked here) have TyFamInstEqns
 tcTyFamInstEqn fam_tc mb_clsinfo
-    (L loc (HsIB { hsib_ext = tv_names
+    (L loc (HsIB { hsib_ext = imp_vars
                  , hsib_body = FamEqn { feqn_tycon  = L _ eqn_tc_name
+                                      , feqn_bndrs  = mb_expl_bndrs
                                       , feqn_pats   = pats
                                       , feqn_rhs    = hs_ty }}))
   = ASSERT( getName fam_tc == eqn_tc_name )
     setSrcSpan loc $
-    tcFamTyPats fam_tc mb_clsinfo tv_names pats
+    tcFamTyPats fam_tc mb_clsinfo imp_vars mb_expl_bndrs pats
                 (kcTyFamEqnRhs mb_clsinfo hs_ty) $
                     \tvs pats res_kind ->
     do { traceTc "tcTyFamInstEqn {" (ppr eqn_tc_name <+> ppr pats)
@@ -1617,6 +1620,7 @@ kcDataDefn :: Maybe (VarEnv Kind) -- ^ Possibly, instantiations for vars
 kcDataDefn mb_kind_env
            (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
               FamEqn { feqn_tycon  = fam_name
+                     , feqn_bndrs  = mb_bndrs
                      , feqn_pats   = pats
                      , feqn_fixity = fixity
                      , feqn_rhs    = HsDataDefn { dd_ctxt = ctxt
@@ -1664,10 +1668,10 @@ kcDataDefn mb_kind_env
         ; return (new_args, lhs_ki) }
   where
     bogus_ty   = pprPanic "kcDataDefn" (ppr fam_name <+> ppr pats)
-    pp_fam_app = pprFamInstLHS fam_name pats fixity (unLoc ctxt) mb_kind
+    pp_fam_app = pprFamInstLHS fam_name mb_bndrs pats fixity (unLoc ctxt) mb_kind
 kcDataDefn _ (DataFamInstDecl (XHsImplicitBndrs _)) _
   = panic "kcDataDefn"
-kcDataDefn _ (DataFamInstDecl (HsIB _ (FamEqn _ _ _ _ (XHsDataDefn _)))) _
+kcDataDefn _ (DataFamInstDecl (HsIB _ (FamEqn _ _ _ _ (XHsDataDefn _)))) _
   = panic "kcDataDefn"
 kcDataDefn _ (DataFamInstDecl (HsIB _ (XFamEqn _))) _
   = panic "kcDataDefn"
@@ -1718,12 +1722,14 @@ two bad things could happen:
 -----------------
 kcFamTyPats :: TcTyCon
             -> [Name]
+            -> Maybe [LHsTyVarBndr GhcRn]
             -> HsTyPats GhcRn
             -> (TcKind -> TcM ())
             -> TcM ()
-kcFamTyPats tc_fam_tc tv_names arg_pats kind_checker
+kcFamTyPats tc_fam_tc imp_vars mb_expl_bndrs arg_pats kind_checker
   = discardResult $
-    kcImplicitTKBndrs tv_names $
+    kcImplicitTKBndrs imp_vars $
+    kcExplicitTKBndrs (fromMaybe [] mb_expl_bndrs) $
     do { let name     = tyConName tc_fam_tc
              loc      = nameSrcSpan name
              lhs_fun  = L loc (HsTyVar noExt NotPromoted (L loc name))
@@ -1739,6 +1745,7 @@ kcFamTyPats tc_fam_tc tv_names arg_pats kind_checker
 tcFamTyPats :: TyCon
             -> Maybe ClsInstInfo
             -> [Name]          -- Implicitly bound kind/type variable names
+            -> Maybe [LHsTyVarBndr GhcRn]
             -> HsTyPats GhcRn  -- Type patterns
             -> (TcKind -> TcM ([TcType], TcKind))
                 -- kind-checker for RHS
@@ -1759,7 +1766,7 @@ tcFamTyPats :: TyCon
 -- In that case, the type variable 'a' will *already be in scope*
 -- (and, if C is poly-kinded, so will its kind parameter).
 tcFamTyPats fam_tc mb_clsinfo
-            tv_names arg_pats kind_checker thing_inside
+            imp_vars mb_expl_bndrs arg_pats kind_checker thing_inside
   = do { -- First, check the arity.
          -- If we wait until validity checking, we'll get kind
          -- errors below when an arity error will be much easier to
@@ -1774,10 +1781,10 @@ tcFamTyPats fam_tc mb_clsinfo
          wrongNumberOfParmsErr vis_arity
                       -- report only explicit arguments
 
-       ; (fam_used_tvs, (typats, (more_typats, res_kind)))
+       ; (imp_tvs, (exp_tvs, (typats, (more_typats, res_kind))))
             <- solveEqualities $  -- See Note [Constraints in patterns]
-               tcImplicitQTKBndrs FamInstSkol tv_names $
-                  -- See Note [Kind-checking tyvar binders for associated types]
+               tcImplicitQTKBndrs FamInstSkol imp_vars $
+               tcExplicitTKBndrs FamInstSkol (fromMaybe [] mb_expl_bndrs) $
                do { let loc = nameSrcSpan fam_name
                         lhs_fun = L loc (HsTyVar noExt NotPromoted
                                                                (L loc fam_name))
@@ -1827,19 +1834,24 @@ tcFamTyPats fam_tc mb_clsinfo
            -- bit is cleverer.
 
        ; traceTc "tcFamTyPats" (ppr (getName fam_tc)
+                                $$ ppr mb_expl_bndrs
                                 $$ ppr all_pats $$ ppr qtkvs)
 
            -- See Note [Free-floating kind vars] in TcHsType
        ; let all_mentioned_tvs = mkVarSet qtkvs
                                    -- qtkvs has all the tyvars bound by LHS
                                    -- type patterns
-             unmentioned_tvs   = filterOut (`elemVarSet` all_mentioned_tvs)
-                                           fam_used_tvs
+             unmentioned_imp_tvs = filterOut (`elemVarSet` all_mentioned_tvs) imp_tvs
                                    -- If there are tyvars left over, we can
                                    -- assume they're free-floating, since they
                                    -- aren't bound by a type pattern
        ; checkNoErrs $ reportFloatingKvs fam_name flav
-                                         qtkvs unmentioned_tvs
+                                         qtkvs unmentioned_imp_tvs
+
+            -- Error if exp_tvs contains anything that is still unused.
+            -- See Note [Unused explicitly bound variables in a family pattern]
+       ; let unmentioned_exp_tvs = filterOut (`elemVarSet` all_mentioned_tvs) exp_tvs
+       ; checkNoErrs $ mapM_ (unusedExplicitForAllErr . Var.varName) unmentioned_exp_tvs
 
        ; scopeTyVars FamInstSkol qtkvs $
             -- Extend envt with TcTyVars not TyVars, because the
@@ -1851,8 +1863,34 @@ tcFamTyPats fam_tc mb_clsinfo
     flav      = tyConFlavour fam_tc
     vis_arity = length (tyConVisibleTyVars fam_tc)
 
+unusedExplicitForAllErr :: Name -> RnM ()
+unusedExplicitForAllErr n = addErrAt (nameSrcSpan n) $
+  text "Explicitly quantified but not used in LHS pattern: type variable"
+  <+> quotes (ppr n)
 
 {-
+
+Note [Unused explicitly bound variables in a family pattern]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Why is 'unusedExplicitForAllErr' not just a warning?
+
+Consider the following examples:
+
+  type instance F a = Maybe b
+  type instance forall b. F a = Bool
+  type instance forall b. F a = Maybe b
+
+In every case, b is a type variable not determined by the LHS pattern. The
+first is caught by the renamer, but we catch the last two here. Perhaps one
+could argue that the second should be accepted, albeit with a warning, but
+consider the fact that in a type family instance, there is no way to interact
+with such a varable. At least with @x :: forall a. Int@ we can use visibile
+type application, like @x \@Bool 1@. (Of course it does nothing, but it is
+permissible.) In the type family case, the only sensible explanation is that
+the user has made a mistake -- thus we throw an error.
+
+
 Note [Constraints in patterns]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 NB: This isn't the whole story. See comment in tcFamTyPats.
index 366dd98..1963503 100644 (file)
@@ -7572,6 +7572,17 @@ instance for ``GMap`` is ::
 In this example, the declaration has only one variant. In general, it
 can be any number.
 
+When :extension:`ExplicitForAll` is enabled, type or kind variables used on
+the left hand side can be explicitly bound. For example: ::
+  
+    data instance forall a (b :: Proxy a). F (Proxy b) = FProxy Bool
+
+When an explicit ``forall`` is present, all *type* variables mentioned must
+be bound by the ``forall``. Kind variables will be implicitly bound if
+necessary, for example: ::
+  
+    data instance forall (a :: k). F a = FOtherwise
+
 When the flag :ghc-flag:`-Wunused-type-patterns` is enabled, type
 variables that are mentioned in the patterns on the left hand side, but not
 used on the right hand side are reported. Variables that occur multiple times
@@ -7585,6 +7596,9 @@ This resembles the wildcards that can be used in
 No error messages reporting the inferred types are generated, nor does
 the extension :extension:`PartialTypeSignatures` have any effect.
 
+A type or kind variable explicitly bound using :extension:`ExplicitForAll` but
+not used on the left hand side will generate an error, not a warning.
+
 Data and newtype instance declarations are only permitted when an
 appropriate family declaration is in scope - just as a class instance
 declaration requires the class declaration to be visible. Moreover, each
@@ -7737,6 +7751,10 @@ with underscores to avoid warnings when the
 :ghc-flag:`-Wunused-type-patterns` flag is enabled. The same rules apply
 as for :ref:`data-instance-declarations`.
 
+Also in the same way as :ref:`data-instance-declarations`, when
+:extension:`ExplicitForAll` is enabled, type and kind variables can be
+explicilty bound in a type instance declaration.
+
 Type family instance declarations are only legitimate when an
 appropriate family declaration is in scope - just like class instances
 require the class declaration to be visible. Moreover, each instance
@@ -7771,8 +7789,14 @@ Note that GHC must be sure that ``a`` cannot unify with ``Int`` or
 their code, GHC will not be able to simplify the type. After all, ``a``
 might later be instantiated with ``Int``.
 
-A closed type family's equations have the same restrictions as the
-equations for open type family instances.
+A closed type family's equations have the same restrictions and extensions as
+the equations for open type family instances. For instance, when
+:extension:`ExplicitForAll` is enabled, type or kind variables used on the
+left hand side of an equation can be explicitly bound, such as in: ::
+
+  type family R a where
+    forall t a. R (t a) = [a]
+    forall a.   R a     = a
 
 A closed type family may be declared with no equations. Such closed type
 families are opaque type-level definitions that will never reduce, are
@@ -8000,7 +8024,7 @@ Hence, the following contrived example is admissible: ::
 Here ``c`` and ``a`` are class parameters, but the type is also indexed
 on a third parameter ``x``.
 
-.. _assoc-data-inst:
+.. _assoc-inst:
 
 Associated instances
 ~~~~~~~~~~~~~~~~~~~~
@@ -8075,6 +8099,15 @@ Note the following points:
    cannot give any *subsequent* instances for ``(GMap Flob ...)``, this
    facility is most useful when the free indexed parameter is of a kind
    with a finite number of alternatives (unlike ``Type``).
+   
+-  When :extension:`ExplicitForAll` is enabled, type and kind variables can be
+   explicily bound in associated data or type family instances in the same way
+   (and with the same restrictions) as :ref:`data-instance-declarations` or
+   :ref:`type-instance-declarations`. For example, adapting the above, the
+   following is accepted: ::
+     
+     instance Eq (Elem [e]) => Collects [e] where
+       type forall e. Elem [e] = e
 
 .. _assoc-decl-defs:
 
@@ -8111,6 +8144,10 @@ Note the following points:
    variables that are explicitly bound on the left hand side. This restriction
    is relaxed for *kind* variables, however, as the right hand side is allowed
    to mention kind variables that are implicitly bound on the left hand side.
+   
+   Because of this, unlike :ref:`assoc-inst`, explicit binding of type/kind
+   variables in default declarations is not permitted by
+   :extension:`ExplicitForAll`.
 
 -  Unlike the associated type family declaration itself, the type variables of
    the default instance are independent of those of the parent class.
@@ -9989,6 +10026,10 @@ means this: ::
 The two are treated identically, except that the latter may bring type variables
 into scope (see :ref:`scoped-type-variables`).
 
+This extension also enables explicit quantification of type and kind variables
+in :ref:`data-instance-declarations`, :ref:`type-instance-declarations`,
+:ref:`closed-type-families`, :ref:`assoc-inst`, and :ref:`rewrite-rules`.
+
 Notes:
 
 - With :extension:`ExplicitForAll`, ``forall`` becomes a keyword; you can't use ``forall`` as a
@@ -15172,7 +15213,7 @@ From a syntactic point of view:
    is never run by GHC, but is nevertheless parsed, typechecked etc, so
    that it is available to the plugin.
 
--  Each variable mentioned in a rule must either be in scope (e.g.
+-  Each (term) variable mentioned in a rule must either be in scope (e.g.
    ``map``), or bound by the ``forall`` (e.g. ``f``, ``g``, ``xs``). The
    variables bound by the ``forall`` are called the *pattern* variables.
    They are separated by spaces, just like in a type ``forall``.
@@ -15186,6 +15227,25 @@ From a syntactic point of view:
 
    Since ``g`` has a polymorphic type, it must have a type signature.
 
+-  If :extension:`ExplicitForAll` is enabled, type/kind variables can also be
+   explicitly bound. For example: ::
+     
+       {-# RULES "id" forall a. forall (x :: a). id @a x = x #-}
+   
+   When a type-level explicit ``forall`` is present, each type/kind variable
+   mentioned must now also be either in scope or bound by the ``forall``. In
+   particular, unlike some other places in Haskell, this means free kind
+   variables will not be implicitly bound. For example: ::
+     
+       "this_is_bad" forall (c :: k). forall (x :: Proxy c) ...
+       "this_is_ok"  forall k (c :: k). forall (x :: Proxy c) ...
+
+   When bound type/kind variables are needed, both foralls must always be
+   included, though if no pattern variables are needed, the second can be left
+   empty. For example: ::
+   
+       {-# RULES "map/id" forall a. forall. map (id @a) = id @[a] #-}
+
 -  The left hand side of a rule must consist of a top-level variable
    applied to arbitrary expressions. For example, this is *not* OK: ::
 
index f603a4c..f0c4ac4 100644 (file)
@@ -1503,7 +1503,7 @@ of ``-W(no-)*``.
         do { mapM_ popInt xs ; return 10 }
 
 .. ghc-flag:: -Wunused-type-patterns
-    :shortdesc: warn about unused type variables which arise from patterns
+    :shortdesc: warn about unused type variables which arise from patterns in
         in type family and data family instances
     :type: dynamic
     :reverse: -Wno-unused-type-patterns
@@ -1513,22 +1513,30 @@ of ``-W(no-)*``.
        single: unused type patterns, warning
        single: type patterns, unused
 
-    Report all unused type variables which arise from patterns in type family
-    and data family instances. For instance: ::
+    Report all unused implicitly bound type variables which arise from
+    patterns in type family and data family instances. For instance: ::
 
         type instance F x y = []
 
-    would report ``x`` and ``y`` as unused. The warning is suppressed if the
-    type variable name begins with an underscore, like so: ::
+    would report ``x`` and ``y`` as unused on the right hand side. The warning
+    is suppressed if the type variable name begins with an underscore, like
+    so: ::
 
         type instance F _x _y = []
 
+    When :extension:`ExplicitForAll` is enabled, explicitly quantified type
+    variables may also be identified as unused. For instance: ::
+      
+        type instance forall x y. F x y = []
+    
+    would still report ``x`` and ``y`` as unused on the right hand side
+
     Unlike :ghc-flag:`-Wunused-matches`, :ghc-flag:`-Wunused-type-patterns` is
     not implied by :ghc-flag:`-Wall`. The rationale for this decision is that
     unlike term-level pattern names, type names are often chosen expressly for
     documentation purposes, so using underscores in type names can make the
     documentation harder to read.
-
+    
 .. ghc-flag:: -Wunused-foralls
     :shortdesc: warn about type variables in user-written
         ``forall``\\s that are unused
index 1f862de..bfcaabf 100644 (file)
@@ -1527,7 +1527,7 @@ defineMacro overwrite s = do
         body = nlHsVar compose_RDR `mkHsApp` (nlHsPar step)
                                    `mkHsApp` (nlHsPar expr)
         tySig = mkLHsSigWcType (stringTy `nlHsFunTy` ioM)
-        new_expr = L (getLoc expr) $ ExprWithTySig tySig body
+        new_expr = L (getLoc expr) $ ExprWithTySig noExt body tySig
     hv <- GHC.compileParsedExprRemote new_expr
 
     let newCmd = Command { cmdName = macro_name
@@ -1591,7 +1591,7 @@ getGhciStepIO = do
       ioM = nlHsTyVar (getRdrName ioTyConName) `nlHsAppTy` stringTy
       body = nlHsVar (getRdrName ghciStepIoMName)
       tySig = mkLHsSigWcType (ghciM `nlHsFunTy` ioM)
-  return $ noLoc $ ExprWithTySig tySig body
+  return $ noLoc $ ExprWithTySig noExt body tySig
 
 -----------------------------------------------------------------------------
 -- :check
index 778e6c0..67a8773 100644 (file)
@@ -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
 
index 989e816..11391da 100644 (file)
@@ -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
index 7df8c98..138cf62 100644 (file)
@@ -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"
index 7ee81c8..b75a048 100644 (file)
@@ -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)
index c3d6c25..de8b96f 100644 (file)
@@ -1,5 +1,17 @@
 # Changelog for [`template-haskell` package](http://hackage.haskell.org/package/template-haskell)
 
+## 2.15.0.0 *TBA*
+
+  * In `Language.Haskell.TH.Syntax`, `DataInstD`, `NewTypeInstD`, `TySynEqn`,
+    and `RuleP` now all have a `Maybe [TyVarBndr]` argument, which contains a
+    list of quantified type variables if an explicit `forall` is present, and
+    `Nothing` otherwise.
+
+    Correspondingly, in `Language.Haskell.TH.Lib.Internal`, `pragRuleD`,
+    `dataInstD`, `newtypeInstD`, and `tySynEqn` now all have a
+    `Maybe [TyVarBndrQ]` argument. Non-API-breaking versions of these
+    functions can be found in `Language.Haskell.TH.Lib`.
+
 ## 2.14.0.0 *TBA*
 
   * Introduce an `addForeignFilePath` function, as well as a corresponding
index 96702f5..1b5803b 100644 (file)
@@ -73,7 +73,7 @@ testOneFile libdir fileName = do
 
      doRuleDecl :: RuleDecl GhcPs
                 -> [(String,[Located (SourceText,FastString)])]
-     doRuleDecl (HsRule _ ss _ _ _ _) = [("r",[ss])]
+     doRuleDecl (HsRule _ ss _ _ _ _ _) = [("r",[ss])]
 
      doCCallTarget :: CCallTarget
                    -> [(String,[Located (SourceText,FastString)])]
index 5a50af8..232d47f 100644 (file)
@@ -60,11 +60,11 @@ testOneFile libdir fileName = do
 
      doRuleDecl :: RuleDecl GhcPs
                 -> [(String,[String])]
-     doRuleDecl (HsRule _ _ (ActiveBefore (SourceText ss) _) _ _ _)
+     doRuleDecl (HsRule _ _ (ActiveBefore (SourceText ss) _) _ _ _ _)
        = [("rb",[ss])]
-     doRuleDecl (HsRule _ _ (ActiveAfter (SourceText ss) _) _ _ _)
+     doRuleDecl (HsRule _ _ (ActiveAfter (SourceText ss) _) _ _ _ _)
        = [("ra",[ss])]
-     doRuleDecl (HsRule _ _ _ _ _ _) = []
+     doRuleDecl (HsRule _ _ _ _ _ _ _) = []
 
      doHsExpr :: HsExpr GhcPs -> [(String,[String])]
      doHsExpr (HsTickPragma _ src (_,_,_) ss _) = [("tp",[show ss])]
diff --git a/testsuite/tests/indexed-types/should_compile/ExplicitForAllFams1.hs b/testsuite/tests/indexed-types/should_compile/ExplicitForAllFams1.hs
new file mode 100644 (file)
index 0000000..067127c
--- /dev/null
@@ -0,0 +1,31 @@
+{-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeInType #-}
+
+module ExplicitForAllFams where
+
+import Data.Proxy
+import Data.Kind
+
+-- From Proposal 0007
+
+data family F a
+data instance forall (x :: Bool). F (Proxy x) = MkF
+
+class C a where
+  type G a b
+instance forall a. C [a] where
+  type forall b. G [a] b = Int
+
+type family H a b where
+  forall x y. H [x] (Proxy y) = Double
+  forall z.   H z   z         = Bool
+
+-- More tests
+
+type family D a b where
+  forall (a :: Type -> Type) (b :: a Int) (c :: k). D (Proxy b) (Proxy c) = ()
+  forall (a :: Bool) (b :: Proxy a). D (Proxy b) () = Int
+  forall (a :: Type). D a a = Maybe a
diff --git a/testsuite/tests/indexed-types/should_compile/ExplicitForAllFams2.hs b/testsuite/tests/indexed-types/should_compile/ExplicitForAllFams2.hs
new file mode 100644 (file)
index 0000000..2b8e2cb
--- /dev/null
@@ -0,0 +1,39 @@
+{-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module ExplicitForAllFams2 where
+
+import Data.Kind (Type)
+
+-- Even more tests
+
+type family CF a b where
+  forall x y.         CF [x] (Maybe y) = (x,y)
+  forall (z :: Type). CF z   z         = Bool
+  forall.             CF _   _         = ()
+
+type family OF a
+type instance forall a b. OF (Maybe a, Either a b) = Either [a] b
+
+data family DF a
+data instance forall a b. DF (Maybe a, Either a b) = DF a a b
+
+data family NF a
+newtype instance forall a b. NF (Maybe a, Either a b) = NF { unNF :: Either [a] b }
+
+class Cl a where
+  type AT a b
+  data AD a b
+instance forall a. Cl (Maybe a) where
+  type forall b. AT (Maybe a) b = b
+  data forall b. AD (Maybe a) b = AD b
+
+-- Should produce warnings
+
+type family N a where
+  forall t a. N (t a) = [a]
+  forall a.   N a     = ()
+
+type family N' a where
+  N' (t a) = [a]
+  N' a     = ()
diff --git a/testsuite/tests/indexed-types/should_compile/ExplicitForAllFams2.stderr b/testsuite/tests/indexed-types/should_compile/ExplicitForAllFams2.stderr
new file mode 100644 (file)
index 0000000..0d2eaae
--- /dev/null
@@ -0,0 +1,12 @@
+
+ExplicitForAllFams2.hs:34:10: warning: [-Wunused-type-patterns]
+    Defined but not used on the right hand side: type variable ‘t’
+
+ExplicitForAllFams2.hs:35:10: warning: [-Wunused-type-patterns]
+    Defined but not used on the right hand side: type variable ‘a’
+
+ExplicitForAllFams2.hs:38:7: warning: [-Wunused-type-patterns]
+    Defined but not used on the right hand side: type variable ‘t’
+
+ExplicitForAllFams2.hs:39:6: warning: [-Wunused-type-patterns]
+    Defined but not used on the right hand side: type variable ‘a’
index 5881145..833315e 100644 (file)
@@ -1,12 +1,12 @@
 
-UnusedTyVarWarnings.hs:8:5: warning: [-Wunused-type-patterns]
-    Defined but not used: type variable ‘b’
+UnusedTyVarWarnings.hs:8:7: warning: [-Wunused-type-patterns]
+    Defined but not used on the right hand side: type variable ‘b’
 
-UnusedTyVarWarnings.hs:11:18: warning: [-Wunused-type-patterns]
-    Defined but not used: type variable ‘b’
+UnusedTyVarWarnings.hs:11:20: warning: [-Wunused-type-patterns]
+    Defined but not used on the right hand side: type variable ‘b’
 
 UnusedTyVarWarnings.hs:27:5: warning: [-Wunused-type-patterns]
-    Defined but not used: type variable ‘a’
+    Defined but not used on the right hand side: type variable ‘a’
 
-UnusedTyVarWarnings.hs:33:17: warning: [-Wunused-type-patterns]
-    Defined but not used: type variable ‘b’
+UnusedTyVarWarnings.hs:33:19: warning: [-Wunused-type-patterns]
+    Defined but not used on the right hand side: type variable ‘b’
index 6cbc861..9049ddf 100644 (file)
@@ -1,12 +1,12 @@
 
-UnusedTyVarWarningsNamedWCs.hs:8:5: warning: [-Wunused-type-patterns]
-    Defined but not used: type variable ‘b’
+UnusedTyVarWarningsNamedWCs.hs:8:7: warning: [-Wunused-type-patterns]
+    Defined but not used on the right hand side: type variable ‘b’
 
-UnusedTyVarWarningsNamedWCs.hs:11:18: warning: [-Wunused-type-patterns]
-    Defined but not used: type variable ‘b’
+UnusedTyVarWarningsNamedWCs.hs:11:20: warning: [-Wunused-type-patterns]
+    Defined but not used on the right hand side: type variable ‘b’
 
 UnusedTyVarWarningsNamedWCs.hs:27:5: warning: [-Wunused-type-patterns]
-    Defined but not used: type variable ‘a’
+    Defined but not used on the right hand side: type variable ‘a’
 
-UnusedTyVarWarningsNamedWCs.hs:33:17: warning: [-Wunused-type-patterns]
-    Defined but not used: type variable ‘b’
+UnusedTyVarWarningsNamedWCs.hs:33:19: warning: [-Wunused-type-patterns]
+    Defined but not used on the right hand side: type variable ‘b’
index 5bfbca4..d95826c 100644 (file)
@@ -94,6 +94,9 @@ test('GivenCheckSwap', normal, compile, [''])
 test('GivenCheckDecomp', normal, compile, [''])
 test('GivenCheckTop', normal, compile, [''])
 
+test('ExplicitForAllFams1', normal, compile, [''])
+test('ExplicitForAllFams2', normal, compile, ['-Wunused-foralls -Wunused-type-patterns'])
+
 # A very delicate test
 test('Gentle', normal, compile, [''])
 
diff --git a/testsuite/tests/indexed-types/should_fail/ExplicitForAllFams3.hs b/testsuite/tests/indexed-types/should_fail/ExplicitForAllFams3.hs
new file mode 100644 (file)
index 0000000..53a0e2a
--- /dev/null
@@ -0,0 +1,23 @@
+{-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module ExplicitForAllFams3 where
+
+type family H a b where
+  forall a.   H [a] (Maybe b) = Double
+
+type family J a
+type instance forall a.   J (a, b) = Bool
+
+data family K a
+data instance forall a.   K (a, b)    = K4 Bool
+
+data family L a
+newtype instance forall a.   L (a, b)    = L4 { unL4 :: Bool    }
+
+class C a where
+  type CT a b
+  data CD a b
+instance C Int where
+  type forall a.   CT [a] (Maybe b) = Bool
+  data forall a.   CD [a] (Maybe b) = CD4 Bool
diff --git a/testsuite/tests/indexed-types/should_fail/ExplicitForAllFams3.stderr b/testsuite/tests/indexed-types/should_fail/ExplicitForAllFams3.stderr
new file mode 100644 (file)
index 0000000..92e0b1d
--- /dev/null
@@ -0,0 +1,17 @@
+
+ExplicitForAllFams3.hs:7:28: error: Not in scope: type variable ‘b’
+
+ExplicitForAllFams3.hs:10:33: error:
+    Not in scope: type variable ‘b’
+
+ExplicitForAllFams3.hs:13:33: error:
+    Not in scope: type variable ‘b’
+
+ExplicitForAllFams3.hs:16:36: error:
+    Not in scope: type variable ‘b’
+
+ExplicitForAllFams3.hs:22:34: error:
+    Not in scope: type variable ‘b’
+
+ExplicitForAllFams3.hs:23:34: error:
+    Not in scope: type variable ‘b’
diff --git a/testsuite/tests/indexed-types/should_fail/ExplicitForAllFams4a.hs b/testsuite/tests/indexed-types/should_fail/ExplicitForAllFams4a.hs
new file mode 100644 (file)
index 0000000..f99e884
--- /dev/null
@@ -0,0 +1,8 @@
+{-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module ExplicitForAllFams4a where
+
+type family H a b where
+  forall a b. H [a] (a,a)     = Float
+  forall b.   H _ _           = Maybe b
diff --git a/testsuite/tests/indexed-types/should_fail/ExplicitForAllFams4a.stderr b/testsuite/tests/indexed-types/should_fail/ExplicitForAllFams4a.stderr
new file mode 100644 (file)
index 0000000..ecbd7d9
--- /dev/null
@@ -0,0 +1,8 @@
+
+ExplicitForAllFams4a.hs:7:12: error:
+    • Explicitly quantified but not used in LHS pattern: type variable ‘b’
+    • In the type family declaration for ‘H’
+
+ExplicitForAllFams4a.hs:8:10: error:
+    • Explicitly quantified but not used in LHS pattern: type variable ‘b’
+    • In the type family declaration for ‘H’
diff --git a/testsuite/tests/indexed-types/should_fail/ExplicitForAllFams4b.hs b/testsuite/tests/indexed-types/should_fail/ExplicitForAllFams4b.hs
new file mode 100644 (file)
index 0000000..cb56654
--- /dev/null
@@ -0,0 +1,26 @@
+{-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module ExplicitForAllFams4 where
+
+type family J a
+type instance forall a b. J [a]    = Float
+type instance forall b.   J _      = Maybe b
+
+data family K a
+data instance forall a b. K (a, Bool) = K5 Float
+data instance forall b.   K _         = K6 (Maybe b)
+
+data family L a
+newtype instance forall a b. L (a, Bool) = L5 { unL5 :: Float   }
+newtype instance forall b.   L _         = L6 { unL56:: Maybe b }
+
+class C a where
+  type CT a b
+  data CD a b
+
+instance C Int where
+  type forall a b. CT [a] (a,a)     = Float
+  type forall b.   CT _ _           = Maybe b
+  data forall a b. CD [a] (a,a)     = CD5 Float
+  data forall b.   CD _ _           = CD6 (Maybe b)
diff --git a/testsuite/tests/indexed-types/should_fail/ExplicitForAllFams4b.stderr b/testsuite/tests/indexed-types/should_fail/ExplicitForAllFams4b.stderr
new file mode 100644 (file)
index 0000000..0861a8a
--- /dev/null
@@ -0,0 +1,44 @@
+
+ExplicitForAllFams4b.hs:7:24: error:
+    • Explicitly quantified but not used in LHS pattern: type variable ‘b’
+    • In the type instance declaration for ‘J’
+
+ExplicitForAllFams4b.hs:8:22: error:
+    • Explicitly quantified but not used in LHS pattern: type variable ‘b’
+    • In the type instance declaration for ‘J’
+
+ExplicitForAllFams4b.hs:11:24: error:
+    • Explicitly quantified but not used in LHS pattern: type variable ‘b’
+    • In the data instance declaration for ‘K’
+
+ExplicitForAllFams4b.hs:12:22: error:
+    • Explicitly quantified but not used in LHS pattern: type variable ‘b’
+    • In the data instance declaration for ‘K’
+
+ExplicitForAllFams4b.hs:15:27: error:
+    • Explicitly quantified but not used in LHS pattern: type variable ‘b’
+    • In the newtype instance declaration for ‘L’
+
+ExplicitForAllFams4b.hs:16:25: error:
+    • Explicitly quantified but not used in LHS pattern: type variable ‘b’
+    • In the newtype instance declaration for ‘L’
+
+ExplicitForAllFams4b.hs:23:17: error:
+    • Explicitly quantified but not used in LHS pattern: type variable ‘b’
+    • In the type instance declaration for ‘CT’
+      In the instance declaration for ‘C Int’
+
+ExplicitForAllFams4b.hs:24:15: error:
+    • Explicitly quantified but not used in LHS pattern: type variable ‘b’
+    • In the type instance declaration for ‘CT’
+      In the instance declaration for ‘C Int’
+
+ExplicitForAllFams4b.hs:25:17: error:
+    • Explicitly quantified but not used in LHS pattern: type variable ‘b’
+    • In the data instance declaration for ‘CD’
+      In the instance declaration for ‘C Int’
+
+ExplicitForAllFams4b.hs:26:15: error:
+    • Explicitly quantified but not used in LHS pattern: type variable ‘b’
+    • In the data instance declaration for ‘CD’
+      In the instance declaration for ‘C Int’
index 11e9d0a..12fa999 100644 (file)
@@ -35,6 +35,10 @@ test('OverIndirectThisMod', [], multimod_compile_fail, ['OverIndirectThisModD',
 
 test('SkolemOccursLoop', expect_fail, compile_fail, [''])
 
+test('ExplicitForAllFams3', normal, compile_fail, [''])
+test('ExplicitForAllFams4a', normal, compile_fail, [''])
+test('ExplicitForAllFams4b', normal, compile_fail, [''])
+
 test('T2334A', normal, compile_fail, [''])
 test('T1900', normal, compile_fail, [''])
 test('T2157', normal, compile_fail, [''])
index edc66e0..4648baa 100644 (file)
@@ -78,6 +78,7 @@
              ({ DumpParsedAst.hs:8:3-8 }
               (Unqual
                {OccName: Length}))
+             (Nothing)
              [({ DumpParsedAst.hs:8:10-17 }
                (HsParTy
                 (NoExt)
              ({ DumpParsedAst.hs:9:3-8 }
               (Unqual
                {OccName: Length}))
+             (Nothing)
              [({ DumpParsedAst.hs:9:10-12 }
                (HsExplicitListTy
                 (NoExt)
index f20c450..5c1a03e 100644 (file)
                (NoExt)
                ({ DumpRenamedAst.hs:11:3-8 }
                 {Name: DumpRenamedAst.Length})
+               (Nothing)
                [({ DumpRenamedAst.hs:11:10-17 }
                  (HsParTy
                   (NoExt)
                (NoExt)
                ({ DumpRenamedAst.hs:12:3-8 }
                 {Name: DumpRenamedAst.Length})
+               (Nothing)
                [({ DumpRenamedAst.hs:12:10-12 }
                  (HsExplicitListTy
                   (NoExt)
            (NoExt)
            ({ DumpRenamedAst.hs:17:18-20 }
             {Name: DumpRenamedAst.Nat})
+           (Nothing)
            [({ DumpRenamedAst.hs:17:22-37 }
              (HsParTy
               (NoExt)
index 4aee57d..71a54b0 100644 (file)
@@ -37,6 +37,7 @@
              ({ KindSigs.hs:12:3-5 }
               (Unqual
                {OccName: Foo}))
+             (Nothing)
              [({ KindSigs.hs:12:7 }
                (HsTyVar
                 (NoExt)
diff --git a/testsuite/tests/rename/should_compile/ExplicitForAllRules1.hs b/testsuite/tests/rename/should_compile/ExplicitForAllRules1.hs
new file mode 100644 (file)
index 0000000..7862468
--- /dev/null
@@ -0,0 +1,45 @@
+{-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeInType #-}
+{-# LANGUAGE TypeApplications #-}
+
+module ExplicitForAllRules1 where
+
+import Data.Proxy
+import Data.Kind
+
+-- From Proposal 0007 (w/ fix to "example")
+
+{-# RULES
+"example"  forall a b. forall. map @a @b f = f
+"example2" forall a. forall (x :: a). id x = x
+  #-}
+
+{-# NOINLINE f #-}
+f :: a -> b
+f = undefined
+
+-- More tests
+
+{-# RULES
+"example3" forall (a :: Type -> Type) (b :: a Int) c. forall x y. g @(Proxy b) @(Proxy c) x y = ()
+"example4" forall (a :: Bool) (b :: Proxy a). forall x. g @(Proxy b) @() x = id @()
+"example5" forall (a :: Type). forall. h @a = id @a
+"example5" forall k (c :: k). forall (x :: Proxy c). id @(Proxy c) x = x
+  #-}
+
+{-# NOINLINE g #-}
+g :: a -> b -> ()
+g _ _ = ()
+
+{-# NOINLINE h #-}
+h :: a -> a
+h x = x
+
+-- Should NOT have a parse error :(
+{-# RULES "example6" forall a forall. g a forall = () #-}
+
+-- Should generate a warning
+{-# RULES "example7" forall a b. forall (x :: a). id x = x #-}
diff --git a/testsuite/tests/rename/should_compile/ExplicitForAllRules1.stderr b/testsuite/tests/rename/should_compile/ExplicitForAllRules1.stderr
new file mode 100644 (file)
index 0000000..54a32ad
--- /dev/null
@@ -0,0 +1,4 @@
+
+ExplicitForAllRules1.hs:45:31: warning: [-Wunused-foralls (in -Wextra)]
+    Unused quantified type variable ‘b’
+    in the rule "example7"
diff --git a/testsuite/tests/rename/should_compile/T2600.hs b/testsuite/tests/rename/should_compile/T2600.hs
new file mode 100644 (file)
index 0000000..bdf483c
--- /dev/null
@@ -0,0 +1,19 @@
+{-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeApplications #-}
+
+module T2600 where
+
+-- ** See trac #10595 for why we're okay with this generating warnings! **
+
+class T t where
+    to :: [a] -> t a
+    from :: t a -> [a]
+    tmap :: (a -> a) -> t a -> t a
+
+{-# RULES
+
+"myrule" forall t a. forall f x.
+     from (tmap f (to x :: t a)) = map f (from (to x :: t a))
+
+  #-}
diff --git a/testsuite/tests/rename/should_compile/T2600.stderr b/testsuite/tests/rename/should_compile/T2600.stderr
new file mode 100644 (file)
index 0000000..91f594f
--- /dev/null
@@ -0,0 +1,10 @@
+
+T2600.hs:16:1: warning: [-Winline-rule-shadowing (in -Wdefault)]
+    Rule "myrule" may never fire
+      because rule "Class op tmap" for ‘tmap’ might fire first
+    Probable fix: add phase [n] or [~n] to the competing rule
+
+T2600.hs:16:1: warning: [-Winline-rule-shadowing (in -Wdefault)]
+    Rule "myrule" may never fire
+      because rule "Class op to" for ‘to’ might fire first
+    Probable fix: add phase [n] or [~n] to the competing rule
\ No newline at end of file
index 3a90cbd..a3f862f 100644 (file)
@@ -81,6 +81,10 @@ test('T2205', normal, compile, [''])
 
 test('T2334', normal, compile, [''])
 test('T2506', normal, compile, [''])
+
+test('ExplicitForAllRules1', normal, compile, ['-Wunused-foralls'])
+test('T2600', normal, compile, [''])
+
 test('T2914', normal, compile, [''])
 test('T3221', normal, compile, [''])
 test('T3262', normal, compile, [''])
diff --git a/testsuite/tests/rename/should_fail/ExplicitForAllRules2.hs b/testsuite/tests/rename/should_fail/ExplicitForAllRules2.hs
new file mode 100644 (file)
index 0000000..081b39b
--- /dev/null
@@ -0,0 +1,12 @@
+{-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE TypeApplications #-}
+
+module ExplicitForAllRules2 where
+
+{-# RULES "new4" forall a. forall (x :: b). id @a (wk x) = (wk x) #-}
+{-# RULES "new5" forall a. forall (x :: a). id @a y = y #-}
+{-# RULES "new6" forall a. forall (x :: a). id @c x = x #-}
+
+{-# NOINLINE wk #-}
+wk :: forall b a. b -> a
+wk _ = error ""
diff --git a/testsuite/tests/rename/should_fail/ExplicitForAllRules2.stderr b/testsuite/tests/rename/should_fail/ExplicitForAllRules2.stderr
new file mode 100644 (file)
index 0000000..909cc0a
--- /dev/null
@@ -0,0 +1,10 @@
+
+ExplicitForAllRules2.hs:6:41: error:
+    Not in scope: type variable ‘b’
+
+ExplicitForAllRules2.hs:7:11: error:
+    Rule "new5":
+    Forall'd variable ‘x’ does not appear on left hand side
+
+ExplicitForAllRules2.hs:8:49: error:
+    Not in scope: type variable ‘c’
index db0db47..6debe7b 100644 (file)
@@ -138,3 +138,5 @@ test('T15539', normal, compile_fail, [''])
 test('T15487', normal, multimod_compile_fail, ['T15487','-v0'])
 test('T15659', normal, compile_fail, [''])
 test('T15607', normal, compile_fail, [''])
+
+test('ExplicitForAllRules2', normal, compile_fail, [''])
index 0b25da9..2a8b3b4 100644 (file)
@@ -11,10 +11,12 @@ $( return [ ClosedTypeFamilyD
                 , KindedTV (mkName "b") (VarT (mkName "k")) ]
                 ( TyVarSig (KindedTV (mkName "r") (VarT (mkName "k"))))
                 Nothing)
-              [ TySynEqn [ (VarT (mkName "a"))
+              [ TySynEqn Nothing
+                         [ (VarT (mkName "a"))
                          , (VarT (mkName "a")) ]
                          (ConT (mkName "Int"))
-              , TySynEqn [ (VarT (mkName "a"))
+              , TySynEqn Nothing
+                         [ (VarT (mkName "a"))
                          , (VarT (mkName "b")) ]
                          (ConT (mkName "Bool")) ] ])
 
index 517c4ba..eef302c 100644 (file)
@@ -21,7 +21,7 @@ data family T2 (a :: b)
 data instance T2 b
 class C2 a
 
-$(do FamilyI (DataFamilyD tName _ _) [DataInstD [] _ [tyVar] _ _ _]
+$(do FamilyI (DataFamilyD tName _ _) [DataInstD [] _ [tyVar] _ _ _]
        <- reify ''T2
      d <- instanceD (cxt [])
                     (conT ''C2 `appT` (conT tName `appT` return tyVar))
index 647ccd6..5b25cff 100644 (file)
@@ -1,3 +1,4 @@
 type family T12646.F (a_0 :: k_1) :: * where
-    T12646.F (a_2 :: * -> *) = GHC.Types.Int
-    T12646.F (a_3 :: k_4) = GHC.Types.Char
+    forall (a_2 :: * -> *). T12646.F (a_2 :: * -> *) = GHC.Types.Int
+    forall (k_3 :: *)
+           (a_4 :: k_3). T12646.F (a_4 :: k_3) = GHC.Types.Char
index 487b5e4..1156aad 100644 (file)
@@ -15,11 +15,11 @@ $(return [])
 main :: IO ()
 main = print
   $(do FamilyI (DataFamilyD _ _ _) insts <- reify ''DF
-       lift $ all (\case DataInstD _ _ [AppT _ (VarT v1)] _
-                                       [NormalC _ [(_, VarT v2)]] _
+       lift $ all (\case DataInstD _ _ [AppT _ (VarT v1)] _
+                                         [NormalC _ [(_, VarT v2)]] _
                            -> v1 == v2
-                         NewtypeInstD _ _ [AppT _ (VarT v1)] _
-                                          (NormalC _ [(_, VarT v2)]) _
+                         NewtypeInstD _ _ [AppT _ (VarT v1)] _
+                                            (NormalC _ [(_, VarT v2)]) _
                            -> v1 == v2
                          _ -> error "Not a data or newtype instance")
               insts)
index 33b4d0e..5756fcc 100644 (file)
@@ -11,5 +11,5 @@ class C α where
   type AT α ∷ Type
 
 bang ∷ DecsQ
-bang = return [InstanceD Nothing [] (AppT (ConT ''C) (ConT ''Int))
-                [TySynInstD ''AT (TySynEqn [ConT ''Int] (ConT ''Int))]]
+bang = return [InstanceD Nothing  [] (AppT (ConT ''C) (ConT ''Int))
+                [TySynInstD ''AT (TySynEqn Nothing [ConT ''Int] (ConT ''Int))]]
index 442e4ab..6b7b67d 100644 (file)
@@ -20,17 +20,20 @@ $( return
                              [(mkName "a"), (mkName "b"), (mkName "c") ]))
    , TySynInstD
        (mkName "F")
-       (TySynEqn [ ConT (mkName "Int"), ConT (mkName "Char")
+       (TySynEqn Nothing
+                 [ ConT (mkName "Int"), ConT (mkName "Char")
                  , ConT (mkName "Bool")]
                  ( ConT (mkName "Bool")))
    , TySynInstD
        (mkName "F")
-       (TySynEqn [ ConT (mkName "Char"), ConT (mkName "Bool")
+       (TySynEqn Nothing
+                 [ ConT (mkName "Char"), ConT (mkName "Bool")
                  , ConT (mkName "Int")]
                  ( ConT (mkName "Int")))
    , TySynInstD
        (mkName "F")
-       (TySynEqn [ ConT (mkName "Bool"), ConT (mkName "Int")
+       (TySynEqn Nothing
+                 [ ConT (mkName "Bool"), ConT (mkName "Int")
                  , ConT (mkName "Char")]
                  ( ConT (mkName "Char")))
    ] )
@@ -48,7 +51,8 @@ $( return
        (Just $ InjectivityAnn (mkName "r") [mkName "a"]))
    , TySynInstD
        (mkName "J")
-       (TySynEqn [ ConT (mkName "Int"), VarT (mkName "b") ]
+       (TySynEqn Nothing
+                 [ ConT (mkName "Int"), VarT (mkName "b") ]
                  ( ConT (mkName "Int")))
    ] )
 
@@ -66,13 +70,16 @@ $( return
        , KindedTV (mkName "c") StarT ]
        (TyVarSig (PlainTV (mkName "r")))
        (Just $ InjectivityAnn (mkName "r") [(mkName "a"), (mkName "b")]))
-       [ TySynEqn [ ConT (mkName "Int"), ConT (mkName "Char")
+       [ TySynEqn Nothing
+                  [ ConT (mkName "Int"), ConT (mkName "Char")
                   , ConT (mkName "Bool")]
                   ( ConT (mkName "Bool"))
-       , TySynEqn [ ConT (mkName "Int"), ConT (mkName "Char")
+       , TySynEqn Nothing
+                  [ ConT (mkName "Int"), ConT (mkName "Char")
                   , ConT (mkName "Int")]
                   ( ConT (mkName "Bool"))
-       , TySynEqn [ ConT (mkName "Bool"), ConT (mkName "Int")
+       , TySynEqn Nothing
+                  [ ConT (mkName "Bool"), ConT (mkName "Int")
                   , ConT (mkName "Int")]
                   ( ConT (mkName "Int"))
        ]
@@ -103,17 +110,20 @@ $( return
                              [(mkName "a"), (mkName "b") ]))
    , TySynInstD
        (mkName "H")
-       (TySynEqn [ ConT (mkName "Int"), ConT (mkName "Char")
+       (TySynEqn Nothing
+                 [ ConT (mkName "Int"), ConT (mkName "Char")
                  , ConT (mkName "Bool")]
                  ( ConT (mkName "Bool")))
    , TySynInstD
        (mkName "H")
-       (TySynEqn [ ConT (mkName "Int"), ConT (mkName "Int")
+       (TySynEqn Nothing
+                 [ ConT (mkName "Int"), ConT (mkName "Int")
                  , ConT (mkName "Int")]
                  ( ConT (mkName "Bool")))
    , TySynInstD
        (mkName "H")
-       (TySynEqn [ ConT (mkName "Bool"), ConT (mkName "Int")
+       (TySynEqn Nothing
+                 [ ConT (mkName "Bool"), ConT (mkName "Int")
                  , ConT (mkName "Int")]
                  ( ConT (mkName "Int")))
    ] )
index 7193fb5..9566b1a 100644 (file)
@@ -1,5 +1,5 @@
 
-T6018th.hs:97:4:
+T6018th.hs:104:4:
     Type family equations violate injectivity annotation:
-      H Int Int Int = Bool -- Defined at T6018th.hs:97:4
-      H Int Char Bool = Bool -- Defined at T6018th.hs:97:4
+      H Int Int Int = Bool -- Defined at T6018th.hs:104:4
+      H Int Char Bool = Bool -- Defined at T6018th.hs:104:4
index 84fa23e..8f686fe 100644 (file)
@@ -11,5 +11,5 @@ class C a where
 bang' :: DecsQ
 bang' = return [
      InstanceD Nothing [] (AppT (ConT ''C) (ConT ''Int)) [
-         DataInstD [] ''D [ConT ''Int] Nothing [
+         DataInstD [] ''D Nothing [ConT ''Int] Nothing [
              NormalC (mkName "T") []] []]]
index 022776e..3226507 100644 (file)
@@ -1,4 +1,5 @@
 type family T8884.Foo (a_0 :: k_1) = (r_2 :: k_1) | r_2 -> k_1 a_0 where
-    T8884.Foo (x_3 :: k_4) = x_3
+    forall (k_3 :: *) (x_4 :: k_3). T8884.Foo (x_4 :: k_3) = x_4
 type family T8884.Baz (a_0 :: k_1) = (r_2 :: k_1) | r_2 -> k_1 a_0
-type instance T8884.Baz (x_0 :: k_1) = x_0
+type instance forall (k_0 :: *)
+                     (x_1 :: k_0). T8884.Baz (x_1 :: k_0) = x_1
index 3dad412..d87acef 100644 (file)
@@ -1,6 +1,7 @@
 type family T8953.Poly (a_0 :: k_1) :: *
-type instance T8953.Poly (x_2 :: GHC.Types.Bool) = GHC.Types.Int
-type instance T8953.Poly (x_3 :: GHC.Maybe.Maybe k_4) = GHC.Types.Double
+type instance forall (x_2 :: GHC.Types.Bool). T8953.Poly (x_2 :: GHC.Types.Bool) = GHC.Types.Int
+type instance forall (k_3 :: *)
+                     (x_4 :: GHC.Maybe.Maybe k_3). T8953.Poly (x_4 :: GHC.Maybe.Maybe k_3) = GHC.Types.Double
 type family T8953.Silly :: k_0 -> *
 type instance T8953.Silly = (Data.Proxy.Proxy :: * -> *)
 type instance T8953.Silly = (Data.Proxy.Proxy :: (* -> *) -> *)
@@ -15,5 +16,6 @@ type instance T8953.F GHC.Types.Char = T8953.G (T8953.T1 :: * ->
                                                             (* -> *) -> *)
                                                GHC.Types.Bool
 type family T8953.G (a_0 :: k_1) :: k_1
-type instance T8953.G (T8953.T1 :: k1_2 ->
-                                   k2_3 -> *) = (T8953.T2 :: k1_2 -> k2_3 -> *)
+type instance forall (k1_2 :: *)
+                     (k2_3 :: *). T8953.G (T8953.T1 :: k1_2 ->
+                                                       k2_3 -> *) = (T8953.T2 :: k1_2 -> k2_3 -> *)
diff --git a/testsuite/tests/th/TH_ExplicitForAllRules.hs b/testsuite/tests/th/TH_ExplicitForAllRules.hs
new file mode 100644 (file)
index 0000000..f5bd519
--- /dev/null
@@ -0,0 +1,9 @@
+{-# LANGUAGE TemplateHaskell, ExplicitForAll #-}
+
+module Main where
+
+import TH_ExplicitForAllRules_a
+
+$(decls)
+
+main = hsToTh
diff --git a/testsuite/tests/th/TH_ExplicitForAllRules.stdout b/testsuite/tests/th/TH_ExplicitForAllRules.stdout
new file mode 100644 (file)
index 0000000..635fce7
--- /dev/null
@@ -0,0 +1,3 @@
+{-# RULES "example"
+    forall a_0 . forall (x_1 :: a_0) . GHC.Base.id x_1
+    = x_1 #-}
\ No newline at end of file
diff --git a/testsuite/tests/th/TH_ExplicitForAllRules_a.hs b/testsuite/tests/th/TH_ExplicitForAllRules_a.hs
new file mode 100644 (file)
index 0000000..e428035
--- /dev/null
@@ -0,0 +1,10 @@
+{-# LANGUAGE ExplicitForAll #-}
+module TH_ExplicitForAllRules_a (decls, hsToTh) where
+
+import Language.Haskell.TH
+
+decls = [d| {-# RULES "example" forall a. forall (x :: a). id x = x #-} |]
+
+hsToTh = do
+  decls' <- runQ decls
+  mapM (print . ppr) decls'
diff --git a/testsuite/tests/th/TH_reifyExplicitForAllFams.hs b/testsuite/tests/th/TH_reifyExplicitForAllFams.hs
new file mode 100644 (file)
index 0000000..60a6d45
--- /dev/null
@@ -0,0 +1,35 @@
+-- test reification of explicit foralls in type families
+
+{-# LANGUAGE TypeFamilies, ExplicitForAll #-}
+module TH_reifyExplicitForAllFams where
+
+import System.IO
+import Language.Haskell.TH
+import Text.PrettyPrint.HughesPJ
+
+import Data.Proxy
+import Data.Kind
+
+$([d| data family F a
+      data instance forall a. F (Maybe a) = MkF a |])
+
+$([d| class C a where
+        type G a b
+      instance forall a. C [a] where
+        type forall b. G [a] b = Proxy b |])
+
+$([d| type family H a b where
+        forall x y. H [x] (Proxy y) = Either x y
+        forall z.   H z   z         = Maybe z |])
+
+$(return [])
+
+test :: ()
+test = $(let
+      display :: Name -> Q ()
+      display q = do { i <- reify q; runIO $ hPutStrLn stderr (pprint i) }
+    in do { display ''F
+          ; display ''C
+          ; display ''G
+          ; display ''H
+          ; [| () |] })
diff --git a/testsuite/tests/th/TH_reifyExplicitForAllFams.stderr b/testsuite/tests/th/TH_reifyExplicitForAllFams.stderr
new file mode 100644 (file)
index 0000000..6205547
--- /dev/null
@@ -0,0 +1,16 @@
+data family TH_reifyExplicitForAllFams.F (a_0 :: *) :: *
+data instance forall (a_1 :: *). TH_reifyExplicitForAllFams.F (GHC.Maybe.Maybe a_1)
+    = TH_reifyExplicitForAllFams.MkF a_1
+class TH_reifyExplicitForAllFams.C (a_0 :: *)
+    where type TH_reifyExplicitForAllFams.G (a_0 :: *) (b_1 :: *) :: *
+instance TH_reifyExplicitForAllFams.C ([a_2])
+type family TH_reifyExplicitForAllFams.G (a_0 :: *) (b_1 :: *) :: *
+type instance forall (a_2 :: *)
+                     (b_3 :: *). TH_reifyExplicitForAllFams.G ([a_2])
+                                                              b_3 = Data.Proxy.Proxy b_3
+type family TH_reifyExplicitForAllFams.H (a_0 :: *) (b_1 :: *) :: * where
+    forall (x_2 :: *) (y_3 :: *). TH_reifyExplicitForAllFams.H ([x_2])
+                                                               (Data.Proxy.Proxy y_3) = Data.Either.Either x_2
+                                                                                                           y_3
+    forall (z_4 :: *). TH_reifyExplicitForAllFams.H z_4
+                                                    z_4 = GHC.Maybe.Maybe z_4
\ No newline at end of file
index 75ec5db..50154a4 100644 (file)
@@ -76,6 +76,10 @@ test('TH_reifyMkName', normal, compile, ['-v0'])
 
 test('TH_reifyInstances', normal, compile, ['-v0'])
 
+test('TH_reifyExplicitForAllFams', normal, compile, ['-v0'])
+test('TH_ExplicitForAllRules', normal, multimod_compile_and_run,
+     ['TH_ExplicitForAllRules.hs', '-v0 ' + config.ghc_th_way_flags])
+
 test('TH_spliceDecl1', normal, compile, ['-v0'])
 test('TH_spliceDecl2', normal, compile, ['-v0'])
 test('TH_spliceDecl3', [], multimod_compile,
index 6f5564d..e774b80 100644 (file)
@@ -306,7 +306,7 @@ boundThings modname lbinding =
                LitPat _ _ -> tl
                NPat {} -> tl -- form of literal pattern?
                NPlusKPat _ id _ _ _ _ -> thing id : tl
-               SigPat _ p -> patThings p tl
+               SigPat _ p -> patThings p tl
                _ -> error "boundThings"
         conArgs (PrefixCon ps) tl = foldr patThings tl ps
         conArgs (RecCon (HsRecFields { rec_flds = flds })) tl
index b5372b7..f345505 160000 (submodule)
@@ -1 +1 @@
-Subproject commit b5372b7d86e3058b419076641dd3048258c4ddf2
+Subproject commit f3455051b59c99d26e0cf040be45f5916463ae55