hdevtools 0.1.0.9 → 0.1.1.9
raw patch · 8 files changed
+223/−65 lines, 8 filesdep +process
Dependencies added: process
Files
- hdevtools.cabal +3/−1
- src/Cabal.hs +19/−11
- src/Client.hs +1/−1
- src/CommandArgs.hs +41/−32
- src/CommandLoop.hs +15/−11
- src/Main.hs +23/−7
- src/Stack.hs +117/−0
- src/Types.hs +4/−2
hdevtools.cabal view
@@ -1,5 +1,5 @@ name: hdevtools-version: 0.1.0.9+version: 0.1.1.9 synopsis: Persistent GHC powered background server for FAST haskell development tools description: 'hdevtools' is a backend for text editor plugins, to allow for things such as@@ -55,6 +55,7 @@ Info, Main, Server,+ Stack, Types, Util, Paths_hdevtools@@ -67,6 +68,7 @@ ghc-paths, syb, network,+ process >= 1.2.3.0, time, unix
src/Cabal.hs view
@@ -5,7 +5,7 @@ ) where #ifdef ENABLE_CABAL-+import Stack import Control.Exception (IOException, catch) import Data.Char (isSpace) import Data.List (foldl', nub, sort, find, isPrefixOf, isSuffixOf)@@ -40,6 +40,7 @@ import System.Directory (doesFileExist, getDirectoryContents) import System.FilePath (takeDirectory, splitFileName, (</>)) + componentName :: Component -> ComponentName componentName = foldComponent (const CLibName)@@ -95,22 +96,33 @@ , benchmarkEnabled bm ] #endif +stackifyFlags :: ConfigFlags -> Maybe StackConfig -> ConfigFlags+stackifyFlags cfg Nothing = cfg+stackifyFlags cfg (Just si) = cfg { configDistPref = toFlag dist+ , configPackageDBs = pdbs+ }+ where+ pdbs = [Nothing, Just GlobalPackageDB] ++ pdbs'+ pdbs' = Just . SpecificPackageDB <$> stackDbs si+ dist = stackDist si -getPackageGhcOpts :: FilePath -> IO (Either String [String])-getPackageGhcOpts path = do+-- 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' `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)+ 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 @@ -121,16 +133,13 @@ return $ cfgFlags' { configPackageDBs = [Just sandboxPackageDb] }- localBuildInfo <- configure (genPkgDescr, emptyHookedBuildInfo) cfgFlags- let pkgDescr = localPkgDescr localBuildInfo let baseDir = fst . splitFileName $ path case getGhcVersion localBuildInfo of Nothing -> return $ Left "GHC is not configured"- Just ghcVersion -> do+ Just _ -> do let mbLibName = pkgLibName pkgDescr- let ghcOpts' = foldl' mappend mempty $ map (getComponentGhcOptions localBuildInfo) $ flip allComponentsBy (\c -> c) . localPkgDescr $ localBuildInfo #if __GLASGOW_HASKELL__ >= 709 -- FIX bug in GhcOptions' `mappend`@@ -139,7 +148,6 @@ , ghcOptPackages = overNubListR (filter (\(_, pkgId, _) -> Just (pkgName pkgId) /= mbLibName)) $ (ghcOptPackages ghcOpts') , ghcOptSourcePath = overNubListR (map (baseDir </>)) (ghcOptSourcePath ghcOpts') }- putStrLn "configuring" (ghcInfo,_,_) <- GHC.configure silent Nothing Nothing defaultProgramConfiguration
src/Client.hs view
@@ -18,7 +18,7 @@ connect :: FilePath -> IO Handle connect sock = do- connectTo "" (UnixSocket sock)+ connectTo "" (UnixSocket sock) getServerStatus :: FilePath -> IO () getServerStatus sock = do
src/CommandArgs.hs view
@@ -44,34 +44,37 @@ data HDevTools = Admin- { socket :: Maybe FilePath+ { socket :: Maybe FilePath , start_server :: Bool- , noDaemon :: Bool- , status :: Bool- , stop_server :: Bool+ , noDaemon :: Bool+ , status :: Bool+ , stop_server :: Bool } | Check- { socket :: Maybe FilePath+ { socket :: Maybe FilePath , ghcOpts :: [String]- , file :: String+ , path :: Maybe String+ , file :: String } | ModuleFile- { socket :: Maybe FilePath+ { socket :: Maybe FilePath , ghcOpts :: [String] , module_ :: String } | Info- { socket :: Maybe FilePath- , ghcOpts :: [String]- , file :: String+ { socket :: Maybe FilePath+ , ghcOpts :: [String]+ , path :: Maybe String+ , file :: String , identifier :: String } | Type- { socket :: Maybe FilePath+ { socket :: Maybe FilePath , ghcOpts :: [String]- , file :: String- , line :: Int- , col :: Int+ , path :: Maybe String+ , file :: String+ , line :: Int+ , col :: Int } deriving (Show, Data, Typeable) @@ -86,48 +89,52 @@ dummyCheck :: HDevTools dummyCheck = Check- { socket = Nothing+ { socket = Nothing , ghcOpts = []- , file = ""+ , path = Nothing+ , file = "" } dummyModuleFile :: HDevTools dummyModuleFile = ModuleFile- { socket = Nothing+ { socket = Nothing , ghcOpts = [] , module_ = "" } dummyInfo :: HDevTools dummyInfo = Info- { socket = Nothing- , ghcOpts = []- , file = ""+ { socket = Nothing+ , ghcOpts = []+ , path = Nothing+ , file = "" , identifier = "" } dummyType :: HDevTools dummyType = Type- { socket = Nothing+ { socket = Nothing , ghcOpts = []- , file = ""- , line = 0- , col = 0+ , path = Nothing+ , file = ""+ , line = 0+ , col = 0 } admin :: Annotate Ann admin = record dummyAdmin- [ socket := def += typFile += help "socket file to use"- , 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"+ [ socket := def += typFile += help "socket file to use"+ , 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" ] += help "Interactions with the server" check :: Annotate Ann check = record dummyCheck- [ socket := def += typFile += help "socket file to use"- , ghcOpts := def += typ "OPTION" += help "ghc options"+ [ socket := def += typFile += help "socket file to use"+ , ghcOpts := def += typ "OPTION" += help "ghc options"+ , path := def += typFile += help "path to target file" , file := def += typFile += argPos 0 += opt "" ] += help "Check a haskell source file for errors and warnings" @@ -140,8 +147,9 @@ info :: Annotate Ann info = record dummyInfo- [ socket := def += typFile += help "socket file to use"+ [ socket := def += typFile += help "socket file to use" , ghcOpts := def += typ "OPTION" += help "ghc options"+ , path := def += typFile += help "path to target file" , file := def += typFile += argPos 0 += opt "" , identifier := def += typ "IDENTIFIER" += argPos 1 ] += help "Get info from GHC about the specified identifier"@@ -150,6 +158,7 @@ type_ = record dummyType [ socket := def += typFile += help "socket file to use" , ghcOpts := def += typ "OPTION" += help "ghc options"+ , path := def += typFile += help "path to target file" , file := def += typFile += argPos 0 += opt "" , line := def += typ "LINE" += argPos 1 , col := def += typ "COLUMN" += argPos 2
src/CommandLoop.hs view
@@ -10,7 +10,9 @@ import Control.Monad (when) import Data.IORef import Data.List (find)+#if __GLASGOW_HASKELL__ < 709 import Data.Traversable (traverse)+#endif import MonadUtils (MonadIO, liftIO) import System.Directory (setCurrentDirectory) import System.Exit (ExitCode(ExitFailure, ExitSuccess))@@ -26,6 +28,7 @@ import Types (ClientDirective(..), Command(..), CommandExtra(..)) import Info (getIdentifierInfo, getType) import Cabal (getPackageGhcOpts)+import Stack type ClientSend = ClientDirective -> IO () @@ -54,18 +57,21 @@ data Config = Config { configGhcOpts :: [String]- , configCabal :: Maybe CabalConfig+ , configCabal :: Maybe CabalConfig+ , configStack :: Maybe StackConfig } deriving Eq newConfig :: CommandExtra -> IO Config newConfig cmdExtra = do mbCabalConfig <- traverse mkCabalConfig $ ceCabalConfig cmdExtra- return $ Config { configGhcOpts = ceGhcOptions cmdExtra+ mbStackConfig <- getStackConfig cmdExtra++ return $ Config { configGhcOpts = "-O0" : ceGhcOptions cmdExtra , configCabal = mbCabalConfig+ , configStack = mbStackConfig } - type CommandObj = (Command, Config) withWarnings :: (MonadIO m, Exception.ExceptionMonad m) => IORef State -> Bool -> m a -> m a@@ -132,22 +138,21 @@ return $ Right [] Just cabalConfig -> do liftIO $ setCurrentDirectory . takeDirectory $ cabalConfigPath cabalConfig- liftIO $ getPackageGhcOpts $ cabalConfigPath cabalConfig-+ liftIO $ getPackageGhcOpts (cabalConfigPath cabalConfig) (configStack config) case eCabalGhcOpts of Left e -> return $ Left e Right cabalGhcOpts -> do- let allGhcOpts = cabalGhcOpts ++ (configGhcOpts config)- GHC.gcatch (fmap Right $ updateDynFlags allGhcOpts)+ let allGhcOpts = cabalGhcOpts ++ configGhcOpts config+ GHC.gcatch (Right <$> updateDynFlags allGhcOpts) (fmap Left . handleGhcError) where updateDynFlags :: [String] -> GHC.Ghc () updateDynFlags ghcOpts = do initialDynFlags <- GHC.getSessionDynFlags let updatedDynFlags = initialDynFlags- { GHC.log_action = logAction state clientSend- , GHC.ghcLink = GHC.NoLink- , GHC.hscTarget = GHC.HscInterpreted+ { GHC.log_action = logAction state clientSend+ , GHC.ghcLink = GHC.NoLink+ , GHC.hscTarget = GHC.HscInterpreted } (finalDynFlags, _, _) <- GHC.parseDynamicFlags updatedDynFlags (map GHC.noLoc ghcOpts) _ <- GHC.setSessionDynFlags finalDynFlags@@ -155,7 +160,6 @@ handleGhcError :: GHC.GhcException -> GHC.Ghc String handleGhcError e = return $ GHC.showGhcException e ""- runCommand :: IORef State -> ClientSend -> Command -> GHC.Ghc () runCommand _ clientSend (CmdCheck file) = do
src/Main.hs view
@@ -1,7 +1,12 @@+{-# LANGUAGE CPP #-}+ module Main where +#if __GLASGOW_HASKELL__ < 709+import Data.Traversable (traverse)+#endif+ import Data.Maybe (fromMaybe)-import Data.Traversable (Traversable(..)) import System.Directory (getCurrentDirectory) import System.Environment (getProgName) import System.IO (hPutStrLn, stderr)@@ -15,9 +20,9 @@ import Types (Command(..), CommandExtra(..), emptyCommandExtra) absoluteFilePath :: FilePath -> IO FilePath-absoluteFilePath path = if isAbsolute path then return path else do+absoluteFilePath p = if isAbsolute p then return p else do dir <- getCurrentDirectory- return $ dir </> path+ return $ dir </> p defaultSocketFile :: FilePath@@ -31,20 +36,31 @@ fileArg args@(Info {}) = Just $ file args fileArg args@(Type {}) = Just $ file args +pathArg' :: HDevTools -> Maybe String+pathArg' (Admin {}) = Nothing+pathArg' (ModuleFile {}) = Nothing+pathArg' args@(Check {}) = path args+pathArg' args@(Info {}) = path args+pathArg' args@(Type {}) = path args +pathArg :: HDevTools -> Maybe String+pathArg args = case pathArg' args of+ Just x -> Just x+ Nothing -> fileArg args+ main :: IO () main = do args <- loadHDevTools- dir <- maybe getCurrentDirectory (return . takeDirectory) $ fileArg args+ let argPath = pathArg args+ dir <- maybe getCurrentDirectory (return . takeDirectory) argPath mCabalFile <- findCabalFile dir >>= traverse absoluteFilePath let extra = emptyCommandExtra- { ceGhcOptions = ghcOpts args+ { ceGhcOptions = ghcOpts args , ceCabalConfig = mCabalFile+ , cePath = argPath }- let defaultSocketPath = maybe "" takeDirectory mCabalFile </> defaultSocketFile let sock = fromMaybe defaultSocketPath $ socket args- case args of Admin {} -> doAdmin sock args extra Check {} -> doCheck sock args extra
+ src/Stack.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE CPP #-}+module Stack+ ( -- * The bits of information needed from `stack`+ StackConfig (..)+ -- * Run `stack exec` to compute @StackConfig@+ , getStackConfig+ ) where++import Data.Maybe (listToMaybe)+import Data.Char (isSpace)+#if __GLASGOW_HASKELL__ < 709+import Control.Applicative((<$>), (<*>))+#endif+import System.Process+import System.FilePath+import System.Directory+import Control.Monad (filterM)+import Control.Exception+import Types++-- | This module adds support for `stack`, as follows:+-- 1. Figure out if the target-file is in a stack project,+-- 2. If `stack` in available in PATH, run `stack exec` to extract+-- `StackConfig`+-- 3. The `StackConfig` is used to suitably alter the cabal ConfigFlags in+-- Cabal.hs+++-- TODO: Move into Types?+data StackConfig = StackConfig { stackDist :: FilePath+ , stackDbs :: [FilePath]+ }+ deriving (Eq, Show)++--------------------------------------------------------------------------------+getStackConfig :: CommandExtra -> IO (Maybe StackConfig)+--------------------------------------------------------------------------------+getStackConfig ce = case cePath ce of+ Nothing -> return Nothing+ Just p -> getStackConfig' p++getStackConfig' :: FilePath -> IO (Maybe StackConfig)+getStackConfig' p = do+ mbYaml <- getStackYaml p+ case mbYaml of+ Nothing -> return Nothing+ Just _ -> do mdbs <- getStackDbs p+ mdst <- getStackDist p+ return $ StackConfig <$> mdst <*> mdbs++--------------------------------------------------------------------------------+getStackYaml :: FilePath -> IO (Maybe FilePath)+--------------------------------------------------------------------------------+getStackYaml p = listToMaybe <$> filterM doesFileExist paths+ where+ paths = [ d </> "stack.yaml" | d <- pathsToRoot dir]+ dir = takeDirectory p++pathsToRoot :: FilePath -> [FilePath]+pathsToRoot p+ | p == parent = [p]+ | otherwise = p : pathsToRoot parent+ where+ parent = takeDirectory p++--------------------------------------------------------------------------------+getStackDist :: FilePath -> IO (Maybe FilePath)+--------------------------------------------------------------------------------+getStackDist p = (trim <$>) <$> execInPath cmd p+ where+ cmd = "stack path --dist-dir"+ -- dir = takeDirectory p+ -- splice = (dir </>) . trim++--------------------------------------------------------------------------------+getStackDbs :: FilePath -> IO (Maybe [FilePath])+--------------------------------------------------------------------------------+getStackDbs p = do mpp <- execInPath cmd p+ case mpp of+ Just pp -> Just <$> extractDbs pp+ Nothing -> return Nothing+ where+ cmd = "stack --verbosity quiet exec printenv GHC_PACKAGE_PATH"++extractDbs :: String -> IO [FilePath]+extractDbs = filterM doesDirectoryExist . stringPaths++stringPaths :: String -> [String]+stringPaths = splitBy ':' . trim++--------------------------------------------------------------------------------+-- | Generic Helpers+--------------------------------------------------------------------------------++splitBy :: Char -> String -> [String]+splitBy c str+ | null str' = [x]+ | otherwise = x : splitBy c (tail str')+ where+ (x, str') = span (c /=) str++trim :: String -> String+trim = f . f+ where+ f = reverse . dropWhile isSpace++execInPath :: String -> FilePath -> IO (Maybe String)+execInPath cmd p = do+ eIOEstr <- (try $ readCreateProcess prc "" :: IO (Either IOError String))+ return $ case eIOEstr of+ Right s -> Just s+ -- This error is most likely "/bin/sh: stack: command not found"+ -- which is caused by the package containing a stack.yaml file but+ -- no stack command is in the PATH.+ Left _ -> Nothing+ where+ prc = (shell cmd) { cwd = Just $ takeDirectory p }
src/Types.hs view
@@ -9,13 +9,15 @@ import System.Exit (ExitCode) data CommandExtra = CommandExtra- { ceGhcOptions :: [String]+ { ceGhcOptions :: [String] , ceCabalConfig :: Maybe FilePath+ , cePath :: Maybe FilePath } deriving (Read, Show) emptyCommandExtra :: CommandExtra-emptyCommandExtra = CommandExtra { ceGhcOptions = []+emptyCommandExtra = CommandExtra { ceGhcOptions = [] , ceCabalConfig = Nothing+ , cePath = Nothing } data ServerDirective