diff --git a/hdevtools.cabal b/hdevtools.cabal index 4cb0bc7..71930b1 100644 --- a/hdevtools.cabal +++ b/hdevtools.cabal @@ -71,6 +71,7 @@ executable hdevtools network, process >= 1.2.3.0, time, + transformers, unix if impl(ghc == 7.6.*) diff --git a/src/Cabal.hs b/src/Cabal.hs index 388133e..6e3f35d 100644 --- a/src/Cabal.hs +++ b/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 diff --git a/src/CommandArgs.hs b/src/CommandArgs.hs index 2f79080..68a5480 100644 --- a/src/CommandArgs.hs +++ b/src/CommandArgs.hs @@ -53,17 +53,20 @@ 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 @@ -71,6 +74,7 @@ data HDevTools | 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,6 +111,7 @@ dummyModuleFile :: HDevTools dummyModuleFile = ModuleFile { socket = Nothing , ghcOpts = [] + , cabalOpts = [] , module_ = "" } @@ -112,6 +119,7 @@ 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,6 +171,11 @@ 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" @@ -163,6 +183,11 @@ 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" diff --git a/src/CommandLoop.hs b/src/CommandLoop.hs index 605900c..3d044a2 100644 --- a/src/CommandLoop.hs +++ b/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 diff --git a/src/Main.hs b/src/Main.hs index 4237087..f124206 100644 --- a/src/Main.hs +++ b/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 diff --git a/src/Types.hs b/src/Types.hs index 4daa50f..eace685 100644 --- a/src/Types.hs +++ b/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