Merge pull request bitc#18 from pbrant/master

Add support for passing extra options to Cabal

hdevtools.cabal

@@ -71,6 +71,7 @@ executable hdevtools
                        network,
                        process >= 1.2.3.0,
                        time,
+                       transformers,
                        unix
 
   if impl(ghc == 7.6.*)

src/Cabal.hs

@@ -7,6 +7,9 @@ module Cabal
 #ifdef ENABLE_CABAL
 import Stack
 import Control.Exception (IOException, catch)
+import Control.Monad (when)
+import Control.Monad.Trans.Class (lift)
+import Control.Monad.Trans.State (execStateT, modify)
 import Data.Char (isSpace)
 import Data.List (foldl', nub, sort, find, isPrefixOf, isSuffixOf)
 #if __GLASGOW_HASKELL__ < 709
@@ -24,12 +27,13 @@ import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..), ComponentLocalBui
 #endif
     componentBuildInfo, foldComponent)
 import Distribution.Simple.Compiler (PackageDB(..))
+import Distribution.Simple.Command (CommandParse(..), commandParseArgs)
 import Distribution.Simple.GHC (componentGhcOptions)
 import Distribution.Simple.Program (defaultProgramConfiguration)
 import Distribution.Simple.Program.Db (lookupProgram)
 import Distribution.Simple.Program.Types (ConfiguredProgram(programVersion), simpleProgram)
 import Distribution.Simple.Program.GHC (GhcOptions(..), renderGhcOptions)
-import Distribution.Simple.Setup (ConfigFlags(..), defaultConfigFlags, toFlag)
+import Distribution.Simple.Setup (ConfigFlags(..), defaultConfigFlags, configureCommand, toFlag)
 #if __GLASGOW_HASKELL__ >= 709
 import Distribution.Utils.NubList
 import qualified Distribution.Simple.GHC as GHC(configure)
@@ -110,30 +114,37 @@ stackifyFlags cfg (Just si) = cfg { configDistPref    = toFlag dist
 -- via: https://groups.google.com/d/msg/haskell-stack/8HJ6DHAinU0/J68U6AXTsasJ
 -- cabal configure --package-db=clear --package-db=global --package-db=$(stack path --snapshot-pkg-db) --package-db=$(stack path --local-pkg-db)
 
-getPackageGhcOpts :: FilePath -> Maybe StackConfig -> IO (Either String [String])
-getPackageGhcOpts path mbStack = do
+getPackageGhcOpts :: FilePath -> Maybe StackConfig -> [String] -> IO (Either String [String])
+getPackageGhcOpts path mbStack opts = do
     getPackageGhcOpts' `catch` (\e -> do
         return $ Left $ "Cabal error: " ++ (ioeGetErrorString (e :: IOException)))
   where
     getPackageGhcOpts' :: IO (Either String [String])
     getPackageGhcOpts' = do
         genPkgDescr <- readPackageDescription silent path
-        let cfgFlags'' = (defaultConfigFlags defaultProgramConfiguration)
-                            { configDistPref = toFlag $ takeDirectory path </> "dist"
-                            -- TODO: figure out how to find out this flag
-                            , configUserInstall = toFlag True
-                            }
-        let cfgFlags'  = stackifyFlags cfgFlags'' mbStack
-        let sandboxConfig = takeDirectory path </> "cabal.sandbox.config"
-        exists <- doesFileExist sandboxConfig
-
-        cfgFlags <- case exists of
-                         False -> return cfgFlags'
-                         True -> do
-                             sandboxPackageDb <- getSandboxPackageDB sandboxConfig
-                             return $ cfgFlags'
-                                          { configPackageDBs = [Just sandboxPackageDb]
-                                          }
+
+        let programCfg = defaultProgramConfiguration
+        let initCfgFlags = (defaultConfigFlags programCfg)
+                             { configDistPref = toFlag $ takeDirectory path </> "dist"
+                             -- TODO: figure out how to find out this flag
+                             , configUserInstall = toFlag True
+                             }
+        let initCfgFlags' = stackifyFlags initCfgFlags mbStack
+
+        cfgFlags <- flip execStateT initCfgFlags' $ do
+          let sandboxConfig = takeDirectory path </> "cabal.sandbox.config"
+
+          exists <- lift $ doesFileExist sandboxConfig
+          when (exists) $ do
+            sandboxPackageDb <- lift $ getSandboxPackageDB sandboxConfig
+            modify $ \x -> x { configPackageDBs = [Just sandboxPackageDb] }
+
+          let cmdUI = configureCommand programCfg
+          case commandParseArgs cmdUI True opts of
+            CommandReadyToGo (modFlags, _) -> modify modFlags
+            CommandErrors (e:_) -> error e
+            _ -> return ()
+
         localBuildInfo <- configure (genPkgDescr, emptyHookedBuildInfo) cfgFlags
         let pkgDescr = localPkgDescr localBuildInfo
         let baseDir = fst . splitFileName $ path
@@ -217,8 +228,8 @@ findCabalFile dir = do
 
 # else
 
-getPackageGhcOpts :: FilePath -> IO (Either String [String])
-getPackageGhcOpts _ = return $ Right []
+getPackageGhcOpts :: FilePath -> [String] -> IO (Either String [String])
+getPackageGhcOpts _ _ = return $ Right []
 
 findCabalFile :: FilePath -> IO (Maybe FilePath)
 findCabalFile _ = return Nothing

src/CommandArgs.hs

@@ -53,24 +53,28 @@ data HDevTools
     | Check
         { socket  :: Maybe FilePath
         , ghcOpts :: [String]
+        , cabalOpts :: [String]
         , path    :: Maybe String
         , file    :: String
         }
     | ModuleFile
         { socket  :: Maybe FilePath
         , ghcOpts :: [String]
+        , cabalOpts :: [String]
         , module_ :: String
         }
     | Info
         { socket     :: Maybe FilePath
         , ghcOpts    :: [String]
+        , cabalOpts  :: [String]
         , path       :: Maybe String
         , file       :: String
         , identifier :: String
         }
     | Type
         { socket  :: Maybe FilePath
         , ghcOpts :: [String]
+        , cabalOpts  :: [String]
         , path    :: Maybe String
         , file    :: String
         , line    :: Int
@@ -79,6 +83,7 @@ data HDevTools
     | FindSymbol
         { socket :: Maybe FilePath
         , ghcOpts :: [String]
+        , cabalOpts :: [String]
         , symbol :: String
         , files :: [String]
         }
@@ -97,6 +102,7 @@ dummyCheck :: HDevTools
 dummyCheck = Check
     { socket  = Nothing
     , ghcOpts = []
+    , cabalOpts = []
     , path    = Nothing
     , file    = ""
     }
@@ -105,13 +111,15 @@ dummyModuleFile :: HDevTools
 dummyModuleFile = ModuleFile
     { socket  = Nothing
     , ghcOpts = []
+    , cabalOpts = []
     , module_ = ""
     }
 
 dummyInfo :: HDevTools
 dummyInfo = Info
     { socket     = Nothing
     , ghcOpts    = []
+    , cabalOpts = []
     , path       = Nothing
     , file       = ""
     , identifier = ""
@@ -121,6 +129,7 @@ dummyType :: HDevTools
 dummyType = Type
     { socket  = Nothing
     , ghcOpts = []
+    , cabalOpts = []
     , path    = Nothing
     , file    = ""
     , line    = 0
@@ -131,6 +140,7 @@ dummyFindSymbol :: HDevTools
 dummyFindSymbol = FindSymbol
     { socket = Nothing
     , ghcOpts = []
+    , cabalOpts = []
     , symbol = ""
     , files = []
     }
@@ -148,6 +158,11 @@ check :: Annotate Ann
 check = record dummyCheck
     [ socket   := def += typFile      += help "socket file to use"
     , ghcOpts  := def += typ "OPTION" += help "ghc options"
+#ifdef ENABLE_CABAL
+    , cabalOpts := def += typ "OPTION"  += help "cabal options"
+#else
+    , cabalOpts := def += ignore
+#endif
     , path     := def += typFile      += help "path to target file"
     , file     := def += typFile      += argPos 0 += opt ""
     ] += help "Check a haskell source file for errors and warnings"
@@ -156,13 +171,23 @@ moduleFile :: Annotate Ann
 moduleFile = record dummyModuleFile
     [ socket   := def += typFile += help "socket file to use"
     , ghcOpts  := def += typ "OPTION" += help "ghc options"
+#ifdef ENABLE_CABAL
+    , cabalOpts := def += typ "OPTION"  += help "cabal options"
+#else
+    , cabalOpts := def += ignore
+#endif
     , module_  := def += typ "MODULE" += argPos 0
     ] += help "Get the haskell source file corresponding to a module name"
 
 info :: Annotate Ann
 info = record dummyInfo
     [ socket     := def += typFile      += help "socket file to use"
     , ghcOpts    := def += typ "OPTION" += help "ghc options"
+#ifdef ENABLE_CABAL
+    , cabalOpts := def += typ "OPTION"  += help "cabal options"
+#else
+    , cabalOpts := def += ignore
+#endif
     , path       := def += typFile      += help "path to target file"
     , file       := def += typFile      += argPos 0 += opt ""
     , identifier := def += typ "IDENTIFIER" += argPos 1
@@ -172,6 +197,11 @@ type_ :: Annotate Ann
 type_ = record dummyType
     [ socket   := def += typFile += help "socket file to use"
     , ghcOpts  := def += typ "OPTION" += help "ghc options"
+#ifdef ENABLE_CABAL
+    , cabalOpts := def += typ "OPTION"  += help "cabal options"
+#else
+    , cabalOpts := def += ignore
+#endif
     , path     := def += typFile      += help "path to target file"
     , file     := def += typFile      += argPos 0 += opt ""
     , line     := def += typ "LINE"   += argPos 1
@@ -182,6 +212,11 @@ findSymbol :: Annotate Ann
 findSymbol = record dummyFindSymbol
     [ socket   := def += typFile += help "socket file to use"
     , ghcOpts  := def += typ "OPTION" += help "ghc options"
+#ifdef ENABLE_CABAL
+    , cabalOpts := def += typ "OPTION"  += help "cabal options"
+#else
+    , cabalOpts := def += ignore
+#endif
     , symbol   := def += typ "SYMBOL" += argPos 0
     , files    := def += typFile += args
     ] += help "List the modules where the given symbol could be found"

src/CommandLoop.hs

@@ -46,14 +46,16 @@ newCommandLoopState = do
 
 data CabalConfig = CabalConfig
     { cabalConfigPath :: FilePath
+    , cabalConfigOpts :: [String]
     , cabalConfigLastUpdatedAt :: EpochTime
     }
     deriving Eq
 
-mkCabalConfig :: FilePath -> IO CabalConfig
-mkCabalConfig path = do
+mkCabalConfig :: FilePath -> [String] -> IO CabalConfig
+mkCabalConfig path opts = do
     fileStatus <- getFileStatus path
     return $ CabalConfig { cabalConfigPath = path
+                         , cabalConfigOpts = opts
                          , cabalConfigLastUpdatedAt = modificationTime fileStatus
                          }
 
@@ -66,7 +68,7 @@ data Config = Config
 
 newConfig :: CommandExtra -> IO Config
 newConfig cmdExtra = do
-    mbCabalConfig <- traverse mkCabalConfig $ ceCabalConfig cmdExtra
+    mbCabalConfig <- traverse (\path -> mkCabalConfig path (ceCabalOptions cmdExtra)) $ ceCabalConfig cmdExtra
     mbStackConfig <- getStackConfig cmdExtra
 
     return $ Config { configGhcOpts = "-O0" : ceGhcOptions cmdExtra
@@ -140,7 +142,7 @@ configSession state clientSend config = do
                           return $ Right []
                       Just cabalConfig -> do
                           liftIO $ setCurrentDirectory . takeDirectory $ cabalConfigPath cabalConfig
-                          liftIO $ getPackageGhcOpts (cabalConfigPath cabalConfig) (configStack config)
+                          liftIO $ getPackageGhcOpts (cabalConfigPath cabalConfig) (configStack config) (cabalConfigOpts cabalConfig)
     case eCabalGhcOpts of
       Left e -> return $ Left e
       Right cabalGhcOpts -> do

src/Main.hs

@@ -60,6 +60,7 @@ main = do
                     { ceGhcOptions  = ghcOpts args
                     , ceCabalConfig = mCabalFile
                     , cePath        = argPath
+                    , ceCabalOptions = cabalOpts args
                     }
     let defaultSocketPath = maybe "" takeDirectory mCabalFile </> defaultSocketFile
     let sock = fromMaybe defaultSocketPath $ socket args

src/Types.hs

@@ -12,12 +12,14 @@ data CommandExtra = CommandExtra
   { ceGhcOptions  :: [String]
   , ceCabalConfig :: Maybe FilePath
   , cePath        :: Maybe FilePath
+  , ceCabalOptions :: [String]
   } deriving (Read, Show)
 
 emptyCommandExtra :: CommandExtra
 emptyCommandExtra = CommandExtra { ceGhcOptions  = []
                                  , ceCabalConfig = Nothing
                                  , cePath        = Nothing
+                                 , ceCabalOptions = []
                                  }
 
 data ServerDirective