Visible kind application
authormynguyen <mnguyen1@brynmawr.edu>
Tue, 18 Dec 2018 16:52:26 +0000 (11:52 -0500)
committerRichard Eisenberg <rae@cs.brynmawr.edu>
Thu, 3 Jan 2019 13:57:32 +0000 (08:57 -0500)
Summary:
This patch implements visible kind application (GHC Proposal 15/#12045), as well as #15360 and #15362.
It also refactors unnamed wildcard handling, and requires that type equations in type families in Template Haskell be
written with full type on lhs. PartialTypeSignatures are on and warnings are off automatically with visible kind
application, just like in term-level.

There are a few remaining issues with this patch, as documented in
ticket #16082.

Includes a submodule update for Haddock.

Test Plan: Tests T12045a/b/c/TH1/TH2, T15362, T15592a

Reviewers: simonpj, goldfire, bgamari, alanz, RyanGlScott, Iceland_jack

Subscribers: ningning, Iceland_jack, RyanGlScott, int-index, rwbarton, mpickering, carter

GHC Trac Issues: `#12045`, `#15362`, `#15592`, `#15788`, `#15793`, `#15795`, `#15797`, `#15799`, `#15801`, `#15807`, `#15816`

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

141 files changed:
compiler/deSugar/DsMeta.hs
compiler/hieFile/HieAst.hs
compiler/hsSyn/Convert.hs
compiler/hsSyn/HsBinds.hs
compiler/hsSyn/HsDecls.hs
compiler/hsSyn/HsExtension.hs
compiler/hsSyn/HsInstances.hs
compiler/hsSyn/HsTypes.hs
compiler/hsSyn/HsUtils.hs
compiler/parser/Parser.y
compiler/parser/RdrHsSyn.hs
compiler/prelude/THNames.hs
compiler/rename/RnSource.hs
compiler/rename/RnTypes.hs
compiler/typecheck/TcDeriv.hs
compiler/typecheck/TcExpr.hs
compiler/typecheck/TcHsType.hs
compiler/typecheck/TcInstDcls.hs
compiler/typecheck/TcSigs.hs
compiler/typecheck/TcSimplify.hs
compiler/typecheck/TcSplice.hs
compiler/typecheck/TcTyClsDecls.hs
compiler/types/TyCoRep.hs
docs/users_guide/glasgow_exts.rst
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/dependent/should_compile/T11241.stderr
testsuite/tests/deriving/should_compile/T14579a.hs [new file with mode: 0644]
testsuite/tests/deriving/should_compile/all.T
testsuite/tests/ghci/scripts/T12447.stdout
testsuite/tests/indexed-types/should_fail/ExplicitForAllFams4b.stderr
testsuite/tests/parser/should_compile/DumpParsedAst.hs
testsuite/tests/parser/should_compile/DumpParsedAst.stderr
testsuite/tests/parser/should_compile/DumpRenamedAst.hs
testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
testsuite/tests/parser/should_compile/DumpTypecheckedAst.hs
testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr
testsuite/tests/parser/should_compile/KindSigs.stderr
testsuite/tests/parser/should_compile/T12045e.hs [new file with mode: 0644]
testsuite/tests/parser/should_compile/all.T
testsuite/tests/parser/should_fail/T12045d.hs [new file with mode: 0644]
testsuite/tests/parser/should_fail/T12045d.stderr [new file with mode: 0644]
testsuite/tests/parser/should_fail/all.T
testsuite/tests/partial-sigs/should_compile/Defaulting2MROff.stderr
testsuite/tests/partial-sigs/should_compile/Defaulting2MROn.stderr
testsuite/tests/partial-sigs/should_compile/Either.stderr
testsuite/tests/partial-sigs/should_compile/EveryNamed.stderr
testsuite/tests/partial-sigs/should_compile/ExprSigLocal.stderr
testsuite/tests/partial-sigs/should_compile/ExtraConstraints3.stderr
testsuite/tests/partial-sigs/should_compile/SimpleGen.stderr
testsuite/tests/partial-sigs/should_compile/SplicesUsed.stderr
testsuite/tests/partial-sigs/should_compile/SuperCls.stderr
testsuite/tests/partial-sigs/should_compile/T10403.stderr
testsuite/tests/partial-sigs/should_compile/T10438.stderr
testsuite/tests/partial-sigs/should_compile/T10519.stderr
testsuite/tests/partial-sigs/should_compile/T11016.stderr
testsuite/tests/partial-sigs/should_compile/T11339a.stderr
testsuite/tests/partial-sigs/should_compile/T11670.stderr
testsuite/tests/partial-sigs/should_compile/T12844.stderr
testsuite/tests/partial-sigs/should_compile/T12845.stderr
testsuite/tests/partial-sigs/should_compile/T13482.stderr
testsuite/tests/partial-sigs/should_compile/T14217.stderr
testsuite/tests/partial-sigs/should_compile/T14643.stderr
testsuite/tests/partial-sigs/should_compile/T14643a.stderr
testsuite/tests/partial-sigs/should_compile/T14715.stderr
testsuite/tests/partial-sigs/should_compile/TypedSplice.stderr
testsuite/tests/partial-sigs/should_compile/Uncurry.stderr
testsuite/tests/partial-sigs/should_compile/UncurryNamed.stderr
testsuite/tests/partial-sigs/should_compile/WarningWildcardInstantiations.stderr
testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInPatternSplice.stderr
testsuite/tests/partial-sigs/should_fail/InstantiatedNamedWildcardsInConstraints.stderr
testsuite/tests/partial-sigs/should_fail/NamedExtraConstraintsWildcard.stderr
testsuite/tests/partial-sigs/should_fail/NamedWildcardsNotInMonotype.stderr
testsuite/tests/partial-sigs/should_fail/PartialTypeSignaturesDisabled.stderr
testsuite/tests/partial-sigs/should_fail/PatBind3.stderr
testsuite/tests/partial-sigs/should_fail/T10615.stderr
testsuite/tests/partial-sigs/should_fail/T10999.stderr
testsuite/tests/partial-sigs/should_fail/T11122.stderr
testsuite/tests/partial-sigs/should_fail/T11515.stderr
testsuite/tests/partial-sigs/should_fail/T11976.stderr
testsuite/tests/partial-sigs/should_fail/T12634.stderr
testsuite/tests/partial-sigs/should_fail/T14040a.stderr
testsuite/tests/partial-sigs/should_fail/T14584.stderr
testsuite/tests/partial-sigs/should_fail/TidyClash.stderr
testsuite/tests/partial-sigs/should_fail/TidyClash2.stderr
testsuite/tests/partial-sigs/should_fail/WildcardInstantiations.stderr
testsuite/tests/partial-sigs/should_fail/WildcardsInPatternAndExprSig.stderr
testsuite/tests/partial-sigs/should_run/T15415.stderr
testsuite/tests/partial-sigs/should_run/T15415.stdout
testsuite/tests/perf/compiler/T13035.stderr
testsuite/tests/polykinds/T14172.stderr
testsuite/tests/polykinds/T14265.stderr
testsuite/tests/th/ClosedFam2TH.hs
testsuite/tests/th/T12045TH1.hs [new file with mode: 0644]
testsuite/tests/th/T12045TH1.stderr [new file with mode: 0644]
testsuite/tests/th/T12045TH2.hs [new file with mode: 0644]
testsuite/tests/th/T12045TH2.stderr [new file with mode: 0644]
testsuite/tests/th/T12503.hs
testsuite/tests/th/T13618.hs
testsuite/tests/th/T15360b.stderr
testsuite/tests/th/T15362.hs [new file with mode: 0644]
testsuite/tests/th/T15362.stderr [new file with mode: 0644]
testsuite/tests/th/T5886a.hs
testsuite/tests/th/T6018th.hs
testsuite/tests/th/T6018th.stderr
testsuite/tests/th/T7532a.hs
testsuite/tests/th/T8884.hs
testsuite/tests/th/TH_TyInstWhere2.hs
testsuite/tests/th/TH_TyInstWhere2.stderr
testsuite/tests/th/TH_reifyDecl1.hs
testsuite/tests/th/TH_reifyDecl1.stderr
testsuite/tests/th/all.T
testsuite/tests/typecheck/should_compile/T10072.stderr
testsuite/tests/typecheck/should_compile/T12045a.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_compile/T14366.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_compile/T15788.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_compile/T15793.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_compile/T15807a.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_compile/all.T
testsuite/tests/typecheck/should_fail/T12045b.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T12045b.stderr [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T12045c.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T12045c.stderr [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T13819.stderr
testsuite/tests/typecheck/should_fail/T15592a.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T15592a.stderr [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T15797.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T15797.stderr [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T15799.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T15799.stderr [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T15801.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T15801.stderr [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T15807.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T15807.stderr [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T15816.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T15816.stderr [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/all.T
utils/haddock

index 9b2256e..9906fc7 100644 (file)
@@ -352,7 +352,7 @@ repRoleD _ = panic "repRoleD"
 repDataDefn :: Core TH.Name
             -> Either (Core [TH.TyVarBndrQ])
                         -- the repTyClD case
-                      (Core (Maybe [TH.TyVarBndrQ]), Core [TH.TypeQ])
+                      (Core (Maybe [TH.TyVarBndrQ]), Core TH.TypeQ)
                         -- the repDataFamInstD case
             -> HsDataDefn GhcRn
             -> DsM (Core TH.DecQ)
@@ -465,18 +465,28 @@ repAssocTyFamDefaults = mapM rep_deflt
     rep_deflt (dL->L _ (FamEqn { feqn_tycon = tc
                                , feqn_bndrs = bndrs
                                , feqn_pats  = tys
+                               , feqn_fixity = fixity
                                , feqn_rhs   = rhs }))
       = addTyClTyVarBinds tys $ \ _ ->
         do { tc1  <- lookupLOcc tc
            ; no_bndrs <- ASSERT( isNothing bndrs )
                          coreNothingList tyVarBndrQTyConName
            ; tys1 <- repLTys (hsLTyVarBndrsToTypes tys)
-           ; tys2 <- coreList typeQTyConName tys1
+           ; lhs <- case fixity of
+                      Prefix -> do { head_ty <- repNamedTyCon tc1
+                                   ; repTapps head_ty tys1 }
+                      Infix -> do { (t1:t2:args) <- checkTys tys1
+                                  ; head_ty <- repTInfix t1 tc1 t2
+                                  ; repTapps head_ty args }
            ; rhs1 <- repLTy rhs
-           ; eqn1 <- repTySynEqn no_bndrs tys2 rhs1
-           ; repTySynInst tc1 eqn1 }
+           ; eqn1 <- repTySynEqn no_bndrs lhs rhs1
+           ; repTySynInst eqn1 }
     rep_deflt _ = panic "repAssocTyFamDefaults"
 
+    checkTys :: [Core TH.TypeQ] -> DsM [Core TH.TypeQ]
+    checkTys tys@(_:_:_) = return tys
+    checkTys _ = panic "repAssocTyFamDefaults:checkTys"
+
 -------------------------
 -- represent fundeps
 --
@@ -547,18 +557,19 @@ repStandaloneDerivD (dL->L loc (DerivDecl { deriv_strategy = strat
 repStandaloneDerivD _ = panic "repStandaloneDerivD"
 
 repTyFamInstD :: TyFamInstDecl GhcRn -> DsM (Core TH.DecQ)
-repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn })
-  = do { let tc_name = tyFamInstDeclLName decl
-       ; tc <- lookupLOcc tc_name          -- See note [Binders and occurrences]
-       ; eqn1 <- repTyFamEqn eqn
-       ; repTySynInst tc eqn1 }
+repTyFamInstD (TyFamInstDecl { tfid_eqn = eqn })
+  = do { eqn1 <- repTyFamEqn eqn
+       ; repTySynInst eqn1 }
 
 repTyFamEqn :: TyFamInstEqn GhcRn -> DsM (Core TH.TySynEqnQ)
 repTyFamEqn (HsIB { hsib_ext = var_names
-                  , hsib_body = FamEqn { feqn_bndrs = mb_bndrs
+                  , hsib_body = FamEqn { feqn_tycon = tc_name
+                                       , feqn_bndrs = mb_bndrs
                                        , feqn_pats = tys
+                                       , feqn_fixity = fixity
                                        , feqn_rhs  = rhs }})
-  = do { let hs_tvs = HsQTvs { hsq_ext = HsQTvsRn
+  = 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 = fromMaybe [] mb_bndrs }
@@ -566,21 +577,39 @@ repTyFamEqn (HsIB { hsib_ext = var_names
          do { mb_bndrs1 <- repMaybeList tyVarBndrQTyConName
                                         repTyVarBndr
                                         mb_bndrs
-            ; tys1 <- repLTys tys
-            ; tys2 <- coreList typeQTyConName tys1
+            ; tys1 <- case fixity of
+                        Prefix -> repTyArgs (repNamedTyCon tc) tys
+                        Infix  -> do { (HsValArg t1: HsValArg t2: args) <- checkTys tys
+                                     ; t1' <- repLTy t1
+                                     ; t2'  <- repLTy t2
+                                     ; repTyArgs (repTInfix t1' tc t2') args }
             ; rhs1 <- repLTy rhs
-            ; repTySynEqn mb_bndrs1 tys2 rhs1 } }
+            ; repTySynEqn mb_bndrs1 tys1 rhs1 } }
+     where checkTys :: [LHsTypeArg GhcRn] -> DsM [LHsTypeArg GhcRn]
+           checkTys tys@(HsValArg _:HsValArg _:_) = return tys
+           checkTys _ = panic "repTyFamEqn:checkTys"
 repTyFamEqn (XHsImplicitBndrs _) = panic "repTyFamEqn"
 repTyFamEqn (HsIB _ (XFamEqn _)) = panic "repTyFamEqn"
 
+repTyArgs :: DsM (Core TH.TypeQ) -> [LHsTypeArg GhcRn] -> DsM (Core TH.TypeQ)
+repTyArgs f [] = f
+repTyArgs f (HsValArg ty : as) = do { f' <- f
+                                    ; ty' <- repLTy ty
+                                    ; repTyArgs (repTapp f' ty') as }
+repTyArgs f (HsTypeArg ki : as) = do { f' <- f
+                                     ; ki' <- repLTy ki
+                                     ; repTyArgs (repTappKind f' ki') as }
+repTyArgs f (HsArgPar _ : as) = repTyArgs f as
+
 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_fixity = fixity
                                              , feqn_rhs   = defn }})})
-  = do { tc <- lookupLOcc tc_name          -- See note [Binders and occurrences]
+  = 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
@@ -589,8 +618,18 @@ repDataFamInstD (DataFamInstDecl { dfid_eqn =
          do { mb_bndrs1 <- repMaybeList tyVarBndrQTyConName
                                         repTyVarBndr
                                         mb_bndrs
-            ; tys1 <- repList typeQTyConName repLTy tys
+            ; tys1 <- case fixity of
+                        Prefix -> repTyArgs (repNamedTyCon tc) tys
+                        Infix  -> do { (HsValArg t1: HsValArg t2: args) <- checkTys tys
+                                     ; t1' <- repLTy t1
+                                     ; t2'  <- repLTy t2
+                                     ; repTyArgs (repTInfix t1' tc t2') args }
             ; repDataDefn tc (Right (mb_bndrs1, tys1)) defn } }
+
+      where checkTys :: [LHsTypeArg GhcRn] -> DsM [LHsTypeArg GhcRn]
+            checkTys tys@(HsValArg _: HsValArg _: _) = return tys
+            checkTys _ = panic "repDataFamInstD:checkTys"
+
 repDataFamInstD (DataFamInstDecl (XHsImplicitBndrs _))
   = panic "repDataFamInstD"
 repDataFamInstD (DataFamInstDecl (HsIB _ (XFamEqn _)))
@@ -1136,6 +1175,10 @@ repTy (HsAppTy _ f a)       = do
                                 f1 <- repLTy f
                                 a1 <- repLTy a
                                 repTapp f1 a1
+repTy (HsAppKindTy _ ty ki) = do
+                                ty1 <- repLTy ty
+                                ki1 <- repLTy ki
+                                repTappKind ty1 ki1
 repTy (HsFunTy _ f a)       = do
                                 f1   <- repLTy f
                                 a1   <- repLTy a
@@ -1174,7 +1217,7 @@ repTy (HsExplicitTupleTy _ tys) = do
 repTy (HsTyLit _ lit) = do
                           lit' <- repTyLit lit
                           repTLit lit'
-repTy (HsWildCardTy (AnonWildCard _)) = repTWildCard
+repTy (HsWildCardTy _) = repTWildCard
 repTy (HsIParamTy _ n t) = do
                              n' <- rep_implicit_param_name (unLoc n)
                              t' <- repLTy t
@@ -2191,26 +2234,26 @@ repFun (MkC nm) (MkC b) = rep2 funDName [nm, b]
 
 repData :: Core TH.CxtQ -> Core TH.Name
         -> Either (Core [TH.TyVarBndrQ])
-                  (Core (Maybe [TH.TyVarBndrQ]), Core [TH.TypeQ])
+                  (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) (Right (MkC mb_bndrs, MkC tys)) (MkC ksig)
-        (MkC cons) (MkC derivs)
-  = rep2 dataInstDName [cxt, nm, mb_bndrs, tys, ksig, cons, derivs]
+repData (MkC cxt) (MkC _) (Right (MkC mb_bndrs, MkC ty)) (MkC ksig) (MkC cons)
+        (MkC derivs)
+  = rep2 dataInstDName [cxt, mb_bndrs, ty, ksig, cons, derivs]
 
 repNewtype :: Core TH.CxtQ -> Core TH.Name
            -> Either (Core [TH.TyVarBndrQ])
-                     (Core (Maybe [TH.TyVarBndrQ]), Core [TH.TypeQ])
+                     (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) (Right (MkC mb_bndrs, MkC tys)) (MkC ksig)
-           (MkC con) (MkC derivs)
-  = rep2 newtypeInstDName [cxt, nm, mb_bndrs, tys, ksig, con, derivs]
+repNewtype (MkC cxt) (MkC _) (Right (MkC mb_bndrs, MkC ty)) (MkC ksig) (MkC con)
+           (MkC derivs)
+  = rep2 newtypeInstDName [cxt, mb_bndrs, ty, ksig, con, derivs]
 
 repTySyn :: Core TH.Name -> Core [TH.TyVarBndrQ]
          -> Core TH.TypeQ -> DsM (Core TH.DecQ)
@@ -2309,9 +2352,9 @@ repPragRule (MkC nm) (MkC ty_bndrs) (MkC tm_bndrs) (MkC lhs) (MkC rhs) (MkC phas
 repPragAnn :: Core TH.AnnTarget -> Core TH.ExpQ -> DsM (Core TH.DecQ)
 repPragAnn (MkC targ) (MkC e) = rep2 pragAnnDName [targ, e]
 
-repTySynInst :: Core TH.Name -> Core TH.TySynEqnQ -> DsM (Core TH.DecQ)
-repTySynInst (MkC nm) (MkC eqn)
-    = rep2 tySynInstDName [nm, eqn]
+repTySynInst :: Core TH.TySynEqnQ -> DsM (Core TH.DecQ)
+repTySynInst (MkC eqn)
+    = rep2 tySynInstDName [eqn]
 
 repDataFamilyD :: Core TH.Name -> Core [TH.TyVarBndrQ]
                -> Core (Maybe TH.KindQ) -> DsM (Core TH.DecQ)
@@ -2336,7 +2379,7 @@ repClosedFamilyD (MkC nm) (MkC tvs) (MkC res) (MkC inj) (MkC eqns)
     = rep2 closedTypeFamilyDName [nm, tvs, res, inj, eqns]
 
 repTySynEqn :: Core (Maybe [TH.TyVarBndrQ]) ->
-               Core [TH.TypeQ] -> Core TH.TypeQ -> DsM (Core TH.TySynEqnQ)
+               Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.TySynEqnQ)
 repTySynEqn (MkC mb_bndrs) (MkC lhs) (MkC rhs)
   = rep2 tySynEqnName [mb_bndrs, lhs, rhs]
 
@@ -2429,6 +2472,9 @@ repTvar (MkC s) = rep2 varTName [s]
 repTapp :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ)
 repTapp (MkC t1) (MkC t2) = rep2 appTName [t1, t2]
 
+repTappKind :: Core TH.TypeQ -> Core TH.KindQ -> DsM (Core TH.TypeQ)
+repTappKind (MkC ty) (MkC ki) = rep2 appKindTName [ty,ki]
+
 repTapps :: Core TH.TypeQ -> [Core TH.TypeQ] -> DsM (Core TH.TypeQ)
 repTapps f []     = return f
 repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }
@@ -2467,6 +2513,10 @@ repTConstraint = rep2 constraintKName []
 repNamedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ)
 repNamedTyCon (MkC s) = rep2 conTName [s]
 
+repTInfix :: Core TH.TypeQ -> Core TH.Name -> Core TH.TypeQ
+             -> DsM (Core TH.TypeQ)
+repTInfix (MkC t1) (MkC name) (MkC t2) = rep2 infixTName [t1,name,t2]
+
 repTupleTyCon :: Int -> DsM (Core TH.TypeQ)
 -- Note: not Core Int; it's easier to be direct here
 repTupleTyCon i = do dflags <- getDynFlags
index 6fcc924..eafafbb 100644 (file)
@@ -328,6 +328,10 @@ instance (HasLoc a, HasLoc b) => HasLoc (FamEqn s a b) where
   loc (FamEqn _ a (Just tvs) b _ c) = foldl1' combineSrcSpans
                                               [loc a, loc tvs, loc b, loc c]
   loc _ = noSrcSpan
+instance (HasLoc tm, HasLoc ty) => HasLoc (HsArg tm ty) where
+  loc (HsValArg tm) = loc tm
+  loc (HsTypeArg ty) = loc ty
+  loc (HsArgPar sp)  = sp
 
 instance HasLoc (HsDataDefn GhcRn) where
   loc def@(HsDataDefn{}) = loc $ dd_cons def
@@ -1339,6 +1343,10 @@ instance ToHie (TScoped (LHsType GhcRn)) where
         [ toHie a
         , toHie b
         ]
+      HsAppKindTy _ ty ki ->
+        [ toHie ty
+        , toHie $ TS (ResolvedScopes []) ki
+        ]
       HsFunTy _ a b ->
         [ toHie a
         , toHie b
@@ -1387,14 +1395,14 @@ instance ToHie (TScoped (LHsType GhcRn)) where
         [ toHie tys
         ]
       HsTyLit _ _ -> []
-      HsWildCardTy e ->
-        [ toHie e
-        ]
+      HsWildCardTy _ -> []
       HsStarTy _ _ -> []
       XHsType _ -> []
 
-instance ToHie HsWildCardInfo where
-  toHie (AnonWildCard name) = toHie $ C Use name
+instance (ToHie tm, ToHie ty) => ToHie (HsArg tm ty) where
+  toHie (HsValArg tm) = toHie tm
+  toHie (HsTypeArg ty) = toHie ty
+  toHie (HsArgPar sp) = pure $ locOnly sp
 
 instance ToHie (TVScoped (LHsTyVarBndr GhcRn)) where
   toHie (TVS tsc sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of
index 3c78a4c..59b42bd 100644 (file)
@@ -40,7 +40,7 @@ import Outputable
 import MonadUtils ( foldrM )
 
 import qualified Data.ByteString as BS
-import Control.Monad( unless, liftM, ap, (<=<) )
+import Control.Monad( unless, liftM, ap )
 
 import Data.Maybe( catMaybes, isNothing )
 import Language.Haskell.TH as TH hiding (sigP)
@@ -296,8 +296,8 @@ cvtDec (DataFamilyD tc tvs kind)
        ; returnJustL $ TyClD noExt $ FamDecl noExt $
          FamilyDecl noExt DataFamily tc' tvs' Prefix result Nothing }
 
-cvtDec (DataInstD ctxt tc bndrs tys ksig constrs derivs)
-  = do { (ctxt', tc', bndrs', typats') <- cvt_tyinst_hdr ctxt tc bndrs tys
+cvtDec (DataInstD ctxt bndrs tys ksig constrs derivs)
+  = do { (ctxt', tc', bndrs', typats') <- cvt_datainst_hdr ctxt bndrs tys
        ; ksig' <- cvtKind `traverse` ksig
        ; cons' <- mapM cvtConstr constrs
        ; derivs' <- cvtDerivs derivs
@@ -317,8 +317,8 @@ cvtDec (DataInstD ctxt tc bndrs tys ksig constrs derivs)
                                   , feqn_rhs = defn
                                   , feqn_fixity = Prefix } }}}
 
-cvtDec (NewtypeInstD ctxt tc bndrs tys ksig constr derivs)
-  = do { (ctxt', tc', bndrs', typats') <- cvt_tyinst_hdr ctxt tc bndrs tys
+cvtDec (NewtypeInstD ctxt bndrs tys ksig constr derivs)
+  = do { (ctxt', tc', bndrs', typats') <- cvt_datainst_hdr ctxt bndrs tys
        ; ksig' <- cvtKind `traverse` ksig
        ; con' <- cvtConstr constr
        ; derivs' <- cvtDerivs derivs
@@ -337,9 +337,8 @@ cvtDec (NewtypeInstD ctxt tc bndrs tys ksig constr derivs)
                                   , feqn_rhs = defn
                                   , feqn_fixity = Prefix } }}}
 
-cvtDec (TySynInstD tc eqn)
-  = do  { tc' <- tconNameL tc
-        ; (dL->L _ eqn') <- cvtTySynEqn tc' eqn
+cvtDec (TySynInstD eqn)
+  = do  { (dL->L _ eqn') <- cvtTySynEqn eqn
         ; returnJustL $ InstD noExt $ TyFamInstD
             { tfid_ext = noExt
             , tfid_inst = TyFamInstDecl { tfid_eqn = eqn' } } }
@@ -352,7 +351,7 @@ cvtDec (OpenTypeFamilyD head)
 
 cvtDec (ClosedTypeFamilyD head eqns)
   = do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head
-       ; eqns' <- mapM (cvtTySynEqn tc') eqns
+       ; eqns' <- mapM cvtTySynEqn eqns
        ; returnJustL $ TyClD noExt $ FamDecl noExt $
          FamilyDecl noExt (ClosedTypeFamily (Just eqns')) tc' tyvars' Prefix
                            result' injectivity' }
@@ -412,18 +411,35 @@ cvtDec (TH.ImplicitParamBindD _ _)
   = failWith (text "Implicit parameter binding only allowed in let or where")
 
 ----------------
-cvtTySynEqn :: Located RdrName -> TySynEqn -> CvtM (LTyFamInstEqn GhcPs)
-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' } }
+cvtTySynEqn :: TySynEqn -> CvtM (LTyFamInstEqn GhcPs)
+cvtTySynEqn (TySynEqn mb_bndrs lhs rhs)
+  = do { mb_bndrs' <- traverse (mapM cvt_tv) mb_bndrs
+       ; (head_ty, args) <- split_ty_app lhs
+       ; case head_ty of
+           ConT nm -> do { nm' <- tconNameL nm
+                         ; rhs' <- cvtType rhs
+                         ; args' <- mapM wrap_tyargs args
+                         ; returnL $ mkHsImplicitBndrs
+                            $ FamEqn { feqn_ext    = noExt
+                                     , feqn_tycon  = nm'
+                                     , feqn_bndrs  = mb_bndrs'
+                                     , feqn_pats   = args'
+                                     , feqn_fixity = Prefix
+                                     , feqn_rhs    = rhs' } }
+           InfixT t1 nm t2 -> do { nm' <- tconNameL nm
+                                 ; args' <- mapM cvtType [t1,t2]
+                                 ; rhs' <- cvtType rhs
+                                 ; returnL $ mkHsImplicitBndrs
+                                      $ FamEqn { feqn_ext    = noExt
+                                               , feqn_tycon  = nm'
+                                               , feqn_bndrs  = mb_bndrs'
+                                               , feqn_pats   =
+                                                (map HsValArg args') ++ args
+                                               , feqn_fixity = Hs.Infix
+                                               , feqn_rhs    = rhs' } }
+           _ -> failWith $ text "Invalid type family instance LHS:"
+                          <+> text (show lhs)
+        }
 
 ----------------
 cvt_ci_decs :: MsgDoc -> [TH.Dec]
@@ -458,17 +474,25 @@ cvt_tycl_hdr cxt tc tvs
        ; return (cxt', tc', tvs')
        }
 
-cvt_tyinst_hdr :: TH.Cxt -> TH.Name -> Maybe [TH.TyVarBndr] -> [TH.Type]
+cvt_datainst_hdr :: TH.Cxt -> Maybe [TH.TyVarBndr] -> TH.Type
                -> CvtM ( LHsContext GhcPs
                        , Located RdrName
                        , Maybe [LHsTyVarBndr GhcPs]
                        , HsTyPats GhcPs)
-cvt_tyinst_hdr cxt tc bndrs tys
-  = do { cxt'   <- cvtContext cxt
-       ; tc'    <- tconNameL tc
+cvt_datainst_hdr cxt bndrs tys
+  = do { cxt' <- cvtContext cxt
        ; bndrs' <- traverse (mapM cvt_tv) bndrs
-       ; tys'   <- mapM (wrap_apps <=< cvtType) tys
-       ; return (cxt', tc', bndrs', tys') }
+       ; (head_ty, args) <- split_ty_app tys
+       ; case head_ty of
+          ConT nm -> do { nm' <- tconNameL nm
+                        ; args' <- mapM wrap_tyargs args
+                        ; return (cxt', nm', bndrs', args') }
+          InfixT t1 nm t2 -> do { nm' <- tconNameL nm
+                                ; args' <- mapM cvtType [t1,t2]
+                                ; return (cxt', nm', bndrs',
+                                         ((map HsValArg args') ++ args)) }
+          _ -> failWith $ text "Invalid type instance header:"
+                          <+> text (show tys) }
 
 ----------------
 cvt_tyfam_head :: TypeFamilyHead
@@ -1299,54 +1323,67 @@ cvtType = cvtTypeKind "type"
 cvtTypeKind :: String -> TH.Type -> CvtM (LHsType GhcPs)
 cvtTypeKind ty_str ty
   = do { (head_ty, tys') <- split_ty_app ty
+       ; let m_normals = mapM extract_normal tys'
+                                where extract_normal (HsValArg ty) = Just ty
+                                      extract_normal _ = Nothing
+
        ; case head_ty of
            TupleT n
-             | tys' `lengthIs` n         -- Saturated
-             -> if n==1 then return (head tys') -- Singleton tuples treated
-                                                -- like nothing (ie just parens)
-                        else returnL (HsTupleTy noExt
-                                                  HsBoxedOrConstraintTuple tys')
-             | n == 1
-             -> failWith (ptext (sLit ("Illegal 1-tuple " ++ ty_str ++ " constructor")))
-             | otherwise
-             -> mk_apps (HsTyVar noExt NotPromoted
-                               (noLoc (getRdrName (tupleTyCon Boxed n)))) tys'
+            | Just normals <- m_normals
+            , normals `lengthIs` n         -- Saturated
+               -> if n==1 then return (head normals) -- Singleton tuples treated
+                                                     -- like nothing (ie just parens)
+                          else returnL (HsTupleTy noExt
+                                        HsBoxedOrConstraintTuple normals)
+            | n == 1
+               -> failWith (ptext (sLit ("Illegal 1-tuple " ++ ty_str ++ " constructor")))
+            | otherwise
+            -> mk_apps
+               (HsTyVar noExt NotPromoted (noLoc (getRdrName (tupleTyCon Boxed n))))
+               tys'
            UnboxedTupleT n
-             | tys' `lengthIs` n         -- Saturated
-             -> returnL (HsTupleTy noExt HsUnboxedTuple tys')
+             | Just normals <- m_normals
+             , normals `lengthIs` n               -- Saturated
+             -> returnL (HsTupleTy noExt HsUnboxedTuple normals)
              | otherwise
-             -> mk_apps (HsTyVar noExt NotPromoted
-                             (noLoc (getRdrName (tupleTyCon Unboxed n)))) tys'
+             -> mk_apps
+                (HsTyVar noExt NotPromoted (noLoc (getRdrName (tupleTyCon Unboxed n))))
+                tys'
            UnboxedSumT n
              | n < 2
             -> failWith $
                    vcat [ text "Illegal sum arity:" <+> text (show n)
                         , nest 2 $
                             text "Sums must have an arity of at least 2" ]
-             | tys' `lengthIs` n -- Saturated
-             -> returnL (HsSumTy noExt tys')
+             | Just normals <- m_normals
+             , normals `lengthIs` n -- Saturated
+             -> returnL (HsSumTy noExt normals)
              | otherwise
-             -> mk_apps (HsTyVar noExt NotPromoted
-                                              (noLoc (getRdrName (sumTyCon n))))
-                        tys'
+             -> mk_apps
+                (HsTyVar noExt NotPromoted (noLoc (getRdrName (sumTyCon n))))
+                tys'
            ArrowT
-             | [x',y'] <- tys' -> do
+             | Just normals <- m_normals
+             , [x',y'] <- normals -> do
                  x'' <- case unLoc x' of
                           HsFunTy{}    -> returnL (HsParTy noExt x')
                           HsForAllTy{} -> returnL (HsParTy noExt x') -- #14646
                           HsQualTy{}   -> returnL (HsParTy noExt x') -- #15324
                           _            -> return x'
                  returnL (HsFunTy noExt x'' y')
-             | otherwise ->
-                  mk_apps (HsTyVar noExt NotPromoted
-                           (noLoc (getRdrName funTyCon)))
-                          tys'
+             | otherwise
+             -> mk_apps
+                (HsTyVar noExt NotPromoted (noLoc (getRdrName funTyCon)))
+                tys'
            ListT
-             | [x']    <- tys' -> returnL (HsListTy noExt x')
-             | otherwise ->
-                  mk_apps (HsTyVar noExt NotPromoted
-                           (noLoc (getRdrName listTyCon)))
-                           tys'
+             | Just normals <- m_normals
+             , [x'] <- normals -> do
+                returnL (HsListTy noExt x')
+             | otherwise
+             -> mk_apps
+                (HsTyVar noExt NotPromoted (noLoc (getRdrName listTyCon)))
+                tys'
+
            VarT nm -> do { nm' <- tNameL nm
                          ; mk_apps (HsTyVar noExt NotPromoted nm') tys' }
            ConT nm -> do { nm' <- tconName nm
@@ -1387,15 +1424,16 @@ cvtTypeKind ty_str ty
              -> do { s'  <- tconName s
                    ; t1' <- cvtType t1
                    ; t2' <- cvtType t2
-                   ; mk_apps (HsTyVar noExt NotPromoted (noLoc s'))
-                             (t1' : t2' : tys')
+                   ; mk_apps
+                      (HsTyVar noExt NotPromoted (noLoc s'))
+                      ([HsValArg t1', HsValArg t2'] ++ tys')
                    }
 
            UInfixT t1 s t2
              -> do { t2' <- cvtType t2
-                   ; t <- cvtOpAppT t1 s t2' -- Note [Converting UInfix]
+                   ; t <- cvtOpAppT t1 s t2'
                    ; mk_apps (unLoc t) tys'
-                   }
+                   } -- Note [Converting UInfix]
 
            ParensT t
              -> do { t' <- cvtType t
@@ -1403,45 +1441,48 @@ cvtTypeKind ty_str ty
                    }
 
            PromotedT nm -> do { nm' <- cName nm
-                              ; let hs_ty = HsTyVar noExt IsPromoted (noLoc nm')
-                              ; mk_apps hs_ty tys' }
+                              ; mk_apps (HsTyVar noExt IsPromoted (noLoc nm'))
+                                        tys' }
                  -- Promoted data constructor; hence cName
 
            PromotedTupleT n
-             | n == 1
-             -> failWith (ptext (sLit ("Illegal promoted 1-tuple " ++ ty_str)))
-             | m == n   -- Saturated
-             -> returnL (HsExplicitTupleTy noExt tys')
-             | otherwise
-             -> mk_apps (HsTyVar noExt IsPromoted
-                               (noLoc (getRdrName (tupleDataCon Boxed n)))) tys'
-             where
-               m = length tys'
+              | n == 1
+              -> failWith (ptext (sLit ("Illegal promoted 1-tuple " ++ ty_str)))
+              | Just normals <- m_normals
+              , normals `lengthIs` n   -- Saturated
+              -> returnL (HsExplicitTupleTy noExt normals)
+              | otherwise
+              -> mk_apps
+                 (HsTyVar noExt IsPromoted (noLoc (getRdrName (tupleDataCon Boxed n))))
+                 tys'
 
            PromotedNilT
              -> mk_apps (HsExplicitListTy noExt IsPromoted []) tys'
 
            PromotedConsT  -- See Note [Representing concrete syntax in types]
                           -- in Language.Haskell.TH.Syntax
-             | [ty1, dL->L _ (HsExplicitListTy _ ip tys2)] <- tys'
-             -> returnL (HsExplicitListTy noExt ip (ty1:tys2))
-             | otherwise
-             -> mk_apps (HsTyVar noExt IsPromoted
-                         (noLoc (getRdrName consDataCon)))
-                        tys'
+              | Just normals <- m_normals
+              , [ty1, dL->L _ (HsExplicitListTy _ ip tys2)] <- normals
+              -> do
+                  returnL (HsExplicitListTy noExt ip (ty1:tys2))
+              | otherwise
+              -> mk_apps
+                 (HsTyVar noExt IsPromoted (noLoc (getRdrName consDataCon)))
+                 tys'
 
            StarT
-             -> mk_apps (HsTyVar noExt NotPromoted
-                              (noLoc (getRdrName liftedTypeKindTyCon)))
-                        tys'
+             -> mk_apps
+                (HsTyVar noExt NotPromoted (noLoc (getRdrName liftedTypeKindTyCon)))
+                tys'
 
            ConstraintT
-             -> mk_apps (HsTyVar noExt NotPromoted
-                              (noLoc (getRdrName constraintKindTyCon)))
-                        tys'
+             -> mk_apps
+                (HsTyVar noExt NotPromoted (noLoc (getRdrName constraintKindTyCon)))
+                tys'
 
            EqualityT
-             | [x',y'] <- tys' ->
+             | Just normals <- m_normals
+             , [x',y'] <- normals ->
                    let px = parenthesizeHsType opPrec x'
                        py = parenthesizeHsType opPrec y'
                    in returnL (HsOpTy noExt px (noLoc eqTyCon_RDR) py)
@@ -1462,21 +1503,35 @@ cvtTypeKind ty_str ty
     }
 
 -- | Constructs an application of a type to arguments passed in a list.
-mk_apps :: HsType GhcPs -> [LHsType GhcPs] -> CvtM (LHsType GhcPs)
+mk_apps :: HsType GhcPs -> [LHsTypeArg GhcPs] -> CvtM (LHsType GhcPs)
 mk_apps head_ty []       = returnL head_ty
-mk_apps head_ty (ty:tys) =
+mk_apps head_ty (arg:args) =
   do { head_ty' <- returnL head_ty
-     ; p_ty      <- add_parens ty
-     ; mk_apps (HsAppTy noExt head_ty' p_ty) tys }
-  where
+     ; case arg of
+       HsValArg ty  -> do { p_ty      <- add_parens ty
+                          ; mk_apps (HsAppTy noExt head_ty' p_ty) args }
+       HsTypeArg ki -> do { p_ki      <- add_parens ki
+                          ; mk_apps (HsAppKindTy noExt head_ty' p_ki) args }
+       HsArgPar _   -> mk_apps (HsParTy noExt head_ty') args
+     }
+   where
     -- See Note [Adding parens for splices]
     add_parens lt@(dL->L _ t)
       | hsTypeNeedsParens appPrec t = returnL (HsParTy noExt lt)
       | otherwise                   = return lt
 
+-- See Note [Adding parens for splices]
 wrap_apps  :: LHsType GhcPs -> CvtM (LHsType GhcPs)
-wrap_apps t@(dL->L _ HsAppTy {}) = returnL (HsParTy noExt t)
-wrap_apps t                      = return t
+wrap_apps t@(dL->L _ HsAppTy {})     = returnL (HsParTy noExt t)
+wrap_apps t@(dL->L _ HsAppKindTy {}) = returnL (HsParTy noExt t)
+wrap_apps t                          = return t
+
+wrap_tyargs :: LHsTypeArg GhcPs -> CvtM (LHsTypeArg GhcPs)
+wrap_tyargs (HsValArg ty) = do { ty' <- wrap_apps ty
+                                  ; return $ HsValArg ty'}
+wrap_tyargs (HsTypeArg ki) = do { ki' <- wrap_apps ki
+                               ; return $ HsTypeArg ki'}
+wrap_tyargs argPar = return argPar
 
 -- ---------------------------------------------------------------------
 -- Note [Adding parens for splices]
@@ -1508,10 +1563,12 @@ mk_arr_apps tys return_ty = foldrM go return_ty tys >>= returnL
           go arg ret_ty = do { ret_ty_l <- returnL ret_ty
                              ; return (HsFunTy noExt arg ret_ty_l) }
 
-split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsType GhcPs])
+split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsTypeArg GhcPs])
 split_ty_app ty = go ty []
   where
-    go (AppT f a) as' = do { a' <- cvtType a; go f (a':as') }
+    go (AppT f a) as' = do { a' <- cvtType a; go f (HsValArg a':as') }
+    go (AppKindT ty ki) as' = do { ki' <- cvtKind ki; go ty (HsTypeArg ki':as') }
+    go (ParensT t) as' = do { loc <- getL; go t (HsArgPar loc: as') }
     go f as           = return (f,as)
 
 cvtTyLit :: TH.TyLit -> HsTyLit
index c541a12..110c0fb 100644 (file)
@@ -901,13 +901,13 @@ data Sig pass
       --
       -- > f :: Num a => a -> a
       --
-      -- After renaming, this list of Names contains the named and unnamed
+      -- After renaming, this list of Names contains the named
       -- wildcards brought into scope by this signature. For a signature
-      -- @_ -> _a -> Bool@, the renamer will give the unnamed wildcard @_@
-      -- a freshly generated name, e.g. @_w@. @_w@ and the named wildcard @_a@
-      -- are then both replaced with fresh meta vars in the type. Their names
-      -- are stored in the type signature that brought them into scope, in
-      -- this third field to be more specific.
+      -- @_ -> _a -> Bool@, the renamer will leave the unnamed wildcard @_@
+      -- untouched, and the named wildcard @_a@ is then replaced with
+      -- fresh meta vars in the type. Their names are stored in the type
+      -- signature that brought them into scope, in this third field to be
+      -- more specific.
       --
       --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon',
       --          'ApiAnnotation.AnnComma'
index 246f8f9..2b8c163 100644 (file)
@@ -1525,7 +1525,7 @@ type LTyFamInstEqn pass = Located (TyFamInstEqn pass)
 type LTyFamDefltEqn pass = Located (TyFamDefltEqn pass)
 
 -- | Haskell Type Patterns
-type HsTyPats pass = [LHsType pass]
+type HsTyPats pass = [LHsTypeArg pass]
 
 {- Note [Family instance declaration binders]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
index 2dff478..9a017c2 100644 (file)
@@ -916,6 +916,7 @@ type family XForAllTy        x
 type family XQualTy          x
 type family XTyVar           x
 type family XAppTy           x
+type family XAppKindTy       x
 type family XFunTy           x
 type family XListTy          x
 type family XTupleTy         x
@@ -942,6 +943,7 @@ type ForallXType (c :: * -> Constraint) (x :: *) =
        , c (XQualTy          x)
        , c (XTyVar           x)
        , c (XAppTy           x)
+       , c (XAppKindTy       x)
        , c (XFunTy           x)
        , c (XListTy          x)
        , c (XTupleTy         x)
index 9a9f21d..3950736 100644 (file)
@@ -382,6 +382,10 @@ deriving instance Data (HsType GhcPs)
 deriving instance Data (HsType GhcRn)
 deriving instance Data (HsType GhcTc)
 
+deriving instance Data (LHsTypeArg GhcPs)
+deriving instance Data (LHsTypeArg GhcRn)
+deriving instance Data (LHsTypeArg GhcTc)
+
 -- deriving instance (DataIdLR p p) => Data (ConDeclField p)
 deriving instance Data (ConDeclField GhcPs)
 deriving instance Data (ConDeclField GhcRn)
index 4ab15b2..7344358 100644 (file)
@@ -8,6 +8,7 @@ HsTypes: Abstract syntax: user-defined types
 
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeSynonymInstances #-}
 {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
@@ -27,6 +28,8 @@ module HsTypes (
         HsContext, LHsContext, noLHsContext,
         HsTyLit(..),
         HsIPName(..), hsIPNameFS,
+        HsArg(..), numVisibleArgs,
+        LHsTypeArg,
 
         LBangType, BangType,
         HsSrcBang(..), HsImplBang(..),
@@ -42,8 +45,7 @@ module HsTypes (
         rdrNameAmbiguousFieldOcc, selectorAmbiguousFieldOcc,
         unambiguousFieldOcc, ambiguousFieldOcc,
 
-        HsWildCardInfo(..), mkAnonWildCardTy, pprAnonWildCard,
-        wildCardName, sameWildCard,
+        mkAnonWildCardTy, pprAnonWildCard,
 
         mkHsImplicitBndrs, mkHsWildCardBndrs, hsImplicitBody,
         mkEmptyImplicitBndrs, mkEmptyWildCardBndrs,
@@ -57,7 +59,7 @@ module HsTypes (
         splitLHsForAllTy, splitLHsQualTy, splitLHsSigmaTy,
         splitHsFunType,
         splitHsAppTys, hsTyGetAppHead_maybe,
-        mkHsOpTy, mkHsAppTy, mkHsAppTys,
+        mkHsOpTy, mkHsAppTy, mkHsAppTys, mkHsAppKindTy,
         ignoreParens, hsSigType, hsSigWcType,
         hsLTyVarBndrToType, hsLTyVarBndrsToTypes,
 
@@ -88,6 +90,7 @@ import SrcLoc
 import Outputable
 import FastString
 import Maybes( isJust )
+import Util ( count )
 
 import Data.Data hiding ( Fixity, Prefix, Infix )
 
@@ -187,8 +190,8 @@ A wildcard in a type can be
   * An anonymous wildcard,
         written '_'
     In HsType this is represented by HsWildCardTy.
-    After the renamer, this contains a Name which uniquely
-    identifies this particular occurrence.
+    The renamer leaves it untouched, and it is later given fresh meta tyvars in
+    the typechecker.
 
   * A named wildcard,
         written '_a', '_foo', etc
@@ -208,9 +211,13 @@ Note carefully:
   Here _a is an ordinary forall'd binder, but (With NamedWildCards)
   _b is a named wildcard.  (See the comments in Trac #10982)
 
-* All wildcards, whether named or anonymous, are bound by the
-  HsWildCardBndrs construct, which wraps types that are allowed
-  to have wildcards.
+* Named wildcards are bound by the HsWildCardBndrs construct, which wraps
+  types that are allowed to have wildcards. Unnamed wildcards however are left
+  unchanged until typechecking, where we give them fresh wild tyavrs and
+  determine whether or not to emit hole constraints on each wildcard
+  (we don't if it's a visible type/kind argument or a type family pattern).
+  See related notes Note [Wildcards in visible kind application]
+  and Note [Wildcards in visible type application] in TcHsType.hs
 
 * After type checking is done, we report what types the wildcards
   got unified with.
@@ -371,7 +378,8 @@ data HsWildCardBndrs pass thing
     -- See Note [The wildcard story for types]
   = HsWC { hswc_ext :: XHsWC pass thing
                 -- after the renamer
-                -- Wild cards, both named and anonymous
+                -- Wild cards, only named
+                -- See Note [Wildcards in visible kind application]
 
          , hswc_body :: thing
                 -- Main payload (type or list of types)
@@ -537,6 +545,10 @@ data HsType pass
 
       -- For details on above see note [Api annotations] in ApiAnnotation
 
+  | HsAppKindTy         (XAppKindTy pass) -- type level type app
+                        (LHsType pass)
+                        (LHsKind pass)
+
   | HsFunTy             (XFunTy pass)
                         (LHsType pass)   -- function type
                         (LHsType pass)
@@ -667,8 +679,6 @@ data HsType pass
 
   | HsWildCardTy (XWildCardTy pass)  -- A type wildcard
       -- See Note [The wildcard story for types]
-      -- A anonymous wild card ('_'). A fresh Name is generated for
-      -- each individual anonymous wildcard during renaming
       -- ^ - 'ApiAnnotation.AnnKeywordId' : None
 
       -- For details on above see note [Api annotations] in ApiAnnotation
@@ -700,6 +710,8 @@ type instance XIParamTy        (GhcPass _) = NoExt
 type instance XStarTy          (GhcPass _) = NoExt
 type instance XKindSig         (GhcPass _) = NoExt
 
+type instance XAppKindTy       (GhcPass _) = NoExt
+
 type instance XSpliceTy        GhcPs = NoExt
 type instance XSpliceTy        GhcRn = NoExt
 type instance XSpliceTy        GhcTc = Kind
@@ -718,9 +730,7 @@ type instance XExplicitTupleTy GhcTc = [Kind]
 
 type instance XTyLit           (GhcPass _) = NoExt
 
-type instance XWildCardTy      GhcPs = NoExt
-type instance XWildCardTy      GhcRn = HsWildCardInfo
-type instance XWildCardTy      GhcTc = HsWildCardInfo
+type instance XWildCardTy      (GhcPass _) = NoExt
 
 type instance XXType         (GhcPass _) = NewHsTypeX
 
@@ -733,11 +743,6 @@ data HsTyLit
   | HsStrTy SourceText FastString
     deriving Data
 
-newtype HsWildCardInfo        -- See Note [The wildcard story for types]
-    = AnonWildCard (Located Name)
-      deriving Data
-      -- A anonymous wild card ('_'). A fresh Name is generated for
-      -- each individual anonymous wildcard during renaming
 
 {-
 Note [HsForAllTy tyvar binders]
@@ -1009,13 +1014,6 @@ hsLTyVarBndrsToTypes (HsQTvs { hsq_explicit = tvbs }) = map hsLTyVarBndrToType t
 hsLTyVarBndrsToTypes (XLHsQTyVars _) = panic "hsLTyVarBndrsToTypes"
 
 ---------------------
-wildCardName :: HsWildCardInfo -> Name
-wildCardName (AnonWildCard  (L _ n)) = n
-
--- Two wild cards are the same when they have the same location
-sameWildCard :: Located HsWildCardInfo -> Located HsWildCardInfo -> Bool
-sameWildCard (L l1 (AnonWildCard _))   (L l2 (AnonWildCard _))   = l1 == l2
-
 ignoreParens :: LHsType pass -> LHsType pass
 ignoreParens (L _ (HsParTy _ ty)) = ignoreParens ty
 ignoreParens ty                   = ty
@@ -1047,6 +1045,11 @@ mkHsAppTys :: LHsType (GhcPass p) -> [LHsType (GhcPass p)]
            -> LHsType (GhcPass p)
 mkHsAppTys = foldl' mkHsAppTy
 
+mkHsAppKindTy :: LHsType (GhcPass p) -> LHsType (GhcPass p)
+              -> LHsType (GhcPass p)
+mkHsAppKindTy ty k
+  = addCLoc ty k (HsAppKindTy noExt ty k)
+
 {-
 ************************************************************************
 *                                                                      *
@@ -1068,7 +1071,9 @@ splitHsFunType (L _ (HsParTy _ ty))
 splitHsFunType (L _ (HsFunTy _ x y))
   | (args, res) <- splitHsFunType y
   = (x:args, res)
-
+{- This is not so correct, because it won't work with visible kind app, in case
+  someone wants to write '(->) @k1 @k2 t1 t2'. Fixing this would require changing
+  ConDeclGADT abstract syntax -}
 splitHsFunType orig_ty@(L _ (HsAppTy _ t1 t2))
   = go t1 [t2]
   where  -- Look for (->) t1 t2, possibly with parenthesisation
@@ -1087,22 +1092,59 @@ splitHsFunType other = ([], other)
 -- used to examine the result of a GADT-like datacon, so it doesn't handle
 -- *all* cases (like lists, tuples, (~), etc.)
 hsTyGetAppHead_maybe :: LHsType (GhcPass p)
-                     -> Maybe (Located (IdP (GhcPass p)), [LHsType (GhcPass p)])
-hsTyGetAppHead_maybe = go []
+                     -> Maybe (Located (IdP (GhcPass p)))
+hsTyGetAppHead_maybe = go
   where
-    go tys (L _ (HsTyVar _ _ ln))          = Just (ln, tys)
-    go tys (L _ (HsAppTy _ l r))           = go (r : tys) l
-    go tys (L _ (HsOpTy _ l (L loc n) r))  = Just (L loc n, l : r : tys)
-    go tys (L _ (HsParTy _ t))             = go tys t
-    go tys (L _ (HsKindSig _ t _))         = go tys t
-    go _   _                             = Nothing
-
-splitHsAppTys :: LHsType GhcRn -> [LHsType GhcRn]
-              -> (LHsType GhcRn, [LHsType GhcRn])
-splitHsAppTys (L _ (HsAppTy _ f a)) as = splitHsAppTys f (a:as)
-splitHsAppTys (L _ (HsParTy _ f))   as = splitHsAppTys f as
-splitHsAppTys f                     as = (f,as)
+    go (L _ (HsTyVar _ _ ln))          = Just ln
+    go (L _ (HsAppTy _ l _))           = go l
+    go (L _ (HsAppKindTy _ t _))       = go t
+    go (L _ (HsOpTy _ _ (L loc n) _))  = Just (L loc n)
+    go (L _ (HsParTy _ t))             = go t
+    go (L _ (HsKindSig _ t _))         = go t
+    go _                               = Nothing
+
+------------------------------------------------------------
+-- Arguments in an expression/type after splitting
+data HsArg tm ty
+  = HsValArg tm   -- Argument is an ordinary expression     (f arg)
+  | HsTypeArg  ty -- Argument is a visible type application (f @ty)
+  | HsArgPar SrcSpan -- See Note [HsArgPar]
+
+numVisibleArgs :: [HsArg tm ty] -> Arity
+numVisibleArgs = count is_vis
+  where is_vis (HsValArg _) = True
+        is_vis _            = False
+
+-- type level equivalent
+type LHsTypeArg p = HsArg (LHsType p) (LHsKind p)
+
+instance (Outputable tm, Outputable ty) => Outputable (HsArg tm ty) where
+  ppr (HsValArg tm)  = ppr tm
+  ppr (HsTypeArg ty) = char '@' <> ppr ty
+  ppr (HsArgPar sp)  = text "HsArgPar"  <+> ppr sp
+{-
+Note [HsArgPar]
+A HsArgPar indicates that everything to the left of this in the argument list is
+enclosed in parentheses together with the function itself. It is necessary so
+that we can recreate the parenthesis structure in the original source after
+typechecking the arguments.
 
+The SrcSpan is the span of the original HsPar
+
+((f arg1) arg2 arg3) results in an input argument list of
+[HsValArg arg1, HsArgPar span1, HsValArg arg2, HsValArg arg3, HsArgPar span2]
+
+-}
+
+splitHsAppTys :: HsType GhcRn -> (LHsType GhcRn, [LHsTypeArg GhcRn])
+splitHsAppTys e = go (noLoc e) []
+  where
+    go :: LHsType GhcRn -> [LHsTypeArg GhcRn]
+       -> (LHsType GhcRn, [LHsTypeArg GhcRn])
+    go (L _ (HsAppTy _ f a))      as = go f (HsValArg a : as)
+    go (L _ (HsAppKindTy _ ty k)) as = go ty (HsTypeArg k : as)
+    go (L sp (HsParTy _ f))       as = go f (HsArgPar sp : as)
+    go f                          as = (f,as)
 --------------------------------
 splitLHsPatSynTy :: LHsType pass
                  -> ( [LHsTyVarBndr pass]    -- universals
@@ -1155,7 +1197,7 @@ getLHsInstDeclClass_maybe :: LHsSigType (GhcPass p)
 -- Works on (HsSigType RdrName)
 getLHsInstDeclClass_maybe inst_ty
   = do { let head_ty = getLHsInstDeclHead inst_ty
-       ; (cls, _) <- hsTyGetAppHead_maybe head_ty
+       ; cls <- hsTyGetAppHead_maybe head_ty
        ; return cls }
 
 {-
@@ -1290,9 +1332,6 @@ instance (p ~ GhcPass pass,Outputable thing)
     ppr (HsWC { hswc_body = ty }) = ppr ty
     ppr (XHsWildCardBndrs x) = ppr x
 
-instance Outputable HsWildCardInfo where
-    ppr (AnonWildCard _)  = char '_'
-
 pprAnonWildCard :: SDoc
 pprAnonWildCard = char '_'
 
@@ -1418,7 +1457,8 @@ ppr_mono_ty (HsStarTy _ isUni)  = char (if isUni then '★' else '*')
 
 ppr_mono_ty (HsAppTy _ fun_ty arg_ty)
   = hsep [ppr_mono_lty fun_ty, ppr_mono_lty arg_ty]
-
+ppr_mono_ty (HsAppKindTy _ ty k)
+  = ppr_mono_lty ty <+> char '@' <> ppr_mono_lty k
 ppr_mono_ty (HsOpTy _ ty1 (L _ op) ty2)
   = sep [ ppr_mono_lty ty1
         , sep [pprInfixOcc op, ppr_mono_lty ty2 ] ]
@@ -1475,6 +1515,7 @@ hsTypeNeedsParens p = go
     go (HsWildCardTy{})      = False
     go (HsStarTy{})          = False
     go (HsAppTy{})           = p >= appPrec
+    go (HsAppKindTy{})       = p >= appPrec
     go (HsOpTy{})            = p >= opPrec
     go (HsParTy{})           = False
     go (HsDocTy _ (L _ t) _) = go t
@@ -1516,6 +1557,7 @@ lhsTypeHasLeadingPromotionQuote ty
     go (HsWildCardTy{})      = False
     go (HsStarTy{})          = False
     go (HsAppTy _ t _)       = goL t
+    go (HsAppKindTy _ t _)   = goL t
     go (HsParTy{})           = False
     go (HsDocTy _ t _)       = goL t
     go (XHsType{})           = False
index eb899cc..8cc3fb2 100644 (file)
@@ -55,7 +55,7 @@ module HsUtils(
   mkBigLHsVarTup, mkBigLHsTup, mkBigLHsVarPatTup, mkBigLHsPatTup,
 
   -- Types
-  mkHsAppTy, mkHsAppTys, userHsTyVarBndrs, userHsLTyVarBndrs,
+  mkHsAppTy, mkHsAppKindTy, userHsTyVarBndrs, userHsLTyVarBndrs,
   mkLHsSigType, mkLHsSigWcType, mkClassOpSigs, mkHsSigEnv,
   nlHsAppTy, nlHsTyVar, nlHsFunTy, nlHsParTy, nlHsTyConApp,
 
index cd41da5..685b2d4 100644 (file)
@@ -91,7 +91,7 @@ import GhcPrelude
 import qualified GHC.LanguageExtensions as LangExt
 }
 
-%expect 236 -- shift/reduce conflicts
+%expect 237 -- shift/reduce conflicts
 
 {- Last updated: 04 June 2018
 
@@ -134,13 +134,13 @@ state 60 contains 1 shift/reduce conflict.
 
 -------------------------------------------------------------------------------
 
-state 61 contains 46 shift/reduce conflicts.
+state 61 contains 47 shift/reduce conflicts.
 
     *** btype -> tyapps .
         tyapps -> tyapps . tyapp
 
-    Conflicts: '_' ':' '~' '!' '.' '`' '{' '[' '[:' '(' '(#' '`' SIMPLEQUOTE
-      VARID CONID VARSYM CONSYM QCONID QVARSYM QCONSYM
+    Conflicts: '_' ':' '~' '!' '.' '`' '{' '[' '[:' '(' '(#' '`' TYPEAPP
+      SIMPLEQUOTE VARID CONID VARSYM CONSYM QCONID QVARSYM QCONSYM
       STRING INTEGER TH_ID_SPLICE '$(' TH_QUASIQUOTE TH_QQUASIQUOTE
       and all the special ids.
 
@@ -1990,6 +1990,7 @@ tyapps :: { [Located TyEl] } -- NB: This list is reversed
 
 tyapp :: { Located TyEl }
         : atype                         { sL1 $1 $ TyElOpd (unLoc $1) }
+        | TYPEAPP atype                 { sLL $1 $> $ (TyElKindApp (getLoc $1) $2) }
         | qtyconop                      { sL1 $1 $ TyElOpr (unLoc $1) }
         | tyvarop                       { sL1 $1 $ TyElOpr (unLoc $1) }
         | SIMPLEQUOTE qconop            {% ams (sLL $1 $> $ TyElOpr (unLoc $2))
@@ -2554,17 +2555,16 @@ infixexp :: { LHsExpr GhcPs }
                  -- AnnVal annotation for NPlusKPat, which discards the operator
 
 infixexp_top :: { LHsExpr GhcPs }
-        : exp10_top               { $1 }
-        | infixexp_top qop exp10_top
-                                  {% do { when (srcSpanEnd (getLoc $2)
-                                            == srcSpanStart (getLoc $3)
-                                            && checkIfBang $2) $
-                                            warnSpaceAfterBang (comb2 $2 $3);
-                                          ams (sLL $1 $> (OpApp noExt $1 $2 $3))
-                                               [mj AnnVal $2]
-                                        }
-                                  }
-
+            : exp10_top               { $1 }
+            | infixexp_top qop exp10_top
+                                      {% do { when (srcSpanEnd (getLoc $2)
+                                                == srcSpanStart (getLoc $3)
+                                                && checkIfBang $2) $
+                                                warnSpaceAfterBang (comb2 $2 $3);
+                                              ams (sLL $1 $> (OpApp noExt $1 $2 $3))
+                                                   [mj AnnVal $2]
+                                            }
+                                      }
 
 exp10_top :: { LHsExpr GhcPs }
         : '-' fexp                      {% ams (sLL $1 $> $ NegApp noExt $2 noSyntaxExpr)
index 9712034..4338968 100644 (file)
@@ -114,7 +114,7 @@ import DynFlags ( WarningFlag(..) )
 import Control.Monad
 import Text.ParserCombinators.ReadP as ReadP
 import Data.Char
-
+import qualified Data.Monoid as Monoid
 import Data.Data       ( dataTypeOf, fromConstr, dataTypeConstrs )
 
 #include "HsVersions.h"
@@ -804,7 +804,7 @@ to make setRdrNameSpace partial, so we just make an Unqual name instead. It
 really doesn't matter!
 -}
 
-checkTyVarsP :: SDoc -> SDoc -> Located RdrName -> [LHsType GhcPs]
+checkTyVarsP :: SDoc -> SDoc -> Located RdrName -> [LHsTypeArg GhcPs]
              -> P (LHsQTyVars GhcPs)
 -- Same as checkTyVars, but in the P monad
 checkTyVarsP pp_what equals_or_where tc tparms
@@ -818,7 +818,7 @@ eitherToP :: Either (SrcSpan, SDoc) a -> P a
 eitherToP (Left (loc, doc)) = parseErrorSDoc loc doc
 eitherToP (Right thing)     = return thing
 
-checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsType GhcPs]
+checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsTypeArg GhcPs]
             -> Either (SrcSpan, SDoc)
                       ( LHsQTyVars GhcPs  -- the synthesized type variables
                       , P () )            -- action which adds annotations
@@ -827,9 +827,17 @@ checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsType GhcPs]
 -- We use the Either monad because it's also called (via 'mkATDefault') from
 -- "Convert".
 checkTyVars pp_what equals_or_where tc tparms
-  = do { (tvs, anns) <- fmap unzip $ mapM (chkParens []) tparms
+  = do { (tvs, anns) <- fmap unzip $ mapM check tparms
        ; return (mkHsQTvs tvs, sequence_ anns) }
   where
+    check (HsTypeArg ki@(L loc _)) = Left (loc,
+                                      vcat [ text "Unexpected type application" <+>
+                                            text "@" <> ppr ki
+                                          , text "In the" <+> pp_what <+>
+                                            ptext (sLit "declaration for") <+> quotes (ppr tc)])
+    check (HsValArg ty) = chkParens [] ty
+    check (HsArgPar sp) = Left (sp, vcat [text "Malformed" <+> pp_what
+                           <+> text "declaration for" <+> quotes (ppr tc)])
         -- Keep around an action for adjusting the annotations of extra parens
     chkParens :: [AddAnn] -> LHsType GhcPs
               -> Either (SrcSpan, SDoc) (LHsTyVarBndr GhcPs, P ())
@@ -936,7 +944,7 @@ checkTyClHdr :: Bool               -- True  <=> class header
                                    -- False <=> type header
              -> LHsType GhcPs
              -> P (Located RdrName,      -- the head symbol (type or class name)
-                   [LHsType GhcPs],      -- parameters of head symbol
+                   [LHsTypeArg GhcPs],      -- parameters of head symbol
                    LexicalFixity,        -- the declaration is in infix format
                    [AddAnn]) -- API Annotation for HsParTy when stripping parens
 -- Well-formedness check and decomposition of type and class heads.
@@ -957,12 +965,12 @@ checkTyClHdr is_cls ty
     go l (HsTyVar _ _ (dL->L _ tc)) acc ann fix
       | isRdrTc tc               = return (cL l tc, acc, fix, ann)
     go _ (HsOpTy _ t1 ltc@(dL->L _ tc) t2) acc ann _fix
-      | isRdrTc tc               = return (ltc, t1:t2:acc, Infix, ann)
+      | isRdrTc tc               = return (ltc, HsValArg t1:HsValArg t2:acc, Infix, ann)
     go l (HsParTy _ ty)    acc ann fix = goL ty acc (ann ++mkParensApiAnn l) fix
-    go _ (HsAppTy _ t1 t2) acc ann fix = goL t1 (t2:acc) ann fix
-
+    go _ (HsAppTy _ t1 t2) acc ann fix = goL t1 (HsValArg t2:acc) ann fix
+    go _ (HsAppKindTy _ ty ki) acc ann fix = goL ty (HsTypeArg ki:acc) ann fix
     go l (HsTupleTy _ HsBoxedOrConstraintTuple ts) [] ann fix
-      = return (cL l (nameRdrName tup_name), ts, fix, ann)
+      = return (cL l (nameRdrName tup_name), map HsValArg ts, fix, ann)
       where
         arity = length ts
         tup_name | is_cls    = cTupleTyConName arity
@@ -1029,6 +1037,7 @@ checkContext (dL->L l orig_t)
 checkNoDocs :: SDoc -> LHsType GhcPs -> P ()
 checkNoDocs msg ty = go ty
   where
+    go (dL->L _ (HsAppKindTy _ ty ki)) = go ty *> go ki
     go (dL->L _ (HsAppTy _ t1 t2)) = go t1 *> go t2
     go (dL->L l (HsDocTy _ t ds)) = parseErrorSDoc l $ hsep
                                   [ text "Unexpected haddock", quotes (ppr ds)
@@ -1366,6 +1375,7 @@ isFunLhs e = go e [] []
 
 -- | Either an operator or an operand.
 data TyEl = TyElOpr RdrName | TyElOpd (HsType GhcPs)
+          | TyElKindApp SrcSpan (LHsType GhcPs)
           | TyElTilde | TyElBang
           | TyElUnpackedness ([AddAnn], SourceText, SrcUnpackedness)
           | TyElDocPrev HsDocString
@@ -1373,6 +1383,7 @@ data TyEl = TyElOpr RdrName | TyElOpd (HsType GhcPs)
 instance Outputable TyEl where
   ppr (TyElOpr name) = ppr name
   ppr (TyElOpd ty) = ppr ty
+  ppr (TyElKindApp _ ki) = text "@" <> ppr ki
   ppr TyElTilde = text "~"
   ppr TyElBang = text "!"
   ppr (TyElUnpackedness (_, _, unpk)) = ppr unpk
@@ -1449,10 +1460,12 @@ mergeOps all_xs = go (0 :: Int) [] id all_xs
     -- handle (NO)UNPACK pragmas
     go k acc ops_acc ((dL->L l (TyElUnpackedness (anns, unpkSrc, unpk))):xs) =
       if not (null acc) && null xs
-      then do { let a = ops_acc (mergeAcc acc)
+      then do { (addAccAnns, acc') <- eitherToP $ mergeOpsAcc acc
+              ; let a = ops_acc acc'
                     strictMark = HsSrcBang unpkSrc unpk NoSrcStrict
                     bl = combineSrcSpans l (getLoc a)
                     bt = HsBangTy noExt strictMark a
+              ; addAccAnns
               ; addAnnsAt bl anns
               ; return (cL bl bt) }
       else parseErrorSDoc l unpkError
@@ -1479,6 +1492,7 @@ mergeOps all_xs = go (0 :: Int) [] id all_xs
       , let guess [] = True
             guess ((dL->L _ (TyElOpd _)):_) = False
             guess ((dL->L _ (TyElOpr _)):_) = True
+            guess ((dL->L _ (TyElKindApp _ _)):_) = False
             guess ((dL->L _ (TyElTilde)):_) = True
             guess ((dL->L _ (TyElBang)):_) = True
             guess ((dL->L _ (TyElUnpackedness _)):_) = True
@@ -1487,7 +1501,9 @@ mergeOps all_xs = go (0 :: Int) [] id all_xs
                       -- due to #15884
         in guess xs
       = if not (null acc) && (k > 1 || length acc > 1)
-        then failOpStrictnessCompound (cL l str) (ops_acc (mergeAcc acc))
+        then do { (_, a) <- eitherToP (mergeOpsAcc acc)
+               -- no need to add annotations since it fails anyways!
+                ; failOpStrictnessCompound (cL l str) (ops_acc a) }
         else failOpStrictnessPosition (cL l str)
 
     -- clause [opr]:
@@ -1497,8 +1513,9 @@ mergeOps all_xs = go (0 :: Int) [] id all_xs
     go k acc ops_acc ((dL->L l (TyElOpr op)):xs) =
       if null acc || null (filter isTyElOpd xs)
         then failOpFewArgs (cL l op)
-        else do { let a = mergeAcc acc
-                ; go (k + 1) [] (\c -> mkLHsOpTy c (cL l op) (ops_acc a)) xs }
+        else do { (addAccAnns, acc') <- eitherToP (mergeOpsAcc acc)
+                ; addAccAnns
+                ; go (k + 1) [] (\c -> mkLHsOpTy c (cL l op) (ops_acc acc')) xs }
       where
         isTyElOpd (dL->L _ (TyElOpd _)) = True
         isTyElOpd _ = False
@@ -1515,20 +1532,38 @@ mergeOps all_xs = go (0 :: Int) [] id all_xs
 
     -- clause [opd]:
     -- whenever an operand is encountered, it is added to the accumulator
-    go k acc ops_acc ((dL->L l (TyElOpd a)):xs) = go k (cL l a:acc) ops_acc xs
+    go k acc ops_acc ((dL->L l (TyElOpd a)):xs) = go k (HsValArg (cL l a):acc) ops_acc xs
+
+    -- clause [tyapp]:
+    -- whenever a type application is encountered, it is added to the accumulator
+    go k acc ops_acc ((dL->L _ (TyElKindApp l a)):xs) = go k (HsTypeArg (l, a):acc) ops_acc xs
 
-    -- clause [end]:
+    -- clause [end]
     -- See Note [Non-empty 'acc' in mergeOps clause [end]]
-    go _ acc ops_acc [] =
-      return (ops_acc (mergeAcc acc))
+    go _ acc ops_acc [] = do { (addAccAnns, acc') <- eitherToP (mergeOpsAcc acc)
+                             ; addAccAnns
+                             ; return (ops_acc acc') }
 
     go _ _ _ _ = panic "mergeOps.go: Impossible Match"
                         -- due to #15884
 
-
-    mergeAcc [] = panic "mergeOps.mergeAcc: empty input"
-    mergeAcc (x:xs) = mkHsAppTys x xs
-
+mergeOpsAcc :: [HsArg (LHsType GhcPs) (SrcSpan, LHsKind GhcPs)]
+         -> Either (SrcSpan, SDoc) (P (), LHsType GhcPs)
+mergeOpsAcc [] = panic "mergeOpsAcc: empty input"
+mergeOpsAcc (HsTypeArg (_, L loc ki):_)
+  = Left (loc, text "Unexpected type application:" <+> ppr ki)
+mergeOpsAcc (HsValArg ty : xs) = go1 (pure ()) ty xs
+  where
+    go1 :: P () -> LHsType GhcPs
+        -> [HsArg (LHsType GhcPs) (SrcSpan, LHsKind GhcPs)]
+        -> Either (SrcSpan, SDoc) (P (), LHsType GhcPs)
+    go1 anns lhs []     = Right (anns, lhs)
+    go1 anns lhs (x:xs) = case x of
+        HsValArg ty -> go1 anns (mkHsAppTy lhs ty) xs
+        HsTypeArg (loc, ki) -> let ty = mkHsAppKindTy lhs ki
+                               in go1 (addAnnotation (getLoc ty) AnnAt loc >> anns) ty xs
+        HsArgPar _ -> go1 anns lhs xs
+mergeOpsAcc (HsArgPar _: xs) = mergeOpsAcc xs
 
 {- Note [Impossible case in mergeOps clause [unpk]]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1586,14 +1621,25 @@ pInfixSide :: [Located TyEl] -> Maybe (LHsType GhcPs, P (), [Located TyEl])
 pInfixSide ((dL->L l (TyElOpd t)):xs)
   | (True, t', addAnns, xs') <- pBangTy (cL l t) xs
   = Just (t', addAnns, xs')
-pInfixSide ((dL->L l1 (TyElOpd t1)):xs1) = go [cL l1 t1] xs1
-  where
-    go acc ((dL->L l (TyElOpd t)):xs) = go (cL l t:acc) xs
-    go acc xs = Just (mergeAcc acc, pure (), xs)
-    mergeAcc [] = panic "pInfixSide.mergeAcc: empty input"
-    mergeAcc (x:xs) = mkHsAppTys x xs
+pInfixSide (el:xs1)
+  | Just t1 <- pLHsTypeArg el
+  = go [t1] xs1
+   where
+     go :: [HsArg (LHsType GhcPs) (SrcSpan, LHsKind GhcPs)]
+        -> [Located TyEl] -> Maybe (LHsType GhcPs, P (), [Located TyEl])
+     go acc (el:xs)
+       | Just t <- pLHsTypeArg el
+       = go (t:acc) xs
+     go acc xs = case mergeOpsAcc acc of
+       Left _ -> Nothing
+       Right (addAnns, acc') -> Just (acc', addAnns, xs)
 pInfixSide _ = Nothing
 
+pLHsTypeArg :: Located TyEl -> Maybe (HsArg (LHsType GhcPs) (SrcSpan, LHsKind GhcPs))
+pLHsTypeArg (dL->L l (TyElOpd a)) = Just (HsValArg (L l a))
+pLHsTypeArg (dL->L _ (TyElKindApp l a)) = Just (HsTypeArg (l,a))
+pLHsTypeArg _ = Nothing
+
 pDocPrev :: [Located TyEl] -> (Maybe LHsDocString, [Located TyEl])
 pDocPrev = go Nothing
   where
@@ -1735,8 +1781,10 @@ mergeDataCon all_xs =
     goFirst ((dL->L l (TyElOpd t)):xs)
       | (_, t', addAnns, xs') <- pBangTy (cL l t) xs
       = go addAnns Nothing [mkLHsDocTyMaybe t' trailingFieldDoc] xs'
-    goFirst xs =
-      go (pure ()) mTrailingDoc [] xs
+    goFirst (L l (TyElKindApp _ _):_)
+      = goInfix Monoid.<> Left (l, kindAppErr)
+    goFirst xs
+      = go (pure ()) mTrailingDoc [] xs
 
     go addAnns mLastDoc ts [ dL->L l (TyElOpd (HsTyVar _ _ (dL->L _ tc))) ]
       = do { data_con <- tyConToDataCon l tc
@@ -1751,6 +1799,7 @@ mergeDataCon all_xs =
       -- Encountered an operator: backtrack to the beginning and attempt
       -- to parse as an infix definition.
       goInfix
+    go _ _ _ (L l (TyElKindApp _ _):_) =  goInfix Monoid.<> Left (l, kindAppErr)
     go _ _ _ _ = Left malformedErr
       where
         malformedErr =
@@ -1782,6 +1831,11 @@ mergeDataCon all_xs =
             text "in a data/newtype declaration:" $$
             nest 2 (hsep . reverse $ map ppr all_xs'))
 
+    kindAppErr =
+      text "Unexpected kind application" <+>
+      text "in a data/newtype declaration:" $$
+      nest 2 (hsep . reverse $ map ppr all_xs')
+
 ---------------------------------------------------------------------------
 -- Check for monad comprehensions
 --
index 7183a7e..40ef6a4 100644 (file)
@@ -96,8 +96,8 @@ templateHaskellNames = [
     -- PatSynArgs (for pattern synonyms)
     prefixPatSynName, infixPatSynName, recordPatSynName,
     -- Type
-    forallTName, varTName, conTName, appTName, equalityTName,
-    tupleTName, unboxedTupleTName, unboxedSumTName,
+    forallTName, varTName, conTName, infixTName, appTName, appKindTName,
+    equalityTName, tupleTName, unboxedTupleTName, unboxedSumTName,
     arrowTName, listTName, sigTName, litTName,
     promotedTName, promotedTupleTName, promotedNilTName, promotedConsTName,
     wildCardTName, implicitParamTName,
@@ -429,9 +429,9 @@ infixPatSynName  = libFun (fsLit "infixPatSyn")  infixPatSynIdKey
 recordPatSynName = libFun (fsLit "recordPatSyn") recordPatSynIdKey
 
 -- data Type = ...
-forallTName, varTName, conTName, tupleTName, unboxedTupleTName,
-    unboxedSumTName, arrowTName, listTName, appTName, sigTName,
-    equalityTName, litTName, promotedTName,
+forallTName, varTName, conTName, infixTName, tupleTName, unboxedTupleTName,
+    unboxedSumTName, arrowTName, listTName, appTName, appKindTName,
+    sigTName, equalityTName, litTName, promotedTName,
     promotedTupleTName, promotedNilTName, promotedConsTName,
     wildCardTName, implicitParamTName :: Name
 forallTName         = libFun (fsLit "forallT")        forallTIdKey
@@ -443,6 +443,7 @@ unboxedSumTName     = libFun (fsLit "unboxedSumT")    unboxedSumTIdKey
 arrowTName          = libFun (fsLit "arrowT")         arrowTIdKey
 listTName           = libFun (fsLit "listT")          listTIdKey
 appTName            = libFun (fsLit "appT")           appTIdKey
+appKindTName        = libFun (fsLit "appKindT")       appKindTIdKey
 sigTName            = libFun (fsLit "sigT")           sigTIdKey
 equalityTName       = libFun (fsLit "equalityT")      equalityTIdKey
 litTName            = libFun (fsLit "litT")           litTIdKey
@@ -451,6 +452,7 @@ promotedTupleTName  = libFun (fsLit "promotedTupleT") promotedTupleTIdKey
 promotedNilTName    = libFun (fsLit "promotedNilT")   promotedNilTIdKey
 promotedConsTName   = libFun (fsLit "promotedConsT")  promotedConsTIdKey
 wildCardTName       = libFun (fsLit "wildCardT")      wildCardTIdKey
+infixTName          = libFun (fsLit "infixT")         infixTIdKey
 implicitParamTName  = libFun (fsLit "implicitParamT") implicitParamTIdKey
 
 -- data TyLit = ...
@@ -949,19 +951,20 @@ recordPatSynIdKey = mkPreludeMiscIdUnique 382
 
 -- data Type = ...
 forallTIdKey, varTIdKey, conTIdKey, tupleTIdKey, unboxedTupleTIdKey,
-    unboxedSumTIdKey, arrowTIdKey, listTIdKey, appTIdKey, sigTIdKey,
-    equalityTIdKey, litTIdKey, promotedTIdKey,
+    unboxedSumTIdKey, arrowTIdKey, listTIdKey, appTIdKey, appKindTIdKey,
+    sigTIdKey, equalityTIdKey, litTIdKey, promotedTIdKey,
     promotedTupleTIdKey, promotedNilTIdKey, promotedConsTIdKey,
-    wildCardTIdKey, implicitParamTIdKey :: Unique
-forallTIdKey        = mkPreludeMiscIdUnique 391
-varTIdKey           = mkPreludeMiscIdUnique 392
-conTIdKey           = mkPreludeMiscIdUnique 393
-tupleTIdKey         = mkPreludeMiscIdUnique 394
-unboxedTupleTIdKey  = mkPreludeMiscIdUnique 395
-unboxedSumTIdKey    = mkPreludeMiscIdUnique 396
-arrowTIdKey         = mkPreludeMiscIdUnique 397
-listTIdKey          = mkPreludeMiscIdUnique 398
-appTIdKey           = mkPreludeMiscIdUnique 399
+    wildCardTIdKey, implicitParamTIdKey, infixTIdKey :: Unique
+forallTIdKey        = mkPreludeMiscIdUnique 390
+varTIdKey           = mkPreludeMiscIdUnique 391
+conTIdKey           = mkPreludeMiscIdUnique 392
+tupleTIdKey         = mkPreludeMiscIdUnique 393
+unboxedTupleTIdKey  = mkPreludeMiscIdUnique 394
+unboxedSumTIdKey    = mkPreludeMiscIdUnique 395
+arrowTIdKey         = mkPreludeMiscIdUnique 396
+listTIdKey          = mkPreludeMiscIdUnique 397
+appTIdKey           = mkPreludeMiscIdUnique 398
+appKindTIdKey       = mkPreludeMiscIdUnique 399
 sigTIdKey           = mkPreludeMiscIdUnique 400
 equalityTIdKey      = mkPreludeMiscIdUnique 401
 litTIdKey           = mkPreludeMiscIdUnique 402
@@ -971,6 +974,7 @@ promotedNilTIdKey   = mkPreludeMiscIdUnique 405
 promotedConsTIdKey  = mkPreludeMiscIdUnique 406
 wildCardTIdKey      = mkPreludeMiscIdUnique 407
 implicitParamTIdKey = mkPreludeMiscIdUnique 408
+infixTIdKey         = mkPreludeMiscIdUnique 409
 
 -- data TyLit = ...
 numTyLitIdKey, strTyLitIdKey :: Unique
index c76eb31..5ec4e05 100644 (file)
@@ -652,7 +652,7 @@ rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds
        ; let (ktv_names, _, head_ty') = splitLHsInstDeclTy inst_ty'
        ; let cls = case hsTyGetAppHead_maybe head_ty' of
                      Nothing -> mkUnboundName (mkTcOccFS (fsLit "<class>"))
-                     Just (dL->L _ cls, _) -> cls
+                     Just (dL->L _ cls) -> cls
                      -- rnLHsInstType has added an error message
                      -- if hsTyGetAppHead_maybe fails
 
@@ -710,7 +710,7 @@ rnFamInstEqn doc mb_cls rhs_kvars
                                , feqn_fixity = fixity
                                , feqn_rhs    = payload }}) rn_payload
   = do { tycon'   <- lookupFamInstName (fmap fst mb_cls) tycon
-       ; let pat_kity_vars_with_dups = extractHsTysRdrTyVarsDups pats
+       ; let pat_kity_vars_with_dups = extractHsTyArgRdrKiTyVarsDup pats
              -- Use the "...Dups" form because it's needed
              -- below to report unsed binder on the LHS
        ; let pat_kity_vars = rmDupsInRdrTyVars pat_kity_vars_with_dups
@@ -745,7 +745,7 @@ rnFamInstEqn doc mb_cls rhs_kvars
                  --  the user meant to bring in scope here. This is an explicit
                  --  forall, so we want fresh names, not class variables.
                  --  Thus: always pass Nothing
-                 do { (pats', pat_fvs) <- rnLHsTypes (FamPatCtx tycon) pats
+                 do { (pats', pat_fvs) <- rnLHsTypeArgs (FamPatCtx tycon) pats
                     ; (payload', rhs_fvs) <- rn_payload doc payload
 
                        -- Report unused binders on the LHS
@@ -780,16 +780,10 @@ rnFamInstEqn doc mb_cls rhs_kvars
 
                     ; return ((bndrs', pats', payload'), rhs_fvs `plusFV` pat_fvs) }
 
-       ; let anon_wcs = concatMap collectAnonWildCards pats'
-             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
-                        -- Note [Wildcards in family instances]
-             all_fvs  = fvs `addOneFV` unLoc tycon'
-                        -- type instance => use, hence addOneFV
+       ; let all_fvs  = fvs `addOneFV` unLoc tycon'
+            -- type instance => use, hence addOneFV
 
-       ; return (HsIB { hsib_ext = all_ibs
+       ; return (HsIB { hsib_ext = all_imp_var_names -- Note [Wildcards in family instances]
                       , hsib_body
                           = FamEqn { feqn_ext    = noExt
                                    , feqn_tycon  = tycon'
@@ -915,12 +909,13 @@ is the same as
     type family F a b :: *
     type instance F Int b = Int
 
-This is implemented as follows: during renaming anonymous wild cards
-'_' are given freshly generated names. These names are collected after
-renaming (rnFamInstEqn) and used to make new type variables during
-type checking (tc_fam_ty_pats). One should not confuse these wild
-cards with the ones from partial type signatures. The latter generate
-fresh meta-variables whereas the former generate fresh skolems.
+This is implemented as follows: Unnamed wildcards remain unchanged after
+the renamer, and then given fresh meta-variables during typechecking, and
+it is handled pretty much the same way as the ones in partial type signatures.
+We however don't want to emit hole constraints on wildcards in family
+instances, so we turn on PartialTypeSignatures and turn off warning flag to
+let typechecker know this.
+See related Note [Wildcards in visible kind application] in TcHsType.hs
 
 Note [Unused type variables in family instances]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
index a3062f1..735456d 100644 (file)
 module RnTypes (
         -- Type related stuff
         rnHsType, rnLHsType, rnLHsTypes, rnContext,
-        rnHsKind, rnLHsKind,
+        rnHsKind, rnLHsKind, rnLHsTypeArgs,
         rnHsSigType, rnHsWcType,
         HsSigWcTypeScoping(..), rnHsSigWcType, rnHsSigWcTypeScoped,
         rnLHsInstType,
-        newTyVarNameRn, collectAnonWildCards,
+        newTyVarNameRn,
         rnConDeclFields,
         rnLTyVar,
 
@@ -32,7 +32,7 @@ module RnTypes (
         extractHsTyRdrTyVarsDups, extractHsTysRdrTyVars,
         extractHsTysRdrTyVarsDups, rmDupsInRdrTyVars,
         extractRdrKindSigVars, extractDataDefnKindVars,
-        extractHsTvBndrs,
+        extractHsTvBndrs, extractHsTyArgRdrKiTyVarsDup,
         freeKiTyVarsAllVars, freeKiTyVarsKindVars, freeKiTyVarsTypeVars,
         elemRdr
   ) where
@@ -166,8 +166,7 @@ rnWcBody ctxt nwc_rdrs hs_ty
                         , rtke_ctxt  = ctxt }
        ; (hs_ty', fvs) <- bindLocalNamesFV nwcs $
                           rn_lty env hs_ty
-       ; let awcs = collectAnonWildCards hs_ty'
-       ; return (nwcs ++ awcs, hs_ty', fvs) }
+       ; return (nwcs, hs_ty', fvs) }
   where
     rn_lty env (dL->L loc hs_ty)
       = setSrcSpan loc $
@@ -187,10 +186,8 @@ rnWcBody ctxt nwc_rdrs hs_ty
       | Just (hs_ctxt1, hs_ctxt_last) <- snocView hs_ctxt
       , (dL->L lx (HsWildCardTy _))  <- ignoreParens hs_ctxt_last
       = do { (hs_ctxt1', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt1
-           ; wc' <- setSrcSpan lx $
-                    do { checkExtraConstraintWildCard env hs_ctxt1
-                       ; rnAnonWildCard }
-           ; let hs_ctxt' = hs_ctxt1' ++ [cL lx (HsWildCardTy wc')]
+           ; setSrcSpan lx $ checkExtraConstraintWildCard env hs_ctxt1
+           ; let hs_ctxt' = hs_ctxt1' ++ [cL lx (HsWildCardTy noExt)]
            ; (hs_ty', fvs2) <- rnLHsTyKi env hs_ty
            ; return (HsQualTy { hst_xqual = noExt
                               , hst_ctxt = cL cx hs_ctxt', hst_body = hs_ty' }
@@ -490,6 +487,22 @@ rnLHsKind ctxt kind = rnLHsTyKi (mkTyKiEnv ctxt KindLevel RnTypeBody) kind
 rnHsKind  :: HsDocContext -> HsKind GhcPs -> RnM (HsKind GhcRn, FreeVars)
 rnHsKind ctxt kind = rnHsTyKi  (mkTyKiEnv ctxt KindLevel RnTypeBody) kind
 
+-- renaming a type only, not a kind
+rnLHsTypeArg :: HsDocContext -> LHsTypeArg GhcPs
+                -> RnM (LHsTypeArg GhcRn, FreeVars)
+rnLHsTypeArg ctxt (HsValArg ty)
+   = do { (tys_rn, fvs) <- rnLHsType ctxt ty
+        ; return (HsValArg tys_rn, fvs) }
+rnLHsTypeArg ctxt (HsTypeArg ki)
+   = do { (kis_rn, fvs) <- rnLHsKind ctxt ki
+        ; return (HsTypeArg kis_rn, fvs) }
+rnLHsTypeArg _ (HsArgPar sp)
+   = return (HsArgPar sp, emptyFVs)
+
+rnLHsTypeArgs :: HsDocContext -> [LHsTypeArg GhcPs]
+                 -> RnM ([LHsTypeArg GhcRn], FreeVars)
+rnLHsTypeArgs doc args = mapFvRn (rnLHsTypeArg doc) args
+
 --------------
 rnTyKiContext :: RnTyKiEnv -> LHsContext GhcPs
               -> RnM (LHsContext GhcRn, FreeVars)
@@ -630,6 +643,13 @@ rnHsTyKi env (HsAppTy _ ty1 ty2)
        ; (ty2', fvs2) <- rnLHsTyKi env ty2
        ; return (HsAppTy noExt ty1' ty2', fvs1 `plusFV` fvs2) }
 
+rnHsTyKi env (HsAppKindTy _ ty k)
+  = do { kind_app <- xoptM LangExt.TypeApplications
+       ; unless kind_app (addErr (typeAppErr k))
+       ; (ty', fvs1) <- rnLHsTyKi env ty
+       ; (k', fvs2) <- rnLHsTyKi (env {rtke_level = KindLevel }) k
+       ; return (HsAppKindTy noExt ty' k', fvs1 `plusFV` fvs2) }
+
 rnHsTyKi env t@(HsIParamTy _ n ty)
   = do { notInKinds env t
        ; (ty', fvs) <- rnLHsTyKi env ty
@@ -667,11 +687,7 @@ rnHsTyKi env ty@(HsExplicitTupleTy _ tys)
 
 rnHsTyKi env (HsWildCardTy _)
   = do { checkAnonWildCard env
-       ; wc' <- rnAnonWildCard
-       ; return (HsWildCardTy wc', emptyFVs) }
-         -- emptyFVs: this occurrence does not refer to a
-         --           user-written binding site, so don't treat
-         --           it as a free variable
+       ; return (HsWildCardTy noExt, emptyFVs) }
 
 --------------
 rnTyVar :: RnTyKiEnv -> RdrName -> RnM Name
@@ -760,12 +776,7 @@ wildCardsAllowed env
        HsTypeCtx {}        -> True
        _                   -> False
 
-rnAnonWildCard :: RnM HsWildCardInfo
-rnAnonWildCard
-  = do { loc <- getSrcSpanM
-       ; uniq <- newUnique
-       ; let name = mkInternalName uniq (mkTyVarOcc "_") loc
-       ; return (AnonWildCard (cL loc name)) }
+
 
 ---------------
 -- | Ensures either that we're in a type or that -XPolyKinds is set
@@ -1051,49 +1062,6 @@ newTyVarNameRn mb_assoc (dL->L loc rdr)
               -- Use the same Name as the parent class decl
 
            _                -> newLocalBndrRn (cL loc rdr) }
-
----------------------
-collectAnonWildCards :: LHsType GhcRn -> [Name]
--- | Extract all wild cards from a type.
-collectAnonWildCards lty = go lty
-  where
-    go lty = case unLoc lty of
-      HsWildCardTy (AnonWildCard wc) -> [unLoc wc]
-      HsAppTy _ ty1 ty2              -> go ty1 `mappend` go ty2
-      HsFunTy _ ty1 ty2              -> go ty1 `mappend` go ty2
-      HsListTy _ ty                  -> go ty
-      HsTupleTy _ _ tys              -> gos tys
-      HsSumTy _ tys                  -> gos tys
-      HsOpTy _ ty1 _ ty2             -> go ty1 `mappend` go ty2
-      HsParTy _ ty                   -> go ty
-      HsIParamTy _ _ ty              -> go ty
-      HsKindSig _ ty kind            -> go ty `mappend` go kind
-      HsDocTy _ ty _                 -> go ty
-      HsBangTy _ _ ty                -> go ty
-      HsRecTy _ flds                 -> gos $ map (cd_fld_type . unLoc) flds
-      HsExplicitListTy _ _ tys       -> gos tys
-      HsExplicitTupleTy _ tys        -> gos tys
-      HsForAllTy { hst_bndrs = bndrs
-                 , hst_body  = ty }  -> collectAnonWildCardsBndrs bndrs
-                                        `mappend` go ty
-      HsQualTy { hst_ctxt = ctxt
-               , hst_body = ty }     -> gos (unLoc ctxt) `mappend` go ty
-      HsSpliceTy _ (HsSpliced _ _ (HsSplicedTy ty)) -> go $ cL noSrcSpan ty
-      HsSpliceTy{} -> mempty
-      HsTyLit{} -> mempty
-      HsTyVar{} -> mempty
-      HsStarTy{} -> mempty
-      XHsType{} -> mempty
-
-    gos = mconcat . map go
-
-collectAnonWildCardsBndrs :: [LHsTyVarBndr GhcRn] -> [Name]
-collectAnonWildCardsBndrs ltvs = concatMap (go . unLoc) ltvs
-  where
-    go (UserTyVar _ _)      = []
-    go (KindedTyVar _ _ ki) = collectAnonWildCards ki
-    go (XTyVarBndr{})       = []
-
 {-
 *********************************************************
 *                                                       *
@@ -1509,6 +1477,10 @@ opTyErr op overall_ty
           | otherwise
           = text "Use TypeOperators to allow operators in types"
 
+typeAppErr :: LHsKind GhcPs -> SDoc
+typeAppErr (L _ k)
+  = hang (text "Illegal visible kind application" <+> quotes (ppr k))
+       2 (text "Perhaps you intended to use TypeApplications")
 {-
 ************************************************************************
 *                                                                      *
@@ -1667,6 +1639,19 @@ inScope rdr_env rdr = rdr `elemLocalRdrEnv` rdr_env
 -- When the same name occurs multiple times in the types, only the first
 -- occurrence is returned.
 -- See Note [Kind and type-variable binders]
+
+
+extract_tyarg :: LHsTypeArg GhcPs -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
+extract_tyarg (HsValArg ty) acc = extract_lty TypeLevel ty acc
+extract_tyarg (HsTypeArg ki) acc = extract_lty KindLevel ki acc
+extract_tyarg (HsArgPar _) acc = acc
+
+extract_tyargs :: [LHsTypeArg GhcPs] -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
+extract_tyargs args acc = foldr extract_tyarg acc args
+
+extractHsTyArgRdrKiTyVarsDup :: [LHsTypeArg GhcPs] -> FreeKiTyVarsWithDups
+extractHsTyArgRdrKiTyVarsDup args = extract_tyargs args emptyFKTV
+
 extractHsTyRdrTyVars :: LHsType GhcPs -> FreeKiTyVarsNoDups
 extractHsTyRdrTyVars ty
   = rmDupsInRdrTyVars (extractHsTyRdrTyVarsDups ty)
@@ -1808,6 +1793,8 @@ extract_lty t_or_k (dL->L _ ty) acc
                                            flds
       HsAppTy _ ty1 ty2           -> extract_lty t_or_k ty1 $
                                      extract_lty t_or_k ty2 acc
+      HsAppKindTy _ ty k          -> extract_lty t_or_k ty $
+                                     extract_lty KindLevel k acc
       HsListTy _ ty               -> extract_lty t_or_k ty acc
       HsTupleTy _ _ tys           -> extract_ltys t_or_k tys acc
       HsSumTy _ tys               -> extract_ltys t_or_k tys acc
index 4bbb42d..dd50786 100644 (file)
@@ -717,7 +717,7 @@ tcStandaloneDerivInstType ctxt
                                        , hsib_body   = deriv_ty_body })})
   | (tvs, theta, rho) <- splitLHsSigmaTy deriv_ty_body
   , L _ [wc_pred] <- theta
-  , L _ (HsWildCardTy (AnonWildCard (L wc_span _))) <- ignoreParens wc_pred
+  , L wc_span (HsWildCardTy _) <- ignoreParens wc_pred
   = do dfun_ty <- tcHsClsInstType ctxt $
                   HsIB { hsib_ext = vars
                        , hsib_body
index 3b8d2c9..63cb351 100644 (file)
@@ -1093,24 +1093,7 @@ arithSeqEltType (Just fl) res_ty
 ************************************************************************
 -}
 
-data HsArg tm ty
-  = HsValArg tm   -- Argument is an ordinary expression     (f arg)
-  | HsTypeArg  ty -- Argument is a visible type application (f @ty)
-  | HsArgPar SrcSpan -- See Note [HsArgPar]
-
-{-
-Note [HsArgPar]
-A HsArgPar indicates that everything to the left of this in the argument list is
-enclosed in parentheses together with the function itself. It is necessary so
-that we can recreate the parenthesis structure in the original source after
-typechecking the arguments.
-
-The SrcSpan is the span of the original HsPar
-
-((f arg1) arg2 arg3) results in an input argument list of
-[HsValArg arg1, HsArgPar span1, HsValArg arg2, HsValArg arg3, HsArgPar span2]
-
--}
+-- HsArg is defined in HsTypes.hs
 
 wrapHsArgs :: (NoGhcTc (GhcPass id) ~ GhcRn)
            => LHsExpr (GhcPass id)
@@ -1121,11 +1104,6 @@ wrapHsArgs f (HsValArg  a : args) = wrapHsArgs (mkHsApp f a)     args
 wrapHsArgs f (HsTypeArg t : args) = wrapHsArgs (mkHsAppType f t) args
 wrapHsArgs f (HsArgPar sp : args) = wrapHsArgs (L sp $ HsPar noExt f) args
 
-instance (Outputable tm, Outputable ty) => Outputable (HsArg tm ty) where
-  ppr (HsValArg tm)  = text "HsValArg"  <+> ppr tm
-  ppr (HsTypeArg ty) = text "HsTypeArg" <+> ppr ty
-  ppr (HsArgPar sp)  = text "HsArgPar"  <+> ppr sp
-
 isHsValArg :: HsArg tm ty -> Bool
 isHsValArg (HsValArg {})  = True
 isHsValArg (HsTypeArg {}) = False
@@ -1340,8 +1318,8 @@ tcArgs fun orig_fun_ty fun_orig orig_args herald
 
                     ; inner_ty <- zonkTcType inner_ty
                           -- See Note [Visible type application zonk]
-
                     ; let in_scope  = mkInScopeSet (tyCoVarsOfTypes [upsilon_ty, ty_arg])
+
                           insted_ty = substTyWithInScope in_scope [tv] [ty_arg] inner_ty
                                       -- NB: tv and ty_arg have the same kind, so this
                                       --     substitution is kind-respecting
index 56a0ea0..7f4e379 100644 (file)
@@ -46,7 +46,7 @@ module TcHsType (
 
         typeLevelMode, kindLevelMode,
 
-        kindGeneralize, checkExpectedKindX,
+        kindGeneralize, checkExpectedKind, RequireSaturation(..),
         reportFloatingKvs,
 
         -- Sort-checking kinds
@@ -79,8 +79,9 @@ import TcHsSyn
 import TcErrors ( reportAllUnsolved )
 import TcType
 import Inst   ( tcInstTyBinders, tcInstTyBinder )
-import TyCoRep( TyCoBinder(..), TyBinder )  -- Used in etaExpandAlgTyCon
+import TyCoRep( TyCoBinder(..), TyBinder, tyCoBinderArgFlag )  -- Used in etaExpandAlgTyCon
 import Type
+import TysPrim
 import Coercion
 import RdrName( lookupLocalRdrOcc )
 import Var
@@ -104,6 +105,7 @@ import UniqSupply
 import Outputable
 import FastString
 import PrelNames hiding ( wildCardName )
+import DynFlags ( WarningFlag (Opt_WarnPartialTypeSignatures) )
 import qualified GHC.LanguageExtensions as LangExt
 
 import Maybes
@@ -362,6 +364,9 @@ tcHsTypeApp wc_ty kind
   = do { ty <- solveLocalEqualities "tcHsTypeApp" $
                -- We are looking at a user-written type, very like a
                -- signature so we want to solve its equalities right now
+               unsetWOptM Opt_WarnPartialTypeSignatures $
+               setXOptM LangExt.PartialTypeSignatures $
+               -- See Note [Wildcards in visible type application]
                tcWildCardBinders sig_wcs $ \ _ ->
                tcCheckLHsType hs_ty kind
        -- We must promote here. Ex:
@@ -373,11 +378,24 @@ tcHsTypeApp wc_ty kind
        ; ty <- zonkPromoteType ty
        ; checkValidType TypeAppCtxt ty
        ; return ty }
-        -- NB: we don't call emitWildcardHoleConstraints here, because
-        -- we want any holes in visible type applications to be used
-        -- without fuss. No errors, warnings, extensions, etc.
 tcHsTypeApp (XHsWildCardBndrs _) _ = panic "tcHsTypeApp"
 
+{- Note [Wildcards in visible type application]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+A HsWildCardBndrs's hswc_ext now only includes named wildcards, so any unnamed
+wildcards stay unchanged in hswc_body and when called in tcHsTypeApp, tcCheckLHsType
+will call emitWildCardHoleConstraints on them. However, this would trigger
+error/warning when an unnamed wildcard is passed in as a visible type argument,
+which we do not want because users should be able to write @_ to skip a instantiating
+a type variable variable without fuss. The solution is to switch the
+PartialTypeSignatures flags here to let the typechecker know that it's checking
+a '@_' and do not emit hole constraints on it.
+See related Note [Wildcards in visible kind application]
+and Note [The wildcard story for types] in HsTypes.hs
+
+-}
+
 {-
 ************************************************************************
 *                                                                      *
@@ -432,30 +450,39 @@ concern things that the renamer can't handle.
 
 -}
 
+-- | Do we require type families to be saturated?
+data RequireSaturation
+  = YesSaturation
+  | NoSaturation   -- e.g. during a call to GHCi's :kind
+
 -- | Info about the context in which we're checking a type. Currently,
 -- differentiates only between types and kinds, but this will likely
 -- grow, at least to include the distinction between patterns and
 -- not-patterns.
 data TcTyMode
   = TcTyMode { mode_level :: TypeOrKind
-             , mode_unsat :: Bool        -- True <=> allow unsaturated type families
+             , mode_sat   :: RequireSaturation
              }
  -- The mode_unsat field is solely so that type families/synonyms can be unsaturated
  -- in GHCi :kind calls
 
 typeLevelMode :: TcTyMode
-typeLevelMode = TcTyMode { mode_level = TypeLevel, mode_unsat = False }
+typeLevelMode = TcTyMode { mode_level = TypeLevel, mode_sat = YesSaturation }
 
 kindLevelMode :: TcTyMode
-kindLevelMode = TcTyMode { mode_level = KindLevel, mode_unsat = False }
+kindLevelMode = TcTyMode { mode_level = KindLevel, mode_sat = YesSaturation }
 
 allowUnsaturated :: TcTyMode -> TcTyMode
-allowUnsaturated mode = mode { mode_unsat = True }
+allowUnsaturated mode = mode { mode_sat = NoSaturation }
 
 -- switch to kind level
 kindLevel :: TcTyMode -> TcTyMode
 kindLevel mode = mode { mode_level = KindLevel }
 
+instance Outputable RequireSaturation where
+  ppr YesSaturation = text "YesSaturation"
+  ppr NoSaturation  = text "NoSaturation"
+
 instance Outputable TcTyMode where
   ppr = ppr . mode_level
 
@@ -553,17 +580,14 @@ tc_infer_hs_type :: TcTyMode -> HsType GhcRn -> TcM (TcType, TcKind)
 tc_infer_hs_type mode (HsParTy _ t)          = tc_infer_lhs_type mode t
 tc_infer_hs_type mode (HsTyVar _ _ (L _ tv)) = tcTyVar mode tv
 
-tc_infer_hs_type mode (HsAppTy _ ty1 ty2)
-  = do { let (hs_fun_ty, hs_arg_tys) = splitHsAppTys ty1 [ty2]
-       ; (fun_ty, fun_kind) <- tc_infer_lhs_type mode hs_fun_ty
-           -- NB: (IT4) of Note [The tcType invariant] ensures that fun_kind is zonked
-       ; tcTyApps mode hs_fun_ty fun_ty fun_kind hs_arg_tys }
+tc_infer_hs_type mode e@(HsAppTy {}) = tcTyApp mode e
+tc_infer_hs_type mode e@(HsAppKindTy {}) = tcTyApp mode e
 
 tc_infer_hs_type mode (HsOpTy _ lhs lhs_op@(L _ hs_op) rhs)
   | not (hs_op `hasKey` funTyConKey)
   = do { (op, op_kind) <- tcTyVar mode hs_op
        ; tcTyApps mode (noLoc $ HsTyVar noExt NotPromoted lhs_op) op op_kind
-                       [lhs, rhs] }
+                       [HsValArg lhs, HsValArg rhs] }
 
 tc_infer_hs_type mode (HsKindSig _ ty sig)
   = do { sig' <- tcLHsKindSig KindSigCtxt sig
@@ -588,6 +612,13 @@ tc_infer_hs_type mode (HsDocTy _ ty _) = tc_infer_lhs_type mode ty
 tc_infer_hs_type _    (XHsType (NHsCoreTy ty))
   = do { ty <- zonkTcType ty  -- (IT3) and (IT4) of Note [The tcType invariant]
        ; return (ty, tcTypeKind ty) }
+
+tc_infer_hs_type _ (HsExplicitListTy _ _ tys)
+  | null tys  -- this is so that we can use visible kind application with '[]
+              -- e.g ... '[] @Bool
+  = return (mkTyConTy promotedNilDataCon,
+            mkSpecForAllTys [alphaTyVar] $ mkListTy alphaTy)
+
 tc_infer_hs_type mode other_ty
   = do { kv <- newMetaKindVar
        ; ty' <- tc_hs_type mode other_ty kv
@@ -608,12 +639,12 @@ tc_fun_type mode ty1 ty2 exp_kind = case mode_level mode of
        ; res_k <- newOpenTypeKind
        ; ty1' <- tc_lhs_type mode ty1 arg_k
        ; ty2' <- tc_lhs_type mode ty2 res_k
-       ; checkExpectedKind (HsFunTy noExt ty1 ty2) (mkFunTy ty1' ty2')
+       ; checkExpectedKindMode mode (ppr $ HsFunTy noExt ty1 ty2) (mkFunTy ty1' ty2')
                            liftedTypeKind exp_kind }
   KindLevel ->  -- no representation polymorphism in kinds. yet.
     do { ty1' <- tc_lhs_type mode ty1 liftedTypeKind
        ; ty2' <- tc_lhs_type mode ty2 liftedTypeKind
-       ; checkExpectedKind (HsFunTy noExt ty1 ty2) (mkFunTy ty1' ty2')
+       ; checkExpectedKindMode mode (ppr $ HsFunTy noExt ty1 ty2) (mkFunTy ty1' ty2')
                            liftedTypeKind exp_kind }
 
 ------------------------------------------
@@ -692,7 +723,7 @@ tc_hs_type mode (HsQualTy { hst_ctxt = ctxt, hst_body = ty }) exp_kind
                                 -- The body kind (result of the function)
                                 -- can be TYPE r, for any r, hence newOpenTypeKind
                         ; ty' <- tc_lhs_type mode ty ek
-                        ; checkExpectedKind (unLoc ty) ty' liftedTypeKind exp_kind }
+                        ; checkExpectedKindMode mode (ppr ty) ty' liftedTypeKind exp_kind }
 
        ; return (mkPhiTy ctxt' ty') }
 
@@ -700,7 +731,7 @@ tc_hs_type mode (HsQualTy { hst_ctxt = ctxt, hst_body = ty }) exp_kind
 tc_hs_type mode rn_ty@(HsListTy _ elt_ty) exp_kind
   = do { tau_ty <- tc_lhs_type mode elt_ty liftedTypeKind
        ; checkWiredInTyCon listTyCon
-       ; checkExpectedKind rn_ty (mkListTy tau_ty) liftedTypeKind exp_kind }
+       ; checkExpectedKindMode mode (ppr rn_ty) (mkListTy tau_ty) liftedTypeKind exp_kind }
 
 -- See Note [Distinguishing tuple kinds] in HsTypes
 -- See Note [Inferring tuple kinds]
@@ -726,10 +757,10 @@ tc_hs_type mode rn_ty@(HsTupleTy _ HsBoxedOrConstraintTuple hs_tys) exp_kind
          -- In the [] case, it's not clear what the kind is, so guess *
 
        ; tys' <- sequence [ setSrcSpan loc $
-                            checkExpectedKind hs_ty ty kind arg_kind
+                            checkExpectedKindMode mode (ppr hs_ty) ty kind arg_kind
                           | ((L loc hs_ty),ty,kind) <- zip3 hs_tys tys kinds ]
 
-       ; finish_tuple rn_ty tup_sort tys' (map (const arg_kind) tys') exp_kind }
+       ; finish_tuple rn_ty mode tup_sort tys' (map (const arg_kind) tys') exp_kind }
 
 
 tc_hs_type mode rn_ty@(HsTupleTy _ hs_tup_sort tys) exp_kind
@@ -747,7 +778,7 @@ tc_hs_type mode rn_ty@(HsSumTy _ hs_tys) exp_kind
        ; tau_tys   <- zipWithM (tc_lhs_type mode) hs_tys arg_kinds
        ; let arg_reps = map kindRep arg_kinds
              arg_tys  = arg_reps ++ tau_tys
-       ; checkExpectedKind rn_ty
+       ; checkExpectedKindMode mode (ppr rn_ty)
                            (mkTyConApp (sumTyCon arity) arg_tys)
                            (unboxedSumKind arg_reps)
                            exp_kind
@@ -758,7 +789,7 @@ tc_hs_type mode rn_ty@(HsExplicitListTy _ _ tys) exp_kind
   = do { tks <- mapM (tc_infer_lhs_type mode) tys
        ; (taus', kind) <- unifyKinds tys tks
        ; let ty = (foldr (mk_cons kind) (mk_nil kind) taus')
-       ; checkExpectedKind rn_ty ty (mkListTy kind) exp_kind }
+       ; checkExpectedKindMode mode (ppr rn_ty) ty (mkListTy kind) exp_kind }
   where
     mk_cons k a b = mkTyConApp (promoteDataCon consDataCon) [k, a, b]
     mk_nil  k     = mkTyConApp (promoteDataCon nilDataCon) [k]
@@ -771,7 +802,7 @@ tc_hs_type mode rn_ty@(HsExplicitTupleTy _ tys) exp_kind
        ; let kind_con   = tupleTyCon           Boxed arity
              ty_con     = promotedTupleDataCon Boxed arity
              tup_k      = mkTyConApp kind_con ks
-       ; checkExpectedKind rn_ty (mkTyConApp ty_con (ks ++ taus)) tup_k exp_kind }
+       ; checkExpectedKindMode mode (ppr rn_ty) (mkTyConApp ty_con (ks ++ taus)) tup_k exp_kind }
   where
     arity = length tys
 
@@ -781,51 +812,83 @@ tc_hs_type mode rn_ty@(HsIParamTy _ (L _ n) ty) exp_kind
        ; ty' <- tc_lhs_type mode ty liftedTypeKind
        ; let n' = mkStrLitTy $ hsIPNameFS n
        ; ipClass <- tcLookupClass ipClassName
-       ; checkExpectedKind rn_ty (mkClassPred ipClass [n',ty'])
+       ; checkExpectedKindMode mode (ppr rn_ty) (mkClassPred ipClass [n',ty'])
            constraintKind exp_kind }
 
-tc_hs_type _ rn_ty@(HsStarTy _ _) exp_kind
+tc_hs_type mode rn_ty@(HsStarTy _ _) exp_kind
   -- Desugaring 'HsStarTy' to 'Data.Kind.Type' here means that we don't have to
   -- handle it in 'coreView' and 'tcView'.
-  = checkExpectedKind rn_ty liftedTypeKind liftedTypeKind exp_kind
+  = checkExpectedKindMode mode (ppr rn_ty) liftedTypeKind liftedTypeKind exp_kind
 
 --------- Literals
-tc_hs_type _ rn_ty@(HsTyLit _ (HsNumTy _ n)) exp_kind
+tc_hs_type mode rn_ty@(HsTyLit _ (HsNumTy _ n)) exp_kind
   = do { checkWiredInTyCon typeNatKindCon
-       ; checkExpectedKind rn_ty (mkNumLitTy n) typeNatKind exp_kind }
+       ; checkExpectedKindMode mode (ppr rn_ty) (mkNumLitTy n) typeNatKind exp_kind }
 
-tc_hs_type _ rn_ty@(HsTyLit _ (HsStrTy _ s)) exp_kind
+tc_hs_type mode rn_ty@(HsTyLit _ (HsStrTy _ s)) exp_kind
   = do { checkWiredInTyCon typeSymbolKindCon
-       ; checkExpectedKind rn_ty (mkStrLitTy s) typeSymbolKind exp_kind }
+       ; checkExpectedKindMode mode (ppr rn_ty) (mkStrLitTy s) typeSymbolKind exp_kind }
 
 --------- Potentially kind-polymorphic types: call the "up" checker
 -- See Note [Future-proofing the type checker]
 tc_hs_type mode ty@(HsTyVar {})   ek = tc_infer_hs_type_ek mode ty ek
 tc_hs_type mode ty@(HsAppTy {})   ek = tc_infer_hs_type_ek mode ty ek
+tc_hs_type mode ty@(HsAppKindTy{}) ek = tc_infer_hs_type_ek mode ty ek
 tc_hs_type mode ty@(HsOpTy {})    ek = tc_infer_hs_type_ek mode ty ek
 tc_hs_type mode ty@(HsKindSig {}) ek = tc_infer_hs_type_ek mode ty ek
 tc_hs_type mode ty@(XHsType (NHsCoreTy{})) ek = tc_infer_hs_type_ek mode ty ek
 
-tc_hs_type _ (HsWildCardTy wc) exp_kind
-  = do { wc_ty <- tcWildCardOcc wc exp_kind
+tc_hs_type mode wc@(HsWildCardTy _) exp_kind
+  = do { wc_ty <- tcWildCardOcc mode wc exp_kind
        ; return (mkNakedCastTy wc_ty (mkTcNomReflCo exp_kind))
          -- Take care here! Even though the coercion is Refl,
          -- we still need it to establish Note [The tcType invariant]
        }
 
-tcWildCardOcc :: HsWildCardInfo -> Kind -> TcM TcType
-tcWildCardOcc wc_info exp_kind
-  = do { wc_tv <- tcLookupTyVar (wildCardName wc_info)
+tcWildCardOcc :: TcTyMode -> HsType GhcRn -> Kind -> TcM TcType
+tcWildCardOcc mode wc exp_kind
+  = do { wc_tv <- newWildTyVar
           -- The wildcard's kind should be an un-filled-in meta tyvar
-       ; checkExpectedKind (HsWildCardTy wc_info) (mkTyVarTy wc_tv)
+       ; loc <- getSrcSpanM
+       ; uniq <- newUnique
+       ; let name = mkInternalName uniq (mkTyVarOcc "_") loc
+       ; part_tysig <- xoptM LangExt.PartialTypeSignatures
+       ; warning <- woptM Opt_WarnPartialTypeSignatures
+       -- See Note [Wildcards in visible kind application]
+       ; unless (part_tysig && not warning)
+             (emitWildCardHoleConstraints [(name,wc_tv)])
+       ; checkExpectedKindMode mode (ppr wc) (mkTyVarTy wc_tv)
                            (tyVarKind wc_tv) exp_kind }
 
+{- Note [Wildcards in visible kind application]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+There are cases where users might want to pass in a wildcard as a visible kind
+argument, for instance:
+
+data T :: forall k1 k2. k1 → k2 → Type where
+  MkT :: T a b
+x :: T @_ @Nat False n
+x = MkT
+
+So we should allow '@_' without emitting any hole constraints, and
+regardless of whether PartialTypeSignatures is enabled or not. But how would
+the typechecker know which '_' is being used in VKA and which is not when it
+calls emitWildCardHoleConstraints in tcHsPartialSigType on all HsWildCardBndrs?
+The solution then is to neither rename nor include unnamed wildcards in HsWildCardBndrs,
+but instead give every unnamed wildcard a fresh wild tyvar in tcWildCardOcc.
+And whenever we see a '@', we automatically turn on PartialTypeSignatures and
+turn off hole constraint warnings, and never call emitWildCardHoleConstraints
+under these conditions.
+See related Note [Wildcards in visible type application] here and
+Note [The wildcard story for types] in HsTypes.hs
+
+-}
 ---------------------------
 -- | Call 'tc_infer_hs_type' and check its result against an expected kind.
 tc_infer_hs_type_ek :: HasDebugCallStack => TcTyMode -> HsType GhcRn -> TcKind -> TcM TcType
 tc_infer_hs_type_ek mode hs_ty ek
   = do { (ty, k) <- tc_infer_hs_type mode hs_ty
-       ; checkExpectedKind hs_ty ty k ek }
+       ; checkExpectedKindMode mode (ppr hs_ty) ty k ek }
 
 ---------------------------
 tupKindSort_maybe :: TcKind -> Maybe TupleSort
@@ -843,17 +906,18 @@ tc_tuple rn_ty mode tup_sort tys exp_kind
            UnboxedTuple    -> mapM (\_ -> newOpenTypeKind) tys
            ConstraintTuple -> return (nOfThem arity constraintKind)
        ; tau_tys <- zipWithM (tc_lhs_type mode) tys arg_kinds
-       ; finish_tuple rn_ty tup_sort tau_tys arg_kinds exp_kind }
+       ; finish_tuple rn_ty mode tup_sort tau_tys arg_kinds exp_kind }
   where
     arity   = length tys
 
 finish_tuple :: HsType GhcRn
+             -> TcTyMode
              -> TupleSort
              -> [TcType]    -- ^ argument types
              -> [TcKind]    -- ^ of these kinds
              -> TcKind      -- ^ expected kind of the whole tuple
              -> TcM TcType
-finish_tuple rn_ty tup_sort tau_tys tau_kinds exp_kind
+finish_tuple rn_ty mode tup_sort tau_tys tau_kinds exp_kind
   = do { traceTc "finish_tuple" (ppr res_kind $$ ppr tau_kinds $$ ppr exp_kind)
        ; let arg_tys  = case tup_sort of
                    -- See also Note [Unboxed tuple RuntimeRep vars] in TyCon
@@ -869,7 +933,7 @@ finish_tuple rn_ty tup_sort tau_tys tau_kinds exp_kind
                                ; checkWiredInTyCon tc
                                ; return tc }
            UnboxedTuple  -> return (tupleTyCon Unboxed arity)
-       ; checkExpectedKind rn_ty (mkTyConApp tycon arg_tys) res_kind exp_kind }
+       ; checkExpectedKindMode mode (ppr rn_ty) (mkTyConApp tycon arg_tys) res_kind exp_kind }
   where
     arity = length tau_tys
     tau_reps = map kindRep tau_kinds
@@ -895,7 +959,7 @@ tcInferApps :: TcTyMode
             -> LHsType GhcRn        -- ^ Function (for printing only)
             -> TcType               -- ^ Function
             -> TcKind               -- ^ Function kind (zonked)
-            -> [LHsType GhcRn]      -- ^ Args
+            -> [LHsTypeArg GhcRn]   -- ^ Args
             -> TcM (TcType, TcKind) -- ^ (f args, args, result kind)
 -- Precondition: tcTypeKind fun_ty = fun_ki
 --    Reason: we will return a type application like (fun_ty arg1 ... argn),
@@ -918,7 +982,7 @@ tcInferApps mode orig_hs_ty fun_ty fun_ki orig_hs_args
        -> TcType          -- function applied to some args
        -> [TyBinder]      -- binders in function kind (both vis. and invis.)
        -> TcKind          -- function kind body (not a Pi-type)
-       -> [LHsType GhcRn] -- un-type-checked args
+       -> [LHsTypeArg GhcRn] -- un-type-checked args
        -> TcM (TcType, TcKind)  -- same as overall return type
 
       -- no user-written args left. We're done!
@@ -926,53 +990,100 @@ tcInferApps mode orig_hs_ty fun_ty fun_ki orig_hs_args
       = return ( fun
                , nakedSubstTy subst $ mkPiTys ki_binders inner_ki)
                  -- nakedSubstTy: see Note [The well-kinded type invariant]
-
+    go n subst fun all_kindbinder inner_ki (HsArgPar _:args)
+      = go n subst fun all_kindbinder inner_ki args
       -- The function's kind has a binder. Is it visible or invisible?
-    go n subst fun (ki_binder:ki_binders) inner_ki
+    go n subst fun all_kindbinder@(ki_binder:ki_binders) inner_ki
        all_args@(arg:args)
+      | Specified <- tyCoBinderArgFlag ki_binder
+      , HsTypeArg ki <- arg
+         -- Invisible and specified binder with visible kind argument
+         = do { traceTc "tcInferApps (vis kind app)" (vcat [ ppr ki_binder, ppr ki
+                                                     , ppr (tyBinderType ki_binder)
+                                                     , ppr subst, ppr (tyCoBinderArgFlag ki_binder) ])
+                  ; let exp_kind = nakedSubstTy subst $ tyBinderType ki_binder
+                    -- nakedSubstTy: see Note [The well-kinded type invariant]
+                  ; arg' <- addErrCtxt (funAppCtxt orig_hs_ty ki n) $
+                            unsetWOptM Opt_WarnPartialTypeSignatures $
+                            setXOptM LangExt.PartialTypeSignatures $
+                            -- see Note [Wildcards in visible kind application]
+                            tc_lhs_type (kindLevel mode) ki exp_kind
+                  ; traceTc "tcInferApps (vis kind app)" (ppr exp_kind)
+                  ; let subst' = extendTvSubstBinderAndInScope subst ki_binder arg'
+                  ; go (n+1) subst'
+                       (mkNakedAppTy fun arg')
+                       ki_binders inner_ki args }
+
       | isInvisibleBinder ki_binder
-        -- It's invisible. Instantiate.
-      = do { traceTc "tcInferApps (invis)" (ppr ki_binder $$ ppr subst)
+          -- Instantiate if not specified or if there is no kind application
+      = do { traceTc "tcInferApps (invis normal app)" (ppr ki_binder $$ ppr subst $$ ppr (tyCoBinderArgFlag ki_binder))
            ; (subst', arg') <- tcInstTyBinder Nothing subst ki_binder
            ; go n subst' (mkNakedAppTy fun arg')
-                ki_binders inner_ki all_args }
-
-      | otherwise
-        -- It's visible. Check the next user-written argument
-      = do { traceTc "tcInferApps (vis)" (vcat [ ppr ki_binder, ppr arg
-                                               , ppr (tyBinderType ki_binder)
-                                               , ppr subst ])
-           ; let exp_kind = nakedSubstTy subst $ tyBinderType ki_binder
-                            -- nakedSubstTy: see Note [The well-kinded type invariant]
-           ; arg' <- addErrCtxt (funAppCtxt orig_hs_ty arg n) $
-                     tc_lhs_type mode arg exp_kind
-           ; traceTc "tcInferApps (vis 1)" (ppr exp_kind)
-           ; let subst' = extendTvSubstBinderAndInScope subst ki_binder arg'
-           ; go (n+1) subst'
-                (mkNakedAppTy fun arg') -- See Note [The well-kinded type invariant]
-                ki_binders inner_ki args }
+                        ki_binders inner_ki all_args }
+
+      | otherwise -- if binder is visible
+         = case arg of
+             HsValArg ty -- check the next argument
+               -> do { traceTc "tcInferApps (vis normal app)"
+                         (vcat [ ppr ki_binder
+                               , ppr ty
+                               , ppr (tyBinderType ki_binder)
+                               , ppr subst ])
+                     ; let exp_kind = nakedSubstTy subst $ tyBinderType ki_binder
+                     -- nakedSubstTy: see Note [The well-kinded type invariant]
+                     ; arg' <- addErrCtxt (funAppCtxt orig_hs_ty ty n) $
+                               tc_lhs_type mode ty exp_kind
+                     ; traceTc "tcInferApps (vis normal app)" (ppr exp_kind)
+                     ; let subst' = extendTvSubstBinderAndInScope subst ki_binder arg'
+                     ; go (n+1) subst'
+                          (mkNakedAppTy fun arg')
+                          ki_binders inner_ki args }
+            -- error if the argument is a kind application
+             HsTypeArg ki -> do { traceTc "tcInferApps (error)"
+                                    (vcat [ ppr ki_binder
+                                          , ppr ki
+                                          , ppr (tyBinderType ki_binder)
+                                          , ppr subst
+                                          , ppr (isInvisibleBinder ki_binder) ])
+                                ; ty_app_err ki $ nakedSubstTy subst $
+                                                  mkPiTys all_kindbinder inner_ki }
+
+             HsArgPar _ -> panic "tcInferApps"  -- handled in separate clause of "go"
 
        -- We've run out of known binders in the functions's kind.
-    go n subst fun [] inner_ki all_args
+    go n subst fun [] inner_ki all_args@(arg:args)
       | not (null new_ki_binders)
          -- But, after substituting, we have more binders.
       = go n zapped_subst fun new_ki_binders new_inner_ki all_args
 
       | otherwise
+      = case arg of
+        (HsValArg _)
          -- Even after substituting, still no binders. Use matchExpectedFunKind
-      = do { traceTc "tcInferApps (no binder)" (ppr new_inner_ki $$ ppr zapped_subst)
-           ; (co, arg_k, res_k) <- matchExpectedFunKind hs_ty substed_inner_ki
-           ; let new_in_scope = tyCoVarsOfTypes [arg_k, res_k]
-                 subst'       = zapped_subst `extendTCvInScopeSet` new_in_scope
-           ; go n subst'
-                (fun `mkNakedCastTy` co)  -- See Note [The well-kinded type invariant]
-                [mkAnonBinder arg_k]
-                res_k all_args }
+         -> do { traceTc "tcInferApps (no binder)" (ppr new_inner_ki $$ ppr zapped_subst)
+               ; (co, arg_k, res_k) <- matchExpectedFunKind hs_ty substed_inner_ki
+               ; let new_in_scope = tyCoVarsOfTypes [arg_k, res_k]
+                     subst'       = zapped_subst `extendTCvInScopeSet` new_in_scope
+               ; go n subst'
+                    (fun `mkNakedCastTy` co)  -- See Note [The well-kinded type invariant]
+                    [mkAnonBinder arg_k]
+                    res_k all_args }
+        (HsTypeArg ki) -> ty_app_err ki substed_inner_ki
+        (HsArgPar _) -> go n subst fun [] inner_ki args
       where
         substed_inner_ki               = substTy subst inner_ki
         (new_ki_binders, new_inner_ki) = tcSplitPiTys substed_inner_ki
         zapped_subst                   = zapTCvSubst subst
-        hs_ty = mkHsAppTys orig_hs_ty (take (n-1) orig_hs_args)
+        hs_ty = appTypeToArg orig_hs_ty (take (n-1) orig_hs_args)
+
+    ty_app_err arg ty = failWith $ text "Cannot apply function of kind" <+> quotes (ppr ty)
+                           $$ text "to visible kind argument" <+> quotes (ppr arg)
+
+appTypeToArg :: LHsType GhcRn -> [LHsTypeArg GhcRn] -> LHsType GhcRn
+appTypeToArg f [] = f
+appTypeToArg f (HsValArg arg : args) = appTypeToArg (mkHsAppTy f arg) args
+appTypeToArg f (HsTypeArg arg : args) = appTypeToArg (mkHsAppKindTy f arg) args
+appTypeToArg f (HsArgPar _ : arg) = appTypeToArg f arg
 
 -- | Applies a type to a list of arguments.
 -- Always consumes all the arguments, using 'matchExpectedFunKind' as
@@ -983,7 +1094,7 @@ tcTyApps :: TcTyMode
          -> LHsType GhcRn        -- ^ Function (for printing only)
          -> TcType               -- ^ Function
          -> TcKind               -- ^ Function kind (zonked)
-         -> [LHsType GhcRn]      -- ^ Args
+         -> [LHsTypeArg GhcRn]   -- ^ Args
          -> TcM (TcType, TcKind) -- ^ (f args, result kind)   result kind is zonked
 -- Precondition: see precondition for tcInferApps
 tcTyApps mode orig_hs_ty fun_ty fun_ki args
@@ -991,59 +1102,93 @@ tcTyApps mode orig_hs_ty fun_ty fun_ki args
        ; return (ty' `mkNakedCastTy` mkNomReflCo ki', ki') }
           -- The mkNakedCastTy is for (IT3) of Note [The tcType invariant]
 
+tcTyApp :: TcTyMode -> HsType GhcRn -> TcM (TcType, TcKind) -- only HsAppTy or HsAppKindTy
+tcTyApp mode e
+  = do { let (hs_fun_ty, hs_args) = splitHsAppTys e
+       ; (fun_ty, fun_kind) <- tc_infer_lhs_type mode hs_fun_ty
+          -- NB: (IT4) of Note [The tcType invariant] ensures that fun_kind is zonked
+       ; tcTyApps mode hs_fun_ty fun_ty fun_kind hs_args }
 --------------------------
--- Like checkExpectedKindX, but returns only the final type; convenient wrapper
+-- Internally-callable version of checkExpectedKind
+checkExpectedKindMode :: HasDebugCallStack
+                      => TcTyMode
+                      -> SDoc        -- type we're checking
+                      -> TcType      -- type we're checking
+                      -> TcKind      -- kind of that type
+                      -> TcKind      -- expected kind
+                      -> TcM TcType
+checkExpectedKindMode mode = checkExpectedKind (mode_sat mode)
+
+-- | This instantiates invisible arguments for the type being checked if it must
+-- be saturated and is not yet saturated. It then calls and uses the result
+-- from checkExpectedKindX to build the final type
 -- Obeys Note [The tcType invariant]
 checkExpectedKind :: HasDebugCallStack
-                  => HsType GhcRn   -- type we're checking (for printing)
-                  -> TcType         -- type we're checking
-                  -> TcKind         -- the known kind of that type
-                  -> TcKind         -- the expected kind
+                  => RequireSaturation  -- ^ Do we require all type families to be saturated?
+                  -> SDoc           -- ^ type we're checking (for printing)
+                  -> TcType         -- ^ type we're checking
+                  -> TcKind         -- ^ the known kind of that type
+                  -> TcKind         -- ^ the expected kind
                   -> TcM TcType
-checkExpectedKind hs_ty ty act exp = checkExpectedKindX (ppr hs_ty) ty act exp
+checkExpectedKind sat hs_ty ty act exp
+  = do { (new_ty, new_act) <- case splitTyConApp_maybe ty of
+           Just (tc, args)
+             -- if the family tycon must be saturated and is not yet satured
+             -- If we don't do this, we get #11246
+             | YesSaturation <- sat
+             , not (mightBeUnsaturatedTyCon tc) && length args < tyConArity tc
+             -> do {
+                   -- we need to instantiate all invisible arguments up until saturation
+                   (tc_args, kind) <- tcInstTyBinders (splitPiTysInvisibleN
+                                                        (tyConArity tc - length args)
+                                                        act)
+                   ; let tc_ty = mkTyConApp tc $ args ++ tc_args
+                   ; traceTc "checkExpectedKind:satTyFam" (vcat [ ppr tc <+> dcolon <+> ppr act
+                                                   , ppr kind ])
+                   ; return (tc_ty, kind) }
+           _ -> return (ty, act)
+       ; (new_args, co_k) <- checkExpectedKindX hs_ty new_act exp
+       ; return (new_ty `mkNakedAppTys` new_args `mkNakedCastTy` co_k) }
 
 checkExpectedKindX :: HasDebugCallStack
                    => SDoc                 -- HsType whose kind we're checking
-                   -> TcType               -- the type whose kind we're checking
                    -> TcKind               -- the known kind of that type, k
                    -> TcKind               -- the expected kind, exp_kind
-                   -> TcM TcType
+                   -> TcM ([TcType], TcCoercionN)
     -- (the new args, the coercion)
 -- Instantiate a kind (if necessary) and then call unifyType
 --      (checkExpectedKind ty act_kind exp_kind)
 -- checks that the actual kind act_kind is compatible
 --      with the expected kind exp_kind
-checkExpectedKindX pp_hs_ty ty act_kind exp_kind
- = do { -- We need to make sure that both kinds have the same number of implicit
-        -- foralls out front. If the actual kind has more, instantiate accordingly.
-        -- Otherwise, just pass the type & kind through: the errors are caught
-        -- in unifyType.
-        let n_exp_invis_bndrs = invisibleTyBndrCount exp_kind
-            n_act_invis_bndrs = invisibleTyBndrCount act_kind
-            n_to_inst         = n_act_invis_bndrs - n_exp_invis_bndrs
-      ; (new_args, act_kind') <- tcInstTyBinders (splitPiTysInvisibleN n_to_inst act_kind)
-
-      ; let origin = TypeEqOrigin { uo_actual   = act_kind'
-                                  , uo_expected = exp_kind
-                                  , uo_thing    = Just pp_hs_ty
-                                  , uo_visible  = True } -- the hs_ty is visible
-            ty' = mkNakedAppTys ty new_args
-
-      ; traceTc "checkExpectedKind" $
-        vcat [ pp_hs_ty
-             , text "act_kind:" <+> ppr act_kind
-             , text "act_kind':" <+> ppr act_kind'
-             , text "exp_kind:" <+> ppr exp_kind ]
-
-      ; if act_kind' `tcEqType` exp_kind
-        then return ty'   -- This is very common
-        else do { co_k <- uType KindLevel origin act_kind' exp_kind
-                ; traceTc "checkExpectedKind" (vcat [ ppr act_kind
-                                                    , ppr exp_kind
-                                                    , ppr co_k ])
-                ; let result_ty = ty' `mkNakedCastTy` co_k
+checkExpectedKindX pp_hs_ty act_kind exp_kind
+  = do { -- We need to make sure that both kinds have the same number of implicit
+         -- foralls out front. If the actual kind has more, instantiate accordingly.
+         -- Otherwise, just pass the type & kind through: the errors are caught
+         -- in unifyType.
+         let n_exp_invis_bndrs = invisibleTyBndrCount exp_kind
+             n_act_invis_bndrs = invisibleTyBndrCount act_kind
+             n_to_inst         = n_act_invis_bndrs - n_exp_invis_bndrs
+       ; (new_args, act_kind') <- tcInstTyBinders (splitPiTysInvisibleN n_to_inst act_kind)
+
+       ; let origin = TypeEqOrigin { uo_actual   = act_kind'
+                                   , uo_expected = exp_kind
+                                   , uo_thing    = Just pp_hs_ty
+                                   , uo_visible  = True } -- the hs_ty is visible
+
+       ; traceTc "checkExpectedKindX" $
+         vcat [ pp_hs_ty
+              , text "act_kind:" <+> ppr act_kind
+              , text "act_kind':" <+> ppr act_kind'
+              , text "exp_kind:" <+> ppr exp_kind ]
+
+       ; if act_kind' `tcEqType` exp_kind
+         then return (new_args, mkTcNomReflCo exp_kind)  -- This is very common
+         else do { co_k <- uType KindLevel origin act_kind' exp_kind
+                 ; traceTc "checkExpectedKind" (vcat [ ppr act_kind
+                                                     , ppr exp_kind
+                                                     , ppr co_k ])
                       -- See Note [The tcType invariant]
-                ; return result_ty } }
+                ; return (new_args, co_k) } }
 
 ---------------------------
 tcHsMbContext :: Maybe (LHsContext GhcRn) -> TcM [PredType]
@@ -1081,16 +1226,19 @@ tcTyVar mode name         -- Could be a tyvar, a tycon, or a datacon
                           do { ty <- zonkTcTyVar tv
                              ; return (ty, tcTypeKind ty) }
 
-           ATcTyCon tc_tc -> do { -- See Note [GADT kind self-reference]
-                                  unless
-                                    (isTypeLevel (mode_level mode))
-                                    (promotionErr name TyConPE)
-                                ; check_tc tc_tc
-                                ; handle_tyfams tc_tc }
+           ATcTyCon tc_tc
+             -> do { -- See Note [GADT kind self-reference]
+                     unless (isTypeLevel (mode_level mode))
+                            (promotionErr name TyConPE)
+                   ; check_tc tc_tc
+                   ; tc_kind <- zonkTcType (tyConKind tc_tc)
+                        -- (IT6) of Note [The tcType invariant]
+                   ; return (mkTyConTy tc_tc `mkNakedCastTy` mkNomReflCo tc_kind, tc_kind) }
+                        -- the mkNakedCastTy ensures (IT5) of Note [The tcType invariant]
 
            AGlobal (ATyCon tc)
              -> do { check_tc tc
-                   ; handle_tyfams tc }
+                   ; return (mkTyConTy tc, tyConKind tc) }
 
            AGlobal (AConLike (RealDataCon dc))
              -> do { data_kinds <- xoptM LangExt.DataKinds
@@ -1118,39 +1266,6 @@ tcTyVar mode name         -- Could be a tyvar, a tycon, or a datacon
                                isKindTyCon tc) $
                        promotionErr name NoDataKindsTC }
 
-    -- if we are type-checking a type family tycon, we must instantiate
-    -- any invisible arguments right away. Otherwise, we get #11246
-    handle_tyfams :: TyCon     -- the tycon to instantiate
-                  -> TcM (TcType, TcKind)
-    handle_tyfams tc
-      | mightBeUnsaturatedTyCon tc || mode_unsat mode
-                                         -- This is where mode_unsat is used
-      = do { tc_kind <- zonkTcType (tyConKind tc)   -- (IT6) of Note [The tcType invariant]
-           ; traceTc "tcTyVar2a" (ppr tc $$ ppr tc_kind)
-           ; return (mkTyConApp tc [] `mkNakedCastTy` mkNomReflCo tc_kind, tc_kind) }
-              -- the mkNakedCastTy ensures (IT5) of Note [The tcType invariant]
-
-      | otherwise
-      = do { let tc_arity = tyConArity tc
-           ; tc_kind <- zonkTcType (tyConKind tc)
-           ; (tc_args, kind) <- tcInstTyBinders (splitPiTysInvisibleN tc_arity tc_kind)
-                 -- Instantiate enough invisible arguments
-                 -- to saturate the family TyCon
-
-           ; let is_saturated = tc_args `lengthAtLeast` tc_arity
-                 tc_ty
-                   | is_saturated = mkTyConApp tc tc_args `mkNakedCastTy` mkNomReflCo kind
-                      -- mkNakedCastTy is for (IT5) of Note [The tcType invariant]
-                   | otherwise    = mkTyConApp tc tc_args
-                      -- if the tycon isn't yet saturated, then we don't want mkNakedCastTy,
-                      -- because that means we'll have an unsaturated type family
-                      -- We don't need it anyway, because we can be sure that the
-                      -- type family kind will accept further arguments (because it is
-                      -- not yet saturated)
-           ; traceTc "tcTyVar2b" (vcat [ ppr tc <+> dcolon <+> ppr tc_kind
-                                       , ppr kind ])
-           ; return (tc_ty, kind) }
-
     -- We cannot promote a data constructor with a context that contains
     -- constraints other than equalities, so error if we find one.
     -- See Note [Constraints handled in types] in Inst.
@@ -1306,6 +1421,7 @@ Help functions for type applications
 addTypeCtxt :: LHsType GhcRn -> TcM a -> TcM a
         -- Wrap a context around only if we want to show that contexts.
         -- Omit invisible ones and ones user's won't grok
+addTypeCtxt (L _ (HsWildCardTy _)) thing = thing   -- "In the type '_'" just isn't helpful.
 addTypeCtxt (L _ ty) thing
   = addErrCtxt doc thing
   where
@@ -1458,18 +1574,18 @@ tcWildCardBinders :: [Name]
                   -> ([(Name, TcTyVar)] -> TcM a)
                   -> TcM a
 tcWildCardBinders wc_names thing_inside
-  = do { wcs <- mapM newWildTyVar wc_names
+  = do { wcs <- mapM (const newWildTyVar) wc_names
        ; let wc_prs = wc_names `zip` wcs
        ; tcExtendNameTyVarEnv wc_prs $
          thing_inside wc_prs }
 
-newWildTyVar :: Name -> TcM TcTyVar
+newWildTyVar :: TcM TcTyVar
 -- ^ New unification variable for a wildcard
-newWildTyVar _name
+newWildTyVar
   = do { kind <- newMetaKindVar
        ; uniq <- newUnique
        ; details <- newMetaDetails TauTv
-       ; let name = mkSysTvName uniq (fsLit "w")
+       ; let name = mkSysTvName uniq (fsLit "_")
              tyvar = (mkTcTyVar name kind details)
        ; traceTc "newWildTyVar" (ppr tyvar)
        ; return tyvar }
@@ -2249,8 +2365,8 @@ tcHsPartialSigType _ (XHsWildCardBndrs _) = panic "tcHsPartialSigType"
 tcPartialContext :: HsContext GhcRn -> TcM (TcThetaType, Maybe TcType)
 tcPartialContext hs_theta
   | Just (hs_theta1, hs_ctxt_last) <- snocView hs_theta
-  , L _ (HsWildCardTy wc) <- ignoreParens hs_ctxt_last
-  = do { wc_tv_ty <- tcWildCardOcc wc constraintKind
+  , L _ wc@(HsWildCardTy _) <- ignoreParens hs_ctxt_last
+  = do { wc_tv_ty <- tcWildCardOcc typeLevelMode wc constraintKind
        ; theta <- mapM tcLHsPredType hs_theta1
        ; return (theta, Just wc_tv_ty) }
   | otherwise
@@ -2263,8 +2379,7 @@ Consider
   f :: (_) => a -> a
   f x = ...
 
-* The renamer makes a wildcard name for the "_", and puts it in
-  the hswc_wcs field.
+* The renamer leaves '_' untouched.
 
 * Then, in tcHsPartialSigType, we make a new hole TcTyVar, in
   tcWildCardBinders.
@@ -2480,7 +2595,7 @@ together.  Hence the new_tv function in tcHsPatSigType.
 unifyKinds :: [LHsType GhcRn] -> [(TcType, TcKind)] -> TcM ([TcType], TcKind)
 unifyKinds rn_tys act_kinds
   = do { kind <- newMetaKindVar
-       ; let check rn_ty (ty, act_kind) = checkExpectedKind (unLoc rn_ty) ty act_kind kind
+       ; let check rn_ty (ty, act_kind) = checkExpectedKind YesSaturation (ppr $ unLoc rn_ty) ty act_kind kind
        ; tys' <- zipWithM check rn_tys act_kinds
        ; return (tys', kind) }
 
index c6628a5..ba33fe2 100644 (file)
@@ -799,7 +799,7 @@ tcDataFamHeader mb_clsinfo fam_tc imp_vars mb_bndrs fixity hs_ctxt hs_pats m_ksi
                   ; addConsistencyConstraints mb_clsinfo lhs_ty
                   ; mapM_ (wrapLocM_ kcConDecl) hs_cons
                   ; res_kind <- tc_kind_sig m_ksig
-                  ; lhs_ty <- checkExpectedKindX pp_lhs lhs_ty lhs_kind res_kind
+                  ; lhs_ty <- checkExpectedKind YesSaturation pp_lhs lhs_ty lhs_kind res_kind
                   ; return (stupid_theta, lhs_ty, res_kind) }
 
        -- See TcTyClsDecls Note [Generalising in tcFamTyPatsGuts]
index 5925fc8..65c2c60 100644 (file)
@@ -249,9 +249,53 @@ completeSigFromId ctxt id
 
 isCompleteHsSig :: LHsSigWcType GhcRn -> Bool
 -- ^ If there are no wildcards, return a LHsSigType
-isCompleteHsSig (HsWC { hswc_ext = wcs }) = null wcs
+isCompleteHsSig (HsWC { hswc_ext  = wcs
+                      , hswc_body = HsIB { hsib_body = hs_ty } })
+   = null wcs && no_anon_wc hs_ty
+isCompleteHsSig (HsWC _ (XHsImplicitBndrs _)) = panic "isCompleteHsSig"
 isCompleteHsSig (XHsWildCardBndrs _) = panic "isCompleteHsSig"
 
+no_anon_wc :: LHsType GhcRn -> Bool
+no_anon_wc lty = go lty
+  where
+    go (L _ ty) = case ty of
+      HsWildCardTy _                 -> False
+      HsAppTy _ ty1 ty2              -> go ty1 && go ty2
+      HsAppKindTy _ ty ki            -> go ty && go ki
+      HsFunTy _ ty1 ty2              -> go ty1 && go ty2
+      HsListTy _ ty                  -> go ty
+      HsTupleTy _ _ tys              -> gos tys
+      HsSumTy _ tys                  -> gos tys
+      HsOpTy _ ty1 _ ty2             -> go ty1 && go ty2
+      HsParTy _ ty                   -> go ty
+      HsIParamTy _ _ ty              -> go ty
+      HsKindSig _ ty kind            -> go ty && go kind
+      HsDocTy _ ty _                 -> go ty
+      HsBangTy _ _ ty                -> go ty
+      HsRecTy _ flds                 -> gos $ map (cd_fld_type . unLoc) flds
+      HsExplicitListTy _ _ tys       -> gos tys
+      HsExplicitTupleTy _ tys        -> gos tys
+      HsForAllTy { hst_bndrs = bndrs
+                 , hst_body = ty } -> no_anon_wc_bndrs bndrs
+                                        && go ty
+      HsQualTy { hst_ctxt = L _ ctxt
+               , hst_body = ty }  -> gos ctxt && go ty
+      HsSpliceTy _ (HsSpliced _ _ (HsSplicedTy ty)) -> go $ L noSrcSpan ty
+      HsSpliceTy{} -> True
+      HsTyLit{} -> True
+      HsTyVar{} -> True
+      HsStarTy{} -> True
+      XHsType{} -> True      -- Core type, which does not have any wildcard
+
+    gos = all go
+
+no_anon_wc_bndrs :: [LHsTyVarBndr GhcRn] -> Bool
+no_anon_wc_bndrs ltvs = all (go . unLoc) ltvs
+  where
+    go (UserTyVar _ _)      = True
+    go (KindedTyVar _ _ ki) = no_anon_wc ki
+    go (XTyVarBndr{})       = panic "no_anon_wc_bndrs"
+
 {- Note [Fail eagerly on bad signatures]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 If a type signature is wrong, fail immediately:
index 4e8fe3b..bda9b77 100644 (file)
@@ -677,8 +677,15 @@ simplifyInfer :: TcLevel               -- Used when generating the constraints
 
 simplifyInfer rhs_tclvl infer_mode sigs name_taus wanteds
   | isEmptyWC wanteds
-  = do { gbl_tvs <- tcGetGlobalTyCoVars
-       ; dep_vars <- candidateQTyVarsOfTypes (map snd name_taus)
+   = do { -- When quantifying, we want to preserve any order of variables as they
+          -- appear in partial signatures. cf. decideQuantifiedTyVars
+          let psig_tv_tys = [ mkTyVarTy tv | sig <- partial_sigs
+                                          , (_,tv) <- sig_inst_skols sig ]
+              psig_theta  = [ pred | sig <- partial_sigs
+                                   , pred <- sig_inst_theta sig ]
+
+       ; gbl_tvs <- tcGetGlobalTyCoVars
+       ; dep_vars <- candidateQTyVarsOfTypes (psig_tv_tys ++ psig_theta ++ map snd name_taus)
        ; qtkvs <- quantifyTyVars gbl_tvs dep_vars
        ; traceTc "simplifyInfer: empty WC" (ppr name_taus $$ ppr qtkvs)
        ; return (qtkvs, [], emptyTcEvBinds, emptyWC, False) }
@@ -692,8 +699,7 @@ simplifyInfer rhs_tclvl infer_mode sigs name_taus wanteds
              , text "(unzonked) wanted =" <+> ppr wanteds
              ]
 
-       ; let partial_sigs = filter isPartialSig sigs
-             psig_theta   = concatMap sig_inst_theta partial_sigs
+       ; let psig_theta = concatMap sig_inst_theta partial_sigs
 
        -- First do full-blown solving
        -- NB: we must gather up all the bindings from doing
@@ -768,7 +774,8 @@ simplifyInfer rhs_tclvl infer_mode sigs name_taus wanteds
        ; return ( qtvs, bound_theta_vars, TcEvBinds ev_binds_var
                 , residual_wanted, definite_error ) }
          -- NB: bound_theta_vars must be fully zonked
-
+  where
+    partial_sigs = filter isPartialSig sigs
 
 --------------------
 mkResidualConstraints :: TcLevel -> Env TcGblEnv TcLclEnv -> EvBindsVar
index 7e34dae..53df2bb 100644 (file)
@@ -1402,8 +1402,9 @@ reifyAxBranch fam_tc (CoAxBranch { cab_tvs = tvs
        ; lhs' <- reifyTypes lhs_types_only
        ; annot_th_lhs <- zipWith3M annotThType (mkIsPolyTvs fam_tvs)
                                    lhs_types_only lhs'
+       ; let lhs_type = mkThAppTs (TH.ConT $ reifyName fam_tc) annot_th_lhs
        ; rhs'  <- reifyType rhs
-       ; return (TH.TySynEqn tvs' annot_th_lhs rhs') }
+       ; return (TH.TySynEqn tvs' lhs_type rhs') }
   where
     fam_tvs = tyConVisibleTyVars fam_tc
 
@@ -1617,7 +1618,8 @@ reifyClass cls
 
     reifyDefImpl :: TH.Name -> [TH.Name] -> Type -> TcM TH.Dec
     reifyDefImpl n args ty =
-      TH.TySynInstD n . TH.TySynEqn Nothing (map TH.VarT args) <$> reifyType ty
+      TH.TySynInstD . TH.TySynEqn Nothing (mkThAppTs (TH.ConT n) (map TH.VarT args))
+                                  <$> reifyType ty
 
     tfNames :: TH.Dec -> (TH.Name, [TH.Name])
     tfNames (TH.OpenTypeFamilyD (TH.TypeFamilyHead n args _ _))
@@ -1708,9 +1710,9 @@ reifyFamilyInstance is_poly_tvs (FamInst { fi_flavor = flavor
            ; th_lhs <- reifyTypes lhs_types_only
            ; annot_th_lhs <- zipWith3M annotThType is_poly_tvs lhs_types_only
                                                    th_lhs
+           ; let lhs_type = mkThAppTs (TH.ConT $ reifyName fam) annot_th_lhs
            ; th_rhs <- reifyType rhs
-           ; return (TH.TySynInstD (reifyName fam)
-                                   (TH.TySynEqn th_tvs annot_th_lhs th_rhs)) }
+           ; return (TH.TySynInstD (TH.TySynEqn th_tvs lhs_type th_rhs)) }
 
       DataFamilyInst rep_tc ->
         do { let -- eta-expand lhs types, because sometimes data/newtype
@@ -1725,10 +1727,11 @@ reifyFamilyInstance is_poly_tvs (FamInst { fi_flavor = flavor
            ; let types_only = filterOutInvisibleTypes fam_tc ee_lhs
            ; th_tys <- reifyTypes types_only
            ; annot_th_tys <- zipWith3M annotThType is_poly_tvs types_only th_tys
+           ; let lhs_type = mkThAppTs (TH.ConT fam') annot_th_tys
            ; return $
                if isNewTyCon rep_tc
-               then TH.NewtypeInstD [] fam' th_tvs annot_th_tys Nothing (head cons) []
-               else TH.DataInstD    [] fam' th_tvs annot_th_tys Nothing       cons  []
+               then TH.NewtypeInstD [] th_tvs lhs_type Nothing (head cons) []
+               else TH.DataInstD    [] th_tvs lhs_type Nothing       cons  []
            }
 
 ------------------------------
index f4ca993..a3b7975 100644 (file)
@@ -1428,7 +1428,7 @@ tcDefaultAssocDecl fam_tc [dL->L loc (FamEqn { feqn_tycon = L _ tc_name
                  (wrongNumberOfParmsErr fam_arity)
 
        -- Typecheck RHS
-       ; let hs_pats = map hsLTyVarBndrToType exp_vars
+       ; let hs_pats = map (HsValArg . hsLTyVarBndrToType) exp_vars
 
           -- NB: Use tcFamTyPats, not bindTyClTyVars. The latter expects to get
           -- the LHsQTyVars used for declaring a tycon, but the names here
@@ -1734,7 +1734,8 @@ kcTyFamInstEqn tc_fam_tc
            , text "feqn_bndrs =" <+> ppr mb_expl_bndrs
            , text "feqn_pats ="  <+> ppr hs_pats ])
           -- this check reports an arity error instead of a kind error; easier for user
-       ; checkTc (hs_pats `lengthIs` vis_arity) $
+       ; let vis_pats = numVisibleArgs hs_pats
+       ; checkTc (vis_pats == vis_arity) $
                   wrongNumberOfParmsErr vis_arity
        ; discardResult $
          bindImplicitTKBndrs_Q_Tv imp_vars $
@@ -1774,7 +1775,8 @@ tcTyFamInstEqn fam_tc mb_clsinfo
        -- If we wait until validity checking, we'll get kind errors
        -- below when an arity error will be much easier to understand.
        ; let vis_arity = length (tyConVisibleTyVars fam_tc)
-       ; checkTc (hs_pats `lengthIs` vis_arity) $
+             vis_pats  = numVisibleArgs hs_pats
+       ; checkTc (vis_pats == vis_arity) $
          wrongNumberOfParmsErr vis_arity
 
        ; (qtvs, pats, rhs_ty) <- tcTyFamInstEqnGuts fam_tc mb_clsinfo
@@ -1944,7 +1946,11 @@ tcFamTyPats fam_tc hs_pats
 
        ; let fun_ty = mkTyConApp fam_tc []
 
-       ; (fam_app, res_kind) <- tcInferApps typeLevelMode lhs_fun fun_ty
+       ; (fam_app, res_kind) <- unsetWOptM Opt_WarnPartialTypeSignatures $
+                                setXOptM LangExt.PartialTypeSignatures $
+                                -- See Note [Wildcards in family instances] in
+                                -- RnSource.hs
+                                tcInferApps typeLevelMode lhs_fun fun_ty
                                             fam_kind hs_pats
 
        ; traceTc "End tcFamTyPats }" $
index c7592c5..fb05ec0 100644 (file)
@@ -58,6 +58,7 @@ module TyCoRep (
         isInvisibleArgFlag, isVisibleArgFlag,
         isInvisibleBinder, isVisibleBinder,
         isTyBinder, isNamedBinder,
+        tyCoBinderArgFlag,
 
         -- * Functions over coercions
         pickLR,
@@ -554,6 +555,12 @@ isTyBinder :: TyCoBinder -> Bool
 isTyBinder (Named bnd) = isTyVarBinder bnd
 isTyBinder _ = True
 
+tyCoBinderArgFlag :: TyCoBinder -> ArgFlag
+tyCoBinderArgFlag (Named (Bndr _ flag)) = flag
+tyCoBinderArgFlag (Anon ty)
+ | isPredTy ty = Inferred
+ | otherwise = Required
+
 {- Note [TyCoBinders]
 ~~~~~~~~~~~~~~~~~~~
 A ForAllTy contains a TyCoVarBinder.  But a type can be decomposed
index 0ef0d05..b1e9bc6 100644 (file)
@@ -10686,7 +10686,7 @@ Visible type application
 ========================
 
 .. extension:: TypeApplications
-    :shortdesc: Enable type application syntax.
+    :shortdesc: Enable type application syntax in terms and types.
 
     :since: 8.0.1
 
@@ -10707,6 +10707,10 @@ is an identifier (the common case), its type is considered known only when
 the identifier has been given a type signature. If the identifier does
 not have a type signature, visible type application cannot be used.
 
+GHC also permits visible kind application, where users can declare the kind
+arguments to be instantiated in kind-polymorphic cases. Its usage parallels
+visible type application in the term level, as specified above.
+
 .. _inferred-vs-specified:
 
 Inferred vs. specified type variables
@@ -10864,8 +10868,8 @@ the rules in the subtler cases:
   application. If you want to specify only the second type argument to
   ``wurble``, then you can say ``wurble @_ @Int``.
   The first argument is a wildcard, just like in a partial type signature.
-  However, if used in a visible type application, it is *not*
-  necessary to specify :extension:`PartialTypeSignatures` and your
+  However, if used in a visible type application/visible kind application,
+  it is *not* necessary to specify :extension:`PartialTypeSignatures` and your
   code will not generate a warning informing you of the omitted type.
 
 The section in this manual on kind polymorphism describes how variables
@@ -12251,10 +12255,10 @@ Anonymous and named wildcards *can* occur on the left hand side of a
 type or data instance declaration;
 see :ref:`type-wildcards-lhs`.
 
-Anonymous wildcards are also allowed in visible type applications
-(:ref:`visible-type-application`). If you want to specify only the second type
-argument to ``wurble``, then you can say ``wurble @_ @Int`` where the first
-argument is a wildcard.
+Anonymous wildcards are also allowed in visible type applications/ visible kind
+applications (:ref:`visible-type-application`). If you want to specify only the
+second type argument to ``wurble``, then you can say ``wurble @_ @Int`` where
+the first argument is a wildcard.
 
 Standalone ``deriving`` declarations permit the use of a single,
 extra-constraints wildcard, like so: ::
index 67a8773..60527b6 100644 (file)
@@ -52,9 +52,10 @@ module Language.Haskell.TH.Lib (
     bindS, letS, noBindS, parS, recS,
 
     -- *** Types
-        forallT, varT, conT, appT, arrowT, infixT, uInfixT, parensT, equalityT,
-        listT, tupleT, unboxedTupleT, unboxedSumT, sigT, litT, wildCardT,
-        promotedT, promotedTupleT, promotedNilT, promotedConsT, implicitParamT,
+        forallT, varT, conT, appT, appKindT, arrowT, infixT, uInfixT, parensT,
+        equalityT, listT, tupleT, unboxedTupleT, unboxedSumT, sigT, litT,
+        wildCardT, promotedT, promotedTupleT, promotedNilT, promotedConsT,
+        implicitParamT,
     -- **** Type literals
     numTyLit, strTyLit,
     -- **** Strictness
@@ -207,20 +208,20 @@ dataInstD :: CxtQ -> Name -> [TypeQ] -> Maybe Kind -> [ConQ] -> [DerivClauseQ]
 dataInstD ctxt tc tys ksig cons derivs =
   do
     ctxt1 <- ctxt
-    tys1  <- sequence tys
+    ty1 <- foldl appT (conT tc) tys
     cons1 <- sequence cons
     derivs1 <- sequence derivs
-    return (DataInstD ctxt1 tc Nothing tys1 ksig cons1 derivs1)
+    return (DataInstD ctxt1 Nothing ty1 ksig cons1 derivs1)
 
 newtypeInstD :: CxtQ -> Name -> [TypeQ] -> Maybe Kind -> ConQ -> [DerivClauseQ]
              -> DecQ
 newtypeInstD ctxt tc tys ksig con derivs =
   do
     ctxt1 <- ctxt
-    tys1  <- sequence tys
+    ty1 <- foldl appT (conT tc) tys
     con1  <- con
     derivs1 <- sequence derivs
-    return (NewtypeInstD ctxt1 tc Nothing tys1 ksig con1 derivs1)
+    return (NewtypeInstD ctxt1 Nothing ty1 ksig con1 derivs1)
 
 dataFamilyD :: Name -> [TyVarBndr] -> Maybe Kind -> DecQ
 dataFamilyD tc tvs kind
@@ -237,12 +238,12 @@ 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 =
+tySynEqn :: (Maybe [TyVarBndr]) -> TypeQ -> TypeQ -> TySynEqnQ
+tySynEqn tvs lhs rhs =
   do
-    lhs1 <- sequence lhs
+    lhs1 <- lhs
     rhs1 <- rhs
-    return (TySynEqn Nothing lhs1 rhs1)
+    return (TySynEqn tvs lhs1 rhs1)
 
 forallC :: [TyVarBndr] -> CxtQ -> ConQ -> ConQ
 forallC ns ctxt con = liftM2 (ForallC ns) ctxt con
index 11391da..ec9ca4f 100644 (file)
@@ -491,35 +491,35 @@ pragLineD line file = return $ PragmaD $ LineP line file
 pragCompleteD :: [Name] -> Maybe Name -> DecQ
 pragCompleteD cls mty = return $ PragmaD $ CompleteP cls mty
 
-dataInstD :: CxtQ -> Name -> (Maybe [TyVarBndrQ]) -> [TypeQ] -> Maybe KindQ
-          -> [ConQ] -> [DerivClauseQ] -> DecQ
-dataInstD ctxt tc mb_bndrs tys ksig cons derivs =
+dataInstD :: CxtQ -> (Maybe [TyVarBndrQ]) -> TypeQ -> Maybe KindQ -> [ConQ]
+          -> [DerivClauseQ] -> DecQ
+dataInstD ctxt mb_bndrs ty ksig cons derivs =
   do
-    ctxt1     <- ctxt
+    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 =
+    ty1    <- ty
+    ksig1   <- sequenceA ksig
+    cons1   <- sequenceA cons
+    derivs1 <- sequenceA derivs
+    return (DataInstD ctxt1 mb_bndrs1 ty1 ksig1 cons1 derivs1)
+
+newtypeInstD :: CxtQ -> (Maybe [TyVarBndrQ]) -> TypeQ -> Maybe KindQ -> ConQ
+             -> [DerivClauseQ] -> DecQ
+newtypeInstD ctxt mb_bndrs ty ksig con derivs =
   do
-    ctxt1     <- ctxt
+    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 =
+    ty1    <- ty
+    ksig1   <- sequenceA ksig
+    con1    <- con
+    derivs1 <- sequence derivs
+    return (NewtypeInstD ctxt1 mb_bndrs1 ty1 ksig1 con1 derivs1)
+
+tySynInstD :: TySynEqnQ -> DecQ
+tySynInstD eqn =
   do
     eqn1 <- eqn
-    return (TySynInstD tc eqn1)
+    return (TySynInstD eqn1)
 
 dataFamilyD :: Name -> [TyVarBndrQ] -> Maybe KindQ -> DecQ
 dataFamilyD tc tvs kind =
@@ -584,11 +584,11 @@ implicitParamBindD n e =
     e' <- e
     return $ ImplicitParamBindD n e'
 
-tySynEqn :: (Maybe [TyVarBndrQ]) -> [TypeQ] -> TypeQ -> TySynEqnQ
+tySynEqn :: (Maybe [TyVarBndrQ]) -> TypeQ -> TypeQ -> TySynEqnQ
 tySynEqn mb_bndrs lhs rhs =
   do
     mb_bndrs1 <- traverse sequence mb_bndrs
-    lhs1 <- sequence lhs
+    lhs1 <- lhs
     rhs1 <- rhs
     return (TySynEqn mb_bndrs1 lhs1 rhs1)
 
@@ -672,6 +672,12 @@ appT t1 t2 = do
            t2' <- t2
            return $ AppT t1' t2'
 
+appKindT :: TypeQ -> KindQ -> TypeQ
+appKindT ty ki = do
+               ty' <- ty
+               ki' <- ki
+               return $ AppKindT ty' ki'
+
 arrowT :: TypeQ
 arrowT = return ArrowT
 
index 621c0f5..c25b2fb 100644 (file)
@@ -325,11 +325,11 @@ ppr_dec _ (FunD f cs)   = vcat $ map (\c -> pprPrefixOcc f <+> ppr c) cs
 ppr_dec _ (ValD p r ds) = ppr p <+> pprBody True r
                           $$ where_clause ds
 ppr_dec _ (TySynD t xs rhs)
-  = ppr_tySyn empty t (hsep (map ppr xs)) rhs
+  = ppr_tySyn empty (Just t) (hsep (map ppr xs)) rhs
 ppr_dec _ (DataD ctxt t xs ksig cs decs)
-  = ppr_data empty ctxt t (hsep (map ppr xs)) ksig cs decs
+  = ppr_data empty ctxt (Just t) (hsep (map ppr xs)) ksig cs decs
 ppr_dec _ (NewtypeD ctxt t xs ksig c decs)
-  = ppr_newtype empty ctxt t (sep (map ppr xs)) ksig c decs
+  = ppr_newtype empty ctxt (Just t) (sep (map ppr xs)) ksig c decs
 ppr_dec _  (ClassD ctxt c xs fds ds)
   = text "class" <+> pprCxt ctxt <+> ppr c <+> hsep (map ppr xs) <+> ppr fds
     $$ where_clause ds
@@ -347,21 +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 bndrs tys ksig cs decs)
-  = ppr_data (maybeInst <+> ppr_bndrs bndrs) ctxt tc
-             (sep (map pprParendType tys)) ksig cs decs
+ppr_dec isTop (DataInstD ctxt bndrs ty ksig cs decs)
+  = ppr_data (maybeInst <+> ppr_bndrs bndrs)
+             ctxt Nothing (ppr ty) ksig cs decs
   where
     maybeInst | isTop     = text "instance"
               | otherwise = empty
-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
+ppr_dec isTop (NewtypeInstD ctxt bndrs ty ksig c decs)
+  = ppr_newtype (maybeInst <+> ppr_bndrs bndrs)
+                ctxt Nothing (ppr ty) ksig c decs
   where
     maybeInst | isTop     = text "instance"
               | otherwise = empty
-ppr_dec isTop (TySynInstD tc (TySynEqn mb_bndrs tys rhs))
-  = ppr_tySyn (maybeInst <+> ppr_bndrs mb_bndrs) tc
-              (sep (map pprParendType tys)) rhs
+ppr_dec isTop (TySynInstD (TySynEqn mb_bndrs ty rhs))
+  = ppr_tySyn (maybeInst <+> ppr_bndrs mb_bndrs)
+              Nothing (ppr ty) rhs
   where
     maybeInst | isTop     = text "instance"
               | otherwise = empty
@@ -370,13 +370,12 @@ ppr_dec isTop (OpenTypeFamilyD tfhead)
   where
     maybeFamily | isTop     = text "family"
                 | otherwise = empty
-ppr_dec _ (ClosedTypeFamilyD tfhead@(TypeFamilyHead tc _ _ _) eqns)
+ppr_dec _ (ClosedTypeFamilyD tfhead eqns)
   = hang (text "type family" <+> ppr_tf_head tfhead <+> text "where")
       nestDepth (vcat (map ppr_eqn eqns))
   where
     ppr_eqn (TySynEqn mb_bndrs lhs rhs)
-      = ppr_bndrs mb_bndrs <+> ppr tc <+> sep (map pprParendType lhs)
-        <+> text "=" <+> ppr rhs
+      = ppr_bndrs mb_bndrs <+> ppr 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)
@@ -416,12 +415,15 @@ ppr_overlap o = text $
     Overlapping   -> "{-# OVERLAPPING #-}"
     Incoherent    -> "{-# INCOHERENT #-}"
 
-ppr_data :: Doc -> Cxt -> Name -> Doc -> Maybe Kind -> [Con] -> [DerivClause]
+ppr_data :: Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> [Con] -> [DerivClause]
          -> Doc
 ppr_data maybeInst ctxt t argsDoc ksig cs decs
   = sep [text "data" <+> maybeInst
             <+> pprCxt ctxt
-            <+> pprName' Applied t <+> argsDoc <+> ksigDoc <+> maybeWhere,
+            <+> case t of
+                 Just n -> pprName' Applied n <+> argsDoc
+                 Nothing -> argsDoc
+            <+> ksigDoc <+> maybeWhere,
          nest nestDepth (sep (pref $ map ppr cs)),
          if null decs
            then empty
@@ -448,12 +450,15 @@ ppr_data maybeInst ctxt t argsDoc ksig cs decs
                 Nothing -> empty
                 Just k  -> dcolon <+> ppr k
 
-ppr_newtype :: Doc -> Cxt -> Name -> Doc -> Maybe Kind -> Con -> [DerivClause]
+ppr_newtype :: Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> Con -> [DerivClause]
             -> Doc
 ppr_newtype maybeInst ctxt t argsDoc ksig c decs
   = sep [text "newtype" <+> maybeInst
             <+> pprCxt ctxt
-            <+> ppr t <+> argsDoc <+> ksigDoc,
+            <+> case t of
+                 Just n -> ppr n <+> argsDoc
+                 Nothing -> argsDoc
+            <+> ksigDoc,
          nest 2 (char '=' <+> ppr c),
          if null decs
            then empty
@@ -477,9 +482,13 @@ ppr_deriv_clause (DerivClause ds ctxt)
         Just (via@ViaStrategy{}) -> (empty, ppr_deriv_strategy via)
         _                        -> (maybe empty ppr_deriv_strategy ds, empty)
 
-ppr_tySyn :: Doc -> Name -> Doc -> Type -> Doc
+ppr_tySyn :: Doc -> Maybe Name -> Doc -> Type -> Doc
 ppr_tySyn maybeInst t argsDoc rhs
-  = text "type" <+> maybeInst <+> ppr t <+> argsDoc <+> text "=" <+> ppr rhs
+  = text "type" <+> maybeInst
+    <+> case t of
+         Just n -> ppr n <+> argsDoc
+         Nothing -> argsDoc
+    <+> text "=" <+> ppr rhs
 
 ppr_tf_head :: TypeFamilyHead -> Doc
 ppr_tf_head (TypeFamilyHead tc tvs res inj)
@@ -742,6 +751,7 @@ pprParendType (ImplicitParamT n t)= text ('?':n) <+> text "::" <+> ppr t
 pprParendType EqualityT           = text "(~)"
 pprParendType t@(ForallT {})      = parens (ppr t)
 pprParendType t@(AppT {})         = parens (ppr t)
+pprParendType t@(AppKindT {})     = parens (ppr t)
 
 pprUInfixT :: Type -> Doc
 pprUInfixT (UInfixT x n y) = pprUInfixT x <+> pprName' Infix n <+> pprUInfixT y
@@ -752,7 +762,13 @@ instance Ppr Type where
     ppr ty = pprTyApp (split ty)
        -- Works, in a degnerate way, for SigT, and puts parens round (ty :: kind)
        -- See Note [Pretty-printing kind signatures]
+instance Ppr TypeArg where
+    ppr (TANormal ty) = ppr ty
+    ppr (TyArg ki) = char '@' <> ppr ki
 
+pprParendTypeArg :: TypeArg -> Doc
+pprParendTypeArg (TANormal ty) = pprParendType ty
+pprParendTypeArg (TyArg ki) = char '@' <> pprParendType ki
 {- Note [Pretty-printing kind signatures]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 GHC's parser only recognises a kind signature in a type when there are
@@ -761,16 +777,16 @@ parens around it.  E.g. the parens are required here:
    type instance F Int = (Bool :: *)
 So we always print a SigT with parens (see Trac #10050). -}
 
-pprTyApp :: (Type, [Type]) -> Doc
-pprTyApp (ArrowT, [arg1,arg2]) = sep [pprFunArgType arg1 <+> text "->", ppr arg2]
-pprTyApp (EqualityT, [arg1, arg2]) =
+pprTyApp :: (Type, [TypeArg]) -> Doc
+pprTyApp (ArrowT, [TANormal arg1, TANormal arg2]) = sep [pprFunArgType arg1 <+> text "->", ppr arg2]
+pprTyApp (EqualityT, [TANormal arg1, TANormal arg2]) =
     sep [pprFunArgType arg1 <+> text "~", ppr arg2]
-pprTyApp (ListT, [arg]) = brackets (ppr arg)
+pprTyApp (ListT, [TANormal arg]) = brackets (ppr arg)
 pprTyApp (TupleT n, args)
  | length args == n = parens (commaSep args)
 pprTyApp (PromotedTupleT n, args)
  | length args == n = quoteParens (commaSep args)
-pprTyApp (fun, args) = pprParendType fun <+> sep (map pprParendType args)
+pprTyApp (fun, args) = pprParendType fun <+> sep (map pprParendTypeArg args)
 
 pprFunArgType :: Type -> Doc    -- Should really use a precedence argument
 -- Everything except forall and (->) binds more tightly than (->)
@@ -779,9 +795,13 @@ pprFunArgType ty@((ArrowT `AppT` _) `AppT` _) = parens (ppr ty)
 pprFunArgType ty@(SigT _ _)                   = parens (ppr ty)
 pprFunArgType ty                              = ppr ty
 
-split :: Type -> (Type, [Type])    -- Split into function and args
+data TypeArg = TANormal Type
+             | TyArg Kind
+
+split :: Type -> (Type, [TypeArg])    -- Split into function and args
 split t = go t []
-    where go (AppT t1 t2) args = go t1 (t2:args)
+    where go (AppT t1 t2) args = go t1 (TANormal t2:args)
+          go (AppKindT ty ki) args = go ty (TyArg ki:args)
           go ty           args = (ty, args)
 
 pprTyLit :: TyLit -> Doc
index ef44a5c..770fac7 100644 (file)
@@ -1727,24 +1727,20 @@ data Dec
                (Maybe Kind)
          -- ^ @{ data family T a b c :: * }@
 
-  | DataInstD Cxt Name
-             (Maybe [TyVarBndr])  -- Quantified type vars
-             [Type]
+  | DataInstD Cxt (Maybe [TyVarBndr]) 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
-                 (Maybe [TyVarBndr])  -- Quantified type vars
-                 [Type]
+  | NewtypeInstD Cxt (Maybe [TyVarBndr]) Type -- Quantified type vars
                  (Maybe Kind)      -- Kind signature
                  Con [DerivClause] -- ^ @{ newtype instance Cxt x => T [x]
                                    --        = A (B x)
                                    --        deriving (Z,W)
                                    --        deriving stock Eq }@
-  | TySynInstD Name TySynEqn       -- ^ @{ type instance ... }@
+  | TySynInstD TySynEqn            -- ^ @{ type instance ... }@
 
   -- | open type families (may also appear in [Dec] of 'ClassD' and 'InstanceD')
   | OpenTypeFamilyD TypeFamilyHead
@@ -1855,9 +1851,23 @@ data TypeFamilyHead =
   deriving( Show, Eq, Ord, Data, Generic )
 
 -- | 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 (Maybe [TyVarBndr]) [Type] Type
+-- arguments are the left-hand-side type and the right-hand-side result.
+--
+-- For instance, if you had the following type family:
+--
+-- @
+-- type family Foo (a :: k) :: k where
+--   forall k (a :: k). Foo \@k a = a
+-- @
+--
+-- The @Foo \@k a = a@ equation would be represented as follows:
+--
+-- @
+-- 'TySynEqn' ('Just' ['PlainTV' k, 'KindedTV' a ('VarT' k)])
+--            ('AppT' ('AppKindT' ('ConT' ''Foo) ('VarT' k)) ('VarT' a))
+--            ('VarT' a)
+-- @
+data TySynEqn = TySynEqn (Maybe [TyVarBndr]) Type Type
   deriving( Show, Eq, Ord, Data, Generic )
 
 data FunDep = FunDep [Name] [Name]
@@ -2037,6 +2047,7 @@ data PatSynArgs
 
 data Type = ForallT [TyVarBndr] Cxt Type  -- ^ @forall \<vars\>. \<ctxt\> => \<type\>@
           | AppT Type Type                -- ^ @T a b@
+          | AppKindT Type Kind            -- ^ @T \@k t@
           | SigT Type Kind                -- ^ @t :: k@
           | VarT Name                     -- ^ @a@
           | ConT Name                     -- ^ @T@
index 5dca983..b144434 100644 (file)
@@ -5,12 +5,18 @@
   * 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.
+    `Nothing` otherwise. `DataInstD`, `NewTypeInstD`, `TySynEqn` also now use
+    a single `Type` argument to represent the left-hand-side to avoid
+    malformed type family equations and allow visible kind application.
 
     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`.
+    functions can be found in `Language.Haskell.TH.Lib`. The type signature
+    of `tySynEqn` has also changed from `[TypeQ] -> TypeQ -> TySynEqnQ` to
+    `(Maybe [TyVarBndrQ]) -> TypeQ -> TypeQ -> TySynEqnQ`, for the same reason
+    as in `Language.Haskell.TH.Syntax` above. Consequently, `tySynInstD` also
+    changes from `Name -> TySynEqnQ -> DecQ` to `TySynEqnQ -> DecQ`.
 
   * Add `Lift` instances for `NonEmpty` and `Void`
 
index 97b2a33..adb7869 100644 (file)
@@ -1,4 +1,5 @@
 
 T11241.hs:5:21: warning: [-Wpartial-type-signatures (in -Wdefault)]
     • Found type wildcard ‘_’ standing for ‘*’
-    • In the type signature: foo :: forall (a :: _). a -> a
+    • In the kind ‘_’
+      In the type signature: foo :: forall (a :: _). a -> a
diff --git a/testsuite/tests/deriving/should_compile/T14579a.hs b/testsuite/tests/deriving/should_compile/T14579a.hs
new file mode 100644 (file)
index 0000000..ac7ba6c
--- /dev/null
@@ -0,0 +1,22 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeInType #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Bug where
+
+import Data.Coerce
+import Data.Kind
+import Data.Proxy
+
+newtype Wat (x :: Proxy (a :: Type)) = MkWat (Maybe a)
+  deriving Eq
+
+newtype Glurp a = MkGlurp (Wat ('Proxy :: Proxy a))
+
+instance Eq a => Eq (Glurp a) where
+  (==) = coerce @(Wat ('Proxy @a) -> Wat ('Proxy @a) -> Bool)
+                @(Glurp a         -> Glurp a         -> Bool)
+                (==)
index c49b808..8c84bcc 100644 (file)
@@ -105,6 +105,7 @@ test('T14339', normal, compile, [''])
 test('T14331', normal, compile, [''])
 test('T14578', normal, compile, ['-ddump-deriv -dsuppress-uniques'])
 test('T14579', normal, compile, [''])
+test('T14579a', normal, compile, [''])
 test('T14682', normal, compile, ['-ddump-deriv -dsuppress-uniques'])
 test('T14883', normal, compile, [''])
 test('T14932', normal, compile, [''])
index 6c469ee..7a64e15 100644 (file)
@@ -1,3 +1,3 @@
 deferEither @(_ ~ _)
-  :: (Typeable w1, Typeable w2) =>
-     proxy (w1 ~ w2) -> ((w1 ~ w2) => r) -> Either String r
+  :: (Typeable _1, Typeable _2) =>
+     proxy (_1 ~ _2) -> ((_1 ~ _2) => r) -> Either String r
index e7065cf..ca0e33c 100644 (file)
@@ -57,18 +57,6 @@ ExplicitForAllFams4b.hs:23:17: error:
     • In the type instance declaration for ‘CT’
       In the instance declaration for ‘C Int’
 
-ExplicitForAllFams4b.hs:23:20: error:
-    Conflicting family instance declarations:
-      CT [a] (a, a) = Float -- Defined at ExplicitForAllFams4b.hs:23:20
-      CT _ _ = Maybe b -- Defined at ExplicitForAllFams4b.hs:24:20
-
-ExplicitForAllFams4b.hs:24:3: error:
-    • Type indexes must match class instance head
-      Expected: CT Int _
-        Actual: CT _ _
-    • In the type instance declaration for ‘CT’
-      In the instance declaration for ‘C Int’
-
 ExplicitForAllFams4b.hs:24:15: error:
     • Type variable ‘b’ is mentioned in the RHS,
         but not bound on the LHS of the family instance
@@ -88,18 +76,6 @@ ExplicitForAllFams4b.hs:26:17: error:
     • In the data instance declaration for ‘CD’
       In the instance declaration for ‘C Int’
 
-ExplicitForAllFams4b.hs:26:20: error:
-    Conflicting family instance declarations:
-      CD [a] (a, a) -- Defined at ExplicitForAllFams4b.hs:26:20
-      CD _ _ -- Defined at ExplicitForAllFams4b.hs:27:20
-
-ExplicitForAllFams4b.hs:27:3: error:
-    • Type indexes must match class instance head
-      Expected: CD Int _
-        Actual: CD _ _
-    • In the data instance declaration for ‘CD’
-      In the instance declaration for ‘C Int’
-
 ExplicitForAllFams4b.hs:27:15: error:
     • Type variable ‘b’ is mentioned in the RHS,
         but not bound on the LHS of the family instance
index 0f83b12..f2bf433 100644 (file)
@@ -1,6 +1,8 @@
-{-# LANGUAGE DataKinds, PolyKinds, TypeOperators, TypeFamilies #-}
+{-# LANGUAGE DataKinds, PolyKinds, TypeOperators, TypeFamilies
+             , TypeApplications, TypeInType #-}
 
 module DumpParsedAst where
+import Data.Kind
 
 data Peano = Zero | Succ Peano
 
@@ -8,4 +10,10 @@ type family Length (as :: [k]) :: Peano where
   Length (a : as) = Succ (Length as)
   Length '[]      = Zero
 
+-- vis kind app
+data T f (a :: k) = MkT (f a)
+
+type family F1 (a :: k) (f :: k -> Type) :: Type where
+  F1 @Peano a f = T @Peano f a
+
 main = putStrLn "hello"
index 408f28b..81607d7 100644 (file)
@@ -4,16 +4,28 @@
 ({ DumpParsedAst.hs:1:1 }
  (HsModule
   (Just
-   ({ DumpParsedAst.hs:3:8-20 }
+   ({ DumpParsedAst.hs:4:8-20 }
     {ModuleName: DumpParsedAst}))
   (Nothing)
-  []
-  [({ DumpParsedAst.hs:5:1-30 }
+  [({ DumpParsedAst.hs:5:1-16 }
+    (ImportDecl
+     (NoExt)
+     (NoSourceText)
+     ({ DumpParsedAst.hs:5:8-16 }
+      {ModuleName: Data.Kind})
+     (Nothing)
+     (False)
+     (False)
+     (False)
+     (False)
+     (Nothing)
+     (Nothing)))]
+  [({ DumpParsedAst.hs:7:1-30 }
     (TyClD
      (NoExt)
      (DataDecl
       (NoExt)
-      ({ DumpParsedAst.hs:5:6-10 }
+      ({ DumpParsedAst.hs:7:6-10 }
        (Unqual
         {OccName: Peano}))
       (HsQTvs
         [])
        (Nothing)
        (Nothing)
-       [({ DumpParsedAst.hs:5:14-17 }
+       [({ DumpParsedAst.hs:7:14-17 }
          (ConDeclH98
           (NoExt)
-          ({ DumpParsedAst.hs:5:14-17 }
+          ({ DumpParsedAst.hs:7:14-17 }
            (Unqual
             {OccName: Zero}))
           ({ <no location info> }
           (PrefixCon
            [])
           (Nothing)))
-       ,({ DumpParsedAst.hs:5:21-30 }
+       ,({ DumpParsedAst.hs:7:21-30 }
          (ConDeclH98
           (NoExt)
-          ({ DumpParsedAst.hs:5:21-24 }
+          ({ DumpParsedAst.hs:7:21-24 }
            (Unqual
             {OccName: Succ}))
           ({ <no location info> }
           []
           (Nothing)
           (PrefixCon
-           [({ DumpParsedAst.hs:5:26-30 }
+           [({ DumpParsedAst.hs:7:26-30 }
              (HsTyVar
               (NoExt)
               (NotPromoted)
-              ({ DumpParsedAst.hs:5:26-30 }
+              ({ DumpParsedAst.hs:7:26-30 }
                (Unqual
                 {OccName: Peano}))))])
           (Nothing)))]
        ({ <no location info> }
         [])))))
-  ,({ DumpParsedAst.hs:7:1-39 }
+  ,({ DumpParsedAst.hs:9:1-39 }
     (TyClD
      (NoExt)
      (FamDecl
        (NoExt)
        (ClosedTypeFamily
         (Just
-         [({ DumpParsedAst.hs:8:3-36 }
+         [({ DumpParsedAst.hs:10:3-36 }
            (HsIB
             (NoExt)
             (FamEqn
              (NoExt)
-             ({ DumpParsedAst.hs:8:3-8 }
+             ({ DumpParsedAst.hs:10:3-8 }
               (Unqual
                {OccName: Length}))
              (Nothing)
-             [({ DumpParsedAst.hs:8:10-17 }
-               (HsParTy
-                (NoExt)
-                ({ DumpParsedAst.hs:8:11-16 }
-                 (HsOpTy
-                  (NoExt)
-                  ({ DumpParsedAst.hs:8:11 }
-                   (HsTyVar
-                    (NoExt)
-                    (NotPromoted)
-                    ({ DumpParsedAst.hs:8:11 }
-                     (Unqual
-                      {OccName: a}))))
-                  ({ DumpParsedAst.hs:8:13 }
-                   (Exact
-                    {Name: :}))
-                  ({ DumpParsedAst.hs:8:15-16 }
-                   (HsTyVar
-                    (NoExt)
-                    (NotPromoted)
-                    ({ DumpParsedAst.hs:8:15-16 }
-                     (Unqual
-                      {OccName: as}))))))))]
+             [(HsValArg
+               ({ DumpParsedAst.hs:10:10-17 }
+                (HsParTy
+                 (NoExt)
+                 ({ DumpParsedAst.hs:10:11-16 }
+                  (HsOpTy
+                   (NoExt)
+                   ({ DumpParsedAst.hs:10:11 }
+                    (HsTyVar
+                     (NoExt)
+                     (NotPromoted)
+                     ({ DumpParsedAst.hs:10:11 }
+                      (Unqual
+                       {OccName: a}))))
+                   ({ DumpParsedAst.hs:10:13 }
+                    (Exact
+                     {Name: :}))
+                   ({ DumpParsedAst.hs:10:15-16 }
+                    (HsTyVar
+                     (NoExt)
+                     (NotPromoted)
+                     ({ DumpParsedAst.hs:10:15-16 }
+                      (Unqual
+                       {OccName: as})))))))))]
              (Prefix)
-             ({ DumpParsedAst.hs:8:21-36 }
+             ({ DumpParsedAst.hs:10:21-36 }
               (HsAppTy
                (NoExt)
-               ({ DumpParsedAst.hs:8:21-24 }
+               ({ DumpParsedAst.hs:10:21-24 }
                 (HsTyVar
                  (NoExt)
                  (NotPromoted)
-                 ({ DumpParsedAst.hs:8:21-24 }
+                 ({ DumpParsedAst.hs:10:21-24 }
                   (Unqual
                    {OccName: Succ}))))
-               ({ DumpParsedAst.hs:8:26-36 }
+               ({ DumpParsedAst.hs:10:26-36 }
                 (HsParTy
                  (NoExt)
-                 ({ DumpParsedAst.hs:8:27-35 }
+                 ({ DumpParsedAst.hs:10:27-35 }
                   (HsAppTy
                    (NoExt)
-                   ({ DumpParsedAst.hs:8:27-32 }
+                   ({ DumpParsedAst.hs:10:27-32 }
                     (HsTyVar
                      (NoExt)
                      (NotPromoted)
-                     ({ DumpParsedAst.hs:8:27-32 }
+                     ({ DumpParsedAst.hs:10:27-32 }
                       (Unqual
                        {OccName: Length}))))
-                   ({ DumpParsedAst.hs:8:34-35 }
+                   ({ DumpParsedAst.hs:10:34-35 }
                     (HsTyVar
                      (NoExt)
                      (NotPromoted)
-                     ({ DumpParsedAst.hs:8:34-35 }
+                     ({ DumpParsedAst.hs:10:34-35 }
                       (Unqual
                        {OccName: as})))))))))))))
-         ,({ DumpParsedAst.hs:9:3-24 }
+         ,({ DumpParsedAst.hs:11:3-24 }
            (HsIB
             (NoExt)
             (FamEqn
              (NoExt)
-             ({ DumpParsedAst.hs:9:3-8 }
+             ({ DumpParsedAst.hs:11:3-8 }
               (Unqual
                {OccName: Length}))
              (Nothing)
-             [({ DumpParsedAst.hs:9:10-12 }
-               (HsExplicitListTy
-                (NoExt)
-                (IsPromoted)
-                []))]
+             [(HsValArg
+               ({ DumpParsedAst.hs:11:10-12 }
+                (HsExplicitListTy
+                 (NoExt)
+                 (IsPromoted)
+                 [])))]
              (Prefix)
-             ({ DumpParsedAst.hs:9:21-24 }
+             ({ DumpParsedAst.hs:11:21-24 }
               (HsTyVar
                (NoExt)
                (NotPromoted)
-               ({ DumpParsedAst.hs:9:21-24 }
+               ({ DumpParsedAst.hs:11:21-24 }
                 (Unqual
                  {OccName: Zero})))))))]))
-       ({ DumpParsedAst.hs:7:13-18 }
+       ({ DumpParsedAst.hs:9:13-18 }
         (Unqual
          {OccName: Length}))
        (HsQTvs
         (NoExt)
-        [({ DumpParsedAst.hs:7:21-29 }
+        [({ DumpParsedAst.hs:9:21-29 }
           (KindedTyVar
            (NoExt)
-           ({ DumpParsedAst.hs:7:21-22 }
+           ({ DumpParsedAst.hs:9:21-22 }
             (Unqual
              {OccName: as}))
-           ({ DumpParsedAst.hs:7:27-29 }
+           ({ DumpParsedAst.hs:9:27-29 }
             (HsListTy
              (NoExt)
-             ({ DumpParsedAst.hs:7:28 }
+             ({ DumpParsedAst.hs:9:28 }
               (HsTyVar
                (NoExt)
                (NotPromoted)
-               ({ DumpParsedAst.hs:7:28 }
+               ({ DumpParsedAst.hs:9:28 }
                 (Unqual
                  {OccName: k}))))))))])
        (Prefix)
-       ({ DumpParsedAst.hs:7:32-39 }
+       ({ DumpParsedAst.hs:9:32-39 }
         (KindSig
          (NoExt)
-         ({ DumpParsedAst.hs:7:35-39 }
+         ({ DumpParsedAst.hs:9:35-39 }
           (HsTyVar
            (NoExt)
            (NotPromoted)
-           ({ DumpParsedAst.hs:7:35-39 }
+           ({ DumpParsedAst.hs:9:35-39 }
             (Unqual
              {OccName: Peano}))))))
        (Nothing)))))
-  ,({ DumpParsedAst.hs:11:1-23 }
+  ,({ DumpParsedAst.hs:14:1-29 }
+    (TyClD
+     (NoExt)
+     (DataDecl
+      (NoExt)
+      ({ DumpParsedAst.hs:14:6 }
+       (Unqual
+        {OccName: T}))
+      (HsQTvs
+       (NoExt)
+       [({ DumpParsedAst.hs:14:8 }
+         (UserTyVar
+          (NoExt)
+          ({ DumpParsedAst.hs:14:8 }
+           (Unqual
+            {OccName: f}))))
+       ,({ DumpParsedAst.hs:14:11-16 }
+         (KindedTyVar
+          (NoExt)
+          ({ DumpParsedAst.hs:14:11 }
+           (Unqual
+            {OccName: a}))
+          ({ DumpParsedAst.hs:14:16 }
+           (HsTyVar
+            (NoExt)
+            (NotPromoted)
+            ({ DumpParsedAst.hs:14:16 }
+             (Unqual
+              {OccName: k}))))))])
+      (Prefix)
+      (HsDataDefn
+       (NoExt)
+       (DataType)
+       ({ <no location info> }
+        [])
+       (Nothing)
+       (Nothing)
+       [({ DumpParsedAst.hs:14:21-29 }
+         (ConDeclH98
+          (NoExt)
+          ({ DumpParsedAst.hs:14:21-23 }
+           (Unqual
+            {OccName: MkT}))
+          ({ <no location info> }
+           (False))
+          []
+          (Nothing)
+          (PrefixCon
+           [({ DumpParsedAst.hs:14:25-29 }
+             (HsParTy
+              (NoExt)
+              ({ DumpParsedAst.hs:14:26-28 }
+               (HsAppTy
+                (NoExt)
+                ({ DumpParsedAst.hs:14:26 }
+                 (HsTyVar
+                  (NoExt)
+                  (NotPromoted)
+                  ({ DumpParsedAst.hs:14:26 }
+                   (Unqual
+                    {OccName: f}))))
+                ({ DumpParsedAst.hs:14:28 }
+                 (HsTyVar
+                  (NoExt)
+                  (NotPromoted)
+                  ({ DumpParsedAst.hs:14:28 }
+                   (Unqual
+                    {OccName: a}))))))))])
+          (Nothing)))]
+       ({ <no location info> }
+        [])))))
+  ,({ DumpParsedAst.hs:16:1-48 }
+    (TyClD
+     (NoExt)
+     (FamDecl
+      (NoExt)
+      (FamilyDecl
+       (NoExt)
+       (ClosedTypeFamily
+        (Just
+         [({ DumpParsedAst.hs:17:3-30 }
+           (HsIB
+            (NoExt)
+            (FamEqn
+             (NoExt)
+             ({ DumpParsedAst.hs:17:3-4 }
+              (Unqual
+               {OccName: F1}))
+             (Nothing)
+             [(HsTypeArg
+               ({ DumpParsedAst.hs:17:7-11 }
+                (HsTyVar
+                 (NoExt)
+                 (NotPromoted)
+                 ({ DumpParsedAst.hs:17:7-11 }
+                  (Unqual
+                   {OccName: Peano})))))
+             ,(HsValArg
+               ({ DumpParsedAst.hs:17:13 }
+                (HsTyVar
+                 (NoExt)
+                 (NotPromoted)
+                 ({ DumpParsedAst.hs:17:13 }
+                  (Unqual
+                   {OccName: a})))))
+             ,(HsValArg
+               ({ DumpParsedAst.hs:17:15 }
+                (HsTyVar
+                 (NoExt)
+                 (NotPromoted)
+                 ({ DumpParsedAst.hs:17:15 }
+                  (Unqual
+                   {OccName: f})))))]
+             (Prefix)
+             ({ DumpParsedAst.hs:17:19-30 }
+              (HsAppTy
+               (NoExt)
+               ({ DumpParsedAst.hs:17:19-28 }
+                (HsAppTy
+                 (NoExt)
+                 ({ DumpParsedAst.hs:17:19-26 }
+                  (HsAppKindTy
+                   (NoExt)
+                   ({ DumpParsedAst.hs:17:19 }
+                    (HsTyVar
+                     (NoExt)
+                     (NotPromoted)
+                     ({ DumpParsedAst.hs:17:19 }
+                      (Unqual
+                       {OccName: T}))))
+                   ({ DumpParsedAst.hs:17:22-26 }
+                    (HsTyVar
+                     (NoExt)
+                     (NotPromoted)
+                     ({ DumpParsedAst.hs:17:22-26 }
+                      (Unqual
+                       {OccName: Peano}))))))
+                 ({ DumpParsedAst.hs:17:28 }
+                  (HsTyVar
+                   (NoExt)
+                   (NotPromoted)
+                   ({ DumpParsedAst.hs:17:28 }
+                    (Unqual
+                     {OccName: f}))))))
+               ({ DumpParsedAst.hs:17:30 }
+                (HsTyVar
+                 (NoExt)
+                 (NotPromoted)
+                 ({ DumpParsedAst.hs:17:30 }
+                  (Unqual
+                   {OccName: a})))))))))]))
+       ({ DumpParsedAst.hs:16:13-14 }
+        (Unqual
+         {OccName: F1}))
+       (HsQTvs
+        (NoExt)
+        [({ DumpParsedAst.hs:16:17-22 }
+          (KindedTyVar
+           (NoExt)
+           ({ DumpParsedAst.hs:16:17 }
+            (Unqual
+             {OccName: a}))
+           ({ DumpParsedAst.hs:16:22 }
+            (HsTyVar
+             (NoExt)
+             (NotPromoted)
+             ({ DumpParsedAst.hs:16:22 }
+              (Unqual
+               {OccName: k}))))))
+        ,({ DumpParsedAst.hs:16:26-39 }
+          (KindedTyVar
+           (NoExt)
+           ({ DumpParsedAst.hs:16:26 }
+            (Unqual
+             {OccName: f}))
+           ({ DumpParsedAst.hs:16:31-39 }
+            (HsFunTy
+             (NoExt)
+             ({ DumpParsedAst.hs:16:31 }
+              (HsTyVar
+               (NoExt)
+               (NotPromoted)
+               ({ DumpParsedAst.hs:16:31 }
+                (Unqual
+                 {OccName: k}))))
+             ({ DumpParsedAst.hs:16:36-39 }
+              (HsTyVar
+               (NoExt)
+               (NotPromoted)
+               ({ DumpParsedAst.hs:16:36-39 }
+                (Unqual
+                 {OccName: Type}))))))))])
+       (Prefix)
+       ({ DumpParsedAst.hs:16:42-48 }
+        (KindSig
+         (NoExt)
+         ({ DumpParsedAst.hs:16:45-48 }
+          (HsTyVar
+           (NoExt)
+           (NotPromoted)
+           ({ DumpParsedAst.hs:16:45-48 }
+            (Unqual
+             {OccName: Type}))))))
+       (Nothing)))))
+  ,({ DumpParsedAst.hs:19:1-23 }
     (ValD
      (NoExt)
      (FunBind
       (NoExt)
-      ({ DumpParsedAst.hs:11:1-4 }
+      ({ DumpParsedAst.hs:19:1-4 }
        (Unqual
         {OccName: main}))
       (MG
        (NoExt)
-       ({ DumpParsedAst.hs:11:1-23 }
-        [({ DumpParsedAst.hs:11:1-23 }
+       ({ DumpParsedAst.hs:19:1-23 }
+        [({ DumpParsedAst.hs:19:1-23 }
           (Match
            (NoExt)
            (FunRhs
-            ({ DumpParsedAst.hs:11:1-4 }
+            ({ DumpParsedAst.hs:19:1-4 }
              (Unqual
               {OccName: main}))
             (Prefix)
            []
            (GRHSs
             (NoExt)
-            [({ DumpParsedAst.hs:11:6-23 }
+            [({ DumpParsedAst.hs:19:6-23 }
               (GRHS
                (NoExt)
                []
-               ({ DumpParsedAst.hs:11:8-23 }
+               ({ DumpParsedAst.hs:19:8-23 }
                 (HsApp
                  (NoExt)
-                 ({ DumpParsedAst.hs:11:8-15 }
+                 ({ DumpParsedAst.hs:19:8-15 }
                   (HsVar
                    (NoExt)
-                   ({ DumpParsedAst.hs:11:8-15 }
+                   ({ DumpParsedAst.hs:19:8-15 }
                     (Unqual
                      {OccName: putStrLn}))))
-                 ({ DumpParsedAst.hs:11:17-23 }
+                 ({ DumpParsedAst.hs:19:17-23 }
                   (HsLit
                    (NoExt)
                    (HsString
index c617feb..d5be862 100644 (file)
@@ -1,7 +1,8 @@
 {-# LANGUAGE DataKinds, GADTs, PolyKinds, RankNTypes, TypeOperators,
-             TypeFamilies #-}
+             TypeFamilies, StarIsType, TypeApplications #-}
 
 module DumpRenamedAst where
+import Data.Kind
 
 import Data.Kind (Type)
 
@@ -17,4 +18,9 @@ data family Nat :: k -> k -> Type
 newtype instance Nat (a :: k -> Type) :: (k -> Type) -> Type where
   Nat :: (forall xx. f xx -> g xx) -> Nat f g
 
+data T f (a :: k) = MkT (f a)
+
+type family F1 (a :: k) (f :: k -> Type) :: Type where
+  F1 @Peano a f = T @Peano f a
+
 main = putStrLn "hello"
index 5a35b00..8df66c8 100644 (file)
      [((,)
        (NonRecursive)
        {Bag(Located (HsBind Name)):
-        [({ DumpRenamedAst.hs:20:1-23 }
+        [({ DumpRenamedAst.hs:26:1-23 }
           (FunBind
            {NameSet:
             []}
-           ({ DumpRenamedAst.hs:20:1-4 }
+           ({ DumpRenamedAst.hs:26:1-4 }
             {Name: DumpRenamedAst.main})
            (MG
             (NoExt)
-            ({ DumpRenamedAst.hs:20:1-23 }
-             [({ DumpRenamedAst.hs:20:1-23 }
+            ({ DumpRenamedAst.hs:26:1-23 }
+             [({ DumpRenamedAst.hs:26:1-23 }
                (Match
                 (NoExt)
                 (FunRhs
-                 ({ DumpRenamedAst.hs:20:1-4 }
+                 ({ DumpRenamedAst.hs:26:1-4 }
                   {Name: DumpRenamedAst.main})
                  (Prefix)
                  (NoSrcStrict))
                 []
                 (GRHSs
                  (NoExt)
-                 [({ DumpRenamedAst.hs:20:6-23 }
+                 [({ DumpRenamedAst.hs:26:6-23 }
                    (GRHS
                     (NoExt)
                     []
-                    ({ DumpRenamedAst.hs:20:8-23 }
+                    ({ DumpRenamedAst.hs:26:8-23 }
                      (HsApp
                       (NoExt)
-                      ({ DumpRenamedAst.hs:20:8-15 }
+                      ({ DumpRenamedAst.hs:26:8-15 }
                        (HsVar
                         (NoExt)
-                        ({ DumpRenamedAst.hs:20:8-15 }
+                        ({ DumpRenamedAst.hs:26:8-15 }
                          {Name: System.IO.putStrLn})))
-                      ({ DumpRenamedAst.hs:20:17-23 }
+                      ({ DumpRenamedAst.hs:26:17-23 }
                        (HsLit
                         (NoExt)
                         (HsString
    []
    [(TyClGroup
      (NoExt)
-     [({ DumpRenamedAst.hs:8:1-30 }
+     [({ DumpRenamedAst.hs:9:1-30 }
        (DataDecl
         (DataDeclRn
          (True)
          {NameSet:
           [{Name: DumpRenamedAst.Peano}]})
-        ({ DumpRenamedAst.hs:8:6-10 }
+        ({ DumpRenamedAst.hs:9:6-10 }
          {Name: DumpRenamedAst.Peano})
         (HsQTvs
          (HsQTvsRn
           [])
          (Nothing)
          (Nothing)
-         [({ DumpRenamedAst.hs:8:14-17 }
+         [({ DumpRenamedAst.hs:9:14-17 }
            (ConDeclH98
             (NoExt)
-            ({ DumpRenamedAst.hs:8:14-17 }
+            ({ DumpRenamedAst.hs:9:14-17 }
              {Name: DumpRenamedAst.Zero})
             ({ <no location info> }
              (False))
             (PrefixCon
              [])
             (Nothing)))
-         ,({ DumpRenamedAst.hs:8:21-30 }
+         ,({ DumpRenamedAst.hs:9:21-30 }
            (ConDeclH98
             (NoExt)
-            ({ DumpRenamedAst.hs:8:21-24 }
+            ({ DumpRenamedAst.hs:9:21-24 }
              {Name: DumpRenamedAst.Succ})
             ({ <no location info> }
              (False))
             []
             (Nothing)
             (PrefixCon
-             [({ DumpRenamedAst.hs:8:26-30 }
+             [({ DumpRenamedAst.hs:9:26-30 }
                (HsTyVar
                 (NoExt)
                 (NotPromoted)
-                ({ DumpRenamedAst.hs:8:26-30 }
+                ({ DumpRenamedAst.hs:9:26-30 }
                  {Name: DumpRenamedAst.Peano})))])
             (Nothing)))]
          ({ <no location info> }
      [])
    ,(TyClGroup
      (NoExt)
-     [({ DumpRenamedAst.hs:10:1-39 }
+     [({ DumpRenamedAst.hs:11:1-39 }
        (FamDecl
         (NoExt)
         (FamilyDecl
          (NoExt)
          (ClosedTypeFamily
           (Just
-           [({ DumpRenamedAst.hs:11:3-36 }
+           [({ DumpRenamedAst.hs:12:3-36 }
              (HsIB
               [{Name: a}
               ,{Name: as}]
               (FamEqn
                (NoExt)
-               ({ DumpRenamedAst.hs:11:3-8 }
+               ({ DumpRenamedAst.hs:12:3-8 }
                 {Name: DumpRenamedAst.Length})
                (Nothing)
-               [({ DumpRenamedAst.hs:11:10-17 }
-                 (HsParTy
-                  (NoExt)
-                  ({ DumpRenamedAst.hs:11:11-16 }
-                   (HsOpTy
-                    (NoExt)
-                    ({ DumpRenamedAst.hs:11:11 }
-                     (HsTyVar
-                      (NoExt)
-                      (NotPromoted)
-                      ({ DumpRenamedAst.hs:11:11 }
-                       {Name: a})))
-                    ({ DumpRenamedAst.hs:11:13 }
-                     {Name: :})
-                    ({ DumpRenamedAst.hs:11:15-16 }
-                     (HsTyVar
-                      (NoExt)
-                      (NotPromoted)
-                      ({ DumpRenamedAst.hs:11:15-16 }
-                       {Name: as})))))))]
+               [(HsValArg
+                 ({ DumpRenamedAst.hs:12:10-17 }
+                  (HsParTy
+                   (NoExt)
+                   ({ DumpRenamedAst.hs:12:11-16 }
+                    (HsOpTy
+                     (NoExt)
+                     ({ DumpRenamedAst.hs:12:11 }
+                      (HsTyVar
+                       (NoExt)
+                       (NotPromoted)
+                       ({ DumpRenamedAst.hs:12:11 }
+                        {Name: a})))
+                     ({ DumpRenamedAst.hs:12:13 }
+                      {Name: :})
+                     ({ DumpRenamedAst.hs:12:15-16 }
+                      (HsTyVar
+                       (NoExt)
+                       (NotPromoted)
+                       ({ DumpRenamedAst.hs:12:15-16 }
+                        {Name: as}))))))))]
                (Prefix)
-               ({ DumpRenamedAst.hs:11:21-36 }
+               ({ DumpRenamedAst.hs:12:21-36 }
                 (HsAppTy
                  (NoExt)
-                 ({ DumpRenamedAst.hs:11:21-24 }
+                 ({ DumpRenamedAst.hs:12:21-24 }
                   (HsTyVar
                    (NoExt)
                    (NotPromoted)
-                   ({ DumpRenamedAst.hs:11:21-24 }
+                   ({ DumpRenamedAst.hs:12:21-24 }
                     {Name: DumpRenamedAst.Succ})))
-                 ({ DumpRenamedAst.hs:11:26-36 }
+                 ({ DumpRenamedAst.hs:12:26-36 }
                   (HsParTy
                    (NoExt)
-                   ({ DumpRenamedAst.hs:11:27-35 }
+                   ({ DumpRenamedAst.hs:12:27-35 }
                     (HsAppTy
                      (NoExt)
-                     ({ DumpRenamedAst.hs:11:27-32 }
+                     ({ DumpRenamedAst.hs:12:27-32 }
                       (HsTyVar
                        (NoExt)
                        (NotPromoted)
-                       ({ DumpRenamedAst.hs:11:27-32 }
+                       ({ DumpRenamedAst.hs:12:27-32 }
                         {Name: DumpRenamedAst.Length})))
-                     ({ DumpRenamedAst.hs:11:34-35 }
+                     ({ DumpRenamedAst.hs:12:34-35 }
                       (HsTyVar
                        (NoExt)
                        (NotPromoted)
-                       ({ DumpRenamedAst.hs:11:34-35 }
+                       ({ DumpRenamedAst.hs:12:34-35 }
                         {Name: as}))))))))))))
-           ,({ DumpRenamedAst.hs:12:3-24 }
+           ,({ DumpRenamedAst.hs:13:3-24 }
              (HsIB
               []
               (FamEqn
                (NoExt)
-               ({ DumpRenamedAst.hs:12:3-8 }
+               ({ DumpRenamedAst.hs:13:3-8 }
                 {Name: DumpRenamedAst.Length})
                (Nothing)
-               [({ DumpRenamedAst.hs:12:10-12 }
-                 (HsExplicitListTy
-                  (NoExt)
-                  (IsPromoted)
-                  []))]
+               [(HsValArg
+                 ({ DumpRenamedAst.hs:13:10-12 }
+                  (HsExplicitListTy
+                   (NoExt)
+                   (IsPromoted)
+                   [])))]
                (Prefix)
-               ({ DumpRenamedAst.hs:12:21-24 }
+               ({ DumpRenamedAst.hs:13:21-24 }
                 (HsTyVar
                  (NoExt)
                  (NotPromoted)
-                 ({ DumpRenamedAst.hs:12:21-24 }
+                 ({ DumpRenamedAst.hs:13:21-24 }
                   {Name: DumpRenamedAst.Zero}))))))]))
-         ({ DumpRenamedAst.hs:10:13-18 }
+         ({ DumpRenamedAst.hs:11:13-18 }
           {Name: DumpRenamedAst.Length})
          (HsQTvs
           (HsQTvsRn
            [{Name: k}]
            {NameSet:
             []})
-          [({ DumpRenamedAst.hs:10:21-29 }
+          [({ DumpRenamedAst.hs:11:21-29 }
             (KindedTyVar
              (NoExt)
-             ({ DumpRenamedAst.hs:10:21-22 }
+             ({ DumpRenamedAst.hs:11:21-22 }
               {Name: as})
-             ({ DumpRenamedAst.hs:10:27-29 }
+             ({ DumpRenamedAst.hs:11:27-29 }
               (HsListTy
                (NoExt)
-               ({ DumpRenamedAst.hs:10:28 }
+               ({ DumpRenamedAst.hs:11:28 }
                 (HsTyVar
                  (NoExt)
                  (NotPromoted)
-                 ({ DumpRenamedAst.hs:10:28 }
+                 ({ DumpRenamedAst.hs:11:28 }
                   {Name: k})))))))])
          (Prefix)
-         ({ DumpRenamedAst.hs:10:32-39 }
+         ({ DumpRenamedAst.hs:11:32-39 }
           (KindSig
            (NoExt)
-           ({ DumpRenamedAst.hs:10:35-39 }
+           ({ DumpRenamedAst.hs:11:35-39 }
             (HsTyVar
              (NoExt)
              (NotPromoted)
-             ({ DumpRenamedAst.hs:10:35-39 }
+             ({ DumpRenamedAst.hs:11:35-39 }
               {Name: DumpRenamedAst.Peano})))))
          (Nothing))))]
      []
      [])
    ,(TyClGroup
      (NoExt)
-     [({ DumpRenamedAst.hs:14:1-33 }
+     [({ DumpRenamedAst.hs:15:1-33 }
        (FamDecl
         (NoExt)
         (FamilyDecl
          (NoExt)
          (DataFamily)
-         ({ DumpRenamedAst.hs:14:13-15 }
+         ({ DumpRenamedAst.hs:15:13-15 }
           {Name: DumpRenamedAst.Nat})
          (HsQTvs
           (HsQTvsRn
             []})
           [])
          (Prefix)
-         ({ DumpRenamedAst.hs:14:17-33 }
+         ({ DumpRenamedAst.hs:15:17-33 }
           (KindSig
            (NoExt)
-           ({ DumpRenamedAst.hs:14:20-33 }
+           ({ DumpRenamedAst.hs:15:20-33 }
             (HsFunTy
              (NoExt)
-             ({ DumpRenamedAst.hs:14:20 }
+             ({ DumpRenamedAst.hs:15:20 }
               (HsTyVar
                (NoExt)
                (NotPromoted)
-               ({ DumpRenamedAst.hs:14:20 }
+               ({ DumpRenamedAst.hs:15:20 }
                 {Name: k})))
-             ({ DumpRenamedAst.hs:14:25-33 }
+             ({ DumpRenamedAst.hs:15:25-33 }
               (HsFunTy
                (NoExt)
-               ({ DumpRenamedAst.hs:14:25 }
+               ({ DumpRenamedAst.hs:15:25 }
                 (HsTyVar
                  (NoExt)
                  (NotPromoted)
-                 ({ DumpRenamedAst.hs:14:25 }
+                 ({ DumpRenamedAst.hs:15:25 }
                   {Name: k})))
-               ({ DumpRenamedAst.hs:14:30-33 }
+               ({ DumpRenamedAst.hs:15:30-33 }
                 (HsTyVar
                  (NoExt)
                  (NotPromoted)
-                 ({ DumpRenamedAst.hs:14:30-33 }
+                 ({ DumpRenamedAst.hs:15:30-33 }
                   {Name: GHC.Types.Type})))))))))
          (Nothing))))]
      []
-     [({ DumpRenamedAst.hs:(17,1)-(18,45) }
+     [({ DumpRenamedAst.hs:(18,1)-(19,45) }
        (DataFamInstD
         (NoExt)
         (DataFamInstDecl
           ,{Name: a}]
           (FamEqn
            (NoExt)
-           ({ DumpRenamedAst.hs:17:18-20 }
+           ({ DumpRenamedAst.hs:18:18-20 }
             {Name: DumpRenamedAst.Nat})
            (Nothing)
-           [({ DumpRenamedAst.hs:17:22-37 }
-             (HsParTy
-              (NoExt)
-              ({ DumpRenamedAst.hs:17:23-36 }
-               (HsKindSig
-                (NoExt)
-                ({ DumpRenamedAst.hs:17:23 }
-                 (HsTyVar
-                  (NoExt)
-                  (NotPromoted)
-                  ({ DumpRenamedAst.hs:17:23 }
-                   {Name: a})))
-                ({ DumpRenamedAst.hs:17:28-36 }
-                 (HsFunTy
-                  (NoExt)
-                  ({ DumpRenamedAst.hs:17:28 }
-                   (HsTyVar
-                    (NoExt)
-                    (NotPromoted)
-                    ({ DumpRenamedAst.hs:17:28 }
-                     {Name: k})))
-                  ({ DumpRenamedAst.hs:17:33-36 }
-                   (HsTyVar
-                    (NoExt)
-                    (NotPromoted)
-                    ({ DumpRenamedAst.hs:17:33-36 }
-                     {Name: GHC.Types.Type})))))))))]
+           [(HsValArg
+             ({ DumpRenamedAst.hs:18:22-37 }
+              (HsParTy
+               (NoExt)
+               ({ DumpRenamedAst.hs:18:23-36 }
+                (HsKindSig
+                 (NoExt)
+                 ({ DumpRenamedAst.hs:18:23 }
+                  (HsTyVar
+                   (NoExt)
+                   (NotPromoted)
+                   ({ DumpRenamedAst.hs:18:23 }
+                    {Name: a})))
+                 ({ DumpRenamedAst.hs:18:28-36 }
+                  (HsFunTy
+                   (NoExt)
+                   ({ DumpRenamedAst.hs:18:28 }
+                    (HsTyVar
+                     (NoExt)
+                     (NotPromoted)
+                     ({ DumpRenamedAst.hs:18:28 }
+                      {Name: k})))
+                   ({ DumpRenamedAst.hs:18:33-36 }
+                    (HsTyVar
+                     (NoExt)
+                     (NotPromoted)
+                     ({ DumpRenamedAst.hs:18:33-36 }
+                      {Name: GHC.Types.Type}))))))))))]
            (Prefix)
            (HsDataDefn
             (NoExt)
              [])
             (Nothing)
             (Just
-             ({ DumpRenamedAst.hs:17:42-60 }
+             ({ DumpRenamedAst.hs:18:42-60 }
               (HsFunTy
                (NoExt)
-               ({ DumpRenamedAst.hs:17:42-52 }
+               ({ DumpRenamedAst.hs:18:42-52 }
                 (HsParTy
                  (NoExt)
-                 ({ DumpRenamedAst.hs:17:43-51 }
+                 ({ DumpRenamedAst.hs:18:43-51 }
                   (HsFunTy
                    (NoExt)
-                   ({ DumpRenamedAst.hs:17:43 }
+                   ({ DumpRenamedAst.hs:18:43 }
                     (HsTyVar
                      (NoExt)
                      (NotPromoted)
-                     ({ DumpRenamedAst.hs:17:43 }
+                     ({ DumpRenamedAst.hs:18:43 }
                       {Name: k})))
-                   ({ DumpRenamedAst.hs:17:48-51 }
+                   ({ DumpRenamedAst.hs:18:48-51 }
                     (HsTyVar
                      (NoExt)
                      (NotPromoted)
-                     ({ DumpRenamedAst.hs:17:48-51 }
+                     ({ DumpRenamedAst.hs:18:48-51 }
                       {Name: GHC.Types.Type})))))))
-               ({ DumpRenamedAst.hs:17:57-60 }
+               ({ DumpRenamedAst.hs:18:57-60 }
                 (HsTyVar
                  (NoExt)
                  (NotPromoted)
-                 ({ DumpRenamedAst.hs:17:57-60 }
+                 ({ DumpRenamedAst.hs:18:57-60 }
                   {Name: GHC.Types.Type}))))))
-            [({ DumpRenamedAst.hs:18:3-45 }
+            [({ DumpRenamedAst.hs:19:3-45 }
               (ConDeclGADT
                (NoExt)
-               [({ DumpRenamedAst.hs:18:3-5 }
+               [({ DumpRenamedAst.hs:19:3-5 }
                  {Name: DumpRenamedAst.Nat})]
-               ({ DumpRenamedAst.hs:18:10-45 }
+               ({ DumpRenamedAst.hs:19:10-45 }
                 (False))
                (HsQTvs
                 (HsQTvsRn
                 [])
                (Nothing)
                (PrefixCon
-                [({ DumpRenamedAst.hs:18:10-34 }
+                [({ DumpRenamedAst.hs:19:10-34 }
                   (HsParTy
                    (NoExt)
-                   ({ DumpRenamedAst.hs:18:11-33 }
+                   ({ DumpRenamedAst.hs:19:11-33 }
                     (HsForAllTy
                      (NoExt)
-                     [({ DumpRenamedAst.hs:18:18-19 }
+                     [({ DumpRenamedAst.hs:19:18-19 }
                        (UserTyVar
                         (NoExt)
-                        ({ DumpRenamedAst.hs:18:18-19 }
+                        ({ DumpRenamedAst.hs:19:18-19 }
                          {Name: xx})))]
-                     ({ DumpRenamedAst.hs:18:22-33 }
+                     ({ DumpRenamedAst.hs:19:22-33 }
                       (HsFunTy
                        (NoExt)
-                       ({ DumpRenamedAst.hs:18:22-25 }
+                       ({ DumpRenamedAst.hs:19:22-25 }
                         (HsAppTy
                          (NoExt)
-                         ({ DumpRenamedAst.hs:18:22 }
+                         ({ DumpRenamedAst.hs:19:22 }
                           (HsTyVar
                            (NoExt)
                            (NotPromoted)
-                           ({ DumpRenamedAst.hs:18:22 }
+                           ({ DumpRenamedAst.hs:19:22 }
                             {Name: f})))
-                         ({ DumpRenamedAst.hs:18:24-25 }
+                         ({ DumpRenamedAst.hs:19:24-25 }
                           (HsTyVar
                            (NoExt)
                            (NotPromoted)
-                           ({ DumpRenamedAst.hs:18:24-25 }
+                           ({ DumpRenamedAst.hs:19:24-25 }
                             {Name: xx})))))
-                       ({ DumpRenamedAst.hs:18:30-33 }
+                       ({ DumpRenamedAst.hs:19:30-33 }
                         (HsAppTy
                          (NoExt)
-                         ({ DumpRenamedAst.hs:18:30 }
+                         ({ DumpRenamedAst.hs:19:30 }
                           (HsTyVar
                            (NoExt)
                            (NotPromoted)
-                           ({ DumpRenamedAst.hs:18:30 }
+                           ({ DumpRenamedAst.hs:19:30 }
                             {Name: g})))
-                         ({ DumpRenamedAst.hs:18:32-33 }
+                         ({ DumpRenamedAst.hs:19:32-33 }
                           (HsTyVar
                            (NoExt)
                            (NotPromoted)
-                           ({ DumpRenamedAst.hs:18:32-33 }
+                           ({ DumpRenamedAst.hs:19:32-33 }
                             {Name: xx})))))))))))])
-               ({ DumpRenamedAst.hs:18:39-45 }
+               ({ DumpRenamedAst.hs:19:39-45 }
                 (HsAppTy
                  (NoExt)
-                 ({ DumpRenamedAst.hs:18:39-43 }
+                 ({ DumpRenamedAst.hs:19:39-43 }
                   (HsAppTy
                    (NoExt)
-                   ({ DumpRenamedAst.hs:18:39-41 }
+                   ({ DumpRenamedAst.hs:19:39-41 }
                     (HsTyVar
                      (NoExt)
                      (NotPromoted)
-                     ({ DumpRenamedAst.hs:18:39-41 }
+                     ({ DumpRenamedAst.hs:19:39-41 }
                       {Name: DumpRenamedAst.Nat})))
-                   ({ DumpRenamedAst.hs:18:43 }
+                   ({ DumpRenamedAst.hs:19:43 }
                     (HsTyVar
                      (NoExt)
                      (NotPromoted)
-                     ({ DumpRenamedAst.hs:18:43 }
+                     ({ DumpRenamedAst.hs:19:43 }
                       {Name: f})))))
-                 ({ DumpRenamedAst.hs:18:45 }
+                 ({ DumpRenamedAst.hs:19:45 }
                   (HsTyVar
                    (NoExt)
                    (NotPromoted)
-                   ({ DumpRenamedAst.hs:18:45 }
+                   ({ DumpRenamedAst.hs:19:45 }
                     {Name: g})))))
                (Nothing)))]
             ({ <no location info> }
-             [])))))))])]
+             [])))))))])
+   ,(TyClGroup
+     (NoExt)
+     [({ DumpRenamedAst.hs:21:1-29 }
+       (DataDecl
+        (DataDeclRn
+         (False)
+         {NameSet:
+          [{Name: a}
+          ,{Name: f}]})
+        ({ DumpRenamedAst.hs:21:6 }
+         {Name: DumpRenamedAst.T})
+        (HsQTvs
+         (HsQTvsRn
+          [{Name: k}]
+          {NameSet:
+           []})
+         [({ DumpRenamedAst.hs:21:8 }
+           (UserTyVar
+            (NoExt)
+            ({ DumpRenamedAst.hs:21:8 }
+             {Name: f})))
+         ,({ DumpRenamedAst.hs:21:11-16 }
+           (KindedTyVar
+            (NoExt)
+            ({ DumpRenamedAst.hs:21:11 }
+             {Name: a})
+            ({ DumpRenamedAst.hs:21:16 }
+             (HsTyVar
+              (NoExt)
+              (NotPromoted)
+              ({ DumpRenamedAst.hs:21:16 }
+               {Name: k})))))])
+        (Prefix)
+        (HsDataDefn
+         (NoExt)
+         (DataType)
+         ({ <no location info> }
+          [])
+         (Nothing)
+         (Nothing)
+         [({ DumpRenamedAst.hs:21:21-29 }
+           (ConDeclH98
+            (NoExt)
+            ({ DumpRenamedAst.hs:21:21-23 }
+             {Name: DumpRenamedAst.MkT})
+            ({ <no location info> }
+             (False))
+            []
+            (Nothing)
+            (PrefixCon
+             [({ DumpRenamedAst.hs:21:25-29 }
+               (HsParTy
+                (NoExt)
+                ({ DumpRenamedAst.hs:21:26-28 }
+                 (HsAppTy
+                  (NoExt)
+                  ({ DumpRenamedAst.hs:21:26 }
+                   (HsTyVar
+                    (NoExt)
+                    (NotPromoted)
+                    ({ DumpRenamedAst.hs:21:26 }
+                     {Name: f})))
+                  ({ DumpRenamedAst.hs:21:28 }
+                   (HsTyVar
+                    (NoExt)
+                    (NotPromoted)
+                    ({ DumpRenamedAst.hs:21:28 }
+                     {Name: a})))))))])
+            (Nothing)))]
+         ({ <no location info> }
+          []))))]
+     []
+     [])
+   ,(TyClGroup
+     (NoExt)
+     [({ DumpRenamedAst.hs:23:1-48 }
+       (FamDecl
+        (NoExt)
+        (FamilyDecl
+         (NoExt)
+         (ClosedTypeFamily
+          (Just
+           [({ DumpRenamedAst.hs:24:3-30 }
+             (HsIB
+              [{Name: a}
+              ,{Name: f}]
+              (FamEqn
+               (NoExt)
+               ({ DumpRenamedAst.hs:24:3-4 }
+                {Name: DumpRenamedAst.F1})
+               (Nothing)
+               [(HsTypeArg
+                 ({ DumpRenamedAst.hs:24:7-11 }
+                  (HsTyVar
+                   (NoExt)
+                   (NotPromoted)
+                   ({ DumpRenamedAst.hs:24:7-11 }
+                    {Name: DumpRenamedAst.Peano}))))
+               ,(HsValArg
+                 ({ DumpRenamedAst.hs:24:13 }
+                  (HsTyVar
+                   (NoExt)
+                   (NotPromoted)
+                   ({ DumpRenamedAst.hs:24:13 }
+                    {Name: a}))))
+               ,(HsValArg
+                 ({ DumpRenamedAst.hs:24:15 }
+                  (HsTyVar
+                   (NoExt)
+                   (NotPromoted)
+                   ({ DumpRenamedAst.hs:24:15 }
+                    {Name: f}))))]
+               (Prefix)
+               ({ DumpRenamedAst.hs:24:19-30 }
+                (HsAppTy
+                 (NoExt)
+                 ({ DumpRenamedAst.hs:24:19-28 }
+                  (HsAppTy
+                   (NoExt)
+                   ({ DumpRenamedAst.hs:24:19-26 }
+                    (HsAppKindTy
+                     (NoExt)
+                     ({ DumpRenamedAst.hs:24:19 }
+                      (HsTyVar
+                       (NoExt)
+                       (NotPromoted)
+                       ({ DumpRenamedAst.hs:24:19 }
+                        {Name: DumpRenamedAst.T})))
+                     ({ DumpRenamedAst.hs:24:22-26 }
+                      (HsTyVar
+                       (NoExt)
+                       (NotPromoted)
+                       ({ DumpRenamedAst.hs:24:22-26 }
+                        {Name: DumpRenamedAst.Peano})))))
+                   ({ DumpRenamedAst.hs:24:28 }
+                    (HsTyVar
+                     (NoExt)
+                     (NotPromoted)
+                     ({ DumpRenamedAst.hs:24:28 }
+                      {Name: f})))))
+                 ({ DumpRenamedAst.hs:24:30 }
+                  (HsTyVar
+                   (NoExt)
+                   (NotPromoted)
+                   ({ DumpRenamedAst.hs:24:30 }
+                    {Name: a}))))))))]))
+         ({ DumpRenamedAst.hs:23:13-14 }
+          {Name: DumpRenamedAst.F1})
+         (HsQTvs
+          (HsQTvsRn
+           [{Name: k}]
+           {NameSet:
+            []})
+          [({ DumpRenamedAst.hs:23:17-22 }
+            (KindedTyVar
+             (NoExt)
+             ({ DumpRenamedAst.hs:23:17 }
+              {Name: a})
+             ({ DumpRenamedAst.hs:23:22 }
+              (HsTyVar
+               (NoExt)
+               (NotPromoted)
+               ({ DumpRenamedAst.hs:23:22 }
+                {Name: k})))))
+          ,({ DumpRenamedAst.hs:23:26-39 }
+            (KindedTyVar
+             (NoExt)
+             ({ DumpRenamedAst.hs:23:26 }
+              {Name: f})
+             ({ DumpRenamedAst.hs:23:31-39 }
+              (HsFunTy
+               (NoExt)
+               ({ DumpRenamedAst.hs:23:31 }
+                (HsTyVar
+                 (NoExt)
+                 (NotPromoted)
+                 ({ DumpRenamedAst.hs:23:31 }
+                  {Name: k})))
+               ({ DumpRenamedAst.hs:23:36-39 }
+                (HsTyVar
+                 (NoExt)
+                 (NotPromoted)
+                 ({ DumpRenamedAst.hs:23:36-39 }
+                  {Name: GHC.Types.Type})))))))])
+         (Prefix)
+         ({ DumpRenamedAst.hs:23:42-48 }
+          (KindSig
+           (NoExt)
+           ({ DumpRenamedAst.hs:23:45-48 }
+            (HsTyVar
+             (NoExt)
+             (NotPromoted)
+             ({ DumpRenamedAst.hs:23:45-48 }
+              {Name: GHC.Types.Type})))))
+         (Nothing))))]
+     []
+     [])]
    []
    []
    []
      (True)
      (Nothing)
      (Nothing)))
-  ,({ DumpRenamedAst.hs:6:1-23 }
+  ,({ DumpRenamedAst.hs:5:1-16 }
+    (ImportDecl
+     (NoExt)
+     (NoSourceText)
+     ({ DumpRenamedAst.hs:5:8-16 }
+      {ModuleName: Data.Kind})
+     (Nothing)
+     (False)
+     (False)
+     (False)
+     (False)
+     (Nothing)
+     (Nothing)))
+  ,({ DumpRenamedAst.hs:7:1-23 }
     (ImportDecl
      (NoExt)
      (NoSourceText)
-     ({ DumpRenamedAst.hs:6:8-16 }
+     ({ DumpRenamedAst.hs:7:8-16 }
       {ModuleName: Data.Kind})
      (Nothing)
      (False)
      (Just
       ((,)
        (False)
-       ({ DumpRenamedAst.hs:6:18-23 }
-        [({ DumpRenamedAst.hs:6:19-22 }
+       ({ DumpRenamedAst.hs:7:18-23 }
+        [({ DumpRenamedAst.hs:7:19-22 }
           (IEThingAbs
            (NoExt)
-           ({ DumpRenamedAst.hs:6:19-22 }
+           ({ DumpRenamedAst.hs:7:19-22 }
             (IEName
-             ({ DumpRenamedAst.hs:6:19-22 }
+             ({ DumpRenamedAst.hs:7:19-22 }
               {Name: GHC.Types.Type})))))])))))]
   (Nothing)
   (Nothing)))
index 3588764..82cf107 100644 (file)
@@ -1,6 +1,8 @@
-{-# LANGUAGE DataKinds, PolyKinds, TypeOperators, TypeFamilies #-}
+{-# LANGUAGE DataKinds, PolyKinds, TypeOperators, TypeFamilies
+             , TypeApplications #-}
 
 module DumpTypecheckedAst where
+import Data.Kind
 
 data Peano = Zero | Succ Peano
 
@@ -8,4 +10,9 @@ type family Length (as :: [k]) :: Peano where
   Length (a : as) = Succ (Length as)
   Length '[]      = Zero
 
+data T f (a :: k) = MkT (f a)
+
+type family F (a :: k) (f :: k -> Type) :: Type where
+  F @Peano a f = T @Peano f a
+
 main = putStrLn "hello"
index 8e3e868..7c6bfd7 100644 (file)
@@ -5,6 +5,138 @@
  [({ <no location info> }
    (VarBind
     (NoExt)
+    {Var: DumpTypecheckedAst.$tcT}
+    ({ <no location info> }
+     (HsApp
+      (NoExt)
+      ({ <no location info> }
+       (HsApp
+        (NoExt)
+        ({ <no location info> }
+         (HsApp
+          (NoExt)
+          ({ <no location info> }
+           (HsApp
+            (NoExt)
+            ({ <no location info> }
+             (HsApp
+              (NoExt)
+              ({ <no location info> }
+               (HsApp
+                (NoExt)
+                ({ <no location info> }
+                 (HsConLikeOut
+                  (NoExt)
+                  ({abstract:ConLike})))
+                ({ <no location info> }
+                 (HsLit
+                  (NoExt)
+                  {HsWord{64}Prim (1374752024144278257) (NoSourceText)}))))
+              ({ <no location info> }
+               (HsLit
+                (NoExt)
+                {HsWord{64}Prim (13654949607623281177) (NoSourceText)}))))
+            ({ <no location info> }
+             (HsVar
+              (NoExt)
+              ({ <no location info> }
+               {Var: DumpTypecheckedAst.$trModule})))))
+          ({ <no location info> }
+           (HsPar
+            (NoExt)
+            ({ <no location info> }
+             (HsApp
+              (NoExt)
+              ({ <no location info> }
+               (HsConLikeOut
+                (NoExt)
+                ({abstract:ConLike})))
+              ({ <no location info> }
+               (HsLit
+                (NoExt)
+                (HsStringPrim
+                 (NoSourceText)
+                 "T")))))))))
+        ({ <no location info> }
+         (HsLit
+          (NoExt)
+          {HsInt{64}Prim (1) (SourceText
+                              "1")}))))
+      ({ <no location info> }
+       (HsVar
+        (NoExt)
+        ({ <no location info> }
+         {Var: $krep})))))
+    (False)))
+ ,({ <no location info> }
+   (VarBind
+    (NoExt)
+    {Var: DumpTypecheckedAst.$tc'MkT}
+    ({ <no location info> }
+     (HsApp
+      (NoExt)
+      ({ <no location info> }
+       (HsApp
+        (NoExt)
+        ({ <no location info> }
+         (HsApp
+          (NoExt)
+          ({ <no location info> }
+           (HsApp
+            (NoExt)
+            ({ <no location info> }
+             (HsApp
+              (NoExt)
+              ({ <no location info> }
+               (HsApp
+                (NoExt)
+                ({ <no location info> }
+                 (HsConLikeOut
+                  (NoExt)
+                  ({abstract:ConLike})))
+                ({ <no location info> }
+                 (HsLit
+                  (NoExt)
+                  {HsWord{64}Prim (10715337633704422415) (NoSourceText)}))))
+              ({ <no location info> }
+               (HsLit
+                (NoExt)
+                {HsWord{64}Prim (12411373583424111944) (NoSourceText)}))))
+            ({ <no location info> }
+             (HsVar
+              (NoExt)
+              ({ <no location info> }
+               {Var: DumpTypecheckedAst.$trModule})))))
+          ({ <no location info> }
+           (HsPar
+            (NoExt)
+            ({ <no location info> }
+             (HsApp
+              (NoExt)
+              ({ <no location info> }
+               (HsConLikeOut
+                (NoExt)
+                ({abstract:ConLike})))
+              ({ <no location info> }
+               (HsLit
+                (NoExt)
+                (HsStringPrim
+                 (NoSourceText)
+                 "'MkT")))))))))
+        ({ <no location info> }
+         (HsLit
+          (NoExt)
+          {HsInt{64}Prim (3) (SourceText
+                              "3")}))))
+      ({ <no location info> }
+       (HsVar
+        (NoExt)
+        ({ <no location info> }
+         {Var: $krep})))))
+    (False)))
+ ,({ <no location info> }
+   (VarBind
+    (NoExt)
     {Var: DumpTypecheckedAst.$tcPeano}
     ({ <no location info> }
      (HsApp
      (HsApp
       (NoExt)
       ({ <no location info> }
+       (HsConLikeOut
+        (NoExt)
+        ({abstract:ConLike})))
+      ({ <no location info> }
+       (HsLit
+        (NoExt)
+        (HsInt
+         (NoExt)
+         (IL
+          (SourceText
+           "2")
+          (False)
+          (2)))))))
+    (False)))
+ ,({ <no location info> }
+   (VarBind
+    (NoExt)
+    {Var: $krep}
+    ({ <no location info> }
+     (HsApp
+      (NoExt)
+      ({ <no location info> }
+       (HsConLikeOut
+        (NoExt)
+        ({abstract:ConLike})))
+      ({ <no location info> }
+       (HsLit
+        (NoExt)
+        (HsInt
+         (NoExt)
+         (IL
+          (SourceText
+           "1")
+          (False)
+          (1)))))))
+    (False)))
+ ,({ <no location info> }
+   (VarBind
+    (NoExt)
+    {Var: $krep}
+    ({ <no location info> }
+     (HsApp
+      (NoExt)
+      ({ <no location info> }
+       (HsConLikeOut
+        (NoExt)
+        ({abstract:ConLike})))
+      ({ <no location info> }
+       (HsLit
+        (NoExt)
+        (HsInt
+         (NoExt)
+         (IL
+          (SourceText
+           "0")
+          (False)
+          (0)))))))
+    (False)))
+ ,({ <no location info> }
+   (VarBind
+    (NoExt)
+    {Var: $krep}
+    ({ <no location info> }
+     (HsApp
+      (NoExt)
+      ({ <no location info> }
+       (HsApp
+        (NoExt)
+        ({ <no location info> }
+         (HsConLikeOut
+          (NoExt)
+          ({abstract:ConLike})))
+        ({ <no location info> }
+         (HsVar
+          (NoExt)
+          ({ <no location info> }
+           {Var: $krep})))))
+      ({ <no location info> }
+       (HsVar
+        (NoExt)
+        ({ <no location info> }
+         {Var: $krep})))))
+    (False)))
+ ,({ <no location info> }
+   (VarBind
+    (NoExt)
+    {Var: $krep}
+    ({ <no location info> }
+     (HsApp
+      (NoExt)
+      ({ <no location info> }
+       (HsApp
+        (NoExt)
+        ({ <no location info> }
+         (HsConLikeOut
+          (NoExt)
+          ({abstract:ConLike})))
+        ({ <no location info> }
+         (HsVar
+          (NoExt)
+          ({ <no location info> }
+           {Var: $krep})))))
+      ({ <no location info> }
+       (HsVar
+        (NoExt)
+        ({ <no location info> }
+         {Var: GHC.Types.krep$*})))))
+    (False)))
+ ,({ <no location info> }
+   (VarBind
+    (NoExt)
+    {Var: $krep}
+    ({ <no location info> }
+     (HsApp
+      (NoExt)
+      ({ <no location info> }
+       (HsApp
+        (NoExt)
+        ({ <no location info> }
+         (HsConLikeOut
+          (NoExt)
+          ({abstract:ConLike})))
+        ({ <no location info> }
+         (HsVar
+          (NoExt)
+          ({ <no location info> }
+           {Var: $krep})))))
+      ({ <no location info> }
+       (HsVar
+        (NoExt)
+        ({ <no location info> }
+         {Var: $krep})))))
+    (False)))
+ ,({ <no location info> }
+   (VarBind
+    (NoExt)
+    {Var: $krep}
+    ({ <no location info> }
+     (HsApp
+      (NoExt)
+      ({ <no location info> }
        (HsApp
         (NoExt)
         ({ <no location info> }
          (HsVar
           (NoExt)
           ({ <no location info> }
+           {Var: $krep})))))
+      ({ <no location info> }
+       (HsVar
+        (NoExt)
+        ({ <no location info> }
+         {Var: $krep})))))
+    (False)))
+ ,({ <no location info> }
+   (VarBind
+    (NoExt)
+    {Var: $krep}
+    ({ <no location info> }
+     (HsApp
+      (NoExt)
+      ({ <no location info> }
+       (HsApp
+        (NoExt)
+        ({ <no location info> }
+         (HsConLikeOut
+          (NoExt)
+          ({abstract:ConLike})))
+        ({ <no location info> }
+         (HsVar
+          (NoExt)
+          ({ <no location info> }
+           {Var: DumpTypecheckedAst.$tcT})))))
+      ({ <no location info> }
+       (HsPar
+        (NoExt)
+        ({ <no location info> }
+         (HsApp
+          (NoExt)
+          ({ <no location info> }
+           (HsApp
+            (NoExt)
+            ({ <no location info> }
+             (HsWrap
+              (NoExt)
+              (WpTyApp
+               (TyConApp
+                ({abstract:TyCon})
+                []))
+              (HsConLikeOut
+               (NoExt)
+               ({abstract:ConLike}))))
+            ({ <no location info> }
+             (HsVar
+              (NoExt)
+              ({ <no location info> }
+               {Var: $krep})))))
+          ({ <no location info> }
+           (HsPar
+            (NoExt)
+            ({ <no location info> }
+             (HsApp
+              (NoExt)
+              ({ <no location info> }
+               (HsApp
+                (NoExt)
+                ({ <no location info> }
+                 (HsWrap
+                  (NoExt)
+                  (WpTyApp
+                   (TyConApp
+                    ({abstract:TyCon})
+                    []))
+                  (HsConLikeOut
+                   (NoExt)
+                   ({abstract:ConLike}))))
+                ({ <no location info> }
+                 (HsVar
+                  (NoExt)
+                  ({ <no location info> }
+                   {Var: $krep})))))
+              ({ <no location info> }
+               (HsPar
+                (NoExt)
+                ({ <no location info> }
+                 (HsApp
+                  (NoExt)
+                  ({ <no location info> }
+                   (HsApp
+                    (NoExt)
+                    ({ <no location info> }
+                     (HsWrap
+                      (NoExt)
+                      (WpTyApp
+                       (TyConApp
+                        ({abstract:TyCon})
+                        []))
+                      (HsConLikeOut
+                       (NoExt)
+                       ({abstract:ConLike}))))
+                    ({ <no location info> }
+                     (HsVar
+                      (NoExt)
+                      ({ <no location info> }
+                       {Var: $krep})))))
+                  ({ <no location info> }
+                   (HsWrap
+                    (NoExt)
+                    (WpTyApp
+                     (TyConApp
+                      ({abstract:TyCon})
+                      []))
+                    (HsConLikeOut
+                     (NoExt)
+                     ({abstract:ConLike}))))))))))))))))))
+    (False)))
+ ,({ <no location info> }
+   (VarBind
+    (NoExt)
+    {Var: $krep}
+    ({ <no location info> }
+     (HsApp
+      (NoExt)
+      ({ <no location info> }
+       (HsApp
+        (NoExt)
+        ({ <no location info> }
+         (HsConLikeOut
+          (NoExt)
+          ({abstract:ConLike})))
+        ({ <no location info> }
+         (HsVar
+          (NoExt)
+          ({ <no location info> }
            {Var: DumpTypecheckedAst.$tcPeano})))))
       ({ <no location info> }
        (HsWrap
              (NoSourceText)
              "DumpTypecheckedAst")))))))))
     (False)))
- ,({ DumpTypecheckedAst.hs:11:1-23 }
+ ,({ DumpTypecheckedAst.hs:18:1-23 }
    (AbsBinds
     (NoExt)
     []
        []))]
     [({abstract:TcEvBinds})]
     {Bag(Located (HsBind Var)):
-     [({ DumpTypecheckedAst.hs:11:1-23 }
+     [({ DumpTypecheckedAst.hs:18:1-23 }
        (FunBind
         {NameSet:
          []}
-        ({ DumpTypecheckedAst.hs:11:1-4 }
+        ({ DumpTypecheckedAst.hs:18:1-4 }
          {Var: main})
         (MG
          (MatchGroupTc
            [(TyConApp
              ({abstract:TyCon})
              [])]))
-         ({ DumpTypecheckedAst.hs:11:1-23 }
-          [({ DumpTypecheckedAst.hs:11:1-23 }
+         ({ DumpTypecheckedAst.hs:18:1-23 }
+          [({ DumpTypecheckedAst.hs:18:1-23 }
             (Match
              (NoExt)
              (FunRhs
-              ({ DumpTypecheckedAst.hs:11:1-4 }
+              ({ DumpTypecheckedAst.hs:18:1-4 }
                {Name: main})
               (Prefix)
               (NoSrcStrict))
              []
              (GRHSs
               (NoExt)
-              [({ DumpTypecheckedAst.hs:11:6-23 }
+              [({ DumpTypecheckedAst.hs:18:6-23 }
                 (GRHS
                  (NoExt)
                  []
-                 ({ DumpTypecheckedAst.hs:11:8-23 }
+                 ({ DumpTypecheckedAst.hs:18:8-23 }
                   (HsApp
                    (NoExt)
-                   ({ DumpTypecheckedAst.hs:11:8-15 }
+                   ({ DumpTypecheckedAst.hs:18:8-15 }
                     (HsVar
                      (NoExt)
                      ({ <no location info> }
                       {Var: putStrLn})))
-                   ({ DumpTypecheckedAst.hs:11:17-23 }
+                   ({ DumpTypecheckedAst.hs:18:17-23 }
                     (HsLit
                      (NoExt)
                      (HsString
index 125e880..8ea6ec5 100644 (file)
               (Unqual
                {OccName: Foo}))
              (Nothing)
-             [({ KindSigs.hs:12:7 }
-               (HsTyVar
-                (NoExt)
-                (NotPromoted)
-                ({ KindSigs.hs:12:7 }
-                 (Unqual
-                  {OccName: a}))))]
+             [(HsValArg
+               ({ KindSigs.hs:12:7 }
+                (HsTyVar
+                 (NoExt)
+                 (NotPromoted)
+                 ({ KindSigs.hs:12:7 }
+                  (Unqual
+                   {OccName: a})))))]
              (Prefix)
              ({ KindSigs.hs:12:11-21 }
               (HsKindSig
diff --git a/testsuite/tests/parser/should_compile/T12045e.hs b/testsuite/tests/parser/should_compile/T12045e.hs
new file mode 100644 (file)
index 0000000..1be903a
--- /dev/null
@@ -0,0 +1,13 @@
+{-# Language DataKinds             #-}
+{-# Language TypeApplications         #-}
+{-# Language PolyKinds             #-}
+
+module T12045e where
+
+import Data.Kind
+
+data Nat = Zero | Succ Nat
+data T (n :: k) = MkT
+data D1 n = T @Nat n :! ()
+data D2 n = () :!! T @Nat n
+data D3 n = T @Nat n :!!! T @Nat n
index a85b09c..b3f693d 100644 (file)
@@ -113,6 +113,7 @@ test('T11622', normal, compile, [''])
 test('DumpParsedAst',      normal, compile, ['-dsuppress-uniques -ddump-parsed-ast'])
 test('DumpRenamedAst',     normal, compile, ['-dsuppress-uniques -ddump-rn-ast'])
 test('DumpTypecheckedAst', normal, compile, ['-dsuppress-uniques -ddump-tc-ast'])
+test('T12045e', normal, compile, [''])
 test('T13087', normal, compile, [''])
 test('T13747', normal, compile, [''])
 test('T14189',     normal, compile, ['-dsuppress-uniques -ddump-rn-ast'])
diff --git a/testsuite/tests/parser/should_fail/T12045d.hs b/testsuite/tests/parser/should_fail/T12045d.hs
new file mode 100644 (file)
index 0000000..3c4b2a6
--- /dev/null
@@ -0,0 +1,11 @@
+{-# Language DataKinds             #-}
+{-# Language TypeApplications         #-}
+{-# Language PolyKinds             #-}
+
+module Bug where
+
+import Data.Kind
+
+data Nat = Zero | Succ Nat
+
+data D n = MkD @Nat Bool
diff --git a/testsuite/tests/parser/should_fail/T12045d.stderr b/testsuite/tests/parser/should_fail/T12045d.stderr
new file mode 100644 (file)
index 0000000..128cf58
--- /dev/null
@@ -0,0 +1,4 @@
+
+T12045d.hs:11:16: error:
+    Unexpected kind application in a data/newtype declaration:
+      MkD @Nat Bool
index f1f5122..2d7c241 100644 (file)
@@ -110,6 +110,7 @@ test('T13414', literate, compile_fail, [''])
 test('T8501a', normal, compile_fail, [''])
 test('T8501b', normal, compile_fail, [''])
 test('T8501c', normal, compile_fail, [''])
+test('T12045d', normal, compile_fail, [''])
 test('T12610', normal, compile_fail, [''])
 test('T13450', normal, compile_fail, [''])
 test('T13450TH', normal, compile_fail, [''])
index 008a1fc..beb850c 100644 (file)
@@ -1,5 +1,5 @@
 TYPE SIGNATURES
-  bravo :: forall w. Num w => w
+  bravo :: forall _. Num _ => _
 Dependent modules: []
 Dependent packages: [base-4.12.0.0, ghc-prim-0.5.3,
                      integer-gmp-1.0.2.0]
index 008a1fc..beb850c 100644 (file)
@@ -1,5 +1,5 @@
 TYPE SIGNATURES
-  bravo :: forall w. Num w => w
+  bravo :: forall _. Num _ => _
 Dependent modules: []
 Dependent packages: [base-4.12.0.0, ghc-prim-0.5.3,
                      integer-gmp-1.0.2.0]
index 86fe4a0..9769909 100644 (file)
@@ -1,5 +1,5 @@
 TYPE SIGNATURES
-  barry :: forall w. w -> (Either [Char] w, Either [Char] w)
+  barry :: forall _. _ -> (Either [Char] _, Either [Char] _)
 Dependent modules: []
 Dependent packages: [base-4.12.0.0, ghc-prim-0.5.3,
                      integer-gmp-1.0.2.0]
index e6f8a90..59e2054 100644 (file)
@@ -1,5 +1,5 @@
 TYPE SIGNATURES
-  every :: forall w. (w -> Bool) -> [w] -> Bool
+  every :: forall _. (_ -> Bool) -> [_] -> Bool
 Dependent modules: []
 Dependent packages: [base-4.12.0.0, ghc-prim-0.5.3,
                      integer-gmp-1.0.2.0]
index cfe5aeb..a6dbd5a 100644 (file)
@@ -4,14 +4,16 @@ ExprSigLocal.hs:9:35: warning: [-Wpartial-type-signatures (in -Wdefault)]
       Where: ‘a’ is a rigid type variable bound by
                the inferred type of <expression> :: a -> a
                at ExprSigLocal.hs:9:20-35
-    • In an expression type signature: forall a. a -> _
+    • In the type ‘a -> _’
+      In an expression type signature: forall a. a -> _
       In the expression: ((\ x -> x) :: forall a. a -> _)
-      In an equation for ‘y’: y = ((\ x -> x) :: forall a. a -> _)
     • Relevant bindings include
         y :: b -> b (bound at ExprSigLocal.hs:9:1)
 
 ExprSigLocal.hs:11:21: warning: [-Wpartial-type-signatures (in -Wdefault)]
     • Found type wildcard ‘_’ standing for ‘a’
       Where: ‘a’ is a rigid type variable bound by
-               the inferred type of g :: a -> a at ExprSigLocal.hs:12:1-7
-    • In the type signature: g :: forall a. a -> _
+               the inferred type of g :: a -> a
+               at ExprSigLocal.hs:12:1-7
+    • In the type ‘a -> _’
+      In the type signature: g :: forall a. a -> _
index c49b1a0..8bd167f 100644 (file)
@@ -125,12 +125,12 @@ TYPE SIGNATURES
     (P.Foldable t, Monad m) =>
     (a -> m b) -> t a -> m ()
   max :: forall a. Ord a => a -> a -> a
-  maxBound :: forall w. Bounded w => w
+  maxBound :: forall _. Bounded _ => _
   maximum ::
     forall (t :: * -> *) a. (P.Foldable t, Ord a) => t a -> a
   maybe :: forall b a. b -> (a -> b) -> Maybe a -> b
   min :: forall a. Ord a => a -> a -> a
-  minBound :: forall w. Bounded w => w
+  minBound :: forall _. Bounded _ => _
   minimum ::
     forall (t :: * -> *) a. (P.Foldable t, Ord a) => t a -> a
   mod :: forall a. Integral a => a -> a -> a
@@ -142,7 +142,7 @@ TYPE SIGNATURES
   odd :: forall a. Integral a => a -> Bool
   or :: forall (t :: * -> *). P.Foldable t => t Bool -> Bool
   otherwise :: Bool
-  pi :: forall w. Floating w => w
+  pi :: forall _. Floating _ => _
   pred :: forall a. Enum a => a -> a
   print :: forall a. Show a => a -> IO ()
   product ::
@@ -212,7 +212,7 @@ TYPE SIGNATURES
   toRational :: forall a. Real a => a -> Rational
   truncate :: forall a b. (RealFrac a, Integral b) => a -> b
   uncurry :: forall a b c. (a -> b -> c) -> (a, b) -> c
-  undefined :: forall w. w
+  undefined :: forall _. _
   unlines :: [String] -> String
   until :: forall a. (a -> Bool) -> (a -> a) -> a -> a
   unwords :: [String] -> String
index bae5060..9d10860 100644 (file)
@@ -1,5 +1,5 @@
 TYPE SIGNATURES
-  bar :: forall w. w -> Bool
+  bar :: forall _. _ -> Bool
 Dependent modules: []
 Dependent packages: [base-4.12.0.0, ghc-prim-0.5.3,
                      integer-gmp-1.0.2.0]
index ea97489..88fc8d5 100644 (file)
@@ -3,12 +3,13 @@
 
 SplicesUsed.hs:7:16: warning: [-Wpartial-type-signatures (in -Wdefault)]
     • Found type wildcard ‘_’ standing for ‘Maybe Bool’
-    • In the type signature: maybeBool :: (_)
+    • In the type ‘_’
+      In the type signature: maybeBool :: (_)
 
 SplicesUsed.hs:8:15: warning: [-Wpartial-type-signatures (in -Wdefault)]
-    • Found type wildcard ‘_a’ standing for ‘w
-      Where: ‘w’ is a rigid type variable bound by
-               the inferred type of <expression> :: w -> w
+    • Found type wildcard ‘_a’ standing for ‘_
+      Where: ‘_’ is a rigid type variable bound by
+               the inferred type of <expression> :: _ -> _
                at SplicesUsed.hs:8:15-22
     • In an expression type signature: _a -> _a
       In the expression: id :: _a -> _a
@@ -18,10 +19,9 @@ SplicesUsed.hs:8:15: warning: [-Wpartial-type-signatures (in -Wdefault)]
 
 SplicesUsed.hs:8:27: warning: [-Wpartial-type-signatures (in -Wdefault)]
     • Found type wildcard ‘_’ standing for ‘Bool’
-    • In an expression type signature: Maybe _
-      In the first argument of ‘id :: _a -> _a’, namely
-        ‘(Just True :: Maybe _)’
-      In the expression: (id :: _a -> _a) (Just True :: Maybe _)
+    • In the first argument of ‘Maybe’, namely ‘_’
+      In the type ‘Maybe _’
+      In an expression type signature: Maybe _
     • Relevant bindings include
         maybeBool :: Maybe Bool (bound at SplicesUsed.hs:8:1)
 
@@ -30,28 +30,32 @@ SplicesUsed.hs:10:17: warning: [-Wpartial-type-signatures (in -Wdefault)]
       Where: ‘a’ is a rigid type variable bound by
                the inferred type of charA :: a -> (Char, a)
                at SplicesUsed.hs:11:1-18
-    • In the type signature: charA :: a -> (_)
+    • In the type ‘a -> (_)’
+      In the type signature: charA :: a -> (_)
 
 SplicesUsed.hs:13:14: warning: [-Wpartial-type-signatures (in -Wdefault)]
     • Found type wildcard ‘_’ standing for ‘a -> Bool’
       Where: ‘a’ is a rigid type variable bound by
                the inferred type of filter' :: (a -> Bool) -> [a] -> [a]
                at SplicesUsed.hs:14:1-16
-    • In the type signature: filter' :: (_ -> _ -> _)
+    • In the type ‘_ -> _ -> _’
+      In the type signature: filter' :: (_ -> _ -> _)
 
 SplicesUsed.hs:13:14: warning: [-Wpartial-type-signatures (in -Wdefault)]
     • Found type wildcard ‘_’ standing for ‘[a]’
       Where: ‘a’ is a rigid type variable bound by
                the inferred type of filter' :: (a -> Bool) -> [a] -> [a]
                at SplicesUsed.hs:14:1-16
-    • In the type signature: filter' :: (_ -> _ -> _)
+    • In the type ‘_ -> _ -> _’
+      In the type signature: filter' :: (_ -> _ -> _)
 
 SplicesUsed.hs:13:14: warning: [-Wpartial-type-signatures (in -Wdefault)]
     • Found type wildcard ‘_’ standing for ‘[a]’
       Where: ‘a’ is a rigid type variable bound by
                the inferred type of filter' :: (a -> Bool) -> [a] -> [a]
                at SplicesUsed.hs:14:1-16
-    • In the type signature: filter' :: (_ -> _ -> _)
+    • In the type ‘_ -> _ -> _’
+      In the type signature: filter' :: (_ -> _ -> _)
 
 SplicesUsed.hs:16:3: warning: [-Wpartial-type-signatures (in -Wdefault)]
     • Found type wildcard ‘_’ standing for ‘Eq a’
@@ -72,8 +76,8 @@ SplicesUsed.hs:18:3: warning: [-Wpartial-type-signatures (in -Wdefault)]
     • In the type signature: bar :: _a -> _b -> (_a, _b)
 
 SplicesUsed.hs:18:3: warning: [-Wpartial-type-signatures (in -Wdefault)]
-    • Found type wildcard ‘_b’ standing for ‘w
-      Where: ‘w’ is a rigid type variable bound by
-               the inferred type of bar :: Bool -> w -> (Bool, w)
+    • Found type wildcard ‘_b’ standing for ‘_
+      Where: ‘_’ is a rigid type variable bound by
+               the inferred type of bar :: Bool -> _ -> (Bool, _)
                at SplicesUsed.hs:18:3-10
     • In the type signature: bar :: _a -> _b -> (_a, _b)
index a111644..a24928a 100644 (file)
@@ -1,4 +1,4 @@
 
-SuperCls.hs:4:14: warning: [-Wpartial-type-signatures (in -Wdefault)]
+SuperCls.hs:4:6: warning: [-Wpartial-type-signatures (in -Wdefault)]
     • Found type wildcard ‘_’ standing for ‘()’
     • In the type signature: f :: (Ord a, _) => a -> Bool
index 229b9e1..870a72e 100644 (file)
@@ -1,25 +1,23 @@
 
 T10403.hs:15:7: warning: [-Wpartial-type-signatures (in -Wdefault)]
     • Found type wildcard ‘_’ standing for ‘Functor f’
-      Where: ‘f’ is a rigid type variable
-               bound by the inferred type of
-                        h1 :: Functor f => (a -> b) -> f a -> H f
+      Where: ‘f’ is a rigid type variable bound by
+               the inferred type of h1 :: Functor f => (a -> b) -> f a -> H f
                at T10403.hs:17:1-41
     • In the type signature: h1 :: _ => _
 
 T10403.hs:15:12: warning: [-Wpartial-type-signatures (in -Wdefault)]
     • Found type wildcard ‘_’ standing for ‘(a -> b) -> f a -> H f’
-      Where: ‘b’, ‘a’, ‘f’ are rigid type variables
-               bound by the inferred type of
-                        h1 :: Functor f => (a -> b) -> f a -> H f
+      Where: ‘b’, ‘a’, ‘f’ are rigid type variables bound by
+               the inferred type of h1 :: Functor f => (a -> b) -> f a -> H f
                at T10403.hs:17:1-41
     • In the type signature: h1 :: _ => _
 
 T10403.hs:19:7: warning: [-Wpartial-type-signatures (in -Wdefault)]
     • Found type wildcard ‘_’ standing for ‘(a -> b) -> f0 a -> H f0’
       Where: ‘f0’ is an ambiguous type variable
-             ‘b’, ‘a’ are rigid type variables
-               bound by the inferred type of h2 :: (a -> b) -> f0 a -> H f0
+             ‘b’, ‘a’ are rigid type variables bound by
+               the inferred type of h2 :: (a -> b) -> f0 a -> H f0
                at T10403.hs:22:1-41
     • In the type signature: h2 :: _
 
index 5acc3fa..1640076 100644 (file)
@@ -2,7 +2,8 @@
 T10438.hs:7:22: warning: [-Wpartial-type-signatures (in -Wdefault)]
     • Found type wildcard ‘_’ standing for ‘p2’
       Where: ‘p2’ is a rigid type variable bound by
-               the inferred type of g :: p2 -> p2 at T10438.hs:(6,9)-(8,21)
+               the inferred type of g :: p2 -> p2
+               at T10438.hs:(6,9)-(8,21)
     • In the type signature: x :: _
       In an equation for ‘g’:
           g r
index f57144d..31d525c 100644 (file)
@@ -1,5 +1,5 @@
 
-T10519.hs:5:18: warning: [-Wpartial-type-signatures (in -Wdefault)]
+T10519.hs:5:8: warning: [-Wpartial-type-signatures (in -Wdefault)]
     • Found type wildcard ‘_’ standing for ‘Eq a’
       Where: ‘a’ is a rigid type variable bound by
                the inferred type of foo :: Eq a => a -> a -> Bool
index 49363fb..01e8b1a 100644 (file)
@@ -1,5 +1,5 @@
 
-T11016.hs:5:19: warning: [-Wpartial-type-signatures (in -Wdefault)]
+T11016.hs:5:7: warning: [-Wpartial-type-signatures (in -Wdefault)]
     • Found type wildcard ‘_’ standing for ‘()’
     • In the type signature: f1 :: (?x :: Int, _) => Int
 
index af8d47d..c5c5e6f 100644 (file)
@@ -2,5 +2,6 @@
 T11339a.hs:5:8: warning: [-Wpartial-type-signatures (in -Wdefault)]
     • Found type wildcard ‘_’ standing for ‘a -> a’
       Where: ‘a’ is a rigid type variable bound by
-               the inferred type of bar :: a -> a at T11339a.hs:6:1-10
+               the inferred type of bar :: a -> a
+               at T11339a.hs:6:1-10
     • In the type signature: bar :: _
index 04d6af5..1a0e7df 100644 (file)
@@ -1,18 +1,17 @@
 
 T11670.hs:10:42: warning: [-Wpartial-type-signatures (in -Wdefault)]
     • Found type wildcard ‘_’ standing for ‘CLong’
-    • In an expression type signature: IO _
-      In the expression: peekElemOff undefined 0 :: IO _
-      In an equation for ‘T11670.peek’:
-          T11670.peek ptr = peekElemOff undefined 0 :: IO _
+    • In the first argument of ‘IO’, namely ‘_’
+      In the type ‘IO _’
+      In an expression type signature: IO _
     • Relevant bindings include
         ptr :: Ptr a (bound at T11670.hs:10:6)
         peek :: Ptr a -> IO CLong (bound at T11670.hs:10:1)
 
 T11670.hs:13:40: warning: [-Wpartial-type-signatures (in -Wdefault)]
-    • Found type wildcard ‘_’ standing for ‘Storable w
-      Where: ‘w’ is a rigid type variable bound by
-               the inferred type of <expression> :: Storable w => IO w
+    • Found type wildcard ‘_’ standing for ‘Storable _
+      Where: ‘_’ is a rigid type variable bound by
+               the inferred type of <expression> :: Storable _ => IO _
                at T11670.hs:13:40-48
     • In an expression type signature: _ => IO _
       In the expression: peekElemOff undefined 0 :: _ => IO _
@@ -23,14 +22,13 @@ T11670.hs:13:40: warning: [-Wpartial-type-signatures (in -Wdefault)]
         peek2 :: Ptr a -> IO CLong (bound at T11670.hs:13:1)
 
 T11670.hs:13:48: warning: [-Wpartial-type-signatures (in -Wdefault)]
-    • Found type wildcard ‘_’ standing for ‘w
-      Where: ‘w’ is a rigid type variable bound by
-               the inferred type of <expression> :: Storable w => IO w
+    • Found type wildcard ‘_’ standing for ‘_
+      Where: ‘_’ is a rigid type variable bound by
+               the inferred type of <expression> :: Storable _ => IO _
                at T11670.hs:13:40-48
-    • In an expression type signature: _ => IO _
-      In the expression: peekElemOff undefined 0 :: _ => IO _
-      In an equation for ‘peek2’:
-          peek2 ptr = peekElemOff undefined 0 :: _ => IO _
+    • In the first argument of ‘IO’, namely ‘_’
+      In the type ‘IO _’
+      In an expression type signature: _ => IO _
     • Relevant bindings include
         ptr :: Ptr a (bound at T11670.hs:13:7)
         peek2 :: Ptr a -> IO CLong (bound at T11670.hs:13:1)
index 0e01cd3..b8cdba7 100644 (file)
@@ -1,5 +1,5 @@
 
-T12844.hs:12:9: warning: [-Wpartial-type-signatures (in -Wdefault)]
+T12844.hs:12:8: warning: [-Wpartial-type-signatures (in -Wdefault)]
     • Found type wildcard ‘_’
         standing for ‘(Foo rngs, Head rngs ~ '(r, r'))’
       Where: ‘rngs’, ‘k’, ‘r’, ‘k1’, ‘r'’
index a483c84..0c01a80 100644 (file)
@@ -1,5 +1,5 @@
 
-T12845.hs:18:70: warning: [-Wpartial-type-signatures (in -Wdefault)]
+T12845.hs:18:11: warning: [-Wpartial-type-signatures (in -Wdefault)]
     • Found type wildcard ‘_’ standing for ‘()’
     • In the type signature:
         broken :: forall r r' rngs.
index a21b7dc..017cc15 100644 (file)
@@ -1,5 +1,5 @@
 
-T13482.hs:10:32: warning: [-Wpartial-type-signatures (in -Wdefault)]
+T13482.hs:10:20: warning: [-Wpartial-type-signatures (in -Wdefault)]
     • Found type wildcard ‘_’ standing for ‘(Eq m, Monoid m)’
       Where: ‘m’ is a rigid type variable bound by
                the inferred type of
@@ -8,21 +8,21 @@ T13482.hs:10:32: warning: [-Wpartial-type-signatures (in -Wdefault)]
     • In the type signature:
         minimal1_noksig :: forall m. _ => Int -> Bool
 
-T13482.hs:13:33: warning: [-Wpartial-type-signatures (in -Wdefault)]
+T13482.hs:13:13: warning: [-Wpartial-type-signatures (in -Wdefault)]
     • Found type wildcard ‘_’ standing for ‘(Eq m, Monoid m)’
       Where: ‘m’ is a rigid type variable bound by
                the inferred type of minimal1 :: (Eq m, Monoid m) => Bool
                at T13482.hs:14:1-41
     • In the type signature: minimal1 :: forall (m :: Type). _ => Bool
 
-T13482.hs:16:30: warning: [-Wpartial-type-signatures (in -Wdefault)]
+T13482.hs:16:13: warning: [-Wpartial-type-signatures (in -Wdefault)]
     • Found type wildcard ‘_’ standing for ‘Monoid m’
       Where: ‘m’ is a rigid type variable bound by
                the inferred type of minimal2 :: (Eq m, Monoid m) => Bool
                at T13482.hs:17:1-41
     • In the type signature: minimal2 :: forall m. (Eq m, _) => Bool
 
-T13482.hs:19:34: warning: [-Wpartial-type-signatures (in -Wdefault)]
+T13482.hs:19:13: warning: [-Wpartial-type-signatures (in -Wdefault)]
     • Found type wildcard ‘_’ standing for ‘Eq m’
       Where: ‘m’ is a rigid type variable bound by
                the inferred type of minimal3 :: (Monoid m, Eq m) => Bool
index ebecbb9..e4b9598 100644 (file)
@@ -1,5 +1,5 @@
 
-T14217.hs:32:11: error:
+T14217.hs:32:10: error:
     • Found type wildcard ‘_’
         standing for ‘(Eq a1, Eq a2, Eq a3, Eq a4, Eq a5, Eq a6, Eq a7,
                        Eq a8, Eq a9, Eq a10, Eq a11, Eq a12, Eq a13, Eq a14, Eq a15,
index c5f204e..5f17627 100644 (file)
@@ -1,8 +1,8 @@
 
-T14643.hs:5:18: warning: [-Wpartial-type-signatures (in -Wdefault)]
+T14643.hs:5:11: warning: [-Wpartial-type-signatures (in -Wdefault)]
     • Found type wildcard ‘_’ standing for ‘()’
     • In the type signature: af :: (Num a, _) => a -> a
 
-T14643.hs:5:18: warning: [-Wpartial-type-signatures (in -Wdefault)]
+T14643.hs:5:11: warning: [-Wpartial-type-signatures (in -Wdefault)]
     • Found type wildcard ‘_’ standing for ‘()’
     • In the type signature: ag :: (Num a, _) => a -> a