hdevtools 0.1.3.2 → 0.1.4.0
raw patch · 10 files changed
+77/−33 lines, 10 files
Files
- CHANGELOG.md +4/−0
- README.md +2/−6
- hdevtools.cabal +1/−1
- src/Cabal.hs +5/−1
- src/Client.hs +1/−1
- src/CommandArgs.hs +24/−0
- src/CommandLoop.hs +6/−2
- src/Main.hs +11/−3
- src/Server.hs +4/−4
- src/Stack.hs +19/−15
CHANGELOG.md view
@@ -1,5 +1,9 @@ # Changelog +## 0.1.4.0 - 2016-08-08++ * Determine GHC libdir and binaries using stack.+ ## 0.1.3.2 - 2016-06-09 * Added GHC 8.0.x support
README.md view
@@ -44,12 +44,8 @@ $ stack install hdevtools ``` -**Note:** As stack manages matching GHC versions, the appropriate compiler has-to be available to `hdevtools`. Thus hdevtools has to be started with `stack exec`,-for example using the alias:-```-$ alias hdevtools="stack exec --no-ghc-package-path hdevtools --"-```+**Note:** `hdevtools` automatically discovers compiler and libraries installed+via stack. Alternatively one can install from [Hackage][1] via cabal install: ```
hdevtools.cabal view
@@ -1,5 +1,5 @@ name: hdevtools-version: 0.1.3.2+version: 0.1.4.0 synopsis: Persistent GHC powered background server for FAST haskell development tools license: MIT license-file: LICENSE
src/Cabal.hs view
@@ -102,13 +102,17 @@ stackifyFlags :: ConfigFlags -> Maybe StackConfig -> ConfigFlags stackifyFlags cfg Nothing = cfg-stackifyFlags cfg (Just si) = cfg { configDistPref = toFlag dist+stackifyFlags cfg (Just si) = cfg { configHcPath = toFlag ghc+ , configHcPkg = toFlag ghcPkg+ , configDistPref = toFlag dist , configPackageDBs = pdbs } where pdbs = [Nothing, Just GlobalPackageDB] ++ pdbs' pdbs' = Just . SpecificPackageDB <$> stackDbs si dist = stackDist si+ ghc = stackGhcBinDir si </> "ghc"+ ghcPkg = stackGhcBinDir si </> "ghc-pkg" -- 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)
src/Client.hs view
@@ -44,7 +44,7 @@ startClientReadLoop h Left _ -> do s <- createListenSocket sock- daemonize False $ startServer sock (Just s)+ daemonize False $ startServer sock (Just s) cmdExtra serverCommand sock cmd cmdExtra startClientReadLoop :: Handle -> IO ()
src/CommandArgs.hs view
@@ -34,10 +34,13 @@ data HDevTools = Admin { socket :: Maybe FilePath+ , ghcOpts :: [String] , start_server :: Bool+ , cabalOpts :: [String] , noDaemon :: Bool , status :: Bool , stop_server :: Bool+ , debug :: Bool } | Check { socket :: Maybe FilePath@@ -46,12 +49,14 @@ , path :: Maybe String , file :: String , json :: Bool+ , debug :: Bool } | ModuleFile { socket :: Maybe FilePath , ghcOpts :: [String] , cabalOpts :: [String] , module_ :: String+ , debug :: Bool } | Info { socket :: Maybe FilePath@@ -60,6 +65,7 @@ , path :: Maybe String , file :: String , identifier :: String+ , debug :: Bool } | Type { socket :: Maybe FilePath@@ -69,6 +75,7 @@ , file :: String , line :: Int , col :: Int+ , debug :: Bool } | FindSymbol { socket :: Maybe FilePath@@ -76,16 +83,20 @@ , cabalOpts :: [String] , symbol :: String , files :: [String]+ , debug :: Bool } deriving (Show, Data, Typeable) dummyAdmin :: HDevTools dummyAdmin = Admin { socket = Nothing+ , ghcOpts = []+ , cabalOpts = [] , start_server = False , noDaemon = False , status = False , stop_server = False+ , debug = False } dummyCheck :: HDevTools@@ -96,6 +107,7 @@ , path = Nothing , file = "" , json = False+ , debug = False } dummyModuleFile :: HDevTools@@ -104,6 +116,7 @@ , ghcOpts = [] , cabalOpts = [] , module_ = ""+ , debug = False } dummyInfo :: HDevTools@@ -114,6 +127,7 @@ , path = Nothing , file = "" , identifier = ""+ , debug = False } dummyType :: HDevTools@@ -125,6 +139,7 @@ , file = "" , line = 0 , col = 0+ , debug = False } dummyFindSymbol :: HDevTools@@ -134,15 +149,19 @@ , cabalOpts = [] , symbol = "" , files = []+ , debug = False } admin :: Annotate Ann admin = record dummyAdmin [ socket := def += typFile += help "socket file to use"+ , ghcOpts := def += typ "OPTION" += help "ghc options"+ , cabalOpts := def += typ "OPTION" += help "cabal options" , start_server := def += help "start server" , noDaemon := def += help "do not daemonize (only if --start-server)" , status := def += help "show status of server" , stop_server := def += help "shutdown the server"+ , debug := def += help "enable debug output" ] += help "Interactions with the server" check :: Annotate Ann@@ -153,6 +172,7 @@ , path := def += typFile += help "path to target file" , file := def += typFile += argPos 0 += opt "" , json := def += help "render output as JSON"+ , debug := def += help "enable debug output" ] += help "Check a haskell source file for errors and warnings" moduleFile :: Annotate Ann@@ -161,6 +181,7 @@ , ghcOpts := def += typ "OPTION" += help "ghc options" , cabalOpts := def += typ "OPTION" += help "cabal options" , module_ := def += typ "MODULE" += argPos 0+ , debug := def += help "enable debug output" ] += help "Get the haskell source file corresponding to a module name" info :: Annotate Ann@@ -171,6 +192,7 @@ , path := def += typFile += help "path to target file" , file := def += typFile += argPos 0 += opt "" , identifier := def += typ "IDENTIFIER" += argPos 1+ , debug := def += help "enable debug output" ] += help "Get info from GHC about the specified identifier" type_ :: Annotate Ann@@ -178,6 +200,7 @@ [ socket := def += typFile += help "socket file to use" , ghcOpts := def += typ "OPTION" += help "ghc options" , cabalOpts := def += typ "OPTION" += help "cabal options"+ , debug := def += help "enable debug output" , path := def += typFile += help "path to target file" , file := def += typFile += argPos 0 += opt "" , line := def += typ "LINE" += argPos 1@@ -191,6 +214,7 @@ , cabalOpts := def += typ "OPTION" += help "cabal options" , symbol := def += typ "SYMBOL" += argPos 0 , files := def += typFile += args+ , debug := def += help "enable debug output" ] += help "List the modules where the given symbol could be found" full :: String -> Annotate Ann
src/CommandLoop.hs view
@@ -7,6 +7,7 @@ , startCommandLoop ) where +import Control.Applicative ((<|>)) import Control.Monad (when) import Data.IORef import Data.List (find, intercalate)@@ -101,7 +102,7 @@ startCommandLoop :: IORef State -> ClientSend -> IO (Maybe CommandObj) -> Config -> Maybe Command -> IO () startCommandLoop state clientSend getNextCommand initialConfig mbInitialCommand = do- continue <- GHC.runGhc (Just GHC.Paths.libdir) $ do+ continue <- GHC.runGhc ghcLibDir $ do configResult <- configSession state clientSend initialConfig case configResult of Left e -> do@@ -119,7 +120,10 @@ -- Exit return () Just (cmd, config) -> startCommandLoop state clientSend getNextCommand config (Just cmd)- where+ where+ ghcLibDir = stackGhcLibDir <$> configStack initialConfig+ <|> Just GHC.Paths.libdir+ processNextCommand :: Bool -> GHC.Ghc (Maybe CommandObj) processNextCommand forceReconfig = do mbNextCmd <- liftIO getNextCommand
src/Main.hs view
@@ -6,7 +6,9 @@ import Data.Traversable (traverse) #endif +import Control.Monad (when) import Data.Maybe (fromMaybe)+import Data.Monoid ((<>)) import System.Directory (getCurrentDirectory) import System.Environment (getProgName) import System.IO (hPutStrLn, stderr)@@ -57,7 +59,11 @@ let argPath = pathArg args dir <- maybe getCurrentDirectory (return . takeDirectory) argPath mCabalFile <- findCabalFile dir >>= traverse absoluteFilePath+ when (debug args) .+ putStrLn $ "Cabal file: " <> show mCabalFile mStackYaml <- findStackYaml dir+ when (debug args) .+ putStrLn $ "Stack file: " <> show mStackYaml let extra = emptyCommandExtra { cePath = argPath , ceGhcOptions = ghcOpts args@@ -67,6 +73,8 @@ } let defaultSocketPath = maybe "" takeDirectory mCabalFile </> defaultSocketFile let sock = fromMaybe defaultSocketPath $ socket args+ when (debug args) .+ putStrLn $ "Socket file: " <> show sock case args of Admin {} -> doAdmin sock args extra Check {} -> doCheck sock args extra@@ -76,12 +84,12 @@ FindSymbol {} -> doFindSymbol sock args extra doAdmin :: FilePath -> HDevTools -> CommandExtra -> IO ()-doAdmin sock args _extra+doAdmin sock args cmdExtra | start_server args =- if noDaemon args then startServer sock Nothing+ if noDaemon args then startServer sock Nothing cmdExtra else do s <- createListenSocket sock- daemonize True $ startServer sock (Just s)+ daemonize True $ startServer sock (Just s) cmdExtra | status args = getServerStatus sock | stop_server args = stopServer sock | otherwise = do
src/Server.hs view
@@ -11,7 +11,7 @@ import System.IO.Error (ioeGetErrorType, isAlreadyInUseError, isDoesNotExistError) import CommandLoop (newCommandLoopState, Config, updateConfig, startCommandLoop)-import Types (ClientDirective(..), Command, emptyCommandExtra, ServerDirective(..))+import Types (ClientDirective(..), Command, CommandExtra(..), ServerDirective(..)) import Util (readMaybe) createListenSocket :: FilePath -> IO Socket@@ -23,8 +23,8 @@ removeFile socketPath listenOn (UnixSocket socketPath) -startServer :: FilePath -> Maybe Socket -> IO ()-startServer socketPath mbSock = do+startServer :: FilePath -> Maybe Socket -> CommandExtra -> IO ()+startServer socketPath mbSock cmdExtra = do case mbSock of Nothing -> bracket (createListenSocket socketPath) cleanup go Just sock -> (go sock) `finally` (cleanup sock)@@ -39,7 +39,7 @@ state <- newCommandLoopState currentClient <- newIORef Nothing configRef <- newIORef Nothing- config <- updateConfig Nothing emptyCommandExtra+ config <- updateConfig Nothing cmdExtra startCommandLoop state (clientSend currentClient) (getNextCommand currentClient sock configRef) config Nothing removeSocketFile :: IO ()
src/Stack.hs view
@@ -6,7 +6,6 @@ , getStackConfig ) where -import Data.Maybe (listToMaybe) import Data.Char (isSpace) #if __GLASGOW_HASKELL__ < 709@@ -25,31 +24,36 @@ data StackConfig = StackConfig { stackYaml :: FilePath , stackDist :: FilePath , stackDbs :: [FilePath]+ , stackGhcBinDir :: FilePath+ , stackGhcLibDir :: FilePath } deriving (Eq, Show) -- | Search for a @stack.yaml@ upwards in given file path tree. findStackYaml :: FilePath -> IO (Maybe FilePath)-findStackYaml p = listToMaybe <$> filterM doesFileExist paths- where- paths = [ d </> "stack.yaml" | d <- pathsToRoot dir]- dir = takeDirectory p+findStackYaml = fmap (fmap trim) . execInPath "stack path --config-location" -- | Run @stack path@ to compute @StackConfig@ getStackConfig :: CommandExtra -> IO (Maybe StackConfig) getStackConfig CommandExtra { ceStackYamlPath = Nothing } = return Nothing getStackConfig CommandExtra { ceStackYamlPath = Just p } = do- dbs <- getStackDbs p- dist <- getStackDist p- return $ StackConfig p <$> dist <*> dbs--pathsToRoot :: FilePath -> [FilePath]-pathsToRoot p- | p == parent = [p]- | otherwise = p : pathsToRoot parent+ dbs <- getStackDbs root+ dist <- getStackDist root+ ghcBinDir <- getStackGhcBinDir root+ ghcLibDir <- getStackGhcLibDir root+ return $ StackConfig p <$> dist+ <*> dbs+ <*> ghcBinDir+ <*> ghcLibDir where- parent = takeDirectory p+ root = takeDirectory p +getStackGhcBinDir :: FilePath -> IO (Maybe FilePath)+getStackGhcBinDir = fmap (fmap trim) . execInPath "stack path --compiler-bin"++getStackGhcLibDir :: FilePath -> IO (Maybe FilePath)+getStackGhcLibDir = fmap (fmap takeDirectory) . execInPath "stack path --global-pkg-db"+ -------------------------------------------------------------------------------- getStackDist :: FilePath -> IO (Maybe FilePath) --------------------------------------------------------------------------------@@ -127,5 +131,5 @@ -- no stack command is in the PATH. Left _ -> Nothing where- prc = (shell cmd) { cwd = Just $ takeDirectory p }+ prc = (shell cmd) { cwd = Just p } #endif