From 0df14b5db06751f817d3ba794cc74ac54519b5b8 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Thu, 21 May 2015 15:05:48 +0200 Subject: [PATCH] ApiAnnotations : parens around a context with wildcard loses annotations Summary: In the following code, the extra set of parens around the context end up with detached annotations. {-# LANGUAGE PartialTypeSignatures #-} module ParensAroundContext where f :: ((Eq a, _)) => a -> a -> Bool f x y = x == y Trac ticket #10354 It turns out it was the TupleTy that was the culprit. This may also solve #10315 Test Plan: ./validate Reviewers: hvr, austin, goldfire Reviewed By: austin Subscribers: goldfire, bgamari, thomie, mpickering Differential Revision: https://phabricator.haskell.org/D868 GHC Trac Issues: #10354, #10315 --- compiler/parser/Parser.y | 10 +- compiler/parser/RdrHsSyn.hs | 18 +-- .../tests/ghc-api/annotations/.gitignore | 1 + testsuite/tests/ghc-api/annotations/Makefile | 8 ++ .../tests/ghc-api/annotations/T10278.stdout | 16 +-- .../tests/ghc-api/annotations/T10354.stderr | 3 + .../tests/ghc-api/annotations/T10354.stdout | 90 +++++++++++++ .../tests/ghc-api/annotations/Test10354.hs | 14 +++ testsuite/tests/ghc-api/annotations/all.T | 1 + testsuite/tests/ghc-api/annotations/t10354.hs | 118 ++++++++++++++++++ 10 files changed, 258 insertions(+), 21 deletions(-) create mode 100644 testsuite/tests/ghc-api/annotations/T10354.stderr create mode 100644 testsuite/tests/ghc-api/annotations/T10354.stdout create mode 100644 testsuite/tests/ghc-api/annotations/Test10354.hs create mode 100644 testsuite/tests/ghc-api/annotations/t10354.hs diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index ed6f5ad4c8..5a862a8058 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -1606,14 +1606,14 @@ ctypedoc :: { LHsType RdrName } -- Thus for some reason we allow f :: a~b => blah -- but not f :: ?x::Int => blah context :: { LHsContext RdrName } - : btype '~' btype {% amms (checkContext - (sLL $1 $> $ HsEqTy $1 $3)) - [mj AnnTilde $2] } - | btype {% do { ctx <- checkContext $1 + : btype '~' btype {% do { (anns,ctx) <- checkContext + (sLL $1 $> $ HsEqTy $1 $3) + ; ams ctx (mj AnnTilde $2:anns) } } + | btype {% do { (anns,ctx) <- checkContext $1 ; if null (unLoc ctx) then addAnnotation (gl $1) AnnUnit (gl $1) else return () - ; return ctx + ; ams ctx anns } } type :: { LHsType RdrName } diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs index 5e2fa131cf..14476407fc 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -864,18 +864,20 @@ checkTyClHdr is_cls ty = parseErrorSDoc l (text "Malformed head of type or class declaration:" <+> ppr ty) -checkContext :: LHsType RdrName -> P (LHsContext RdrName) +checkContext :: LHsType RdrName -> P ([AddAnn],LHsContext RdrName) checkContext (L l orig_t) - = check orig_t + = check [] (L l orig_t) where - check (HsTupleTy _ ts) -- (Eq a, Ord b) shows up as a tuple type - = return (L l ts) -- Ditto () + check anns (L lp (HsTupleTy _ ts)) -- (Eq a, Ord b) shows up as a tuple type + = return (anns ++ mkParensApiAnn lp,L l ts) -- Ditto () - check (HsParTy ty) -- to be sure HsParTy doesn't get into the way - = check (unLoc ty) + check anns (L lp1 (HsParTy ty))-- to be sure HsParTy doesn't get into the way + = check anns' ty + where anns' = if l == lp1 then anns + else (anns ++ mkParensApiAnn lp1) - check _ - = return (L l [L l orig_t]) + check _anns _ + = return ([],L l [L l orig_t]) -- no need for anns, returning original -- ------------------------------------------------------------------------- -- Checking Patterns. diff --git a/testsuite/tests/ghc-api/annotations/.gitignore b/testsuite/tests/ghc-api/annotations/.gitignore index 0dcfb284e1..bb19b136c0 100644 --- a/testsuite/tests/ghc-api/annotations/.gitignore +++ b/testsuite/tests/ghc-api/annotations/.gitignore @@ -14,6 +14,7 @@ t10312 t10307 boolFormula t10278 +t10354 *.hi *.o *.run.* diff --git a/testsuite/tests/ghc-api/annotations/Makefile b/testsuite/tests/ghc-api/annotations/Makefile index 17cc6fdcb7..da6a3586d7 100644 --- a/testsuite/tests/ghc-api/annotations/Makefile +++ b/testsuite/tests/ghc-api/annotations/Makefile @@ -12,6 +12,7 @@ clean: rm -f listcomps boolFormula rm -f t10357 rm -f t10278 + rm -f t10354 annotations: rm -f annotations.o annotations.hi @@ -113,3 +114,10 @@ T10278: ./t10278 "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" .PHONY: T10278 + +T10354: + rm -f t10354.o t10354.hi + '$(TEST_HC)' $(TEST_HC_OPTS) --make -v0 -package ghc t10354 + ./t10354 "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" + +.PHONY: t10354 diff --git a/testsuite/tests/ghc-api/annotations/T10278.stdout b/testsuite/tests/ghc-api/annotations/T10278.stdout index b274095af9..4c10d26aca 100644 --- a/testsuite/tests/ghc-api/annotations/T10278.stdout +++ b/testsuite/tests/ghc-api/annotations/T10278.stdout @@ -36,11 +36,11 @@ (AK Test10278.hs:(7,1)-(11,33) AnnSemi = [Test10278.hs:12:1]) -(AK Test10278.hs:7:20-39 AnnCloseP = [Test10278.hs:7:39]) +(AK Test10278.hs:7:20-39 AnnCloseP = [Test10278.hs:7:39, Test10278.hs:7:39]) (AK Test10278.hs:7:20-39 AnnDarrow = [Test10278.hs:7:41-42]) -(AK Test10278.hs:7:20-39 AnnOpenP = [Test10278.hs:7:20]) +(AK Test10278.hs:7:20-39 AnnOpenP = [Test10278.hs:7:20, Test10278.hs:7:20]) (AK Test10278.hs:7:21-24 AnnComma = [Test10278.hs:7:25]) @@ -100,11 +100,11 @@ (AK Test10278.hs:15:14-64 AnnForall = [Test10278.hs:15:14-19]) -(AK Test10278.hs:15:25-40 AnnCloseP = [Test10278.hs:15:40]) +(AK Test10278.hs:15:25-40 AnnCloseP = [Test10278.hs:15:40, Test10278.hs:15:40]) (AK Test10278.hs:15:25-40 AnnDarrow = [Test10278.hs:15:42-43]) -(AK Test10278.hs:15:25-40 AnnOpenP = [Test10278.hs:15:25]) +(AK Test10278.hs:15:25-40 AnnOpenP = [Test10278.hs:15:25, Test10278.hs:15:25]) (AK Test10278.hs:15:27-30 AnnComma = [Test10278.hs:15:31]) @@ -122,11 +122,11 @@ (AK Test10278.hs:16:14-64 AnnForall = [Test10278.hs:16:14-19]) -(AK Test10278.hs:16:25-40 AnnCloseP = [Test10278.hs:16:40]) +(AK Test10278.hs:16:25-40 AnnCloseP = [Test10278.hs:16:40, Test10278.hs:16:40]) (AK Test10278.hs:16:25-40 AnnDarrow = [Test10278.hs:16:42-43]) -(AK Test10278.hs:16:25-40 AnnOpenP = [Test10278.hs:16:25]) +(AK Test10278.hs:16:25-40 AnnOpenP = [Test10278.hs:16:25, Test10278.hs:16:25]) (AK Test10278.hs:16:27-30 AnnComma = [Test10278.hs:16:31]) @@ -148,11 +148,11 @@ (AK Test10278.hs:17:25-80 AnnForall = [Test10278.hs:17:25-30]) -(AK Test10278.hs:17:36-51 AnnCloseP = [Test10278.hs:17:51]) +(AK Test10278.hs:17:36-51 AnnCloseP = [Test10278.hs:17:51, Test10278.hs:17:51]) (AK Test10278.hs:17:36-51 AnnDarrow = [Test10278.hs:17:53-54]) -(AK Test10278.hs:17:36-51 AnnOpenP = [Test10278.hs:17:36]) +(AK Test10278.hs:17:36-51 AnnOpenP = [Test10278.hs:17:36, Test10278.hs:17:36]) (AK Test10278.hs:17:38-41 AnnComma = [Test10278.hs:17:42]) diff --git a/testsuite/tests/ghc-api/annotations/T10354.stderr b/testsuite/tests/ghc-api/annotations/T10354.stderr new file mode 100644 index 0000000000..c0f9172c02 --- /dev/null +++ b/testsuite/tests/ghc-api/annotations/T10354.stderr @@ -0,0 +1,3 @@ + +Test10354.hs:13:8: error: + Not in scope: type constructor or class ‘ForceError’ diff --git a/testsuite/tests/ghc-api/annotations/T10354.stdout b/testsuite/tests/ghc-api/annotations/T10354.stdout new file mode 100644 index 0000000000..b0203c9d8a --- /dev/null +++ b/testsuite/tests/ghc-api/annotations/T10354.stdout @@ -0,0 +1,90 @@ +---Problems--------------------- +[ +(AK Test10354.hs:4:7-15 AnnCloseP = [Test10354.hs:4:15]) + +(AK Test10354.hs:4:7-15 AnnOpenP = [Test10354.hs:4:7]) +] + +---Problems'-------------------- +[] +-------------------------------- +[ +(AK Test10354.hs:1:1 AnnModule = [Test10354.hs:2:1-6]) + +(AK Test10354.hs:1:1 AnnWhere = [Test10354.hs:2:18-22]) + +(AK Test10354.hs:4:1-34 AnnDcolon = [Test10354.hs:4:3-4]) + +(AK Test10354.hs:4:1-34 AnnSemi = [Test10354.hs:5:1]) + +(AK Test10354.hs:4:6-16 AnnCloseP = [Test10354.hs:4:16, Test10354.hs:4:15]) + +(AK Test10354.hs:4:6-16 AnnDarrow = [Test10354.hs:4:18-19]) + +(AK Test10354.hs:4:6-16 AnnOpenP = [Test10354.hs:4:6, Test10354.hs:4:7]) + +(AK Test10354.hs:4:7-15 AnnCloseP = [Test10354.hs:4:15]) + +(AK Test10354.hs:4:7-15 AnnOpenP = [Test10354.hs:4:7]) + +(AK Test10354.hs:4:8-11 AnnComma = [Test10354.hs:4:12]) + +(AK Test10354.hs:4:21-34 AnnRarrow = [Test10354.hs:4:23-24]) + +(AK Test10354.hs:4:26-34 AnnRarrow = [Test10354.hs:4:28-29]) + +(AK Test10354.hs:5:1-14 AnnEqual = [Test10354.hs:5:7]) + +(AK Test10354.hs:5:1-14 AnnFunId = [Test10354.hs:5:1]) + +(AK Test10354.hs:5:1-14 AnnSemi = [Test10354.hs:7:1]) + +(AK Test10354.hs:5:9-14 AnnVal = [Test10354.hs:5:11-12]) + +(AK Test10354.hs:7:1-24 AnnDcolon = [Test10354.hs:7:5-6]) + +(AK Test10354.hs:7:1-24 AnnSemi = [Test10354.hs:8:1]) + +(AK Test10354.hs:7:8-12 AnnCloseP = [Test10354.hs:7:12, Test10354.hs:7:12]) + +(AK Test10354.hs:7:8-12 AnnDarrow = [Test10354.hs:7:14-15]) + +(AK Test10354.hs:7:8-12 AnnOpenP = [Test10354.hs:7:8, Test10354.hs:7:8]) + +(AK Test10354.hs:7:8-12 AnnUnit = [Test10354.hs:7:8-12]) + +(AK Test10354.hs:7:17-24 AnnRarrow = [Test10354.hs:7:18-19]) + +(AK Test10354.hs:8:1-15 AnnEqual = [Test10354.hs:8:5]) + +(AK Test10354.hs:8:1-15 AnnFunId = [Test10354.hs:8:1-3]) + +(AK Test10354.hs:8:1-15 AnnSemi = [Test10354.hs:10:1]) + +(AK Test10354.hs:10:1-23 AnnDcolon = [Test10354.hs:10:5-6]) + +(AK Test10354.hs:10:1-23 AnnSemi = [Test10354.hs:11:1]) + +(AK Test10354.hs:10:8 AnnDarrow = [Test10354.hs:10:10-11]) + +(AK Test10354.hs:10:13-23 AnnRarrow = [Test10354.hs:10:15-16]) + +(AK Test10354.hs:11:1-15 AnnEqual = [Test10354.hs:11:5]) + +(AK Test10354.hs:11:1-15 AnnFunId = [Test10354.hs:11:1-3]) + +(AK Test10354.hs:11:1-15 AnnSemi = [Test10354.hs:13:1]) + +(AK Test10354.hs:13:1-17 AnnDcolon = [Test10354.hs:13:5-6]) + +(AK Test10354.hs:13:1-17 AnnSemi = [Test10354.hs:14:1]) + +(AK Test10354.hs:14:1-15 AnnEqual = [Test10354.hs:14:5]) + +(AK Test10354.hs:14:1-15 AnnFunId = [Test10354.hs:14:1-3]) + +(AK Test10354.hs:14:1-15 AnnSemi = [Test10354.hs:15:1]) + +(AK AnnEofPos = [Test10354.hs:15:1]) +] + diff --git a/testsuite/tests/ghc-api/annotations/Test10354.hs b/testsuite/tests/ghc-api/annotations/Test10354.hs new file mode 100644 index 0000000000..267ea45ab0 --- /dev/null +++ b/testsuite/tests/ghc-api/annotations/Test10354.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE PartialTypeSignatures #-} +module Test10354 where + +f :: ((Eq a, _)) => a -> a -> Bool +f x y = x == y + +bar :: ( ) => a-> Bool +bar = undefined + +baz :: _ => a -> String +baz = undefined + +foo :: ForceError +foo = undefined diff --git a/testsuite/tests/ghc-api/annotations/all.T b/testsuite/tests/ghc-api/annotations/all.T index 3980a9d346..0a0b5a6b7d 100644 --- a/testsuite/tests/ghc-api/annotations/all.T +++ b/testsuite/tests/ghc-api/annotations/all.T @@ -14,3 +14,4 @@ test('boolFormula', normal, run_command, ['$MAKE -s --no-print-directory boolFor test('T10357', normal, run_command, ['$MAKE -s --no-print-directory t10357']) test('T10358', normal, run_command, ['$MAKE -s --no-print-directory t10358']) test('T10278', normal, run_command, ['$MAKE -s --no-print-directory T10278']) +test('T10354', normal, run_command, ['$MAKE -s --no-print-directory T10354']) diff --git a/testsuite/tests/ghc-api/annotations/t10354.hs b/testsuite/tests/ghc-api/annotations/t10354.hs new file mode 100644 index 0000000000..628dabb073 --- /dev/null +++ b/testsuite/tests/ghc-api/annotations/t10354.hs @@ -0,0 +1,118 @@ +{-# 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 "Test10354" + +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) + + problems = filter (\(s,a) -> not (Set.member s spans)) + $ getAnnSrcSpans (anns,cs) + + exploded = [((kw,ss),[anchor]) + | ((anchor,kw),sss) <- Map.toList anns,ss <- sss] + + exploded' = Map.toList $ Map.fromListWith (++) exploded + + problems' = filter (\(_,anchors) + -> not (any (\a -> Set.member a spans) anchors)) + exploded' + + putStrLn "---Problems---------------------" + putStrLn (intercalate "\n" [showAnns $ Map.fromList $ map snd problems]) + putStrLn "---Problems'--------------------" + putStrLn (intercalate "\n" [pp $ Map.fromList $ map fst 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) -- GitLab