ApiAnnotations tweaks

Summary:
A collection of minor updates for the API Annotations.

1. The annotations for the implicity parameter is disconnected in the
   following

    type MPI = ?mpi_secret :: MPISecret

2. In the following, the annotation for one of the commas is disconeected.

    mkPoli = mkBila . map ((,,(),,()) <$> P.base <*> P.pos <*> P.form)

3. In the following, the annotation for the parens becomes disconnected

    data MaybeDefault v where
        SetTo :: forall v . ( Eq v, Show v ) => !v -> MaybeDefault v
        SetTo4 :: forall v a. (( Eq v, Show v ) => v -> MaybeDefault v
                                                -> a -> MaybeDefault [a])

Test Plan: ./validate

Reviewers: hvr, austin

Reviewed By: austin

Subscribers: bgamari, thomie, mpickering

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

GHC Trac Issues: #10399

5 files changed, 44 insertions, 26 deletions

diff --git a/compiler/ghc.mk b/compiler/ghc.mk
index 000912674d..f6ed9c27cc 100644
--- a/compiler/ghc.mk
+++ b/compiler/ghc.mk
@@ -491,6 +491,7 @@ compiler_stage2_dll0_MODULES = \
 	CoreUnfold \
 	CoreUtils \
 	CostCentre \
+	Ctype \
 	DataCon \
 	Demand \
 	Digraph \
@@ -529,6 +530,7 @@ compiler_stage2_dll0_MODULES = \
 	InstEnv \
 	Kind \
 	Lexeme \
+	Lexer \
 	ListSetOps \
 	Literal \
 	Maybes \
diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs
index 15a07169ad..09c4a2f991 100644
--- a/compiler/hsSyn/HsTypes.hs
+++ b/compiler/hsSyn/HsTypes.hs
@@ -37,6 +37,7 @@ module HsTypes (
         mkExplicitHsForAllTy, mkImplicitHsForAllTy, mkQualifiedHsForAllTy,
         mkHsForAllTy,
         flattenTopLevelLHsForAllTy,flattenTopLevelHsForAllTy,
+        flattenHsForAllTyKeepAnns,
         hsExplicitTvs,
         hsTyVarName, mkHsWithBndrs, hsLKiTyVarNames,
         hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames,
@@ -66,6 +67,7 @@ import SrcLoc
 import StaticFlags
 import Outputable
 import FastString
+import Lexer ( AddAnn, mkParensApiAnn )
 import Maybes( isJust )
 
 import Data.Data hiding ( Fixity )
@@ -589,24 +591,30 @@ flattenTopLevelLHsForAllTy (L l ty) = L l (flattenTopLevelHsForAllTy ty)
 
 flattenTopLevelHsForAllTy :: HsType name -> HsType name
 flattenTopLevelHsForAllTy (HsForAllTy exp extra tvs (L l []) ty)
-  = mk_forall_ty l exp extra tvs ty
+  = snd $ mk_forall_ty [] l exp extra tvs ty
 flattenTopLevelHsForAllTy ty = ty
 
+flattenHsForAllTyKeepAnns :: HsType name -> ([AddAnn],HsType name)
+flattenHsForAllTyKeepAnns (HsForAllTy exp extra tvs (L l []) ty)
+  = mk_forall_ty [] l exp extra tvs ty
+flattenHsForAllTyKeepAnns ty = ([],ty)
+
 -- mk_forall_ty makes a pure for-all type (no context)
-mk_forall_ty :: SrcSpan -> HsExplicitFlag -> Maybe SrcSpan -> LHsTyVarBndrs name
-             -> LHsType name -> HsType name
-mk_forall_ty _ exp1 extra1 tvs1 (L _ (HsForAllTy exp2 extra qtvs2 ctxt ty)) =
-  HsForAllTy (exp1 `plus` exp2) (mergeExtra extra1 extra)
-             (tvs1 `mappend` qtvs2) ctxt ty
+mk_forall_ty :: [AddAnn] -> SrcSpan -> HsExplicitFlag -> Maybe SrcSpan
+             -> LHsTyVarBndrs name
+             -> LHsType name -> ([AddAnn],HsType name)
+mk_forall_ty ann _ exp1 extra1 tvs1 (L _ (HsForAllTy exp2 extra qtvs2 ctxt ty))
+  = (ann,HsForAllTy (exp1 `plus` exp2) (mergeExtra extra1 extra)
+                    (tvs1 `mappend` qtvs2) ctxt ty)
   where
         -- Bias the merging of extra's to the top level, so that a single
         -- wildcard context will prevail
         mergeExtra (Just s) _ = Just s
         mergeExtra _        e = e
-mk_forall_ty l exp  extra tvs  (L _ (HsParTy ty))
-  = mk_forall_ty l exp extra tvs ty
-mk_forall_ty l exp extra tvs  ty
-  = HsForAllTy exp extra tvs (L l []) ty
+mk_forall_ty ann l exp  extra tvs  (L lp (HsParTy ty))
+  = mk_forall_ty (ann ++ mkParensApiAnn lp) l exp extra tvs ty
+mk_forall_ty ann l exp extra tvs  ty
+  = (ann,HsForAllTy exp extra tvs (L l []) ty)
         -- Even if tvs is empty, we still make a HsForAll!
         -- In the Implicit case, this signals the place to do implicit quantification
         -- In the Explicit case, it prevents implicit quantification
diff --git a/compiler/parser/ApiAnnotation.hs b/compiler/parser/ApiAnnotation.hs
index babd93a0ab..0c80ec7270 100644
--- a/compiler/parser/ApiAnnotation.hs
+++ b/compiler/parser/ApiAnnotation.hs
@@ -233,6 +233,8 @@ data AnnKeywordId
     | AnnOpen   -- ^ '(\#' or '{-\# LANGUAGE' etc
     | AnnOpenC   -- ^ '{'
     | AnnOpenP   -- ^ '('
+    | AnnOpenPE   -- ^ '$('
+    | AnnOpenPTE   -- ^ '$$('
     | AnnOpenS   -- ^ '['
     | AnnPackageName
     | AnnPattern
@@ -248,6 +250,7 @@ data AnnKeywordId
     | AnnThen
     | AnnThIdSplice -- ^ '$'
     | AnnThIdTySplice -- ^ '$$'
+    | AnnThTyQuote -- ^ double '''
     | AnnTilde -- ^ '~'
     | AnnTildehsh -- ^ '~#'
     | AnnType
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index c167da0a1c..63fc5f9c94 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -1591,7 +1591,7 @@ ctypedoc :: { LHsType RdrName }
                                          >> return (sLL $1 $> $
                                                   mkQualifiedHsForAllTy $1 $3) }
         | ipvar '::' type             {% ams (sLL $1 $> (HsIParamTy (unLoc $1) $3))
-                                             [mj AnnDcolon $2] }
+                                             [mj AnnVal $1,mj AnnDcolon $2] }
         | typedoc                     { $1 }
 
 ----------------------
@@ -1688,9 +1688,10 @@ atype :: { LHsType RdrName }
                                              [mop $1,mj AnnDcolon $3,mcp $5] }
         | quasiquote                  { sL1 $1 (HsSpliceTy (unLoc $1) placeHolderKind) }
         | '$(' exp ')'                {% ams (sLL $1 $> $ mkHsSpliceTy $2)
-                                             [mo $1,mc $3] }
-        | TH_ID_SPLICE                { sLL $1 $> $ mkHsSpliceTy $ sL1 $1 $ HsVar $
-                                        mkUnqual varName (getTH_ID_SPLICE $1) }
+                                             [mj AnnOpenPE $1,mj AnnCloseP $3] }
+        | TH_ID_SPLICE                {%ams (sLL $1 $> $ mkHsSpliceTy $ sL1 $1 $ HsVar $
+                                             mkUnqual varName (getTH_ID_SPLICE $1))
+                                             [mj AnnThIdSplice $1] }
                                       -- see Note [Promotion] for the followings
         | SIMPLEQUOTE qcon_nowiredlist {% ams (sLL $1 $> $ HsTyVar $ unLoc $2) [mj AnnSimpleQuote $1,mj AnnName $2] }
         | SIMPLEQUOTE  '(' ctype ',' comma_types1 ')'
@@ -1863,9 +1864,9 @@ gadt_constrs :: { Located [LConDecl RdrName] }
 gadt_constr :: { LConDecl RdrName }
                    -- Returns a list because of:   C,D :: ty
         : con_list '::' sigtype
-                {% do { gadtDecl <- mkGadtDecl (unLoc $1) $3
+                {% do { (anns,gadtDecl) <- mkGadtDecl (unLoc $1) $3
                       ; ams (sLL $1 $> $ gadtDecl)
-                            [mj AnnDcolon $2] } }
+                            (mj AnnDcolon $2:anns) } }
 
                 -- Deprecated syntax for GADT record declarations
         | oqtycon '{' fielddecls '}' '::' sigtype
@@ -2313,8 +2314,8 @@ aexp2   :: { LHsExpr RdrName }
 
         | SIMPLEQUOTE  qvar     {% ams (sLL $1 $> $ HsBracket (VarBr True  (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] }
         | SIMPLEQUOTE  qcon     {% ams (sLL $1 $> $ HsBracket (VarBr True  (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] }
-        | TH_TY_QUOTE tyvar     {% ams (sLL $1 $> $ HsBracket (VarBr False (unLoc $2))) [mj AnnThIdSplice $1,mj AnnName $2] }
-        | TH_TY_QUOTE gtycon    {% ams (sLL $1 $> $ HsBracket (VarBr False (unLoc $2))) [mj AnnThIdSplice $1,mj AnnName $2] }
+        | TH_TY_QUOTE tyvar     {% ams (sLL $1 $> $ HsBracket (VarBr False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] }
+        | TH_TY_QUOTE gtycon    {% ams (sLL $1 $> $ HsBracket (VarBr False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] }
         | '[|' exp '|]'       {% ams (sLL $1 $> $ HsBracket (ExpBr $2)) [mo $1,mc $3] }
         | '[||' exp '||]'     {% ams (sLL $1 $> $ HsBracket (TExpBr $2)) [mo $1,mc $3]}
         | '[t|' ctype '|]'    {% checkNoPartialType
@@ -2338,12 +2339,14 @@ splice_exp :: { LHsExpr RdrName }
                                         (sL1 $1 $ HsVar (mkUnqual varName
                                                         (getTH_ID_SPLICE $1))))
                                        [mj AnnThIdSplice $1] }
-        | '$(' exp ')'          {% ams (sLL $1 $> $ mkHsSpliceE $2) [mo $1,mc $3] }
+        | '$(' exp ')'          {% ams (sLL $1 $> $ mkHsSpliceE $2)
+                                       [mj AnnOpenPE $1,mj AnnCloseP $3] }
         | TH_ID_TY_SPLICE       {% ams (sL1 $1 $ mkHsSpliceTE
                                         (sL1 $1 $ HsVar (mkUnqual varName
                                                      (getTH_ID_TY_SPLICE $1))))
                                        [mj AnnThIdTySplice $1] }
-        | '$$(' exp ')'         {% ams (sLL $1 $> $ mkHsSpliceTE $2) [mo $1,mc $3] }
+        | '$$(' exp ')'         {% ams (sLL $1 $> $ mkHsSpliceTE $2)
+                                       [mj AnnOpenPTE $1,mj AnnCloseP $3] }
 
 cmdargs :: { [LHsCmdTop RdrName] }
         : cmdargs acmd                  { $2 : $1 }
@@ -2412,7 +2415,7 @@ commas_tup_tail : commas tup_tail
                     then [L (last $ fst $1) missingTupArg]
                     else $2
          in (head $ fst $1
-            ,(map (\l -> L l missingTupArg) (init $ fst $1)) ++ tt)) } }
+            ,(map (\l -> L l missingTupArg) (tail $ fst $1)) ++ tt)) } }
 
 -- Always follows a comma
 tup_tail :: { [LHsTupArg RdrName] }
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index 14476407fc..d3d3b7af90 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -622,9 +622,12 @@ mkSimpleConDecl name qvars cxt details
 
 mkGadtDecl :: [Located RdrName]
            -> LHsType RdrName     -- Always a HsForAllTy
-           -> P (ConDecl RdrName)
-mkGadtDecl names (L l ty)
-  = mkGadtDecl' names (L l (flattenTopLevelHsForAllTy ty))
+           -> P ([AddAnn], ConDecl RdrName)
+mkGadtDecl names (L l ty) = do
+  let
+    (anns,ty') = flattenHsForAllTyKeepAnns ty
+  gadt <- mkGadtDecl' names (L l ty')
+  return (anns,gadt)
 
 mkGadtDecl' :: [Located RdrName]
            -> LHsType RdrName     -- Always a HsForAllTy
@@ -950,8 +953,7 @@ checkAPat msg loc e0 = do
                                         L _ (HsForAllTy Implicit _ _
                                              (L _ []) ty) -> ty
                                         other -> other
-                             return (SigPatIn e (mkHsWithBndrs
-                                                   (L (getLoc t) (HsParTy t'))))
+                             return (SigPatIn e (mkHsWithBndrs t'))
 
    -- n+k patterns
    OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _