summaryrefslogtreecommitdiff
path: root/testsuite/tests/ghc-api/annotations-literals/parsed.hs
blob: 352aae6e178ca9a53e0922af6b063965b47947e5 (plain)
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
{-# LANGUAGE RankNTypes #-}
-- This program must be called with GHC's libdir as the single command line
-- argument.
module Main where

import BasicTypes
import Data.Data
import Data.List (intercalate)
import System.IO
import GHC
import GHC.Driver.Session
import MonadUtils
import Outputable
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] <- getArgs
        testOneFile libdir "LiteralsTest2"

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 <- GHC.parseModule modSum
        return p

    let res = gq (pm_parsed_source p)
    putStrLn (intercalate "\n" res)

    where
     gq ast = everything (++) ([] `mkQ` doHsLit `extQ` doOverLit) ast

     doHsLit :: HsLit GhcPs -> [String]
     doHsLit (HsChar       (SourceText src) c)
       = ["HsChar [" ++ src ++ "] " ++ show c]
     doHsLit (HsCharPrim   (SourceText src) c)
       = ["HsCharPrim [" ++ src ++ "] " ++ show c]
     doHsLit (HsString     (SourceText src) c)
       = ["HsString [" ++ src ++ "] " ++ show c]
     doHsLit (HsStringPrim (SourceText src) c)
       = ["HsStringPrim [" ++ src ++ "] " ++ show c]
     doHsLit (HsInt  _     (IL (SourceText src) _ c))
       = ["HsInt [" ++ src ++ "] " ++ show c]
     doHsLit (HsIntPrim (SourceText src) c)
       = ["HsIntPrim [" ++ src ++ "] " ++ show c]
     doHsLit (HsWordPrim   (SourceText src) c)
       = ["HsWordPrim [" ++ src ++ "] " ++ show c]
     doHsLit (HsInt64Prim  (SourceText src) c)
       = ["HsInt64Prim [" ++ src ++ "] " ++ show c]
     doHsLit (HsWord64Prim (SourceText src) c)
       = ["HsWord64Prim [" ++ src ++ "] " ++ show c]
     doHsLit (HsInteger  (SourceText src) c _)
       = ["HsInteger [" ++ src ++ "] " ++ show c]
     doHsLit _ = []

     doOverLit :: OverLitVal -> [String]
     doOverLit (HsIntegral  (IL (SourceText src) _ c))
       = ["HsIntegral [" ++ src ++ "] " ++ show c]
     doOverLit (HsIsString  (SourceText src) c)
       = ["HsIsString [" ++ src ++ "] " ++ show c]
     doOverLit _ = []

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)