Improve parser error messages for TypeApplications

With this patch, we always parse  f @t  as a type application,
thereby producing better error messages.

This steals two syntactic forms:

* Prefix form of the @-operator in expressions. Since the @-operator is
  a divergence from the Haskell Report anyway, this is not a major loss.

* Prefix form of @-patterns. Since we are stealing loose infix form
  anyway, might as well sacrifice the prefix form for the sake of much
  better error messages.

3 files changed, 12 insertions, 8 deletions

diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y
index 6dde13f7a9..a9bb4fa87d 100644
--- a/compiler/GHC/Parser.y
+++ b/compiler/GHC/Parser.y
@@ -2738,11 +2738,9 @@ fexp    :: { ECP }
                                           mkHsAppPV (comb2 $1 $>) $1 $2 }
 
         -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer
-        | fexp PREFIX_AT atype       {% runECP_P $1 >>= \ $1 ->
-                                        runPV (checkExpBlockArguments $1) >>= \_ ->
-                                        fmap ecpFromExp $
-                                        ams (sLL $1 $> $ HsAppType noExtField $1 (mkHsWildCardBndrs $3))
-                                            [mj AnnAt $2] }
+        | fexp PREFIX_AT atype       { ECP $
+                                        runECP_PV $1 >>= \ $1 ->
+                                        amms (mkHsAppTypePV (comb2 $1 $>) $1 $3) [mj AnnAt $2] }
 
         | 'static' aexp              {% runECP_P $2 >>= \ $2 ->
                                         fmap ecpFromExp $
diff --git a/compiler/GHC/Parser/Lexer.x b/compiler/GHC/Parser/Lexer.x
index bc4349e391..8245974db6 100644
--- a/compiler/GHC/Parser/Lexer.x
+++ b/compiler/GHC/Parser/Lexer.x
@@ -1449,7 +1449,7 @@ qconsym buf len = ITqconsym $! splitQualName buf len False
 -- See Note [Whitespace-sensitive operator parsing]
 varsym_prefix :: Action
 varsym_prefix = sym $ \exts s ->
-  if | TypeApplicationsBit `xtest` exts, s == fsLit "@"
+  if | s == fsLit "@"  -- regardless of TypeApplications for better error messages
      -> return ITtypeApp
      | ThQuotesBit `xtest` exts, s == fsLit "$"
      -> return ITdollar
@@ -2461,7 +2461,6 @@ data ExtBits
   | BinaryLiteralsBit
   | NegativeLiteralsBit
   | HexFloatLiteralsBit
-  | TypeApplicationsBit
   | StaticPointersBit
   | NumericUnderscoresBit
   | StarIsTypeBit
@@ -2548,7 +2547,6 @@ mkParserFlags' warningFlags extensionFlags thisPackage
       .|. NegativeLiteralsBit         `xoptBit` LangExt.NegativeLiterals
       .|. HexFloatLiteralsBit         `xoptBit` LangExt.HexFloatLiterals
       .|. PatternSynonymsBit          `xoptBit` LangExt.PatternSynonyms
-      .|. TypeApplicationsBit         `xoptBit` LangExt.TypeApplications
       .|. StaticPointersBit           `xoptBit` LangExt.StaticPointers
       .|. NumericUnderscoresBit       `xoptBit` LangExt.NumericUnderscores
       .|. StarIsTypeBit               `xoptBit` LangExt.StarIsType
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index 82a8b9398f..273fa0d704 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -1811,6 +1811,8 @@ class b ~ (Body b) GhcPs => DisambECP b where
   superFunArg :: (DisambECP (FunArg b) => PV (Located b)) -> PV (Located b)
   -- | Disambiguate "f x" (function application)
   mkHsAppPV :: SrcSpan -> Located b -> Located (FunArg b) -> PV (Located b)
+  -- | Disambiguate "f @t" (visible type application)
+  mkHsAppTypePV :: SrcSpan -> Located b -> LHsType GhcPs -> PV (Located b)
   -- | Disambiguate "if ... then ... else ..."
   mkHsIfPV :: SrcSpan
          -> LHsExpr GhcPs
@@ -1925,6 +1927,7 @@ instance DisambECP (HsCmd GhcPs) where
     checkCmdBlockArguments c
     checkExpBlockArguments e
     return $ L l (HsCmdApp noExtField c e)
+  mkHsAppTypePV l c t = cmdFail l (ppr c <+> text "@" <> ppr t)
   mkHsIfPV l c semi1 a semi2 b = do
     checkDoAndIfThenElse c semi1 a semi2 b
     return $ L l (mkHsCmdIf c a b)
@@ -1982,6 +1985,9 @@ instance DisambECP (HsExpr GhcPs) where
     checkExpBlockArguments e1
     checkExpBlockArguments e2
     return $ L l (HsApp noExtField e1 e2)
+  mkHsAppTypePV l e t = do
+    checkExpBlockArguments e
+    return $ L l (HsAppType noExtField e (mkHsWildCardBndrs t))
   mkHsIfPV l c semi1 a semi2 b = do
     checkDoAndIfThenElse c semi1 a semi2 b
     return $ L l (mkHsIf c a b)
@@ -2064,6 +2070,8 @@ instance DisambECP (PatBuilder GhcPs) where
   type FunArg (PatBuilder GhcPs) = PatBuilder GhcPs
   superFunArg m = m
   mkHsAppPV l p1 p2 = return $ L l (PatBuilderApp p1 p2)
+  mkHsAppTypePV l _ _ = addFatalError l $
+    text "Type applications in patterns are not yet supported"
   mkHsIfPV l _ _ _ _ _ = addFatalError l $ text "(if ... then ... else ...)-syntax in pattern"
   mkHsDoPV l _ = addFatalError l $ text "do-notation in pattern"
   mkHsParPV l p = return $ L l (PatBuilderPar p)