1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
|
{-# LANGUAGE RankNTypes #-}
import Data.Data
import Data.List
import GHC
import GHC.Driver.Session
import GHC.Utils.Outputable
import GHC.Parser.Annotation
import GHC.Types.SrcLoc
import System.Environment( getArgs )
import System.Exit
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Maybe( isJust )
main::IO()
main = do
args <- getArgs
case args of
[libdir,fileName] -> testOneFile libdir fileName
_ -> putStrLn "invoke with the libdir and a file to parse."
testOneFile :: FilePath -> String -> IO ()
testOneFile libdir fileName = do
let modByFile m =
case ml_hs_file $ ms_location m of
Nothing -> False
Just fn -> fn == fileName
(anns,p) <- runGhc (Just libdir) $ do
dflags <- getSessionDynFlags
_ <- setSessionDynFlags dflags
addTarget Target { targetId = TargetFile fileName Nothing
, targetAllowObjCode = True
, targetContents = Nothing }
_ <- load LoadAllTargets
graph <- getModuleGraph
let modSum =
case filter modByFile (mgModSummaries graph) of
[x] -> x
xs -> error $ "Can't find module, got:"
++ show (map (ml_hs_file . ms_location) xs)
p <- parseModule modSum
return (pm_annotations p,p)
let sspans = Set.fromList $ getAllSrcSpans (pm_parsed_source p)
ann_items = apiAnnItems anns
exploded = [((kw,ss),[anchor])
| ((anchor,kw),sss) <- Map.toList ann_items,ss <- sss]
exploded' = Map.toList $ Map.fromListWith (++) exploded
problems' = filter (\(_,anchors)
-> not (any (\a -> Set.member a sspans) anchors))
exploded'
-- Check that every annotation location in 'vs' appears after
-- the start of the enclosing span 's'
comesBefore ((s,_),vs) = not $ all ok vs
where ok v = realSrcSpanStart s <= realSrcSpanStart v
precedingProblems = filter comesBefore $ Map.toList ann_items
putStrLn "---Unattached Annotation Problems (should be empty list)---"
putStrLn (intercalate "\n" [pp $ Map.fromList $ map fst problems'])
putStrLn "---Ann before enclosing span problem (should be empty list)---"
putStrLn (showAnnsList precedingProblems)
putStrLn "---Annotations-----------------------"
putStrLn "-- SrcSpan the annotation is attached to, AnnKeywordId,"
putStrLn "-- list of locations the keyword item appears in"
-- putStrLn (intercalate "\n" [showAnns ann_items])
putStrLn (showAnns ann_items)
putStrLn "---Eof Position (should be Just)-----"
putStrLn (show (apiAnnEofPos anns))
if null problems' && null precedingProblems && isJust (apiAnnEofPos anns)
then exitSuccess
else exitFailure
where
getAllSrcSpans :: (Data t) => t -> [RealSrcSpan]
getAllSrcSpans ast = everything (++) ([] `mkQ` getSrcSpan) ast
where
getSrcSpan :: SrcSpan -> [RealSrcSpan]
getSrcSpan (RealSrcSpan ss _) = [ss]
getSrcSpan (UnhelpfulSpan _) = []
showAnns :: Map.Map ApiAnnKey [RealSrcSpan] -> String
showAnns anns = showAnnsList $ Map.toList anns
showAnnsList :: [(ApiAnnKey, [RealSrcSpan])] -> String
showAnnsList annsList = "[\n" ++ (intercalate ",\n"
$ map (\((s,k),v)
-> ("((" ++ pp s ++ "," ++ show k ++"), " ++ pp v ++ ")"))
annsList)
++ "\n]\n"
pp :: (Outputable a) => a -> String
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)
|
