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

2 files changed, 98 insertions, 44 deletions

diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index cd41da53eb..685b2d451d 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -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)
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index 9712034b7a..4338968ecf 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -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
 --