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
|
{-# 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 (intercalate)
import System.IO
import GHC
import GHC.Types.Basic
import GHC.Driver.Session
import GHC.Driver.Ppr
import GHC.Utils.Monad
import GHC.Utils.Outputable
import GHC.Parser.Annotation
import GHC.Data.Bag (filterBag,isEmptyBag)
import System.Directory (removeFile)
import System.Environment( getArgs )
import System.Exit
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 "ListComprehensions"
exitSuccess
testOneFile libdir fileName = do
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
t <- typecheckModule p
d <- desugarModule t
l <- loadModule d
return p
let anns = pm_annotations p
ann_items = apiAnnItems anns
ann_eof = apiAnnEofPos anns
let spans = Set.fromList $ getAllSrcSpans (pm_parsed_source p)
putStrLn (pp spans)
putStrLn "--------------------------------"
putStrLn (intercalate "\n" [showAnns ann_items,"EOF: " ++ show ann_eof])
where
getAnnSrcSpans :: ApiAnns -> [(RealSrcSpan,(ApiAnnKey,[RealSrcSpan]))]
getAnnSrcSpans anns = map (\a@((ss,_),_) -> (ss,a)) $ Map.toList (apiAnnItems anns)
getAllSrcSpans :: (Data t) => t -> [RealSrcSpan]
getAllSrcSpans ast = everything (++) ([] `mkQ` getSrcSpan) ast
where
getSrcSpan :: SrcSpan -> [RealSrcSpan]
getSrcSpan (RealSrcSpan ss _) = [ss]
getSrcSpan (UnhelpfulSpan _) = []
showAnns anns = "[\n" ++ (intercalate "\n"
$ map (\((s,k),v)
-> ("(AK " ++ pp s ++ " " ++ show k ++" = " ++ pp v ++ ")\n"))
$ Map.toList anns)
++ "]\n"
pp a = showPprUnsafe 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)
|
