diff --git a/hdevtools.cabal b/hdevtools.cabal --- a/hdevtools.cabal +++ b/hdevtools.cabal @@ -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 diff --git a/src/Cabal.hs b/src/Cabal.hs --- a/src/Cabal.hs +++ b/src/Cabal.hs @@ -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 diff --git a/src/Client.hs b/src/Client.hs --- a/src/Client.hs +++ b/src/Client.hs @@ -18,7 +18,7 @@ connect :: FilePath -> IO Handle connect sock = do - connectTo "" (UnixSocket sock) + connectTo "" (UnixSocket sock) getServerStatus :: FilePath -> IO () getServerStatus sock = do diff --git a/src/CommandArgs.hs b/src/CommandArgs.hs --- a/src/CommandArgs.hs +++ b/src/CommandArgs.hs @@ -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 diff --git a/src/CommandLoop.hs b/src/CommandLoop.hs --- a/src/CommandLoop.hs +++ b/src/CommandLoop.hs @@ -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 diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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 diff --git a/src/Stack.hs b/src/Stack.hs new file mode 100644 --- /dev/null +++ b/src/Stack.hs @@ -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 } diff --git a/src/Types.hs b/src/Types.hs --- a/src/Types.hs +++ b/src/Types.hs @@ -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