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
139
140
141
142
143
144
145
146
|
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
-- 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 FastString
import GHC.Types.ForeignCall
import MonadUtils
import Outputable
import GHC.Hs.Decls
import Bag (filterBag,isEmptyBag)
import System.Directory (removeFile)
import System.Environment( getArgs )
import qualified Data.Map as Map
import Data.Dynamic ( fromDynamic,Dynamic )
main::IO()
main = do
[libdir,fileName] <- getArgs
testOneFile libdir fileName
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
return p
let tupArgs = gq (pm_parsed_source p)
putStrLn (pp tupArgs)
-- putStrLn (intercalate "\n" [showAnns anns])
where
gq ast = everything (++) ([] `mkQ` doWarningTxt
`extQ` doImportDecl
`extQ` doCType
`extQ` doRuleDecl
`extQ` doCCallTarget
`extQ` doHsExpr
) ast
doWarningTxt :: WarningTxt -> [(String,[Located (SourceText,FastString)])]
doWarningTxt ((WarningTxt _ ss)) = [("w",map conv ss)]
doWarningTxt ((DeprecatedTxt _ ss)) = [("d",map conv ss)]
doImportDecl :: ImportDecl GhcPs
-> [(String,[Located (SourceText,FastString)])]
doImportDecl (ImportDecl _ _ _ Nothing _ _ _ _ _ _) = []
doImportDecl (ImportDecl _ _ _ (Just ss) _ _ _ _ _ _)
= [("i",[conv (noLoc ss)])]
doCType :: CType -> [(String,[Located (SourceText,FastString)])]
doCType (CType src (Just (Header hs hf)) c)
= [("c",[noLoc (hs,hf),noLoc c])]
doCType (CType src Nothing c) = [("c",[noLoc c])]
doRuleDecl :: RuleDecl GhcPs
-> [(String,[Located (SourceText,FastString)])]
doRuleDecl (HsRule _ ss _ _ _ _ _) = [("r",[ss])]
doCCallTarget :: CCallTarget
-> [(String,[Located (SourceText,FastString)])]
doCCallTarget (StaticTarget s f _ _) = [("st",[(noLoc (s,f))])]
doHsExpr :: HsExpr GhcPs -> [(String,[Located (SourceText,FastString)])]
doHsExpr (HsPragE _ prag _) = doPragE prag
doHsExpr _ = []
doPragE :: HsPragE GhcPs -> [(String,[Located (SourceText,FastString)])]
doPragE (HsPragCore _ src ss) = [("co",[conv (noLoc ss)])]
doPragE (HsPragSCC _ src ss) = [("sc",[conv (noLoc ss)])]
doPragE (HsPragTick _ src (ss,_,_) _ss2) = [("tp",[conv (noLoc ss)])]
doPragE (XHsPragE x) = noExtCon x
conv (GHC.L l (StringLiteral st fs)) = GHC.L l (st,fs)
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
-- | Extend a generic query by a type-specific case
extQ :: ( Typeable a
, Typeable b
)
=> (a -> q)
-> (b -> q)
-> a
-> q
extQ f g a = maybe (f a) g (cast a)
-- | 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)
|
