summaryrefslogtreecommitdiff
path: root/testsuite/tests/ghc-api/target-contents/TargetContents.hs
blob: db02dbde2bbad9c9e6b351bf12954c89fae1a831 (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
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
150
{-# LANGUAGE ScopedTypeVariables #-}

module Main where

import DynFlags
import GHC

import Control.Monad
import Control.Monad.IO.Class (liftIO)
import Data.List
import Data.Maybe
import Data.Time.Calendar
import Data.Time.Clock
import Exception
import HeaderInfo
import HscTypes
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 targetContents, place an empty dummy module
               -- on disk though to make Finder shut up though.

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 ()