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
|
-- cabal-helper: Simple interface to Cabal's configuration state
-- Copyright (C) 2018 Daniel Gröber <cabal-helper@dxld.at>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU General Public License for more details.
--
-- You should have received a copy of the GNU General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
{-|
Module : CabalHelper.Compiletime.Program.GHC
Description : GHC program interface
License : GPL-3
-}
module CabalHelper.Compiletime.Program.GHC where
import Control.Monad
import Control.Monad.Trans.Maybe
import Control.Monad.IO.Class
import Data.Char
import Data.List
import Data.String
import Data.Maybe
import Data.Version
import System.Exit
import System.FilePath
import System.Directory
import CabalHelper.Shared.Common
(parseVer, trim, appCacheDir, parsePkgId)
import CabalHelper.Compiletime.Types
import CabalHelper.Compiletime.Cabal
(CabalVersion(..), showCabalVersion)
import CabalHelper.Compiletime.Process
import CabalHelper.Compiletime.Log
data GhcInvocation = GhcInvocation
{ giOutDir :: FilePath
, giOutput :: FilePath
, giCPPOptions :: [String]
, giPackageDBs :: [PackageDbDir]
, giIncludeDirs :: [FilePath]
, giHideAllPackages :: Bool
, giPackages :: [String]
, giWarningFlags :: [String]
, giInputs :: [String]
}
ghcVersion :: (Verbose, CProgs) => IO Version
ghcVersion =
parseVer . trim <$> readProcess' (ghcProgram ?cprogs) ["--numeric-version"] ""
ghcPkgVersion :: (Verbose, CProgs) => IO Version
ghcPkgVersion =
parseVer . trim . dropWhile (not . isDigit)
<$> readProcess' (ghcPkgProgram ?cprogs) ["--version"] ""
createPkgDb :: (Verbose, CProgs) => CabalVersion -> IO PackageDbDir
createPkgDb cabalVer = do
db@(PackageDbDir db_path) <- getPrivateCabalPkgDb cabalVer
exists <- doesDirectoryExist db_path
when (not exists) $
callProcessStderr Nothing (ghcPkgProgram ?cprogs) ["init", db_path]
return db
getPrivateCabalPkgDb :: (Verbose, CProgs) => CabalVersion -> IO PackageDbDir
getPrivateCabalPkgDb cabalVer = do
appdir <- appCacheDir
ghcVer <- ghcVersion
let db_path =
appdir </> "ghc-" ++ showVersion ghcVer ++ ".package-db"
</> "Cabal-" ++ showCabalVersion cabalVer
return $ PackageDbDir db_path
listCabalVersions
:: (Verbose, Progs) => Maybe PackageDbDir -> MaybeT IO [Version]
listCabalVersions mdb = do
let mdb_path = unPackageDbDir <$> mdb
exists <- fromMaybe True <$>
traverse (liftIO . doesDirectoryExist) mdb_path
case exists of
True -> MaybeT $ logIOError "listCabalVersions" $ Just <$> do
let mdbopt = ("--package-conf="++) <$> mdb_path
args = ["list", "--simple-output", "Cabal"] ++ maybeToList mdbopt
catMaybes . map (fmap snd . parsePkgId . fromString) . words
<$> readProcess' (ghcPkgProgram ?cprogs) args ""
_ -> mzero
cabalVersionExistsInPkgDb
:: (Verbose, Progs) => Version -> PackageDbDir -> IO Bool
cabalVersionExistsInPkgDb cabalVer db@(PackageDbDir db_path) = do
exists <- doesDirectoryExist db_path
case exists of
False -> return False
True -> fromMaybe False <$> runMaybeT (do
vers <- listCabalVersions (Just db)
return $ cabalVer `elem` vers)
invokeGhc :: Env => GhcInvocation -> IO (Either ExitCode FilePath)
invokeGhc GhcInvocation {..} = do
rv <- callProcessStderr' Nothing (ghcProgram ?cprogs) $ concat
[ [ "-outputdir", giOutDir
, "-o", giOutput
]
, map ("-optP"++) giCPPOptions
, map ("-package-conf="++) $ unPackageDbDir <$> giPackageDBs
, map ("-i"++) $ nub $ "" : giIncludeDirs
, if giHideAllPackages then ["-hide-all-packages"] else []
, concatMap (\p -> ["-package", p]) giPackages
, giWarningFlags
, ["--make"]
, giInputs
]
return $
case rv of
ExitSuccess -> Right giOutput
e@(ExitFailure _) -> Left e
|
