diff options
author | Alan Zimmerman <alan.zimm@gmail.com> | 2015-05-11 09:34:27 +0200 |
---|---|---|
committer | Austin Seipp <austin@well-typed.com> | 2015-05-11 17:30:33 -0500 |
commit | bc4968f40da5ac6764623466915175377fa6f4dc (patch) | |
tree | 907f08e0371945cd89aff00a98d0dafa489d38a3 | |
parent | d260ce3e4ff483705bfc9725a137161b8bd99d92 (diff) | |
download | haskell-bc4968f40da5ac6764623466915175377fa6f4dc.tar.gz |
Api Annotations: RdrHsSyn.mkAtDefault causes annotations to be disconnected.
Summary:
The code for mkAtDefault is as follows.
mkATDefault (L loc (TyFamInstDecl { tfid_eqn = L _ e }))
| TyFamEqn { tfe_tycon = tc, tfe_pats = pats, tfe_rhs = rhs } <- e
= do { tvs <- checkTyVars (ptext (sLit "default")) equalsDots tc (hswb_cts pats)
; return (L loc (TyFamEqn { tfe_tycon = tc
, tfe_pats = tvs
, tfe_rhs = rhs })) }
An associated type in a class of the form
type FoldableConstraint t x = ()
has an AnnEqual attached to the location in tfid_eqn. Since the location
is discarded, this annotation is then disconnected from the AST.
Test Plan: ./validate
Reviewers: hvr, austin
Reviewed By: austin
Subscribers: bgamari, thomie, mpickering
Differential Revision: https://phabricator.haskell.org/D842
GHC Trac Issues: #10307
(cherry picked from commit 811b72adedcd12149783eac19ebccff1dd72bc1c)
Conflicts:
compiler/parser/Parser.y
-rw-r--r-- | compiler/parser/Parser.y | 32 | ||||
-rw-r--r-- | testsuite/tests/ghc-api/annotations/.gitignore | 1 | ||||
-rw-r--r-- | testsuite/tests/ghc-api/annotations/Makefile | 8 | ||||
-rw-r--r-- | testsuite/tests/ghc-api/annotations/T10307.stdout | 36 | ||||
-rw-r--r-- | testsuite/tests/ghc-api/annotations/Test10307.hs | 6 | ||||
-rw-r--r-- | testsuite/tests/ghc-api/annotations/all.T | 1 | ||||
-rw-r--r-- | testsuite/tests/ghc-api/annotations/t10307.hs | 106 |
7 files changed, 177 insertions, 13 deletions
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index 0f185def25..602af192eb 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -830,8 +830,9 @@ inst_decl :: { LInstDecl RdrName } -- type instance declarations | 'type' 'instance' ty_fam_inst_eqn - {% amms (mkTyFamInst (comb2 $1 $3) $3) - [mj AnnType $1,mj AnnInstance $2] } + {% ams $3 (fst $ unLoc $3) + >> amms (mkTyFamInst (comb2 $1 $3) (snd $ unLoc $3)) + (mj AnnType $1:mj AnnInstance $2:(fst $ unLoc $3)) } -- data/newtype instance declaration | data_or_newtype 'instance' capi_ctype tycl_hdr constrs deriving @@ -881,18 +882,20 @@ ty_fam_inst_eqn_list :: { Located ([AddAnn],[LTyFamInstEqn RdrName]) } ty_fam_inst_eqns :: { Located [LTyFamInstEqn RdrName] } : ty_fam_inst_eqns ';' ty_fam_inst_eqn - {% asl (unLoc $1) $2 $3 - >> return (sLL $1 $> ($3 : unLoc $1)) } + {% asl (unLoc $1) $2 (snd $ unLoc $3) + >> ams $3 (fst $ unLoc $3) + >> return (sLL $1 $> ((snd $ unLoc $3) : unLoc $1)) } | ty_fam_inst_eqns ';' {% addAnnotation (gl $1) AnnSemi (gl $2) >> return (sLL $1 $> (unLoc $1)) } - | ty_fam_inst_eqn { sLL $1 $> [$1] } + | ty_fam_inst_eqn {% ams $1 (fst $ unLoc $1) + >> return (sLL $1 $> [snd $ unLoc $1]) } -ty_fam_inst_eqn :: { LTyFamInstEqn RdrName } +ty_fam_inst_eqn :: { Located ([AddAnn],LTyFamInstEqn RdrName) } : type '=' ctype -- Note the use of type for the head; this allows -- infix type constructors and type patterns {% do { (eqn,ann) <- mkTyFamInstEqn $1 $3 - ; ams (sLL $1 $> eqn) (mj AnnEqual $2:ann) } } + ; return (sLL $1 $> (mj AnnEqual $2:ann, sLL $1 $> eqn)) } } -- Associated type family declarations -- @@ -923,11 +926,13 @@ at_decl_cls :: { LHsDecl RdrName } -- default type instances, with optional 'instance' keyword | 'type' ty_fam_inst_eqn - {% amms (liftM mkInstD (mkTyFamInst (comb2 $1 $2) $2)) - [mj AnnType $1] } + {% ams $2 (fst $ unLoc $2) >> + amms (liftM mkInstD (mkTyFamInst (comb2 $1 $2) (snd $ unLoc $2))) + (mj AnnType $1:(fst $ unLoc $2)) } | 'type' 'instance' ty_fam_inst_eqn - {% amms (liftM mkInstD (mkTyFamInst (comb2 $1 $3) $3)) - [mj AnnType $1,mj AnnInstance $2] } + {% ams $3 (fst $ unLoc $3) >> + amms (liftM mkInstD (mkTyFamInst (comb2 $1 $3) (snd $ unLoc $3))) + (mj AnnType $1:mj AnnInstance $2:(fst $ unLoc $3)) } opt_family :: { [AddAnn] } : {- empty -} { [] } @@ -940,8 +945,9 @@ at_decl_inst :: { LInstDecl RdrName } : 'type' ty_fam_inst_eqn -- Note the use of type for the head; this allows -- infix type constructors and type patterns - {% amms (mkTyFamInst (comb2 $1 $2) $2) - [mj AnnType $1] } + {% ams $2 (fst $ unLoc $2) >> + amms (mkTyFamInst (comb2 $1 $2) (snd $ unLoc $2)) + (mj AnnType $1:(fst $ unLoc $2)) } -- data/newtype instance declaration | data_or_newtype capi_ctype tycl_hdr constrs deriving diff --git a/testsuite/tests/ghc-api/annotations/.gitignore b/testsuite/tests/ghc-api/annotations/.gitignore index 41b32acb65..8b7f082773 100644 --- a/testsuite/tests/ghc-api/annotations/.gitignore +++ b/testsuite/tests/ghc-api/annotations/.gitignore @@ -8,6 +8,7 @@ t10268 t10269 t10280 t10312 +t10307 *.hi *.o *.run.* diff --git a/testsuite/tests/ghc-api/annotations/Makefile b/testsuite/tests/ghc-api/annotations/Makefile index 1f03afc5ea..15c3bc4237 100644 --- a/testsuite/tests/ghc-api/annotations/Makefile +++ b/testsuite/tests/ghc-api/annotations/Makefile @@ -7,6 +7,7 @@ clean: rm -f annotations comments parseTree exampleTest rm -f t10269 rm -f t10255 t10312 + rm -f t1037 annotations: rm -f annotations.o annotations.hi @@ -65,3 +66,10 @@ t10312: ./t10312 "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" .PHONY: clean annotations parseTree comments exampleTest listcomps t10255 t10312 + +t10307: + rm -f t10307.o t10307.hi + '$(TEST_HC)' $(TEST_HC_OPTS) --make -v0 -package ghc t10307 + ./t10307 "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" + +.PHONY: t10307 diff --git a/testsuite/tests/ghc-api/annotations/T10307.stdout b/testsuite/tests/ghc-api/annotations/T10307.stdout new file mode 100644 index 0000000000..66cc8aa59b --- /dev/null +++ b/testsuite/tests/ghc-api/annotations/T10307.stdout @@ -0,0 +1,36 @@ +---Problems--------------------- +[ +(AK Test10307.hs:6:8-34 AnnEqual = [Test10307.hs:6:31]) +] + +-------------------------------- +[ +(AK Test10307.hs:1:1 AnnModule = [Test10307.hs:2:1-6]) + +(AK Test10307.hs:1:1 AnnWhere = [Test10307.hs:2:18-22]) + +(AK Test10307.hs:(4,1)-(6,34) AnnClass = [Test10307.hs:4:1-5]) + +(AK Test10307.hs:(4,1)-(6,34) AnnSemi = [Test10307.hs:7:1]) + +(AK Test10307.hs:(4,1)-(6,34) AnnWhere = [Test10307.hs:4:18-22]) + +(AK Test10307.hs:5:3-34 AnnDcolon = [Test10307.hs:5:31-32]) + +(AK Test10307.hs:5:3-34 AnnSemi = [Test10307.hs:6:3]) + +(AK Test10307.hs:5:3-34 AnnType = [Test10307.hs:5:3-6]) + +(AK Test10307.hs:6:3-34 AnnEqual = [Test10307.hs:6:31]) + +(AK Test10307.hs:6:3-34 AnnType = [Test10307.hs:6:3-6]) + +(AK Test10307.hs:6:8-34 AnnEqual = [Test10307.hs:6:31]) + +(AK Test10307.hs:6:33-34 AnnCloseP = [Test10307.hs:6:34]) + +(AK Test10307.hs:6:33-34 AnnOpenP = [Test10307.hs:6:33]) + +(AK <no location info> AnnEofPos = [Test10307.hs:7:1]) +] + diff --git a/testsuite/tests/ghc-api/annotations/Test10307.hs b/testsuite/tests/ghc-api/annotations/Test10307.hs new file mode 100644 index 0000000000..938801a8d6 --- /dev/null +++ b/testsuite/tests/ghc-api/annotations/Test10307.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TypeFamilies #-} +module Test10307 where + +class Foldable t where + type FoldableConstraint t x :: * + type FoldableConstraint t x = () diff --git a/testsuite/tests/ghc-api/annotations/all.T b/testsuite/tests/ghc-api/annotations/all.T index b537bcd617..3e145b946b 100644 --- a/testsuite/tests/ghc-api/annotations/all.T +++ b/testsuite/tests/ghc-api/annotations/all.T @@ -8,3 +8,4 @@ test('T10268', normal, run_command, ['$MAKE -s --no-print-directory T10268' test('T10269', normal, run_command, ['$MAKE -s --no-print-directory T10269']) test('T10280', normal, run_command, ['$MAKE -s --no-print-directory T10280']) test('T10312', normal, run_command, ['$MAKE -s --no-print-directory t10312']) +test('T10307', normal, run_command, ['$MAKE -s --no-print-directory t10307']) diff --git a/testsuite/tests/ghc-api/annotations/t10307.hs b/testsuite/tests/ghc-api/annotations/t10307.hs new file mode 100644 index 0000000000..5c6f233f02 --- /dev/null +++ b/testsuite/tests/ghc-api/annotations/t10307.hs @@ -0,0 +1,106 @@ +{-# 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 "Test10307" + +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) + 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) |