|
|
1
|
+module Main where
|
|
|
2
|
+
|
|
|
3
|
+import Control.Monad (when)
|
|
|
4
|
+import Control.Monad.IO.Class (liftIO)
|
|
|
5
|
+import Data.List (intercalate)
|
|
|
6
|
+import GHC
|
|
|
7
|
+import GHC.Driver.DynFlags
|
|
|
8
|
+import GHC.Driver.Env (hsc_dflags)
|
|
|
9
|
+import GHC.Settings
|
|
|
10
|
+import System.Directory
|
|
|
11
|
+import System.Environment
|
|
|
12
|
+import System.Exit (ExitCode (ExitFailure), exitWith)
|
|
|
13
|
+import System.FilePath
|
|
|
14
|
+import System.IO (hPutStrLn, stderr)
|
|
|
15
|
+import System.Process (readProcess)
|
|
|
16
|
+import Unsafe.Coerce (unsafeCoerce)
|
|
|
17
|
+
|
|
|
18
|
+-- Verify that a LibDir setting in the settings file is respected:
|
|
|
19
|
+-- 1. fileSettings_libDir and fileSettings_globalPackageDatabase reflect the
|
|
|
20
|
+-- configured LibDir path (not topDir)
|
|
|
21
|
+-- 2. GHC can still compile with a LibDir that differs from topDir
|
|
|
22
|
+-- 3. --print-libdir and --print-global-package-db output the correct paths
|
|
|
23
|
+--
|
|
|
24
|
+-- We create a symlink to the real lib dir so that the package DB remains
|
|
|
25
|
+-- findable, but use a separate topDir so that topDir ≠ libDir, proving
|
|
|
26
|
+-- the LibDir setting is actually used.
|
|
|
27
|
+--
|
|
|
28
|
+-- Tested for both relative and absolute LibDir values.
|
|
|
29
|
+main :: IO ()
|
|
|
30
|
+main = do
|
|
|
31
|
+ libdir : ghcBin : _ <- getArgs
|
|
|
32
|
+
|
|
|
33
|
+ (rawSettingOpts, rawTargetOpts, realLibDir) <- runGhc (Just libdir) $ do
|
|
|
34
|
+ dflags <- hsc_dflags <$> getSession
|
|
|
35
|
+ pure (rawSettings dflags, rawTarget dflags, fileSettings_libDir (fileSettings dflags))
|
|
|
36
|
+
|
|
|
37
|
+ tmpDir <- getTemporaryDirectory
|
|
|
38
|
+ let topDir = tmpDir </> "T19174_top"
|
|
|
39
|
+ symlinkLib = tmpDir </> "T19174_lib"
|
|
|
40
|
+ -- Remove stale dirs from prior runs; createDirectoryLink fails if path exists.
|
|
|
41
|
+ removePathForcibly topDir
|
|
|
42
|
+ removePathForcibly symlinkLib
|
|
|
43
|
+ createDirectoryIfMissing True (topDir </> "targets")
|
|
|
44
|
+ createDirectoryLink realLibDir symlinkLib
|
|
|
45
|
+
|
|
|
46
|
+ let testWithLibDir libDirValue = do
|
|
|
47
|
+ writeTopDirFiles topDir rawSettingOpts rawTargetOpts libDirValue
|
|
|
48
|
+ runGhc (Just topDir) $ do
|
|
|
49
|
+ assertSettings topDir symlinkLib
|
|
|
50
|
+ compileAndRunTestExpr
|
|
|
51
|
+ assertGhcFlags ghcBin topDir symlinkLib
|
|
|
52
|
+
|
|
|
53
|
+ testWithLibDir (".." </> takeFileName symlinkLib)
|
|
|
54
|
+ testWithLibDir symlinkLib
|
|
|
55
|
+
|
|
|
56
|
+ putStrLn "OK"
|
|
|
57
|
+
|
|
|
58
|
+writeTopDirFiles ::
|
|
|
59
|
+ (Show a) =>
|
|
|
60
|
+ FilePath ->
|
|
|
61
|
+ [(String, String)] ->
|
|
|
62
|
+ a ->
|
|
|
63
|
+ String ->
|
|
|
64
|
+ IO ()
|
|
|
65
|
+writeTopDirFiles topDir rawSettingOpts rawTargetOpts libDirValue = do
|
|
|
66
|
+ let settings = filter ((/= "LibDir") . fst) rawSettingOpts ++ [("LibDir", libDirValue)]
|
|
|
67
|
+ writeFile (topDir </> "settings") $
|
|
|
68
|
+ "[" ++ intercalate "\n," (map show settings) ++ "]"
|
|
|
69
|
+ writeFile (topDir </> "targets" </> "default.target") $
|
|
|
70
|
+ show rawTargetOpts
|
|
|
71
|
+
|
|
|
72
|
+assertSettings :: FilePath -> FilePath -> Ghc ()
|
|
|
73
|
+assertSettings topDir expectedLib = do
|
|
|
74
|
+ dflags <- hsc_dflags <$> getSession
|
|
|
75
|
+ let fs = fileSettings dflags
|
|
|
76
|
+ actualLib = fileSettings_libDir fs
|
|
|
77
|
+ actualPkgDb = fileSettings_globalPackageDatabase fs
|
|
|
78
|
+ normActualLib <- liftIO $ canonicalizePath actualLib
|
|
|
79
|
+ normExpected <- liftIO $ canonicalizePath expectedLib
|
|
|
80
|
+ normTopDir <- liftIO $ canonicalizePath topDir
|
|
|
81
|
+ normActualPkgDb <- liftIO $ canonicalizePath actualPkgDb
|
|
|
82
|
+ normExpectedPkgDb <- liftIO $ canonicalizePath (expectedLib </> "package.conf.d")
|
|
|
83
|
+ liftIO $ do
|
|
|
84
|
+ when (normActualLib /= normExpected) $
|
|
|
85
|
+ die
|
|
|
86
|
+ [ "FAIL: libDir should be " ++ normExpected,
|
|
|
87
|
+ " got " ++ normActualLib
|
|
|
88
|
+ ]
|
|
|
89
|
+ when (normActualLib == normTopDir) $
|
|
|
90
|
+ die ["FAIL: libDir equals topDir — LibDir setting was ignored"]
|
|
|
91
|
+ when (normActualPkgDb /= normExpectedPkgDb) $
|
|
|
92
|
+ die
|
|
|
93
|
+ [ "FAIL: globalPackageDB should be " ++ normExpectedPkgDb,
|
|
|
94
|
+ " got " ++ normActualPkgDb
|
|
|
95
|
+ ]
|
|
|
96
|
+
|
|
|
97
|
+assertGhcFlags :: FilePath -> FilePath -> FilePath -> IO ()
|
|
|
98
|
+assertGhcFlags ghcBin topDir expectedLib = do
|
|
|
99
|
+ normExpectedLib <- canonicalizePath expectedLib
|
|
|
100
|
+ normExpectedPkgDb <- canonicalizePath (expectedLib </> "package.conf.d")
|
|
|
101
|
+
|
|
|
102
|
+ printedLibDir <- trim <$> readProcess ghcBin ["-B" ++ topDir, "--print-libdir"] ""
|
|
|
103
|
+ normPrintedLib <- canonicalizePath printedLibDir
|
|
|
104
|
+ when (normPrintedLib /= normExpectedLib) $
|
|
|
105
|
+ die
|
|
|
106
|
+ [ "FAIL: --print-libdir should be " ++ normExpectedLib,
|
|
|
107
|
+ " got " ++ normPrintedLib
|
|
|
108
|
+ ]
|
|
|
109
|
+
|
|
|
110
|
+ printedPkgDb <- trim <$> readProcess ghcBin ["-B" ++ topDir, "--print-global-package-db"] ""
|
|
|
111
|
+ normPrintedPkgDb <- canonicalizePath printedPkgDb
|
|
|
112
|
+ when (normPrintedPkgDb /= normExpectedPkgDb) $
|
|
|
113
|
+ die
|
|
|
114
|
+ [ "FAIL: --print-global-package-db should be " ++ normExpectedPkgDb,
|
|
|
115
|
+ " got " ++ normPrintedPkgDb
|
|
|
116
|
+ ]
|
|
|
117
|
+
|
|
|
118
|
+compileAndRunTestExpr :: Ghc ()
|
|
|
119
|
+compileAndRunTestExpr = do
|
|
|
120
|
+ dflags <- getSessionDynFlags
|
|
|
121
|
+ _ <- setSessionDynFlags dflags
|
|
|
122
|
+ setContext [IIDecl (simpleImportDecl (mkModuleName "Prelude"))]
|
|
|
123
|
+ result <- compileExpr "length [1,2,3 :: Int]"
|
|
|
124
|
+ liftIO $ print (unsafeCoerce result :: Int)
|
|
|
125
|
+
|
|
|
126
|
+trim :: String -> String
|
|
|
127
|
+trim = reverse . dropWhile (== '\n') . reverse
|
|
|
128
|
+
|
|
|
129
|
+die :: [String] -> IO ()
|
|
|
130
|
+die msgs = mapM_ (hPutStrLn stderr) msgs >> exitWith (ExitFailure 1) |