ApiAnnotations : AST version of nested forall loses forall annotation

Summary:
When parsing

    {-# LANGUAGE ScopedTypeVariables #-}

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

the parser creates nested HsForAllTy's for the two forall statements.

These get flattened into a single one in `HsTypes.mk_forall_ty`

This patch removes the flattening, so that API Annotations are not lost in the
process.

Test Plan: ./validate

Reviewers: goldfire, austin, simonpj

Reviewed By: simonpj

Subscribers: bgamari, mpickering, thomie, goldfire

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

GHC Trac Issues: #10278, #10315, #10354, #10363

14 files changed, 477 insertions, 77 deletions

diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index 20cb234dbd..38c5101173 100644
--- a/compiler/hsSyn/Convert.hs
+++ b/compiler/hsSyn/Convert.hs
@@ -13,6 +13,7 @@ module Convert( convertToHsExpr, convertToPat, convertToHsDecls,
                 thRdrNameGuesses ) where
 
 import HsSyn as Hs
+import HsTypes  ( mkHsForAllTy )
 import qualified Class
 import RdrName
 import qualified Name
@@ -244,7 +245,7 @@ cvtDec (InstanceD ctxt ty decs)
         ; unless (null fams') (failWith (mkBadDecMsg doc fams'))
         ; ctxt' <- cvtContext ctxt
         ; L loc ty' <- cvtType ty
-        ; let inst_ty' = L loc $ mkImplicitHsForAllTy ctxt' $ L loc ty'
+        ; let inst_ty' = L loc $ mkHsForAllTy Implicit [] ctxt' $ L loc ty'
         ; returnJustL $ InstD $ ClsInstD $
           ClsInstDecl inst_ty' binds' sigs' ats' adts' Nothing }
 
@@ -310,7 +311,7 @@ cvtDec (TH.RoleAnnotD tc roles)
 cvtDec (TH.StandaloneDerivD cxt ty)
   = do { cxt' <- cvtContext cxt
        ; L loc ty'  <- cvtType ty
-       ; let inst_ty' = L loc $ mkImplicitHsForAllTy cxt' $ L loc ty'
+       ; let inst_ty' = L loc $ mkHsForAllTy Implicit [] cxt' $ L loc ty'
        ; returnJustL $ DerivD $
          DerivDecl { deriv_type = inst_ty', deriv_overlap_mode = Nothing } }
 
diff --git a/compiler/hsSyn/HsSyn.hs b/compiler/hsSyn/HsSyn.hs
index 72525b2519..d084dc2f7c 100644
--- a/compiler/hsSyn/HsSyn.hs
+++ b/compiler/hsSyn/HsSyn.hs
@@ -40,7 +40,7 @@ import HsImpExp
 import HsLit
 import PlaceHolder
 import HsPat
-import HsTypes
+import HsTypes  hiding  ( mkHsForAllTy )
 import BasicTypes       ( Fixity, WarningTxt )
 import HsUtils
 import HsDoc
diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs
index caa83013e0..15a07169ad 100644
--- a/compiler/hsSyn/HsTypes.hs
+++ b/compiler/hsSyn/HsTypes.hs
@@ -14,6 +14,7 @@ HsTypes: Abstract syntax: user-defined types
 {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
                                       -- in module PlaceHolder
 {-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE CPP #-}
 
 module HsTypes (
         HsType(..), LHsType, HsKind, LHsKind,
@@ -34,6 +35,8 @@ module HsTypes (
 
         mkHsQTvs, hsQTvBndrs, isHsKindedTyVar, hsTvbAllKinded,
         mkExplicitHsForAllTy, mkImplicitHsForAllTy, mkQualifiedHsForAllTy,
+        mkHsForAllTy,
+        flattenTopLevelLHsForAllTy,flattenTopLevelHsForAllTy,
         hsExplicitTvs,
         hsTyVarName, mkHsWithBndrs, hsLKiTyVarNames,
         hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames,
@@ -67,6 +70,9 @@ import Maybes( isJust )
 
 import Data.Data hiding ( Fixity )
 import Data.Maybe ( fromMaybe )
+#if __GLASGOW_HASKELL__ < 709
+import Data.Monoid hiding ((<>))
+#endif
 
 {-
 ************************************************************************
@@ -153,6 +159,11 @@ emptyHsQTvs =  HsQTvs { hsq_kvs = [], hsq_tvs = [] }
 hsQTvBndrs :: LHsTyVarBndrs name -> [LHsTyVarBndr name]
 hsQTvBndrs = hsq_tvs
 
+instance Monoid (LHsTyVarBndrs name) where
+  mempty = emptyHsQTvs
+  mappend (HsQTvs kvs1 tvs1) (HsQTvs kvs2 tvs2)
+    = HsQTvs (kvs1 ++ kvs2) (tvs1 ++ tvs2)
+
 ------------------------------------------------
 --            HsWithBndrs
 -- Used to quantify the binders of a type in cases
@@ -529,26 +540,36 @@ data ConDeclField name  -- Record fields have Haddoc docs on them
 deriving instance (DataId name) => Data (ConDeclField name)
 
 -----------------------
--- Combine adjacent for-alls.
--- The following awkward situation can happen otherwise:
---      f :: forall a. ((Num a) => Int)
--- might generate HsForAll (Just [a]) [] (HsForAll Nothing [Num a] t)
--- Then a isn't discovered as ambiguous, and we abstract the AbsBinds wrt []
--- but the export list abstracts f wrt [a].  Disaster.
---
--- A valid type must have one for-all at the top of the type, or of the fn arg types
-
-mkImplicitHsForAllTy  ::                           LHsContext RdrName -> LHsType RdrName -> HsType RdrName
+-- A valid type must have a for-all at the top of the type, or of the fn arg
+-- types
+
+mkImplicitHsForAllTy  ::                                                 LHsType RdrName -> HsType RdrName
 mkExplicitHsForAllTy  :: [LHsTyVarBndr RdrName] -> LHsContext RdrName -> LHsType RdrName -> HsType RdrName
 mkQualifiedHsForAllTy ::                           LHsContext RdrName -> LHsType RdrName -> HsType RdrName
-mkImplicitHsForAllTy      ctxt ty = mkHsForAllTy Implicit  []  ctxt ty
+
+-- | mkImplicitHsForAllTy is called when we encounter
+--    f :: type
+-- Wrap around a HsForallTy if one is not there already.
+mkImplicitHsForAllTy (L _ (HsForAllTy exp extra tvs cxt ty))
+  = HsForAllTy exp' extra tvs cxt ty
+  where
+    exp' = case exp of
+             Qualified -> Implicit
+                          -- Qualified is used only for a nested forall,
+                          -- this is now top level
+             _         -> exp
+mkImplicitHsForAllTy ty = mkHsForAllTy Implicit  [] (noLoc []) ty
+
 mkExplicitHsForAllTy  tvs ctxt ty = mkHsForAllTy Explicit  tvs ctxt ty
 mkQualifiedHsForAllTy     ctxt ty = mkHsForAllTy Qualified []  ctxt ty
 
+-- |Smart constructor for HsForAllTy, which populates the extra-constraints
+-- field if a wildcard is present in the context.
 mkHsForAllTy :: HsExplicitFlag -> [LHsTyVarBndr RdrName] -> LHsContext RdrName -> LHsType RdrName -> HsType RdrName
--- Smart constructor for HsForAllTy
-mkHsForAllTy exp tvs (L _ []) ty = mk_forall_ty exp tvs ty
-mkHsForAllTy exp tvs ctxt     ty = HsForAllTy exp extra (mkHsQTvs tvs) cleanCtxt ty
+mkHsForAllTy exp tvs (L l []) ty
+  = HsForAllTy exp Nothing (mkHsQTvs tvs) (L l []) ty
+mkHsForAllTy exp tvs ctxt     ty
+  = HsForAllTy exp extra   (mkHsQTvs tvs) cleanCtxt        ty
   where -- Separate the extra-constraints wildcard when present
         (cleanCtxt, extra)
           | (L l HsWildcardTy) <- ignoreParens (last (unLoc ctxt)) = (init `fmap` ctxt, Just l)
@@ -557,14 +578,35 @@ mkHsForAllTy exp tvs ctxt     ty = HsForAllTy exp extra (mkHsQTvs tvs) cleanCtxt
         ignoreParens ty                 = ty
 
 
+-- |When a sigtype is parsed, the type found is wrapped in an Implicit
+-- HsForAllTy via mkImplicitHsForAllTy, to ensure that a signature always has a
+-- forall at the outer level. For Api Annotations this nested structure is
+-- important to ensure that all `forall` and `.` locations are retained.  From
+-- the renamer onwards this structure is flattened, to ease the renaming and
+-- type checking process.
+flattenTopLevelLHsForAllTy :: LHsType name -> LHsType name
+flattenTopLevelLHsForAllTy (L l ty) = L l (flattenTopLevelHsForAllTy ty)
+
+flattenTopLevelHsForAllTy :: HsType name -> HsType name
+flattenTopLevelHsForAllTy (HsForAllTy exp extra tvs (L l []) ty)
+  = mk_forall_ty l exp extra tvs ty
+flattenTopLevelHsForAllTy ty = ty
+
 -- mk_forall_ty makes a pure for-all type (no context)
-mk_forall_ty :: HsExplicitFlag -> [LHsTyVarBndr RdrName] -> LHsType RdrName -> HsType RdrName
-mk_forall_ty exp1 tvs1 (L _ (HsForAllTy exp2 extra qtvs2 ctxt ty))
-  = addExtra $ mkHsForAllTy (exp1 `plus` exp2) (tvs1 ++ hsq_tvs qtvs2) ctxt ty
-  where addExtra (HsForAllTy exp _ qtvs ctxt ty) = HsForAllTy exp extra qtvs ctxt ty
-        addExtra ty = ty -- Impossible, as mkHsForAllTy always returns a HsForAllTy
-mk_forall_ty exp  tvs  (L _ (HsParTy ty)) = mk_forall_ty exp tvs ty
-mk_forall_ty exp  tvs  ty                 = HsForAllTy exp Nothing (mkHsQTvs tvs) (noLoc []) ty
+mk_forall_ty :: SrcSpan -> HsExplicitFlag -> Maybe SrcSpan -> LHsTyVarBndrs name
+             -> LHsType name -> HsType name
+mk_forall_ty _ exp1 extra1 tvs1 (L _ (HsForAllTy exp2 extra qtvs2 ctxt ty)) =
+  HsForAllTy (exp1 `plus` exp2) (mergeExtra extra1 extra)
+             (tvs1 `mappend` qtvs2) ctxt ty
+  where
+        -- Bias the merging of extra's to the top level, so that a single
+        -- wildcard context will prevail
+        mergeExtra (Just s) _ = Just s
+        mergeExtra _        e = e
+mk_forall_ty l exp  extra tvs  (L _ (HsParTy ty))
+  = mk_forall_ty l exp extra tvs ty
+mk_forall_ty l exp extra tvs  ty
+  = HsForAllTy exp extra tvs (L l []) ty
         -- Even if tvs is empty, we still make a HsForAll!
         -- In the Implicit case, this signals the place to do implicit quantification
         -- In the Explicit case, it prevents implicit quantification
@@ -579,6 +621,7 @@ _         `plus` _         = Implicit
   -- NB: Implicit `plus` Qualified = Implicit
   --     so that  f :: Eq a => a -> a  ends up Implicit
 
+---------------------
 hsExplicitTvs :: LHsType Name -> [Name]
 -- The explicitly-given forall'd type variables of a HsType
 hsExplicitTvs (L _ (HsForAllTy Explicit _ tvs _ _)) = hsLKiTyVarNames tvs
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index 7ffa6b6a05..ed6f5ad4c8 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -1523,11 +1523,11 @@ 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                         { sL1 $1 (mkImplicitHsForAllTy $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                      { sL1 $1 (mkImplicitHsForAllTy $1) }
         -- Wrap an Implicit forall if there isn't one there already
 
 sig_vars :: { Located [Located RdrName] }    -- Returned in reversed order
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index 39589fe72c..5e2fa131cf 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -623,15 +623,22 @@ mkSimpleConDecl name qvars cxt details
 mkGadtDecl :: [Located RdrName]
            -> LHsType RdrName     -- Always a HsForAllTy
            -> P (ConDecl RdrName)
+mkGadtDecl names (L l ty)
+  = mkGadtDecl' names (L l (flattenTopLevelHsForAllTy ty))
+
+mkGadtDecl' :: [Located RdrName]
+           -> LHsType RdrName     -- Always a HsForAllTy
+           -> P (ConDecl RdrName)
+
 -- We allow C,D :: ty
 -- and expand it as if it had been
 --    C :: ty; D :: ty
 -- (Just like type signatures in general.)
-mkGadtDecl _ ty@(L _ (HsForAllTy _ (Just l) _ _ _))
+mkGadtDecl' _ ty@(L _ (HsForAllTy _ (Just l) _ _ _))
   = parseErrorSDoc l $
     text "A constructor cannot have a partial type:" $$
     ppr ty
-mkGadtDecl names (L ls (HsForAllTy imp Nothing qvars cxt tau))
+mkGadtDecl' names (L ls (HsForAllTy imp Nothing qvars cxt tau))
   = return $ mk_gadt_con names
   where
     (details, res_ty)           -- See Note [Sorting out the result type]
@@ -649,7 +656,7 @@ mkGadtDecl names (L ls (HsForAllTy imp Nothing qvars cxt tau))
                  , con_details  = details
                  , con_res      = ResTyGADT ls res_ty
                  , con_doc      = Nothing }
-mkGadtDecl _ other_ty = pprPanic "mkGadtDecl" (ppr other_ty)
+mkGadtDecl' _ other_ty = pprPanic "mkGadtDecl" (ppr other_ty)
 
 tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
 tyConToDataCon loc tc
diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs
index 00381b3567..0aa33add9e 100644
--- a/compiler/rename/RnNames.hs
+++ b/compiler/rename/RnNames.hs
@@ -595,7 +595,8 @@ getLocalNonValBinders fixity_env
     new_assoc (L _ (ClsInstD { cid_inst = ClsInstDecl
                              { cid_poly_ty = inst_ty
                              , cid_datafam_insts = adts } }))
-      | Just (_, _, L loc cls_rdr, _) <- splitLHsInstDeclTy_maybe inst_ty
+      | Just (_, _, L loc cls_rdr, _) <-
+                   splitLHsInstDeclTy_maybe (flattenTopLevelLHsForAllTy inst_ty)
       = do { cls_nm <- setSrcSpan loc $ lookupGlobalOccRn cls_rdr
            ; mapM (new_di (Just cls_nm) . unLoc) adts }
       | otherwise
diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs
index c77ef3f7a8..93a7dfdb1c 100644
--- a/compiler/rename/RnTypes.hs
+++ b/compiler/rename/RnTypes.hs
@@ -74,7 +74,8 @@ rnLHsInstType doc_str ty
        ; return (ty', fvs) }
   where
     good_inst_ty
-      | Just (_, _, L _ cls, _) <- splitLHsInstDeclTy_maybe ty
+      | Just (_, _, L _ cls, _) <-
+                        splitLHsInstDeclTy_maybe (flattenTopLevelLHsForAllTy ty)
       , isTcOcc (rdrNameOcc cls) = True
       | otherwise                = False
 
@@ -133,52 +134,8 @@ rnHsKind = rnHsTyKi False
 
 rnHsTyKi :: Bool -> HsDocContext -> HsType RdrName -> RnM (HsType Name, FreeVars)
 
-rnHsTyKi isType doc (HsForAllTy Implicit extra _ lctxt@(L _ ctxt) ty)
-  = ASSERT( isType ) do
-        -- Implicit quantifiction in source code (no kinds on tyvars)
-        -- Given the signature  C => T  we universally quantify
-        -- over FV(T) \ {in-scope-tyvars}
-    rdr_env <- getLocalRdrEnv
-    loc <- getSrcSpanM
-    let
-        (forall_kvs, forall_tvs) = filterInScope rdr_env $
-                                   extractHsTysRdrTyVars (ty:ctxt)
-           -- In for-all types we don't bring in scope
-           -- kind variables mentioned in kind signatures
-           -- (Well, not yet anyway....)
-           --    f :: Int -> T (a::k)    -- Not allowed
-
-           -- The filterInScope is to ensure that we don't quantify over
-           -- type variables that are in scope; when GlasgowExts is off,
-           -- there usually won't be any, except for class signatures:
-           --   class C a where { op :: a -> a }
-        tyvar_bndrs = userHsTyVarBndrs loc forall_tvs
-
-    rnForAll doc Implicit extra forall_kvs (mkHsQTvs tyvar_bndrs) lctxt ty
-
-rnHsTyKi isType doc fulltype@(HsForAllTy Qualified extra _ lctxt@(L _ ctxt) ty)
-  = ASSERT( isType ) do
-    rdr_env <- getLocalRdrEnv
-    loc <- getSrcSpanM
-    let
-        (forall_kvs, forall_tvs) = filterInScope rdr_env $
-                                   extractHsTysRdrTyVars (ty:ctxt)
-        tyvar_bndrs = userHsTyVarBndrs loc forall_tvs
-        in_type_doc = ptext (sLit "In the type") <+> quotes (ppr fulltype)
-
-    -- See Note [Context quantification]
-    warnContextQuantification (in_type_doc $$ docOfHsDocContext doc) tyvar_bndrs
-    rnForAll doc Implicit extra forall_kvs (mkHsQTvs tyvar_bndrs) lctxt ty
-
-rnHsTyKi isType doc ty@(HsForAllTy Explicit extra forall_tyvars lctxt@(L _ ctxt) tau)
-  = ASSERT( isType ) do {      -- Explicit quantification.
-         -- Check that the forall'd tyvars are actually
-         -- mentioned in the type, and produce a warning if not
-         let (kvs, mentioned) = extractHsTysRdrTyVars (tau:ctxt)
-             in_type_doc = ptext (sLit "In the type") <+> quotes (ppr ty)
-       ; warnUnusedForAlls (in_type_doc $$ docOfHsDocContext doc) forall_tyvars mentioned
-
-       ; rnForAll doc Explicit extra kvs forall_tyvars lctxt tau }
+rnHsTyKi isType doc ty@HsForAllTy{}
+  = rnHsTyKiForAll isType doc (flattenTopLevelHsForAllTy ty)
 
 rnHsTyKi isType _ (HsTyVar rdr_name)
   = do { name <- rnTyVar isType rdr_name
@@ -326,6 +283,62 @@ rnHsTyKi isType _doc (HsNamedWildcardTy rdr_name)
        ; return (HsNamedWildcardTy name, unitFV name) }
 
 --------------
+rnHsTyKiForAll :: Bool -> HsDocContext -> HsType RdrName
+               -> RnM (HsType Name, FreeVars)
+rnHsTyKiForAll isType doc (HsForAllTy Implicit extra _ lctxt@(L _ ctxt) ty)
+  = ASSERT( isType ) do
+        -- Implicit quantifiction in source code (no kinds on tyvars)
+        -- Given the signature  C => T  we universally quantify
+        -- over FV(T) \ {in-scope-tyvars}
+    rdr_env <- getLocalRdrEnv
+    loc <- getSrcSpanM
+    let
+        (forall_kvs, forall_tvs) = filterInScope rdr_env $
+                                   extractHsTysRdrTyVars (ty:ctxt)
+           -- In for-all types we don't bring in scope
+           -- kind variables mentioned in kind signatures
+           -- (Well, not yet anyway....)
+           --    f :: Int -> T (a::k)    -- Not allowed
+
+           -- The filterInScope is to ensure that we don't quantify over
+           -- type variables that are in scope; when GlasgowExts is off,
+           -- there usually won't be any, except for class signatures:
+           --   class C a where { op :: a -> a }
+        tyvar_bndrs = userHsTyVarBndrs loc forall_tvs
+
+    rnForAll doc Implicit extra forall_kvs (mkHsQTvs tyvar_bndrs) lctxt ty
+
+rnHsTyKiForAll isType doc
+               fulltype@(HsForAllTy Qualified extra _ lctxt@(L _ ctxt) ty)
+  = ASSERT( isType ) do
+    rdr_env <- getLocalRdrEnv
+    loc <- getSrcSpanM
+    let
+        (forall_kvs, forall_tvs) = filterInScope rdr_env $
+                                   extractHsTysRdrTyVars (ty:ctxt)
+        tyvar_bndrs = userHsTyVarBndrs loc forall_tvs
+        in_type_doc = ptext (sLit "In the type") <+> quotes (ppr fulltype)
+
+    -- See Note [Context quantification]
+    warnContextQuantification (in_type_doc $$ docOfHsDocContext doc) tyvar_bndrs
+    rnForAll doc Implicit extra forall_kvs (mkHsQTvs tyvar_bndrs) lctxt ty
+
+rnHsTyKiForAll isType doc
+               ty@(HsForAllTy Explicit extra forall_tyvars lctxt@(L _ ctxt) tau)
+  = ASSERT( isType ) do {      -- Explicit quantification.
+         -- Check that the forall'd tyvars are actually
+         -- mentioned in the type, and produce a warning if not
+         let (kvs, mentioned) = extractHsTysRdrTyVars (tau:ctxt)
+             in_type_doc = ptext (sLit "In the type") <+> quotes (ppr ty)
+       ; warnUnusedForAlls (in_type_doc $$ docOfHsDocContext doc)
+                           forall_tyvars mentioned
+       ; traceRn (text "rnHsTyKiForAll:Exlicit" <+> vcat
+            [ppr forall_tyvars, ppr lctxt,ppr tau ])
+       ; rnForAll doc Explicit extra kvs forall_tyvars lctxt tau }
+
+-- The following should never happen but keeps the completeness checker happy
+rnHsTyKiForAll isType doc ty = rnHsTyKi isType doc ty
+--------------
 rnTyVar :: Bool -> RdrName -> RnM Name
 rnTyVar is_type rdr_name
   | is_type   = lookupTypeOccRn rdr_name
diff --git a/testsuite/tests/ghc-api/annotations/.gitignore b/testsuite/tests/ghc-api/annotations/.gitignore
index b8bba4fdcc..0dcfb284e1 100644
--- a/testsuite/tests/ghc-api/annotations/.gitignore
+++ b/testsuite/tests/ghc-api/annotations/.gitignore
@@ -13,6 +13,7 @@ t10280
 t10312
 t10307
 boolFormula
+t10278
 *.hi
 *.o
 *.run.*
diff --git a/testsuite/tests/ghc-api/annotations/Makefile b/testsuite/tests/ghc-api/annotations/Makefile
index 7cd6519988..17cc6fdcb7 100644
--- a/testsuite/tests/ghc-api/annotations/Makefile
+++ b/testsuite/tests/ghc-api/annotations/Makefile
@@ -11,6 +11,7 @@ clean:
 	rm -f t10309
 	rm -f listcomps boolFormula
 	rm -f t10357
+	rm -f t10278
 
 annotations: 
 	rm -f annotations.o annotations.hi
@@ -105,3 +106,10 @@ boolFormula:
 	./boolFormula "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`"
 
 .PHONY: clean annotations parseTree comments exampleTest listcomps boolFormula
+
+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: T10278
diff --git a/testsuite/tests/ghc-api/annotations/T10278.stderr b/testsuite/tests/ghc-api/annotations/T10278.stderr
new file mode 100644
index 0000000000..d3788b752d
--- /dev/null
+++ b/testsuite/tests/ghc-api/annotations/T10278.stderr
@@ -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
index 0000000000..b274095af9
--- /dev/null
+++ b/testsuite/tests/ghc-api/annotations/T10278.stdout
@@ -0,0 +1,171 @@
+---Problems---------------------
+[
+]
+
+---Problems'--------------------
+[]
+--------------------------------
+[
+(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])
+
+(AK Test10278.hs:4:19-61 AnnForall = [Test10278.hs:4:19-24])
+
+(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])
+
+(AK Test10278.hs:(8,20)-(10,57) AnnForall = [Test10278.hs:8:20-25])
+
+(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-50 AnnRarrow = [Test10278.hs:10:31-32])
+
+(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:14:1])
+
+(AK Test10278.hs:12:35-44 AnnCloseP = [Test10278.hs:12:44])
+
+(AK Test10278.hs:12:35-44 AnnOpenP = [Test10278.hs:12:35])
+
+(AK Test10278.hs:(14,1)-(17,80) AnnData = [Test10278.hs:14:1-4])
+
+(AK Test10278.hs:(14,1)-(17,80) AnnSemi = [Test10278.hs:21:1])
+
+(AK Test10278.hs:(14,1)-(17,80) AnnWhere = [Test10278.hs:14:21-25])
+
+(AK Test10278.hs:15:5-64 AnnDcolon = [Test10278.hs:15:11-12])
+
+(AK Test10278.hs:15:5-64 AnnSemi = [Test10278.hs:16:5])
+
+(AK Test10278.hs:15:14-64 AnnDot = [Test10278.hs:15:23])
+
+(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 AnnDarrow = [Test10278.hs:15:42-43])
+
+(AK Test10278.hs:15:25-40 AnnOpenP = [Test10278.hs:15:25])
+
+(AK Test10278.hs:15:27-30 AnnComma = [Test10278.hs:15:31])
+
+(AK Test10278.hs:15:45-46 AnnBang = [Test10278.hs:15:45])
+
+(AK Test10278.hs:15:45-46 AnnRarrow = [Test10278.hs:15:48-49])
+
+(AK Test10278.hs:15:45-64 AnnRarrow = [Test10278.hs:15:48-49])
+
+(AK Test10278.hs:16:5-64 AnnDcolon = [Test10278.hs:16:11-12])
+
+(AK Test10278.hs:16:5-64 AnnSemi = [Test10278.hs:17:5])
+
+(AK Test10278.hs:16:14-64 AnnDot = [Test10278.hs:16:23])
+
+(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 AnnDarrow = [Test10278.hs:16:42-43])
+
+(AK Test10278.hs:16:25-40 AnnOpenP = [Test10278.hs:16:25])
+
+(AK Test10278.hs:16:27-30 AnnComma = [Test10278.hs:16:31])
+
+(AK Test10278.hs:16:45-46 AnnBang = [Test10278.hs:16:45])
+
+(AK Test10278.hs:16:45-46 AnnRarrow = [Test10278.hs:16:48-49])
+
+(AK Test10278.hs:16:45-64 AnnRarrow = [Test10278.hs:16:48-49])
+
+(AK Test10278.hs:17:5-80 AnnDcolon = [Test10278.hs:17:12-13])
+
+(AK Test10278.hs:17:15-20 AnnCloseP = [Test10278.hs:17:20])
+
+(AK Test10278.hs:17:15-20 AnnDarrow = [Test10278.hs:17:22-23])
+
+(AK Test10278.hs:17:15-20 AnnOpenP = [Test10278.hs:17:15])
+
+(AK Test10278.hs:17:25-80 AnnDot = [Test10278.hs:17:34])
+
+(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 AnnDarrow = [Test10278.hs:17:53-54])
+
+(AK Test10278.hs:17:36-51 AnnOpenP = [Test10278.hs:17:36])
+
+(AK Test10278.hs:17:38-41 AnnComma = [Test10278.hs:17:42])
+
+(AK Test10278.hs:17:56-57 AnnBang = [Test10278.hs:17:56])
+
+(AK Test10278.hs:17:56-57 AnnRarrow = [Test10278.hs:17:59-60])
+
+(AK Test10278.hs:17:56-80 AnnRarrow = [Test10278.hs:17:59-60])
+
+(AK Test10278.hs:17:62 AnnRarrow = [Test10278.hs:17:64-65])
+
+(AK Test10278.hs:17:62-80 AnnRarrow = [Test10278.hs:17:64-65])
+
+(AK <no location info> AnnEofPos = [Test10278.hs:21:1])
+]
+
diff --git a/testsuite/tests/ghc-api/annotations/Test10278.hs b/testsuite/tests/ghc-api/annotations/Test10278.hs
new file mode 100644
index 0000000000..1159bd2eab
--- /dev/null
+++ b/testsuite/tests/ghc-api/annotations/Test10278.hs
@@ -0,0 +1,20 @@
+{-# 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
+
+data MaybeDefault v where
+    SetTo :: forall v . ( Eq v, Show v ) => !v -> MaybeDefault v
+    SetTo2:: forall v . ( Eq v, Show v ) => !v -> MaybeDefault v
+    SetTo3 :: (Eq a) => forall v . ( Eq v, Show v ) => !v -> a -> MaybeDefault v
+    {-
+    SetTo4 :: forall v . (( Eq v, Show v ) => v -> MaybeDefault v -> a -> [a])
+    -}
diff --git a/testsuite/tests/ghc-api/annotations/all.T b/testsuite/tests/ghc-api/annotations/all.T
index b60f0bc622..3980a9d346 100644
--- a/testsuite/tests/ghc-api/annotations/all.T
+++ b/testsuite/tests/ghc-api/annotations/all.T
@@ -13,3 +13,4 @@ test('T10309',      normal, run_command, ['$MAKE -s --no-print-directory t10309'
 test('boolFormula', normal, run_command, ['$MAKE -s --no-print-directory boolFormula'])
 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'])
diff --git a/testsuite/tests/ghc-api/annotations/t10278.hs b/testsuite/tests/ghc-api/annotations/t10278.hs
new file mode 100644
index 0000000000..9d135486f7
--- /dev/null
+++ b/testsuite/tests/ghc-api/annotations/t10278.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 "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)
+
+           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)