149658a231590fb2b7402d243bed54e56bf688e9
[ghc.git] / testsuite / tests / ghc-api / annotations / parseTree.hs
1 {-# LANGUAGE RankNTypes #-}
2
3 -- This program must be called with GHC's libdir as the single command line
4 -- argument.
5 module Main where
6
7 -- import Data.Generics
8 import Data.Data
9 import Data.List
10 import System.IO
11 import GHC
12 import BasicTypes
13 import DynFlags
14 import MonadUtils
15 import Outputable
16 import Bag (filterBag,isEmptyBag)
17 import System.Directory (removeFile)
18 import System.Environment( getArgs )
19 import qualified Data.Map as Map
20 import Data.Dynamic ( fromDynamic,Dynamic )
21
22 main::IO()
23 main = do
24 [libdir] <- getArgs
25 testOneFile libdir "AnnotationTuple"
26
27 testOneFile libdir fileName = do
28 ((anns,cs),p) <- runGhc (Just libdir) $ do
29 dflags <- getSessionDynFlags
30 setSessionDynFlags dflags
31 let mn =mkModuleName fileName
32 addTarget Target { targetId = TargetModule mn
33 , targetAllowObjCode = True
34 , targetContents = Nothing }
35 load LoadAllTargets
36 modSum <- getModSummary mn
37 p <- parseModule modSum
38 t <- typecheckModule p
39 d <- desugarModule t
40 l <- loadModule d
41 let ts=typecheckedSource l
42 r =renamedSource l
43 return (pm_annotations p,p)
44
45 let tupArgs = gq (pm_parsed_source p)
46
47 putStrLn (pp tupArgs)
48 putStrLn (intercalate "\n" [showAnns anns])
49
50 where
51 gq ast = everything (++) ([] `mkQ` doLHsTupArg) ast
52
53 doLHsTupArg :: LHsTupArg GhcPs -> [(SrcSpan,String,HsExpr GhcPs)]
54 doLHsTupArg (L l arg@(Present _))
55 = [(l,"p",ExplicitTuple noExt [L l arg] Boxed)]
56 doLHsTupArg (L l arg@(Missing _))
57 = [(l,"m",ExplicitTuple noExt [L l arg] Boxed)]
58
59
60 showAnns anns = "[\n" ++ (intercalate "\n"
61 $ map (\((s,k),v)
62 -> ("(AK " ++ pp s ++ " " ++ show k ++" = " ++ pp v ++ ")\n"))
63 $ Map.toList anns)
64 ++ "]\n"
65
66 pp a = showPpr unsafeGlobalDynFlags a
67
68
69 -- ---------------------------------------------------------------------
70
71 -- Copied from syb for the test
72
73
74 -- | Generic queries of type \"r\",
75 -- i.e., take any \"a\" and return an \"r\"
76 --
77 type GenericQ r = forall a. Data a => a -> r
78
79
80 -- | Make a generic query;
81 -- start from a type-specific case;
82 -- return a constant otherwise
83 --
84 mkQ :: ( Typeable a
85 , Typeable b
86 )
87 => r
88 -> (b -> r)
89 -> a
90 -> r
91 (r `mkQ` br) a = case cast a of
92 Just b -> br b
93 Nothing -> r
94
95
96
97 -- | Summarise all nodes in top-down, left-to-right order
98 everything :: (r -> r -> r) -> GenericQ r -> GenericQ r
99
100 -- Apply f to x to summarise top-level node;
101 -- use gmapQ to recurse into immediate subterms;
102 -- use ordinary foldl to reduce list of intermediate results
103
104 everything k f x = foldl k (f x) (gmapQ (everything k f) x)