Retain AnnTilde in splitTildeApps

splitTildeApps can introduce a new HsAppInfix for a tilde, with a fresh
SrcSpan, disconnecting its existing AnnTilde API Annotation.

A tilde needs AnnTilde to render properly, this patch adds a new one on
the fresh SrcSpan

2 files changed, 15 insertions, 9 deletions

diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index d6255a34b4..2b4e779db6 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -1652,7 +1652,8 @@ typedoc :: { LHsType RdrName }
 
 -- See Note [Parsing ~]
 btype :: { LHsType RdrName }
-        : tyapps                      { sL1 $1 $ HsAppsTy (splitTildeApps (reverse (unLoc $1))) }
+        : tyapps                      {%  splitTildeApps (reverse (unLoc $1)) >>=
+                                          \ts -> return $ sL1 $1 $ HsAppsTy ts }
 
 -- Used for parsing Haskell98-style data constructors,
 -- in order to forbid the blasphemous
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index c3c356a479..222641b6f5 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -93,6 +93,7 @@ import Util
 import ApiAnnotation
 import Data.List
 import qualified GHC.LanguageExtensions as LangExt
+import MonadUtils
 
 #if __GLASGOW_HASKELL__ < 709
 import Control.Applicative ((<$>))
@@ -1071,21 +1072,25 @@ splitTilde t = go t
 
 -- | Transform tyapps with strict_marks into uses of twiddle
 -- [~a, ~b, c, ~d] ==> (~a) ~ b c ~ d
-splitTildeApps :: [LHsAppType RdrName] -> [LHsAppType RdrName]
-splitTildeApps []         = []
-splitTildeApps (t : rest) = t : concatMap go rest
+splitTildeApps :: [LHsAppType RdrName] -> P [LHsAppType RdrName]
+splitTildeApps []         = return []
+splitTildeApps (t : rest) = do
+  rest' <- concatMapM go rest
+  return (t : rest')
   where go (L l (HsAppPrefix
             (L loc (HsBangTy
                     (HsSrcBang Nothing NoSrcUnpack SrcLazy)
                     ty))))
-          = [L tilde_loc (HsAppInfix (L tilde_loc eqTyCon_RDR)),
-             L l (HsAppPrefix ty)]
-             -- NOTE: no annotation is attached to an HsAppPrefix, so the
-             --       surrounding SrcSpan is not critical
+          = addAnnotation l AnnTilde l >>
+            return
+              [L tilde_loc (HsAppInfix (L tilde_loc eqTyCon_RDR)),
+               L l (HsAppPrefix ty)]
+               -- NOTE: no annotation is attached to an HsAppPrefix, so the
+               --       surrounding SrcSpan is not critical
           where
             tilde_loc = srcSpanFirstCharacter loc
 
-        go t = [t]
+        go t = return [t]