This repository has been archived by the owner on Mar 4, 2023. It is now read-only.
/
Cabal.hs
158 lines (145 loc) · 6.22 KB
/
Cabal.hs
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
151
152
153
154
155
156
157
158
{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables, CPP, PatternGuards #-}
-- | Stuff related to working on top of Cabal. E.g., configuring a
-- project.
--
-- Some functions are in the 'Worker' monad and can therefore be only
-- run on a worker. This mainly includes functions that may take a
-- while to run. Other functions are parameterised over the monad and
-- can therefore be run where wanted.
--
--
module Scion.Cabal where
import Scion.Types.Core
import Scion.Types.Session
import Scion.Types.Worker
import Data.Maybe ( isJust )
import Data.Typeable ( Typeable )
import Control.Exception ( throwIO, Exception )
import Control.Monad ( when )
import Distribution.PackageDescription.Parse
import Distribution.Simple.Build ( initialBuildSteps )
import Distribution.Simple.Configure
import Distribution.Simple.LocalBuildInfo hiding ( libdir )
import qualified Distribution.PackageDescription as PD
import qualified Distribution.PackageDescription.Parse as PD
import qualified Distribution.PackageDescription.Configuration as PD
import Distribution.Simple.PreProcess ( knownSuffixHandlers )
import Distribution.Simple.Program
import Distribution.Simple.Setup ( defaultConfigFlags,
ConfigFlags(..), Flag(..) )
import qualified Distribution.Verbosity as V ( normal, deafening, silent )
import GHC.Paths ( ghc, ghc_pkg )
import System.Directory
import System.Exit ( ExitCode(..) )
import System.FilePath ( (</>), dropFileName, takeExtension,
dropExtension,(<.>), takeBaseName )
-- | Something went wrong inside Cabal.
data CabalException = CabalException String
deriving (Typeable)
instance Show CabalException where
show (CabalException msg) = "CabalException: " ++ msg
instance Exception CabalException
-- | Set up a Cabal component, (re-)configuring it if necessary.
--
-- Checks whether an existing configuration result exists on disk and
-- configures the project if not. Similarly, if the existing config
-- is outdated the project is reconfigured.
--
-- Configuration is roughly equivalent to calling "./Setup configure"
-- on the command line. The difference is that this makes sure to use
-- the same version of Cabal and the GHC API that Scion was built
-- against. This is important to avoid compatibility problems.
--
configureCabalProject :: SessionConfig -> FilePath
-> Worker LocalBuildInfo
configureCabalProject conf@CabalConfig{} build_dir = do
cabal_exists <- io $ doesFileExist cabal_file
when (not cabal_exists) $
io $ throwIO $ CabalException $
".cabal file does not exist: " ++ cabal_file
let setup_config = localBuildInfoFile build_dir
conf'd <- io $ doesFileExist setup_config
if not conf'd
then do
message verbose $ "Configuring for first time: " ++ cabal_file
do_configure
else do
-- check whether setup_config is up to date
cabal_time <- io $ getModificationTime cabal_file
conf_time <- io $ getModificationTime setup_config
if cabal_time >= conf_time
then do
message verbose $ "Reconfiguring because .cabal file is newer: "
++ cabal_file
do_configure
else do
mb_lbi <- io $ maybeGetPersistBuildConfig build_dir
case mb_lbi of
Nothing -> do
message verbose $ "Reconfiguring because Cabal says so: "
++ cabal_file
do_configure
Just lbi ->
return lbi
where
cabal_file = sc_cabalFile conf
do_configure =
ghandle (\(e :: IOError) ->
io $ throwIO $
CabalException $ "Failed to configure" ++ show e) $ do
gen_pkg_descr <- io $ readPackageDescription V.normal cabal_file
-- TODO: The following only works for build-type simple. We
-- should support non-standard Setup.hs as well.
-- Make sure we configure with the same version of GHC
let prog_conf =
userSpecifyPaths [("ghc", ghc), ("ghc-pkg", ghc_pkg)]
defaultProgramConfiguration
let config_flags =
(defaultConfigFlags prog_conf)
{ configDistPref = Flag build_dir
, configVerbosity = Flag V.deafening
, configUserInstall = Flag True
-- TODO: parse flags properly
}
let root_dir = dropFileName cabal_file
io $ do
setCurrentDirectory root_dir
lbi <- configure (gen_pkg_descr, (Nothing, []))
config_flags
writePersistBuildConfig build_dir lbi
initialBuildSteps build_dir (localPkgDescr lbi) lbi V.normal
knownSuffixHandlers
return lbi
availableComponents :: PD.PackageDescription -> [Component]
availableComponents pd =
(if isJust (PD.library pd) then [Library] else []) ++
[ Executable (PD.exeName e)
| e <- PD.executables pd ]
-- | List all possible components of the @.cabal@ given file.
--
-- Some components might not be available depending on the way the
-- program is configured.
fileComponents :: (ExceptionMonad m, MonadIO m) => FilePath -> m [Component]
fileComponents cabal_file = do
ghandle (\(_ :: ExitCode) ->
io $ throwIO $ CabalException $ "Cannot open Cabal file: "
++ cabal_file) $ do
gpd <- io $ PD.readPackageDescription V.silent cabal_file
return (availableComponents (PD.flattenPackageDescription gpd))
-- | List all possible default session configs from a given @.cabal@ file.
cabalSessionConfigs :: (ExceptionMonad m, MonadIO m) => FilePath
-> m [SessionConfig]
cabalSessionConfigs cabal_file = do
comps <- fileComponents cabal_file
return (map componentToSessionConfig comps)
where
componentToSessionConfig comp =
CabalConfig{ sc_name = nameFromComponent comp
, sc_cabalFile = cabal_file
, sc_component = comp
, sc_configFlags = []
}
library_name = takeBaseName cabal_file
nameFromComponent Library = library_name
nameFromComponent (Executable exe_name) =
library_name ++ ":" ++ exe_name