ApiAnnotations : RdrHsSyn.isFunLhs discards parentheses

Summary:
The RdrHsSyn.isFunLhs function has the following

  isFunLhs e = go e []
   where
     go (L loc (HsVar f)) es
          | not (isRdrDataCon f)   = return (Just (L loc f, False, es))
     go (L _ (HsApp f e)) es       = go f (e:es)
     go (L _ (HsPar e))   es@(_:_) = go e es

The treatment of HsPar means that any parentheses around an infix function will be discarded.

e.g.

  (f =*= g) sa i = f (toF sa i) =^= g (toG sa i)

will lose the ( before f and the closing one after g

Test Plan: ./validate

Reviewers: hvr, austin

Reviewed By: austin

Subscribers: bgamari, thomie

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

GHC Trac Issues: #10269

8 files changed, 184 insertions, 23 deletions

diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index 4670550f10..2b57b5a4c4 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -1991,13 +1991,13 @@ decl_no_th :: { Located (OrdList (LHsDecl RdrName)) }
                                 -- Turn it all into an expression so that
                                 -- checkPattern can check that bangs are enabled
 
-        | infixexp opt_sig rhs  {% do { r <- checkValDef empty $1 (snd $2) $3;
+        | infixexp opt_sig rhs  {% do { (ann,r) <- checkValDef empty $1 (snd $2) $3;
                                         let { l = comb2 $1 $> };
                                         case r of {
                                           (FunBind n _ _ _ _ _) ->
                                                 ams (L l ()) (mj AnnFunId n:(fst $2)) >> return () ;
                                           _ -> return () } ;
-                                        _ <- ams (L l ()) ((fst $2) ++ (fst $ unLoc $3));
+                                        _ <- ams (L l ()) (ann ++ (fst $2) ++ (fst $ unLoc $3));
                                         return $! (sL l (unitOL $! (sL l $ ValD r))) } }
         | pattern_synonym_decl  { sLL $1 $> $ unitOL $1 }
         | docdecl               { sLL $1 $> $ unitOL $1 }
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index 06c6564716..f0dc1ea433 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -910,7 +910,7 @@ checkValDef :: SDoc
             -> LHsExpr RdrName
             -> Maybe (LHsType RdrName)
             -> Located (a,GRHSs RdrName (LHsExpr RdrName))
-            -> P (HsBind RdrName)
+            -> P ([AddAnn],HsBind RdrName)
 
 checkValDef msg lhs (Just sig) grhss
         -- x :: ty = rhs  parses as a *pattern* binding
@@ -920,22 +920,26 @@ checkValDef msg lhs (Just sig) grhss
 checkValDef msg lhs opt_sig g@(L l (_,grhss))
   = do  { mb_fun <- isFunLhs lhs
         ; case mb_fun of
-            Just (fun, is_infix, pats) -> checkFunBind msg (getLoc lhs)
+            Just (fun, is_infix, pats, ann) ->
+              checkFunBind msg ann (getLoc lhs)
                                            fun is_infix pats opt_sig (L l grhss)
             Nothing -> checkPatBind msg lhs g }
 
 checkFunBind :: SDoc
+             -> [AddAnn]
              -> SrcSpan
              -> Located RdrName
              -> Bool
              -> [LHsExpr RdrName]
              -> Maybe (LHsType RdrName)
              -> Located (GRHSs RdrName (LHsExpr RdrName))
-             -> P (HsBind RdrName)
-checkFunBind msg lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
+             -> P ([AddAnn],HsBind RdrName)
+checkFunBind msg ann lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
   = do  ps <- checkPatterns msg pats
         let match_span = combineSrcSpans lhs_loc rhs_span
-        return (makeFunBind fun is_infix
+        -- Add back the annotations stripped from any HsPar values in the lhs
+        -- mapM_ (\a -> a match_span) ann
+        return (ann,makeFunBind fun is_infix
                   [L match_span (Match (Just (fun,is_infix)) ps opt_sig grhss)])
         -- The span of the match covers the entire equation.
         -- That isn't quite right, but it'll do for now.
@@ -953,10 +957,10 @@ makeFunBind fn is_infix ms
 checkPatBind :: SDoc
              -> LHsExpr RdrName
              -> Located (a,GRHSs RdrName (LHsExpr RdrName))
-             -> P (HsBind RdrName)
+             -> P ([AddAnn],HsBind RdrName)
 checkPatBind msg lhs (L _ (_,grhss))
   = do  { lhs <- checkPattern msg lhs
-        ; return (PatBind lhs grhss placeHolderType placeHolderNames
+        ; return ([],PatBind lhs grhss placeHolderType placeHolderNames
                     ([],[])) }
 
 checkValSig
@@ -1160,7 +1164,7 @@ splitBang (L loc (OpApp l_arg bang@(L _ (HsVar op)) _ r_arg))
 splitBang _ = Nothing
 
 isFunLhs :: LHsExpr RdrName
-         -> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName]))
+         -> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName],[AddAnn]))
 -- A variable binding is parsed as a FunBind.
 -- Just (fun, is_infix, arg_pats) if e is a function LHS
 --
@@ -1173,12 +1177,12 @@ isFunLhs :: LHsExpr RdrName
 --
 -- a .!. !b
 
-isFunLhs e = go e []
+isFunLhs e = go e [] []
  where
-   go (L loc (HsVar f)) es
-        | not (isRdrDataCon f)   = return (Just (L loc f, False, es))
-   go (L _ (HsApp f e)) es       = go f (e:es)
-   go (L _ (HsPar e))   es@(_:_) = go e es
+   go (L loc (HsVar f)) es ann
+        | not (isRdrDataCon f)       = return (Just (L loc f, False, es, ann))
+   go (L _ (HsApp f e)) es       ann = go f (e:es) ann
+   go (L l (HsPar e))   es@(_:_) ann = go e es (ann ++ mkParensApiAnn l)
 
         -- For infix function defns, there should be only one infix *function*
         -- (though there may be infix *datacons* involved too).  So we don't
@@ -1193,23 +1197,23 @@ isFunLhs e = go e []
         -- ToDo: what about this?
         --              x + 1 `op` y = ...
 
-   go e@(L loc (OpApp l (L loc' (HsVar op)) fix r)) es
+   go e@(L loc (OpApp l (L loc' (HsVar op)) fix r)) es ann
         | Just (e',es') <- splitBang e
         = do { bang_on <- extension bangPatEnabled
-             ; if bang_on then go e' (es' ++ es)
-               else return (Just (L loc' op, True, (l:r:es))) }
+             ; if bang_on then go e' (es' ++ es) ann
+               else return (Just (L loc' op, True, (l:r:es), ann)) }
                 -- No bangs; behave just like the next case
         | not (isRdrDataCon op)         -- We have found the function!
-        = return (Just (L loc' op, True, (l:r:es)))
+        = return (Just (L loc' op, True, (l:r:es), ann))
         | otherwise                     -- Infix data con; keep going
-        = do { mb_l <- go l es
+        = do { mb_l <- go l es ann
              ; case mb_l of
-                 Just (op', True, j : k : es')
-                    -> return (Just (op', True, j : op_app : es'))
+                 Just (op', True, j : k : es', ann')
+                    -> return (Just (op', True, j : op_app : es', ann'))
                     where
                       op_app = L loc (OpApp k (L loc' (HsVar op)) fix r)
                  _ -> return Nothing }
-   go _ _ = return Nothing
+   go _ _ _ = return Nothing
 
 
 ---------------------------------------------------------------------------
diff --git a/testsuite/tests/ghc-api/annotations/.gitignore b/testsuite/tests/ghc-api/annotations/.gitignore
index 3c1f510777..2280a5a7a8 100644
--- a/testsuite/tests/ghc-api/annotations/.gitignore
+++ b/testsuite/tests/ghc-api/annotations/.gitignore
@@ -5,6 +5,7 @@ exampleTest
 listcomps
 t10255
 t10268
+t10269
 *.hi
 *.o
 *.run.*
diff --git a/testsuite/tests/ghc-api/annotations/Makefile b/testsuite/tests/ghc-api/annotations/Makefile
index d74d3c2aff..898db5f248 100644
--- a/testsuite/tests/ghc-api/annotations/Makefile
+++ b/testsuite/tests/ghc-api/annotations/Makefile
@@ -5,6 +5,7 @@ include $(TOP)/mk/test.mk
 clean:
 	rm -f *.o *.hi
 	rm -f annotations comments parseTree exampleTest
+	rm -f t10269
 
 annotations: 
 	rm -f annotations.o annotations.hi
@@ -44,3 +45,10 @@ T10268:
 	./t10268 "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`"
 
 .PHONY: clean annotations parseTree comments exampleTest listcomps
+
+T10269:
+	rm -f T10269.o T10269.hi
+	'$(TEST_HC)' $(TEST_HC_OPTS) --make -v0 -package ghc t10269
+	./t10269 "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`"
+
+.PHONY: t10269
diff --git a/testsuite/tests/ghc-api/annotations/T10269.stdout b/testsuite/tests/ghc-api/annotations/T10269.stdout
new file mode 100644
index 0000000000..c27435db5c
--- /dev/null
+++ b/testsuite/tests/ghc-api/annotations/T10269.stdout
@@ -0,0 +1,36 @@
+---Problems---------------------
+[
+(AK Test10269.hs:4:1-9 AnnCloseP = [Test10269.hs:4:9])
+
+(AK Test10269.hs:4:1-9 AnnOpenP = [Test10269.hs:4:1])
+
+(AK Test10269.hs:4:2-8 AnnVal = [Test10269.hs:4:4-6])
+
+(AK <no location info> AnnEofPos = [Test10269.hs:5:1])
+]
+
+--------------------------------
+[
+(AK Test10269.hs:1:1 AnnModule = [Test10269.hs:1:1-6])
+
+(AK Test10269.hs:1:1 AnnWhere = [Test10269.hs:1:18-22])
+
+(AK Test10269.hs:4:1-9 AnnCloseP = [Test10269.hs:4:9])
+
+(AK Test10269.hs:4:1-9 AnnOpenP = [Test10269.hs:4:1])
+
+(AK Test10269.hs:4:1-26 AnnCloseP = [Test10269.hs:4:9])
+
+(AK Test10269.hs:4:1-26 AnnEqual = [Test10269.hs:4:16])
+
+(AK Test10269.hs:4:1-26 AnnFunId = [Test10269.hs:4:4-6])
+
+(AK Test10269.hs:4:1-26 AnnOpenP = [Test10269.hs:4:1])
+
+(AK Test10269.hs:4:1-26 AnnSemi = [Test10269.hs:5:1])
+
+(AK Test10269.hs:4:2-8 AnnVal = [Test10269.hs:4:4-6])
+
+(AK <no location info> AnnEofPos = [Test10269.hs:5:1])
+]
+
diff --git a/testsuite/tests/ghc-api/annotations/Test10269.hs b/testsuite/tests/ghc-api/annotations/Test10269.hs
new file mode 100644
index 0000000000..c6df750c04
--- /dev/null
+++ b/testsuite/tests/ghc-api/annotations/Test10269.hs
@@ -0,0 +1,4 @@
+module Test10269 where
+
+
+(f =*= g) sa i = undefined
diff --git a/testsuite/tests/ghc-api/annotations/all.T b/testsuite/tests/ghc-api/annotations/all.T
index c8df1c403d..29e22c6d46 100644
--- a/testsuite/tests/ghc-api/annotations/all.T
+++ b/testsuite/tests/ghc-api/annotations/all.T
@@ -5,3 +5,4 @@ test('exampleTest', normal, run_command, ['$MAKE -s --no-print-directory example
 test('listcomps',   normal, run_command, ['$MAKE -s --no-print-directory listcomps'])
 test('T10255',      normal, run_command, ['$MAKE -s --no-print-directory t10255'])
 test('T10268',      normal, run_command, ['$MAKE -s --no-print-directory T10268'])
+test('T10269',      normal, run_command, ['$MAKE -s --no-print-directory T10269'])
diff --git a/testsuite/tests/ghc-api/annotations/t10269.hs b/testsuite/tests/ghc-api/annotations/t10269.hs
new file mode 100644
index 0000000000..e71cd3b56b
--- /dev/null
+++ b/testsuite/tests/ghc-api/annotations/t10269.hs
@@ -0,0 +1,107 @@
+{-# LANGUAGE RankNTypes #-}
+
+-- This program must be called with GHC's libdir as the single command line
+-- argument.
+module Main where
+
+-- import Data.Generics
+import Data.Data
+import Data.List
+import System.IO
+import GHC
+import BasicTypes
+import DynFlags
+import MonadUtils
+import Outputable
+import ApiAnnotation
+import Bag (filterBag,isEmptyBag)
+import System.Directory (removeFile)
+import System.Environment( getArgs )
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import Data.Dynamic ( fromDynamic,Dynamic )
+
+main::IO()
+main = do
+        [libdir] <- getArgs
+        testOneFile libdir "Test10269"
+
+testOneFile libdir fileName = do
+       ((anns,cs),p) <- runGhc (Just libdir) $ do
+                        dflags <- getSessionDynFlags
+                        setSessionDynFlags dflags
+                        let mn =mkModuleName fileName
+                        addTarget Target { targetId = TargetModule mn
+                                         , targetAllowObjCode = True
+                                         , targetContents = Nothing }
+                        load LoadAllTargets
+                        modSum <- getModSummary mn
+                        p <- parseModule modSum
+                        return (pm_annotations p,p)
+
+       let spans = Set.fromList $ getAllSrcSpans (pm_parsed_source p)
+
+       -- putStrLn (pp spans)
+           problems = filter (\(s,a) -> not (Set.member s spans))
+                             $ getAnnSrcSpans (anns,cs)
+       putStrLn "---Problems---------------------"
+       putStrLn (intercalate "\n" [showAnns $ Map.fromList $ map snd problems])
+       putStrLn "--------------------------------"
+       putStrLn (intercalate "\n" [showAnns anns])
+
+    where
+      getAnnSrcSpans :: ApiAnns -> [(SrcSpan,(ApiAnnKey,[SrcSpan]))]
+      getAnnSrcSpans (anns,_) = map (\a@((ss,_),_) -> (ss,a)) $ Map.toList anns
+
+      getAllSrcSpans :: (Data t) => t -> [SrcSpan]
+      getAllSrcSpans ast = everything (++) ([] `mkQ` getSrcSpan) ast
+        where
+          getSrcSpan :: SrcSpan -> [SrcSpan]
+          getSrcSpan ss = [ss]
+
+
+showAnns anns = "[\n" ++ (intercalate "\n"
+   $ map (\((s,k),v)
+              -> ("(AK " ++ pp s ++ " " ++ show k ++" = " ++ pp v ++ ")\n"))
+   $ Map.toList anns)
+    ++ "]\n"
+
+pp a = showPpr unsafeGlobalDynFlags a
+
+
+-- ---------------------------------------------------------------------
+
+-- Copied from syb for the test
+
+
+-- | Generic queries of type \"r\",
+--   i.e., take any \"a\" and return an \"r\"
+--
+type GenericQ r = forall a. Data a => a -> r
+
+
+-- | Make a generic query;
+--   start from a type-specific case;
+--   return a constant otherwise
+--
+mkQ :: ( Typeable a
+       , Typeable b
+       )
+    => r
+    -> (b -> r)
+    -> a
+    -> r
+(r `mkQ` br) a = case cast a of
+                        Just b  -> br b
+                        Nothing -> r
+
+
+
+-- | Summarise all nodes in top-down, left-to-right order
+everything :: (r -> r -> r) -> GenericQ r -> GenericQ r
+
+-- Apply f to x to summarise top-level node;
+-- use gmapQ to recurse into immediate subterms;
+-- use ordinary foldl to reduce list of intermediate results
+
+everything k f x = foldl k (f x) (gmapQ (everything k f) x)