Visible kind application

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

7 files changed, 252 insertions, 147 deletions

diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index 3c78a4c3d8..59b42bda0f 100644
--- a/compiler/hsSyn/Convert.hs
+++ b/compiler/hsSyn/Convert.hs
@@ -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
diff --git a/compiler/hsSyn/HsBinds.hs b/compiler/hsSyn/HsBinds.hs
index c541a129ce..110c0fb488 100644
--- a/compiler/hsSyn/HsBinds.hs
+++ b/compiler/hsSyn/HsBinds.hs
@@ -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'
diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs
index 246f8f9b9b..2b8c16311d 100644
--- a/compiler/hsSyn/HsDecls.hs
+++ b/compiler/hsSyn/HsDecls.hs
@@ -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]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/hsSyn/HsExtension.hs b/compiler/hsSyn/HsExtension.hs
index 2dff478e55..9a017c250f 100644
--- a/compiler/hsSyn/HsExtension.hs
+++ b/compiler/hsSyn/HsExtension.hs
@@ -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)
diff --git a/compiler/hsSyn/HsInstances.hs b/compiler/hsSyn/HsInstances.hs
index 9a9f21d046..39507362cf 100644
--- a/compiler/hsSyn/HsInstances.hs
+++ b/compiler/hsSyn/HsInstances.hs
@@ -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)
diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs
index 4ab15b2625..73443587fe 100644
--- a/compiler/hsSyn/HsTypes.hs
+++ b/compiler/hsSyn/HsTypes.hs
@@ -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
diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs
index eb899cc2fb..8cc3fb2cea 100644
--- a/compiler/hsSyn/HsUtils.hs
+++ b/compiler/hsSyn/HsUtils.hs
@@ -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,