Commit c553e980 authored by Alan Zimmerman's avatar Alan Zimmerman

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
parent 9f968e97
......@@ -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 } }
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......@@ -325,6 +282,62 @@ rnHsTyKi isType _doc (HsNamedWildcardTy rdr_name)
do { name <- rnTyVar isType 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
......
......@@ -13,6 +13,7 @@ t10280
t10312
t10307
boolFormula
t10278
*.hi
*.o
*.run.*
......
......@@ -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
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’
---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])
]
{-# 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])
-}
......@@ -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'])
{-# 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