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
147
148
149
|
{-# LANGUAGE ScopedTypeVariables #-}
module Main where
import GHC.Driver.Session
import GHC
import Control.Monad
import Control.Monad.IO.Class (liftIO)
import Data.List (intercalate)
import Data.Maybe
import Data.Time.Calendar
import Data.Time.Clock
import Exception
import HeaderInfo
import GHC.Driver.Types
import Outputable
import StringBuffer
import System.Directory
import System.Environment
import System.Process
import System.IO
import Text.Printf
main :: IO ()
main = do
libdir:args <- getArgs
createDirectoryIfMissing False "outdir"
runGhc (Just libdir) $ do
dflags0 <- getSessionDynFlags
(dflags1, xs, warn) <- parseDynamicFlags dflags0 $ map noLoc $
[ "-outputdir", "./outdir"
, "-fno-diagnostics-show-caret"
] ++ args
_ <- setSessionDynFlags dflags1
-- This test fails on purpose to check if the error message mentions
-- the source file and not the intermediary preprocessor input file
-- even when no preprocessor is in use. Just a sanity check.
go "Error" ["A"]
-- ^ ^-- targets
-- ^-- test name
[("A" -- this module's name
, "" -- pragmas
, [] -- imports/non exported decls
, [("x", "z")] -- exported decls
, OnDisk -- write this module to disk?
)
]
forM_ [OnDisk, InMemory] $ \sync ->
-- This one fails unless CPP actually preprocessed the source
go ("CPP_" ++ ppSync sync) ["A"]
[( "A"
, "{-# LANGUAGE CPP #-}"
, ["#define y 1"]
, [("x", "y")]
, sync
)
]
-- These check if on-disk modules can import in-memory targets and
-- vice-verca.
forM_ (words "DD MM DM MD") $ \sync@[a_sync, b_sync] -> do
dep <- return $ \y ->
[( "A"
, "{-# LANGUAGE CPP #-}"
, ["import B"]
, [("x", "y")]
, readSync a_sync
),
( "B"
, "{-# LANGUAGE CPP #-}"
, []
, [("y", y)]
, readSync b_sync
)
]
go ("Dep_" ++ sync ++ "_AB") ["A", "B"] (dep "()")
-- This checks if error messages are correctly referring to the real
-- source file and not the temp preprocessor input file.
go ("Dep_Error_" ++ sync ++ "_AB") ["A", "B"] (dep "z")
-- Try with only one target, this is expected to fail with a module
-- not found error where module B is not OnDisk.
go ("Dep_Error_" ++ sync ++ "_A") ["A"] (dep "z")
return ()
data Sync
= OnDisk -- | Write generated module to disk
| InMemory -- | Only fill in targetContents.
ppSync OnDisk = "D"
ppSync InMemory = "M"
readSync 'D' = OnDisk
readSync 'M' = InMemory
go label targets mods = do
liftIO $ createDirectoryIfMissing False "./outdir"
setTargets []; _ <- load LoadAllTargets
liftIO $ hPutStrLn stderr $ "== " ++ label
t <- liftIO getCurrentTime
setTargets =<< catMaybes <$> mapM (mkTarget t) mods
ex <- gtry $ load LoadAllTargets
case ex of
Left ex -> liftIO $ hPutStrLn stderr $ show (ex :: SourceError)
Right _ -> return ()
mapM_ (liftIO . cleanup) mods
liftIO $ removeDirectoryRecursive "./outdir"
where
mkTarget t mod@(name,_,_,_,sync) = do
src <- liftIO $ genMod mod
return $ if not (name `elem` targets)
then Nothing
else Just $ Target
{ targetId = TargetFile (name++".hs") Nothing
, targetAllowObjCode = False
, targetContents =
case sync of
OnDisk -> Nothing
InMemory ->
Just ( stringToStringBuffer src
, t
)
}
genMod :: (String, String, [String], [(String, String)], Sync) -> IO String
genMod (mod, pragmas, internal, binders, sync) = do
case sync of
OnDisk -> writeFile (mod++".hs") src
InMemory -> return ()
return src
where
exports = intercalate ", " $ map fst binders
decls = map (\(b,v) -> b ++ " = " ++ v) binders
src = unlines $
[ pragmas
, "module " ++ mod ++ " ("++ exports ++") where"
] ++ internal ++ decls
cleanup :: (String, String, [String], [(String, String)], Sync) -> IO ()
cleanup (mod,_,_,_,OnDisk) = removeFile (mod++".hs")
cleanup _ = return ()
|
