a063d916242e867785762fa5cd7c9d8a1ed5d711
[ghc.git] / testsuite / tests / ghc-api / annotations / t10278.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 ApiAnnotation
17 import Bag (filterBag,isEmptyBag)
18 import System.Directory (removeFile)
19 import System.Environment( getArgs )
20 import qualified Data.Map as Map
21 import qualified Data.Set as Set
22 import Data.Dynamic ( fromDynamic,Dynamic )
23
24 main::IO()
25 main = do
26 [libdir] <- getArgs
27 testOneFile libdir "Test10278"
28
29 testOneFile libdir fileName = do
30 ((anns,cs),p) <- runGhc (Just libdir) $ do
31 dflags <- getSessionDynFlags
32 setSessionDynFlags dflags
33 let mn =mkModuleName fileName
34 addTarget Target { targetId = TargetModule mn
35 , targetAllowObjCode = True
36 , targetContents = Nothing }
37 load LoadAllTargets
38 modSum <- getModSummary mn
39 p <- parseModule modSum
40 return (pm_annotations p,p)
41
42 let spans = Set.fromList $ getAllSrcSpans (pm_parsed_source p)
43
44 -- putStrLn (pp spans)
45 problems = filter (\(s,a) -> not (Set.member s spans))
46 $ getAnnSrcSpans (anns,cs)
47 putStrLn "---Problems---------------------"
48 putStrLn (intercalate "\n" [showAnns $ Map.fromList $ map snd problems])
49 putStrLn "--------------------------------"
50 putStrLn (intercalate "\n" [showAnns anns])
51
52 where
53 getAnnSrcSpans :: ApiAnns -> [(SrcSpan,(ApiAnnKey,[SrcSpan]))]
54 getAnnSrcSpans (anns,_) = map (\a@((ss,_),_) -> (ss,a)) $ Map.toList anns
55
56 getAllSrcSpans :: (Data t) => t -> [SrcSpan]
57 getAllSrcSpans ast = everything (++) ([] `mkQ` getSrcSpan) ast
58 where
59 getSrcSpan :: SrcSpan -> [SrcSpan]
60 getSrcSpan ss = [ss]
61
62
63 showAnns anns = "[\n" ++ (intercalate "\n"
64 $ map (\((s,k),v)
65 -> ("(AK " ++ pp s ++ " " ++ show k ++" = " ++ pp v ++ ")\n"))
66 $ Map.toList anns)
67 ++ "]\n"
68
69 pp a = showPpr unsafeGlobalDynFlags a
70
71
72 -- ---------------------------------------------------------------------
73
74 -- Copied from syb for the test
75
76
77 -- | Generic queries of type \"r\",
78 -- i.e., take any \"a\" and return an \"r\"
79 --
80 type GenericQ r = forall a. Data a => a -> r
81
82
83 -- | Make a generic query;
84 -- start from a type-specific case;
85 -- return a constant otherwise
86 --
87 mkQ :: ( Typeable a
88 , Typeable b
89 )
90 => r
91 -> (b -> r)
92 -> a
93 -> r
94 (r `mkQ` br) a = case cast a of
95 Just b -> br b
96 Nothing -> r
97
98
99
100 -- | Summarise all nodes in top-down, left-to-right order
101 everything :: (r -> r -> r) -> GenericQ r -> GenericQ r
102
103 -- Apply f to x to summarise top-level node;
104 -- use gmapQ to recurse into immediate subterms;
105 -- use ordinary foldl to reduce list of intermediate results
106
107 everything k f x = foldl k (f x) (gmapQ (everything k f) x)