Skip to content

Commit d3c9d6f

Browse files
schellschell
committed
Merge pull request bitc#18 from pbrant/master
Add support for passing extra options to Cabal
2 parents 0424c14 + 1e2e2ba commit d3c9d6f

File tree

6 files changed

+77
-25
lines changed

6 files changed

+77
-25
lines changed

‎hdevtools.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -71,6 +71,7 @@ executable hdevtools
7171
network,
7272
process >= 1.2.3.0,
7373
time,
74+
transformers,
7475
unix
7576

7677
if impl(ghc == 7.6.*)

‎src/Cabal.hs‎

Lines changed: 32 additions & 21 deletions
Original file line numberDiff line numberDiff line change
@@ -7,6 +7,9 @@ module Cabal
77
#ifdef ENABLE_CABAL
88
import Stack
99
import Control.Exception (IOException, catch)
10+
import Control.Monad (when)
11+
import Control.Monad.Trans.Class (lift)
12+
import Control.Monad.Trans.State (execStateT, modify)
1013
import Data.Char (isSpace)
1114
import Data.List (foldl', nub, sort, find, isPrefixOf, isSuffixOf)
1215
#if __GLASGOW_HASKELL__ < 709
@@ -24,12 +27,13 @@ import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..), ComponentLocalBui
2427
#endif
2528
componentBuildInfo, foldComponent)
2629
import Distribution.Simple.Compiler (PackageDB(..))
30+
import Distribution.Simple.Command (CommandParse(..), commandParseArgs)
2731
import Distribution.Simple.GHC (componentGhcOptions)
2832
import Distribution.Simple.Program (defaultProgramConfiguration)
2933
import Distribution.Simple.Program.Db (lookupProgram)
3034
import Distribution.Simple.Program.Types (ConfiguredProgram(programVersion), simpleProgram)
3135
import Distribution.Simple.Program.GHC (GhcOptions(..), renderGhcOptions)
32-
import Distribution.Simple.Setup (ConfigFlags(..), defaultConfigFlags, toFlag)
36+
import Distribution.Simple.Setup (ConfigFlags(..), defaultConfigFlags, configureCommand, toFlag)
3337
#if __GLASGOW_HASKELL__ >= 709
3438
import Distribution.Utils.NubList
3539
import qualified Distribution.Simple.GHC as GHC(configure)
@@ -110,30 +114,37 @@ stackifyFlags cfg (Just si) = cfg { configDistPref = toFlag dist
110114
-- via: https://groups.google.com/d/msg/haskell-stack/8HJ6DHAinU0/J68U6AXTsasJ
111115
-- cabal configure --package-db=clear --package-db=global --package-db=$(stack path --snapshot-pkg-db) --package-db=$(stack path --local-pkg-db)
112116

113-
getPackageGhcOpts :: FilePath -> Maybe StackConfig -> IO (Either String [String])
114-
getPackageGhcOpts path mbStack = do
117+
getPackageGhcOpts :: FilePath -> Maybe StackConfig -> [String] -> IO (Either String [String])
118+
getPackageGhcOpts path mbStack opts = do
115119
getPackageGhcOpts' `catch` (\e -> do
116120
return $ Left $ "Cabal error: " ++ (ioeGetErrorString (e :: IOException)))
117121
where
118122
getPackageGhcOpts' :: IO (Either String [String])
119123
getPackageGhcOpts' = do
120124
genPkgDescr <- readPackageDescription silent path
121-
let cfgFlags'' = (defaultConfigFlags defaultProgramConfiguration)
122-
{ configDistPref = toFlag $ takeDirectory path </> "dist"
123-
-- TODO: figure out how to find out this flag
124-
, configUserInstall = toFlag True
125-
}
126-
let cfgFlags' = stackifyFlags cfgFlags'' mbStack
127-
let sandboxConfig = takeDirectory path </> "cabal.sandbox.config"
128-
exists <- doesFileExist sandboxConfig
129-
130-
cfgFlags <- case exists of
131-
False -> return cfgFlags'
132-
True -> do
133-
sandboxPackageDb <- getSandboxPackageDB sandboxConfig
134-
return $ cfgFlags'
135-
{ configPackageDBs = [Just sandboxPackageDb]
136-
}
125+
126+
let programCfg = defaultProgramConfiguration
127+
let initCfgFlags = (defaultConfigFlags programCfg)
128+
{ configDistPref = toFlag $ takeDirectory path </> "dist"
129+
-- TODO: figure out how to find out this flag
130+
, configUserInstall = toFlag True
131+
}
132+
let initCfgFlags' = stackifyFlags initCfgFlags mbStack
133+
134+
cfgFlags <- flip execStateT initCfgFlags' $ do
135+
let sandboxConfig = takeDirectory path </> "cabal.sandbox.config"
136+
137+
exists <- lift $ doesFileExist sandboxConfig
138+
when (exists) $ do
139+
sandboxPackageDb <- lift $ getSandboxPackageDB sandboxConfig
140+
modify $ \x -> x { configPackageDBs = [Just sandboxPackageDb] }
141+
142+
let cmdUI = configureCommand programCfg
143+
case commandParseArgs cmdUI True opts of
144+
CommandReadyToGo (modFlags, _) -> modify modFlags
145+
CommandErrors (e:_) -> error e
146+
_ -> return ()
147+
137148
localBuildInfo <- configure (genPkgDescr, emptyHookedBuildInfo) cfgFlags
138149
let pkgDescr = localPkgDescr localBuildInfo
139150
let baseDir = fst . splitFileName $ path
@@ -217,8 +228,8 @@ findCabalFile dir = do
217228

218229
# else
219230

220-
getPackageGhcOpts :: FilePath -> IO (Either String [String])
221-
getPackageGhcOpts _ = return $ Right []
231+
getPackageGhcOpts :: FilePath -> [String] -> IO (Either String [String])
232+
getPackageGhcOpts _ _ = return $ Right []
222233

223234
findCabalFile :: FilePath -> IO (Maybe FilePath)
224235
findCabalFile _ = return Nothing

‎src/CommandArgs.hs‎

Lines changed: 35 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -53,24 +53,28 @@ data HDevTools
5353
| Check
5454
{ socket :: Maybe FilePath
5555
, ghcOpts :: [String]
56+
, cabalOpts :: [String]
5657
, path :: Maybe String
5758
, file :: String
5859
}
5960
| ModuleFile
6061
{ socket :: Maybe FilePath
6162
, ghcOpts :: [String]
63+
, cabalOpts :: [String]
6264
, module_ :: String
6365
}
6466
| Info
6567
{ socket :: Maybe FilePath
6668
, ghcOpts :: [String]
69+
, cabalOpts :: [String]
6770
, path :: Maybe String
6871
, file :: String
6972
, identifier :: String
7073
}
7174
| Type
7275
{ socket :: Maybe FilePath
7376
, ghcOpts :: [String]
77+
, cabalOpts :: [String]
7478
, path :: Maybe String
7579
, file :: String
7680
, line :: Int
@@ -79,6 +83,7 @@ data HDevTools
7983
| FindSymbol
8084
{ socket :: Maybe FilePath
8185
, ghcOpts :: [String]
86+
, cabalOpts :: [String]
8287
, symbol :: String
8388
, files :: [String]
8489
}
@@ -97,6 +102,7 @@ dummyCheck :: HDevTools
97102
dummyCheck = Check
98103
{ socket = Nothing
99104
, ghcOpts = []
105+
, cabalOpts = []
100106
, path = Nothing
101107
, file = ""
102108
}
@@ -105,13 +111,15 @@ dummyModuleFile :: HDevTools
105111
dummyModuleFile = ModuleFile
106112
{ socket = Nothing
107113
, ghcOpts = []
114+
, cabalOpts = []
108115
, module_ = ""
109116
}
110117

111118
dummyInfo :: HDevTools
112119
dummyInfo = Info
113120
{ socket = Nothing
114121
, ghcOpts = []
122+
, cabalOpts = []
115123
, path = Nothing
116124
, file = ""
117125
, identifier = ""
@@ -121,6 +129,7 @@ dummyType :: HDevTools
121129
dummyType = Type
122130
{ socket = Nothing
123131
, ghcOpts = []
132+
, cabalOpts = []
124133
, path = Nothing
125134
, file = ""
126135
, line = 0
@@ -131,6 +140,7 @@ dummyFindSymbol :: HDevTools
131140
dummyFindSymbol = FindSymbol
132141
{ socket = Nothing
133142
, ghcOpts = []
143+
, cabalOpts = []
134144
, symbol = ""
135145
, files = []
136146
}
@@ -148,6 +158,11 @@ check :: Annotate Ann
148158
check = record dummyCheck
149159
[ socket := def += typFile += help "socket file to use"
150160
, ghcOpts := def += typ "OPTION" += help "ghc options"
161+
#ifdef ENABLE_CABAL
162+
, cabalOpts := def += typ "OPTION" += help "cabal options"
163+
#else
164+
, cabalOpts := def += ignore
165+
#endif
151166
, path := def += typFile += help "path to target file"
152167
, file := def += typFile += argPos 0 += opt ""
153168
] += help "Check a haskell source file for errors and warnings"
@@ -156,13 +171,23 @@ moduleFile :: Annotate Ann
156171
moduleFile = record dummyModuleFile
157172
[ socket := def += typFile += help "socket file to use"
158173
, ghcOpts := def += typ "OPTION" += help "ghc options"
174+
#ifdef ENABLE_CABAL
175+
, cabalOpts := def += typ "OPTION" += help "cabal options"
176+
#else
177+
, cabalOpts := def += ignore
178+
#endif
159179
, module_ := def += typ "MODULE" += argPos 0
160180
] += help "Get the haskell source file corresponding to a module name"
161181

162182
info :: Annotate Ann
163183
info = record dummyInfo
164184
[ socket := def += typFile += help "socket file to use"
165185
, ghcOpts := def += typ "OPTION" += help "ghc options"
186+
#ifdef ENABLE_CABAL
187+
, cabalOpts := def += typ "OPTION" += help "cabal options"
188+
#else
189+
, cabalOpts := def += ignore
190+
#endif
166191
, path := def += typFile += help "path to target file"
167192
, file := def += typFile += argPos 0 += opt ""
168193
, identifier := def += typ "IDENTIFIER" += argPos 1
@@ -172,6 +197,11 @@ type_ :: Annotate Ann
172197
type_ = record dummyType
173198
[ socket := def += typFile += help "socket file to use"
174199
, ghcOpts := def += typ "OPTION" += help "ghc options"
200+
#ifdef ENABLE_CABAL
201+
, cabalOpts := def += typ "OPTION" += help "cabal options"
202+
#else
203+
, cabalOpts := def += ignore
204+
#endif
175205
, path := def += typFile += help "path to target file"
176206
, file := def += typFile += argPos 0 += opt ""
177207
, line := def += typ "LINE" += argPos 1
@@ -182,6 +212,11 @@ findSymbol :: Annotate Ann
182212
findSymbol = record dummyFindSymbol
183213
[ socket := def += typFile += help "socket file to use"
184214
, ghcOpts := def += typ "OPTION" += help "ghc options"
215+
#ifdef ENABLE_CABAL
216+
, cabalOpts := def += typ "OPTION" += help "cabal options"
217+
#else
218+
, cabalOpts := def += ignore
219+
#endif
185220
, symbol := def += typ "SYMBOL" += argPos 0
186221
, files := def += typFile += args
187222
] += help "List the modules where the given symbol could be found"

‎src/CommandLoop.hs‎

Lines changed: 6 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -46,14 +46,16 @@ newCommandLoopState = do
4646

4747
data CabalConfig = CabalConfig
4848
{ cabalConfigPath :: FilePath
49+
, cabalConfigOpts :: [String]
4950
, cabalConfigLastUpdatedAt :: EpochTime
5051
}
5152
deriving Eq
5253

53-
mkCabalConfig :: FilePath -> IO CabalConfig
54-
mkCabalConfig path = do
54+
mkCabalConfig :: FilePath -> [String] -> IO CabalConfig
55+
mkCabalConfig path opts = do
5556
fileStatus <- getFileStatus path
5657
return $ CabalConfig { cabalConfigPath = path
58+
, cabalConfigOpts = opts
5759
, cabalConfigLastUpdatedAt = modificationTime fileStatus
5860
}
5961

@@ -66,7 +68,7 @@ data Config = Config
6668

6769
newConfig :: CommandExtra -> IO Config
6870
newConfig cmdExtra = do
69-
mbCabalConfig <- traverse mkCabalConfig $ ceCabalConfig cmdExtra
71+
mbCabalConfig <- traverse (\path -> mkCabalConfig path (ceCabalOptions cmdExtra)) $ ceCabalConfig cmdExtra
7072
mbStackConfig <- getStackConfig cmdExtra
7173

7274
return $ Config { configGhcOpts = "-O0" : ceGhcOptions cmdExtra
@@ -140,7 +142,7 @@ configSession state clientSend config = do
140142
return $ Right []
141143
Just cabalConfig -> do
142144
liftIO $ setCurrentDirectory . takeDirectory $ cabalConfigPath cabalConfig
143-
liftIO $ getPackageGhcOpts (cabalConfigPath cabalConfig) (configStack config)
145+
liftIO $ getPackageGhcOpts (cabalConfigPath cabalConfig) (configStack config) (cabalConfigOpts cabalConfig)
144146
case eCabalGhcOpts of
145147
Left e -> return $ Left e
146148
Right cabalGhcOpts -> do

‎src/Main.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -60,6 +60,7 @@ main = do
6060
{ ceGhcOptions = ghcOpts args
6161
, ceCabalConfig = mCabalFile
6262
, cePath = argPath
63+
, ceCabalOptions = cabalOpts args
6364
}
6465
let defaultSocketPath = maybe "" takeDirectory mCabalFile </> defaultSocketFile
6566
let sock = fromMaybe defaultSocketPath $ socket args

‎src/Types.hs‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -12,12 +12,14 @@ data CommandExtra = CommandExtra
1212
{ ceGhcOptions :: [String]
1313
, ceCabalConfig :: Maybe FilePath
1414
, cePath :: Maybe FilePath
15+
, ceCabalOptions :: [String]
1516
} deriving (Read, Show)
1617

1718
emptyCommandExtra :: CommandExtra
1819
emptyCommandExtra = CommandExtra { ceGhcOptions = []
1920
, ceCabalConfig = Nothing
2021
, cePath = Nothing
22+
, ceCabalOptions = []
2123
}
2224

2325
data ServerDirective

0 commit comments

Comments
 (0)