Commit c5911479 authored by Alan Zimmerman's avatar Alan Zimmerman

ApiAnnotations tweaks

Summary:
A collection of minor updates for the API Annotations.

1. The annotations for the implicity parameter is disconnected in the
   following

    type MPI = ?mpi_secret :: MPISecret

2. In the following, the annotation for one of the commas is disconeected.

    mkPoli = mkBila . map ((,,(),,()) <$> P.base <*> P.pos <*> P.form)

3. In the following, the annotation for the parens becomes disconnected

    data MaybeDefault v where
        SetTo :: forall v . ( Eq v, Show v ) => !v -> MaybeDefault v
        SetTo4 :: forall v a. (( Eq v, Show v ) => v -> MaybeDefault v
                                                -> a -> MaybeDefault [a])

Test Plan: ./validate

Reviewers: hvr, austin

Reviewed By: austin

Subscribers: bgamari, thomie, mpickering

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

GHC Trac Issues: #10399
parent 388448bc
......@@ -491,6 +491,7 @@ compiler_stage2_dll0_MODULES = \
CoreUnfold \
CoreUtils \
CostCentre \
Ctype \
DataCon \
Demand \
Digraph \
......@@ -529,6 +530,7 @@ compiler_stage2_dll0_MODULES = \
InstEnv \
Kind \
Lexeme \
Lexer \
ListSetOps \
Literal \
Maybes \
......
......@@ -37,6 +37,7 @@ module HsTypes (
mkExplicitHsForAllTy, mkImplicitHsForAllTy, mkQualifiedHsForAllTy,
mkHsForAllTy,
flattenTopLevelLHsForAllTy,flattenTopLevelHsForAllTy,
flattenHsForAllTyKeepAnns,
hsExplicitTvs,
hsTyVarName, mkHsWithBndrs, hsLKiTyVarNames,
hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames,
......@@ -66,6 +67,7 @@ import SrcLoc
import StaticFlags
import Outputable
import FastString
import Lexer ( AddAnn, mkParensApiAnn )
import Maybes( isJust )
import Data.Data hiding ( Fixity )
......@@ -589,24 +591,30 @@ 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
= snd $ mk_forall_ty [] l exp extra tvs ty
flattenTopLevelHsForAllTy ty = ty
flattenHsForAllTyKeepAnns :: HsType name -> ([AddAnn],HsType name)
flattenHsForAllTyKeepAnns (HsForAllTy exp extra tvs (L l []) ty)
= mk_forall_ty [] l exp extra tvs ty
flattenHsForAllTyKeepAnns ty = ([],ty)
-- mk_forall_ty makes a pure for-all type (no context)
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
mk_forall_ty :: [AddAnn] -> SrcSpan -> HsExplicitFlag -> Maybe SrcSpan
-> LHsTyVarBndrs name
-> LHsType name -> ([AddAnn],HsType name)
mk_forall_ty ann _ exp1 extra1 tvs1 (L _ (HsForAllTy exp2 extra qtvs2 ctxt ty))
= (ann,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
mk_forall_ty ann l exp extra tvs (L lp (HsParTy ty))
= mk_forall_ty (ann ++ mkParensApiAnn lp) l exp extra tvs ty
mk_forall_ty ann l exp extra tvs ty
= (ann,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
......
......@@ -233,6 +233,8 @@ data AnnKeywordId
| AnnOpen -- ^ '(\#' or '{-\# LANGUAGE' etc
| AnnOpenC -- ^ '{'
| AnnOpenP -- ^ '('
| AnnOpenPE -- ^ '$('
| AnnOpenPTE -- ^ '$$('
| AnnOpenS -- ^ '['
| AnnPackageName
| AnnPattern
......@@ -248,6 +250,7 @@ data AnnKeywordId
| AnnThen
| AnnThIdSplice -- ^ '$'
| AnnThIdTySplice -- ^ '$$'
| AnnThTyQuote -- ^ double '''
| AnnTilde -- ^ '~'
| AnnTildehsh -- ^ '~#'
| AnnType
......
......@@ -1591,7 +1591,7 @@ ctypedoc :: { LHsType RdrName }
>> return (sLL $1 $> $
mkQualifiedHsForAllTy $1 $3) }
| ipvar '::' type {% ams (sLL $1 $> (HsIParamTy (unLoc $1) $3))
[mj AnnDcolon $2] }
[mj AnnVal $1,mj AnnDcolon $2] }
| typedoc { $1 }
----------------------
......@@ -1688,9 +1688,10 @@ atype :: { LHsType RdrName }
[mop $1,mj AnnDcolon $3,mcp $5] }
| quasiquote { sL1 $1 (HsSpliceTy (unLoc $1) placeHolderKind) }
| '$(' exp ')' {% ams (sLL $1 $> $ mkHsSpliceTy $2)
[mo $1,mc $3] }
| TH_ID_SPLICE { sLL $1 $> $ mkHsSpliceTy $ sL1 $1 $ HsVar $
mkUnqual varName (getTH_ID_SPLICE $1) }
[mj AnnOpenPE $1,mj AnnCloseP $3] }
| TH_ID_SPLICE {%ams (sLL $1 $> $ mkHsSpliceTy $ sL1 $1 $ HsVar $
mkUnqual varName (getTH_ID_SPLICE $1))
[mj AnnThIdSplice $1] }
-- see Note [Promotion] for the followings
| SIMPLEQUOTE qcon_nowiredlist {% ams (sLL $1 $> $ HsTyVar $ unLoc $2) [mj AnnSimpleQuote $1,mj AnnName $2] }
| SIMPLEQUOTE '(' ctype ',' comma_types1 ')'
......@@ -1863,9 +1864,9 @@ gadt_constrs :: { Located [LConDecl RdrName] }
gadt_constr :: { LConDecl RdrName }
-- Returns a list because of: C,D :: ty
: con_list '::' sigtype
{% do { gadtDecl <- mkGadtDecl (unLoc $1) $3
{% do { (anns,gadtDecl) <- mkGadtDecl (unLoc $1) $3
; ams (sLL $1 $> $ gadtDecl)
[mj AnnDcolon $2] } }
(mj AnnDcolon $2:anns) } }
-- Deprecated syntax for GADT record declarations
| oqtycon '{' fielddecls '}' '::' sigtype
......@@ -2313,8 +2314,8 @@ aexp2 :: { LHsExpr RdrName }
| SIMPLEQUOTE qvar {% ams (sLL $1 $> $ HsBracket (VarBr True (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] }
| SIMPLEQUOTE qcon {% ams (sLL $1 $> $ HsBracket (VarBr True (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] }
| TH_TY_QUOTE tyvar {% ams (sLL $1 $> $ HsBracket (VarBr False (unLoc $2))) [mj AnnThIdSplice $1,mj AnnName $2] }
| TH_TY_QUOTE gtycon {% ams (sLL $1 $> $ HsBracket (VarBr False (unLoc $2))) [mj AnnThIdSplice $1,mj AnnName $2] }
| TH_TY_QUOTE tyvar {% ams (sLL $1 $> $ HsBracket (VarBr False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] }
| TH_TY_QUOTE gtycon {% ams (sLL $1 $> $ HsBracket (VarBr False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] }
| '[|' exp '|]' {% ams (sLL $1 $> $ HsBracket (ExpBr $2)) [mo $1,mc $3] }
| '[||' exp '||]' {% ams (sLL $1 $> $ HsBracket (TExpBr $2)) [mo $1,mc $3]}
| '[t|' ctype '|]' {% checkNoPartialType
......@@ -2338,12 +2339,14 @@ splice_exp :: { LHsExpr RdrName }
(sL1 $1 $ HsVar (mkUnqual varName
(getTH_ID_SPLICE $1))))
[mj AnnThIdSplice $1] }
| '$(' exp ')' {% ams (sLL $1 $> $ mkHsSpliceE $2) [mo $1,mc $3] }
| '$(' exp ')' {% ams (sLL $1 $> $ mkHsSpliceE $2)
[mj AnnOpenPE $1,mj AnnCloseP $3] }
| TH_ID_TY_SPLICE {% ams (sL1 $1 $ mkHsSpliceTE
(sL1 $1 $ HsVar (mkUnqual varName
(getTH_ID_TY_SPLICE $1))))
[mj AnnThIdTySplice $1] }
| '$$(' exp ')' {% ams (sLL $1 $> $ mkHsSpliceTE $2) [mo $1,mc $3] }
| '$$(' exp ')' {% ams (sLL $1 $> $ mkHsSpliceTE $2)
[mj AnnOpenPTE $1,mj AnnCloseP $3] }
cmdargs :: { [LHsCmdTop RdrName] }
: cmdargs acmd { $2 : $1 }
......@@ -2412,7 +2415,7 @@ commas_tup_tail : commas tup_tail
then [L (last $ fst $1) missingTupArg]
else $2
in (head $ fst $1
,(map (\l -> L l missingTupArg) (init $ fst $1)) ++ tt)) } }
,(map (\l -> L l missingTupArg) (tail $ fst $1)) ++ tt)) } }
-- Always follows a comma
tup_tail :: { [LHsTupArg RdrName] }
......
......@@ -622,9 +622,12 @@ 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))
-> P ([AddAnn], ConDecl RdrName)
mkGadtDecl names (L l ty) = do
let
(anns,ty') = flattenHsForAllTyKeepAnns ty
gadt <- mkGadtDecl' names (L l ty')
return (anns,gadt)
mkGadtDecl' :: [Located RdrName]
-> LHsType RdrName -- Always a HsForAllTy
......@@ -950,8 +953,7 @@ checkAPat msg loc e0 = do
L _ (HsForAllTy Implicit _ _
(L _ []) ty) -> ty
other -> other
return (SigPatIn e (mkHsWithBndrs
(L (getLoc t) (HsParTy t'))))
return (SigPatIn e (mkHsWithBndrs t'))
-- n+k patterns
OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
......
......@@ -12,6 +12,7 @@ t10269
t10280
t10312
t10307
t10399
boolFormula
t10278
t10354
......
......@@ -14,6 +14,7 @@ clean:
rm -f t10278
rm -f t10354
rm -f t10396
rm -f t10399
annotations:
rm -f annotations.o annotations.hi
......@@ -129,3 +130,10 @@ T10354:
./t10354 "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`"
.PHONY: t10354
t10399:
rm -f t10399.o t10399.hi
'$(TEST_HC)' $(TEST_HC_OPTS) --make -v0 -package ghc t10399
./t10399 "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`"
.PHONY: t10399
Test10399.hs:7:27: error:
Not in scope: type constructor or class ‘MPISecret’
Test10399.hs:9:10: error: Not in scope: ‘mkBila’
Test10399.hs:9:24: error: Illegal tuple section: use TupleSections
Test10399.hs:9:39: error: Not in scope: ‘P.base’
Test10399.hs:9:50: error: Not in scope: ‘P.pos’
Test10399.hs:9:60: error: Not in scope: ‘P.form’
---Problems---------------------
[
(AK Test10399.hs:(13,27)-(14,69) AnnCloseP = [Test10399.hs:14:69])
(AK Test10399.hs:(13,27)-(14,69) AnnOpenP = [Test10399.hs:13:27])
]
---Problems'--------------------
[]
--------------------------------
[
(AK Test10399.hs:1:1 AnnModule = [Test10399.hs:5:1-6])
(AK Test10399.hs:1:1 AnnWhere = [Test10399.hs:5:18-22])
(AK Test10399.hs:7:1-35 AnnEqual = [Test10399.hs:7:10])
(AK Test10399.hs:7:1-35 AnnSemi = [Test10399.hs:9:1])
(AK Test10399.hs:7:1-35 AnnType = [Test10399.hs:7:1-4])
(AK Test10399.hs:7:12-35 AnnDcolon = [Test10399.hs:7:24-25])
(AK Test10399.hs:7:12-35 AnnVal = [Test10399.hs:7:12-22])
(AK Test10399.hs:9:1-66 AnnEqual = [Test10399.hs:9:8])
(AK Test10399.hs:9:1-66 AnnFunId = [Test10399.hs:9:1-6])
(AK Test10399.hs:9:1-66 AnnSemi = [Test10399.hs:11:1])
(AK Test10399.hs:9:10-66 AnnVal = [Test10399.hs:9:17])
(AK Test10399.hs:9:23-66 AnnCloseP = [Test10399.hs:9:66])
(AK Test10399.hs:9:23-66 AnnOpenP = [Test10399.hs:9:23])
(AK Test10399.hs:9:24-33 AnnCloseP = [Test10399.hs:9:33])
(AK Test10399.hs:9:24-33 AnnOpenP = [Test10399.hs:9:24])
(AK Test10399.hs:9:24-44 AnnVal = [Test10399.hs:9:35-37])
(AK Test10399.hs:9:24-54 AnnVal = [Test10399.hs:9:46-48])
(AK Test10399.hs:9:24-65 AnnVal = [Test10399.hs:9:56-58])
(AK Test10399.hs:9:25 AnnComma = [Test10399.hs:9:25])
(AK Test10399.hs:9:26 AnnComma = [Test10399.hs:9:26])
(AK Test10399.hs:9:27-28 AnnCloseP = [Test10399.hs:9:28])
(AK Test10399.hs:9:27-28 AnnComma = [Test10399.hs:9:29])
(AK Test10399.hs:9:27-28 AnnOpenP = [Test10399.hs:9:27])
(AK Test10399.hs:9:30 AnnComma = [Test10399.hs:9:30])
(AK Test10399.hs:9:31-32 AnnCloseP = [Test10399.hs:9:32])
(AK Test10399.hs:9:31-32 AnnOpenP = [Test10399.hs:9:31])
(AK Test10399.hs:(11,1)-(14,69) AnnData = [Test10399.hs:11:1-4])
(AK Test10399.hs:(11,1)-(14,69) AnnSemi = [Test10399.hs:16:1])
(AK Test10399.hs:(11,1)-(14,69) AnnWhere = [Test10399.hs:11:21-25])
(AK Test10399.hs:12:5-64 AnnDcolon = [Test10399.hs:12:11-12])
(AK Test10399.hs:12:5-64 AnnSemi = [Test10399.hs:13:5])
(AK Test10399.hs:12:14-64 AnnDot = [Test10399.hs:12:23])
(AK Test10399.hs:12:14-64 AnnForall = [Test10399.hs:12:14-19])
(AK Test10399.hs:12:25-40 AnnCloseP = [Test10399.hs:12:40, Test10399.hs:12:40])
(AK Test10399.hs:12:25-40 AnnDarrow = [Test10399.hs:12:42-43])
(AK Test10399.hs:12:25-40 AnnOpenP = [Test10399.hs:12:25, Test10399.hs:12:25])
(AK Test10399.hs:12:27-30 AnnComma = [Test10399.hs:12:31])
(AK Test10399.hs:12:45-46 AnnBang = [Test10399.hs:12:45])
(AK Test10399.hs:12:45-46 AnnRarrow = [Test10399.hs:12:48-49])
(AK Test10399.hs:12:45-64 AnnRarrow = [Test10399.hs:12:48-49])
(AK Test10399.hs:(13,5)-(14,69) AnnCloseP = [Test10399.hs:14:69])
(AK Test10399.hs:(13,5)-(14,69) AnnDcolon = [Test10399.hs:13:12-13])
(AK Test10399.hs:(13,5)-(14,69) AnnOpenP = [Test10399.hs:13:27])
(AK Test10399.hs:(13,15)-(14,69) AnnDot = [Test10399.hs:13:25])
(AK Test10399.hs:(13,15)-(14,69) AnnForall = [Test10399.hs:13:15-20])
(AK Test10399.hs:(13,27)-(14,69) AnnCloseP = [Test10399.hs:14:69])
(AK Test10399.hs:(13,27)-(14,69) AnnOpenP = [Test10399.hs:13:27])
(AK Test10399.hs:13:28-43 AnnCloseP = [Test10399.hs:13:43, Test10399.hs:13:43])
(AK Test10399.hs:13:28-43 AnnDarrow = [Test10399.hs:13:45-46])
(AK Test10399.hs:13:28-43 AnnOpenP = [Test10399.hs:13:28, Test10399.hs:13:28])
(AK Test10399.hs:13:30-33 AnnComma = [Test10399.hs:13:34])
(AK Test10399.hs:13:48 AnnRarrow = [Test10399.hs:13:50-51])
(AK Test10399.hs:(13,48)-(14,68) AnnRarrow = [Test10399.hs:13:50-51])
(AK Test10399.hs:13:53-66 AnnRarrow = [Test10399.hs:14:45-46])
(AK Test10399.hs:(13,53)-(14,68) AnnRarrow = [Test10399.hs:14:45-46])
(AK Test10399.hs:14:48 AnnRarrow = [Test10399.hs:14:50-51])
(AK Test10399.hs:14:48-68 AnnRarrow = [Test10399.hs:14:50-51])
(AK Test10399.hs:14:66-68 AnnCloseS = [Test10399.hs:14:68])
(AK Test10399.hs:14:66-68 AnnOpenS = [Test10399.hs:14:66])
(AK Test10399.hs:16:1-25 AnnClose = [Test10399.hs:16:24-25])
(AK Test10399.hs:16:1-25 AnnOpen = [Test10399.hs:16:1-3])
(AK Test10399.hs:16:1-25 AnnSemi = [Test10399.hs:18:1])
(AK Test10399.hs:16:20-22 AnnThIdSplice = [Test10399.hs:16:20-22])
(AK Test10399.hs:18:1-21 AnnEqual = [Test10399.hs:18:19])
(AK Test10399.hs:18:1-21 AnnFunId = [Test10399.hs:18:1-3])
(AK Test10399.hs:18:1-21 AnnSemi = [Test10399.hs:19:1])
(AK Test10399.hs:18:5-17 AnnCloseP = [Test10399.hs:18:17])
(AK Test10399.hs:18:5-17 AnnOpenPE = [Test10399.hs:18:5-6])
(AK Test10399.hs:18:8-15 AnnClose = [Test10399.hs:18:14-15])
(AK Test10399.hs:18:8-15 AnnOpen = [Test10399.hs:18:8-10])
(AK <no location info> AnnEofPos = [Test10399.hs:19:1])
]
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Test10399 where
type MPI = ?mpi_secret :: MPISecret
mkPoli = mkBila . map ((,,(),,()) <$> P.base <*> P.pos <*> P.form)
data MaybeDefault v where
SetTo :: forall v . ( Eq v, Show v ) => !v -> MaybeDefault v
SetTo4 :: forall v a. (( Eq v, Show v ) => v -> MaybeDefault v
-> a -> MaybeDefault [a])
[t| Map.Map T.Text $tc |]
bar $( [p| x |] ) = x
......@@ -16,3 +16,4 @@ 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'])
test('T10396', normal, run_command, ['$MAKE -s --no-print-directory T10396'])
test('T10399', normal, run_command, ['$MAKE -s --no-print-directory t10399'])
---Problems---------------------
[
(AK AnnotationTuple.hs:14:39 AnnComma = [AnnotationTuple.hs:14:39])
(AK <no location info> AnnEofPos = [AnnotationTuple.hs:32:1])
]
......
[(AnnotationTuple.hs:14:20, [p], (1)),
(AnnotationTuple.hs:14:23-29, [p], ("hello")),
(AnnotationTuple.hs:14:35-37, [p], (6.5)),
(AnnotationTuple.hs:14:38, [m], ()),
(AnnotationTuple.hs:14:39, [m], ()),
(AnnotationTuple.hs:14:41-52, [p], ([5, 5, 6, 7])),
(AnnotationTuple.hs:16:8, [p], (1)),
(AnnotationTuple.hs:16:11-17, [p], ("hello")),
(AnnotationTuple.hs:16:20-22, [p], (6.5)),
(AnnotationTuple.hs:16:23, [m], ()),
(AnnotationTuple.hs:16:24, [m], ()),
(AnnotationTuple.hs:16:25, [m], ()),
(AnnotationTuple.hs:16:26, [m], ()),
(AnnotationTuple.hs:16:26, [m], ())]
[
(AK AnnotationTuple.hs:1:1 AnnCloseC = [AnnotationTuple.hs:27:1])
......
{-# 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 "Test10399"
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)
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment