ApiAnnotations : Nested forall loses forall annotation
authorAlan Zimmerman <alan.zimm@gmail.com>
Wed, 6 May 2015 13:08:40 +0000 (08:08 -0500)
committerAustin Seipp <austin@well-typed.com>
Wed, 6 May 2015 13:10:00 +0000 (08:10 -0500)
When parsing

    {-# LANGUAGE ScopedTypeVariables #-}

    extremumNewton :: forall tag. forall tag1.
                       tag -> tag1 -> Int
    extremumNewton = undefined

The parser attaches an AnnForall to the second forall, which appears as
a nested HsForAllTy.

Somewhere this nesting is flattened, and the tyvarbndrs are collapsed
into a single HsForAllTy. In this process the second AnnForAll loses its
anchor in the AST.

Reviewed By: austin

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

GHC Trac Issues: #10278

compiler/parser/Parser.y
testsuite/tests/ghc-api/annotations/.gitignore
testsuite/tests/ghc-api/annotations/Makefile
testsuite/tests/ghc-api/annotations/T10278.stderr [new file with mode: 0644]
testsuite/tests/ghc-api/annotations/T10278.stdout [new file with mode: 0644]
testsuite/tests/ghc-api/annotations/Test10278.hs [new file with mode: 0644]
testsuite/tests/ghc-api/annotations/all.T
testsuite/tests/ghc-api/annotations/t10278.hs [new file with mode: 0644]

index 5d1da69..529bc9f 100644 (file)
@@ -565,7 +565,7 @@ TH_QQUASIQUOTE  { L _ (ITqQuasiQuote _) }
 %name parseFullStmt   stmt
 %name parseStmt   maybe_stmt
 %name parseIdentifier  identifier
-%name parseType ctype
+%name parseType ctype_noann
 %partial parseHeader header
 %%
 
@@ -909,7 +909,7 @@ ty_decl :: { LTyClDecl RdrName }
                 --
                 -- Note the use of type for the head; this allows
                 -- infix type constructors to be declared
-                {% amms (mkTySynonym (comb2 $1 $4) $2 $4)
+                {% amms (mkTySynonym (comb2 $1 $4) $2 (snd $ unLoc $4))
                         [mj AnnType $1,mj AnnEqual $3] }
 
            -- type family declarations
@@ -1024,7 +1024,7 @@ ty_fam_inst_eqn :: { 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
+              {% do { (eqn,ann) <- mkTyFamInstEqn $1 (snd $ unLoc $3)
                     ; ams (sLL $1 $> eqn) (mj AnnEqual $2:ann) } }
 
 -- Associated type family declarations
@@ -1404,7 +1404,7 @@ rule_var_list :: { [LRuleBndr RdrName] }
 rule_var :: { LRuleBndr RdrName }
         : varid                         { sLL $1 $> (RuleBndr $1) }
         | '(' varid '::' ctype ')'      {% ams (sLL $1 $> (RuleBndrSig $2
-                                                       (mkHsWithBndrs $4)))
+                                                       (mkHsWithBndrs (snd $ unLoc $4))))
                                                [mop $1,mj AnnDcolon $3,mcp $5] }
 
 -----------------------------------------------------------------------------
@@ -1518,11 +1518,13 @@ opt_asig :: { ([AddAnn],Maybe (LHsType RdrName)) }
 
 sigtype :: { LHsType RdrName }          -- Always a HsForAllTy,
                                         -- to tell the renamer where to generalise
-        : ctype                         { sL1 $1 (mkImplicitHsForAllTy (noLoc []) $1) }
+        : ctype                         {% ams (sL1 $1 (mkImplicitHsForAllTy (noLoc []) (snd $ unLoc $1)))
+                                               (fst $ unLoc $1) }
         -- Wrap an Implicit forall if there isn't one there already
 
 sigtypedoc :: { LHsType RdrName }       -- Always a HsForAllTy
-        : ctypedoc                      { sL1 $1 (mkImplicitHsForAllTy (noLoc []) $1) }
+        : ctypedoc                      {% ams (sL1 $1 (mkImplicitHsForAllTy (noLoc []) (snd $ unLoc $1)))
+                                                (fst $ unLoc $1) }
         -- Wrap an Implicit forall if there isn't one there already
 
 sig_vars :: { Located [Located RdrName] }    -- Returned in reversed order
@@ -1554,17 +1556,22 @@ strict_mark :: { Located ([AddAnn],HsBang) }
         -- better error message if we parse it here
 
 -- A ctype is a for-all type
-ctype   :: { LHsType RdrName }
+ctype   :: { Located ([AddAnn],LHsType RdrName) }
         : 'forall' tv_bndrs '.' ctype   {% hintExplicitForall (getLoc $1) >>
-                                           ams (sLL $1 $> $ mkExplicitHsForAllTy $2
-                                                                 (noLoc []) $4)
-                                               [mj AnnForall $1,mj AnnDot $3] }
+                                           ams (sLL $1 $> (mj AnnForall $1:mj AnnDot $3:(fst $ unLoc $4),
+                                                sLL $1 $> $ mkExplicitHsForAllTy $2
+                                                                 (noLoc []) (snd $ unLoc $4)))
+                                               (mj AnnForall $1:mj AnnDot $3:(fst $ unLoc $4)) }
         | context '=>' ctype          {% addAnnotation (gl $1) AnnDarrow (gl $2)
-                                         >> return (sLL $1 $> $
-                                               mkQualifiedHsForAllTy $1 $3) }
-        | ipvar '::' type             {% ams (sLL $1 $> (HsIParamTy (unLoc $1) $3))
+                                         >> ams (sLL $1 $> ([], sLL $1 $> $
+                                                    mkQualifiedHsForAllTy $1 (snd $ unLoc $3)))
+                                                (fst $ unLoc $3) }
+        | ipvar '::' type             {% ams (sLL $1 $> ([],sLL $1 $> (HsIParamTy (unLoc $1) $3)))
                                              [mj AnnVal $1,mj AnnDcolon $2] }
-        | type                        { $1 }
+        | type                        { sL1 $1 ([], $1) }
+
+ctype_noann  :: { LHsType RdrName }
+ctype_noann  : ctype                       { snd $ unLoc $1 }
 
 ----------------------
 -- Notes for 'ctypedoc'
@@ -1577,17 +1584,19 @@ ctype   :: { LHsType RdrName }
 -- If we allow comments on types here, it's not clear if the comment applies
 -- to 'field' or to 'Int'. So we must use `ctype` to describe the type.
 
-ctypedoc :: { LHsType RdrName }
+ctypedoc :: { Located ([AddAnn],LHsType RdrName) }
         : 'forall' tv_bndrs '.' ctypedoc {% hintExplicitForall (getLoc $1) >>
-                                            ams (sLL $1 $> $ mkExplicitHsForAllTy $2
-                                                                  (noLoc []) $4)
-                                                [mj AnnForall $1,mj AnnDot $3] }
+                                            ams (sLL $1 $> (mj AnnForall $1:mj AnnDot $3:(fst $ unLoc $4),
+                                                      sLL $1 $> $ mkExplicitHsForAllTy $2
+                                                                  (noLoc []) (snd $ unLoc $4)))
+                                                (mj AnnForall $1:mj AnnDot $3:(fst $ unLoc $4)) }
         | context '=>' ctypedoc       {% addAnnotation (gl $1) AnnDarrow (gl $2)
-                                         >> return (sLL $1 $> $
-                                                  mkQualifiedHsForAllTy $1 $3) }
-        | ipvar '::' type             {% ams (sLL $1 $> (HsIParamTy (unLoc $1) $3))
+                                         >> ams (sLL $1 $>
+                                                  ([], sLL $1 $> $ mkQualifiedHsForAllTy $1 (snd $ unLoc $3)))
+                                                  (fst $ unLoc $3) }
+        | ipvar '::' type             {% ams (sLL $1 $> ([],sLL $1 $> (HsIParamTy (unLoc $1) $3)))
                                              [mj AnnDcolon $2] }
-        | typedoc                     { $1 }
+        | typedoc                     { sL1 $1 ([],$1) }
 
 ----------------------
 -- Notes for 'context'
@@ -1615,7 +1624,7 @@ type :: { LHsType RdrName }
         : btype                         { $1 }
         | btype qtyconop type           { sLL $1 $> $ mkHsOpTy $1 $2 $3 }
         | btype tyvarop  type           { sLL $1 $> $ mkHsOpTy $1 $2 $3 }
-        | btype '->'     ctype          {% ams (sLL $1 $> $ HsFunTy $1 $3)
+        | btype '->'     ctype          {% ams (sLL $1 $> $ HsFunTy $1 (snd $ unLoc $3))
                                                [mj AnnRarrow $2] }
         | btype '~'      btype          {% ams (sLL $1 $> $ HsEqTy $1 $3)
                                                [mj AnnTilde $2] }
@@ -1632,10 +1641,10 @@ typedoc :: { LHsType RdrName }
         | btype qtyconop type docprev    { sLL $1 $> $ HsDocTy (L (comb3 $1 $2 $3) (mkHsOpTy $1 $2 $3)) $4 }
         | btype tyvarop  type            { sLL $1 $> $ mkHsOpTy $1 $2 $3 }
         | btype tyvarop  type docprev    { sLL $1 $> $ HsDocTy (L (comb3 $1 $2 $3) (mkHsOpTy $1 $2 $3)) $4 }
-        | btype '->'     ctypedoc        {% ams (sLL $1 $> $ HsFunTy $1 $3)
+        | btype '->'     ctypedoc        {% ams (sLL $1 $> $ HsFunTy $1 (snd $ unLoc $3))
                                                 [mj AnnRarrow $2] }
         | btype docprev '->' ctypedoc    {% ams (sLL $1 $> $ HsFunTy (L (comb2 $1 $2)
-                                                            (HsDocTy $1 $2)) $4)
+                                                            (HsDocTy $1 $2)) (snd $ unLoc $4))
                                                 [mj AnnRarrow $3] }
         | btype '~'      btype           {% ams (sLL $1 $> $ HsEqTy $1 $3)
                                                 [mj AnnTilde $2] }
@@ -1669,16 +1678,16 @@ atype :: { LHsType RdrName }
         | '(' ctype ',' comma_types1 ')' {% addAnnotation (gl $2) AnnComma
                                                           (gl $3) >>
                                             ams (sLL $1 $> $ HsTupleTy
-                                             HsBoxedOrConstraintTuple ($2 : $4))
+                                             HsBoxedOrConstraintTuple ((snd $ unLoc $2) : $4))
                                                 [mop $1,mcp $5] }
         | '(#' '#)'                   {% ams (sLL $1 $> $ HsTupleTy HsUnboxedTuple [])
                                              [mo $1,mc $2] }
         | '(#' comma_types1 '#)'      {% ams (sLL $1 $> $ HsTupleTy HsUnboxedTuple $2)
                                              [mo $1,mc $3] }
-        | '[' ctype ']'               {% ams (sLL $1 $> $ HsListTy  $2) [mos $1,mcs $3] }
-        | '[:' ctype ':]'             {% ams (sLL $1 $> $ HsPArrTy  $2) [mo $1,mc $3] }
-        | '(' ctype ')'               {% ams (sLL $1 $> $ HsParTy   $2) [mop $1,mcp $3] }
-        | '(' ctype '::' kind ')'     {% ams (sLL $1 $> $ HsKindSig $2 $4)
+        | '[' ctype ']'               {% ams (sLL $1 $> $ HsListTy  (snd $ unLoc $2)) [mos $1,mcs $3] }
+        | '[:' ctype ':]'             {% ams (sLL $1 $> $ HsPArrTy  (snd $ unLoc $2)) [mo $1,mc $3] }
+        | '(' ctype ')'               {% ams (sLL $1 $> $ HsParTy   (snd $ unLoc $2)) [mop $1,mcp $3] }
+        | '(' ctype '::' kind ')'     {% ams (sLL $1 $> $ HsKindSig (snd $ unLoc $2) $4)
                                              [mop $1,mj AnnDcolon $3,mcp $5] }
         | quasiquote                  { sL1 $1 (HsSpliceTy (unLoc $1) placeHolderKind) }
         | '$(' exp ')'                {% ams (sLL $1 $> $ mkHsSpliceTy $2)
@@ -1689,7 +1698,7 @@ atype :: { LHsType RdrName }
         | SIMPLEQUOTE qcon_nowiredlist {% ams (sLL $1 $> $ HsTyVar $ unLoc $2) [mj AnnSimpleQuote $1,mj AnnName $2] }
         | SIMPLEQUOTE  '(' ctype ',' comma_types1 ')'
                              {% addAnnotation (gl $3) AnnComma (gl $4) >>
-                                ams (sLL $1 $> $ HsExplicitTupleTy [] ($3 : $5))
+                                ams (sLL $1 $> $ HsExplicitTupleTy [] ((snd $ unLoc $3) : $5))
                                     [mj AnnSimpleQuote $1,mop $2,mcp $6] }
         | SIMPLEQUOTE  '[' comma_types0 ']'     {% ams (sLL $1 $> $ HsExplicitListTy
                                                             placeHolderKind $3)
@@ -1704,7 +1713,7 @@ atype :: { LHsType RdrName }
         | '[' ctype ',' comma_types1 ']'  {% addAnnotation (gl $2) AnnComma
                                                            (gl $3) >>
                                              ams (sLL $1 $> $ HsExplicitListTy
-                                                     placeHolderKind ($2 : $4))
+                                                     placeHolderKind ((snd $ unLoc $2) : $4))
                                                  [mos $1,mcs $5] }
         | INTEGER              { sLL $1 $> $ HsTyLit $ HsNumTy (getINTEGERs $1)
                                                                (getINTEGER $1) }
@@ -1730,9 +1739,9 @@ comma_types0  :: { [LHsType RdrName] }  -- Zero or more:  ty,ty,ty
         | {- empty -}                   { [] }
 
 comma_types1    :: { [LHsType RdrName] }  -- One or more:  ty,ty,ty
-        : ctype                        { [$1] }
+        : ctype                        { [snd $ unLoc $1] }
         | ctype  ',' comma_types1      {% addAnnotation (gl $1) AnnComma (gl $2)
-                                          >> return ($1 : $3) }
+                                          >> return ((snd $ unLoc $1) : $3) }
 
 tv_bndrs :: { [LHsTyVarBndr RdrName] }
          : tv_bndr tv_bndrs             { $1 : $2 }
@@ -1921,7 +1930,7 @@ fielddecl :: { LConDeclField RdrName }
                                               -- A list because of   f,g :: Int
         : maybe_docnext sig_vars '::' ctype maybe_docprev
             {% ams (L (comb2 $2 $4)
-                      (ConDeclField (reverse (unLoc $2)) $4 ($1 `mplus` $5)))
+                      (ConDeclField (reverse (unLoc $2)) (snd $ unLoc $4) ($1 `mplus` $5)))
                    [mj AnnDcolon $3] }
 
 -- We allow the odd-looking 'inst_type' in a deriving clause, so that
@@ -2311,8 +2320,8 @@ aexp2   :: { LHsExpr RdrName }
         | '[||' exp '||]'     {% ams (sLL $1 $> $ HsBracket (TExpBr $2)) [mo $1,mc $3]}
         | '[t|' ctype '|]'    {% checkNoPartialType
                                    (text "in type brackets" <> colon
-                                    <+> quotes (text "[t|" <+> ppr $2 <+> text "|]")) $2 >>
-                                 ams (sLL $1 $> $ HsBracket (TypBr $2)) [mo $1,mc $3] }
+                                    <+> quotes (text "[t|" <+> ppr (snd $ unLoc $2) <+> text "|]")) (snd $ unLoc $2) >>
+                                 ams (sLL $1 $> $ HsBracket (TypBr (snd $ unLoc $2))) [mo $1,mc $3] }
         | '[p|' infixexp '|]' {% checkPattern empty $2 >>= \p ->
                                       ams (sLL $1 $> $ HsBracket (PatBr p))
                                           [mo $1,mc $3] }
index d74d3c2..bf7108a 100644 (file)
@@ -43,4 +43,9 @@ T10268:
        '$(TEST_HC)' $(TEST_HC_OPTS) --make -v0 -package ghc t10268
        ./t10268 "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`"
 
+T10278:
+       rm -f t10278.o t10278.hi
+       '$(TEST_HC)' $(TEST_HC_OPTS) --make -v0 -package ghc t10278
+       ./t10278 "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`"
+
 .PHONY: clean annotations parseTree comments exampleTest listcomps
diff --git a/testsuite/tests/ghc-api/annotations/T10278.stderr b/testsuite/tests/ghc-api/annotations/T10278.stderr
new file mode 100644 (file)
index 0000000..d3788b7
--- /dev/null
@@ -0,0 +1,16 @@
+
+Test10278.hs:9:27: error:
+    Not in scope: type constructor or class ‘Tower’
+
+Test10278.hs:9:39: error:
+    Not in scope: type constructor or class ‘Tower’
+
+Test10278.hs:10:34: error:
+    Not in scope: type constructor or class ‘Tower’
+
+Test10278.hs:10:46: error:
+    Not in scope: type constructor or class ‘Tower’
+
+Test10278.hs:12:24: error: Not in scope: ‘zeroNewton’
+
+Test10278.hs:12:36: error: Not in scope: ‘diffUU’
diff --git a/testsuite/tests/ghc-api/annotations/T10278.stdout b/testsuite/tests/ghc-api/annotations/T10278.stdout
new file mode 100644 (file)
index 0000000..a3834c7
--- /dev/null
@@ -0,0 +1,96 @@
+---Problems---------------------
+[
+(AK Test10278.hs:4:31-61 AnnDot = [Test10278.hs:4:42])
+
+(AK Test10278.hs:4:31-61 AnnForall = [Test10278.hs:4:31-36])
+
+(AK Test10278.hs:(8,32)-(10,57) AnnDot = [Test10278.hs:8:43])
+
+(AK Test10278.hs:(8,32)-(10,57) AnnForall = [Test10278.hs:8:32-37])
+]
+
+--------------------------------
+[
+(AK Test10278.hs:1:1 AnnModule = [Test10278.hs:2:1-6])
+
+(AK Test10278.hs:1:1 AnnWhere = [Test10278.hs:2:18-22])
+
+(AK Test10278.hs:4:1-61 AnnDcolon = [Test10278.hs:4:16-17])
+
+(AK Test10278.hs:4:1-61 AnnSemi = [Test10278.hs:5:1])
+
+(AK Test10278.hs:4:19-61 AnnDot = [Test10278.hs:4:29, Test10278.hs:4:42, Test10278.hs:4:29,
+ Test10278.hs:4:42])
+
+(AK Test10278.hs:4:19-61 AnnForall = [Test10278.hs:4:19-24, Test10278.hs:4:31-36, Test10278.hs:4:19-24,
+ Test10278.hs:4:31-36])
+
+(AK Test10278.hs:4:31-61 AnnDot = [Test10278.hs:4:42])
+
+(AK Test10278.hs:4:31-61 AnnForall = [Test10278.hs:4:31-36])
+
+(AK Test10278.hs:4:44-61 AnnRarrow = [Test10278.hs:4:48-49])
+
+(AK Test10278.hs:4:51-61 AnnRarrow = [Test10278.hs:4:56-57])
+
+(AK Test10278.hs:5:1-26 AnnEqual = [Test10278.hs:5:16])
+
+(AK Test10278.hs:5:1-26 AnnFunId = [Test10278.hs:5:1-14])
+
+(AK Test10278.hs:5:1-26 AnnSemi = [Test10278.hs:7:1])
+
+(AK Test10278.hs:(7,1)-(11,33) AnnDcolon = [Test10278.hs:7:17-18])
+
+(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 AnnDarrow = [Test10278.hs:7:41-42])
+
+(AK Test10278.hs:7:20-39 AnnOpenP = [Test10278.hs:7:20])
+
+(AK Test10278.hs:7:21-24 AnnComma = [Test10278.hs:7:25])
+
+(AK Test10278.hs:(8,19)-(10,58) AnnCloseP = [Test10278.hs:10:58])
+
+(AK Test10278.hs:(8,19)-(10,58) AnnOpenP = [Test10278.hs:8:19])
+
+(AK Test10278.hs:(8,19)-(11,33) AnnRarrow = [Test10278.hs:11:23-24])
+
+(AK Test10278.hs:(8,20)-(10,57) AnnDot = [Test10278.hs:8:30, Test10278.hs:8:43])
+
+(AK Test10278.hs:(8,20)-(10,57) AnnForall = [Test10278.hs:8:20-25, Test10278.hs:8:32-37])
+
+(AK Test10278.hs:(8,32)-(10,57) AnnDot = [Test10278.hs:8:43])
+
+(AK Test10278.hs:(8,32)-(10,57) AnnForall = [Test10278.hs:8:32-37])
+
+(AK Test10278.hs:(9,27)-(10,57) AnnRarrow = [Test10278.hs:10:31-32])
+
+(AK Test10278.hs:9:38-50 AnnCloseP = [Test10278.hs:9:50])
+
+(AK Test10278.hs:9:38-50 AnnOpenP = [Test10278.hs:9:38])
+
+(AK Test10278.hs:10:45-57 AnnCloseP = [Test10278.hs:10:57])
+
+(AK Test10278.hs:10:45-57 AnnOpenP = [Test10278.hs:10:45])
+
+(AK Test10278.hs:11:26-33 AnnRarrow = [Test10278.hs:11:28-29])
+
+(AK Test10278.hs:11:31-33 AnnCloseS = [Test10278.hs:11:33])
+
+(AK Test10278.hs:11:31-33 AnnOpenS = [Test10278.hs:11:31])
+
+(AK Test10278.hs:12:1-47 AnnEqual = [Test10278.hs:12:22])
+
+(AK Test10278.hs:12:1-47 AnnFunId = [Test10278.hs:12:1-15])
+
+(AK Test10278.hs:12:1-47 AnnSemi = [Test10278.hs:13:1])
+
+(AK Test10278.hs:12:35-44 AnnCloseP = [Test10278.hs:12:44])
+
+(AK Test10278.hs:12:35-44 AnnOpenP = [Test10278.hs:12:35])
+
+(AK <no location info> AnnEofPos = [Test10278.hs:13:1])
+]
+
diff --git a/testsuite/tests/ghc-api/annotations/Test10278.hs b/testsuite/tests/ghc-api/annotations/Test10278.hs
new file mode 100644 (file)
index 0000000..5586ecc
--- /dev/null
@@ -0,0 +1,12 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+module Test10278 where
+
+extremumNewton :: forall tag. forall tag1. tag -> tag1 -> Int
+extremumNewton = undefined
+
+extremumNewton1 :: (Eq a, Fractional a) =>
+                  (forall tag. forall tag1.
+                          Tower tag1 (Tower tag a)
+                              -> Tower tag1 (Tower tag a))
+                      -> a -> [a]
+extremumNewton1 f x0 = zeroNewton (diffUU f) x0
index c8df1c4..46f788a 100644 (file)
@@ -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('T10278',      normal, run_command, ['$MAKE -s --no-print-directory T10278'])
diff --git a/testsuite/tests/ghc-api/annotations/t10278.hs b/testsuite/tests/ghc-api/annotations/t10278.hs
new file mode 100644 (file)
index 0000000..a063d91
--- /dev/null
@@ -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 "Test10278"
+
+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)