diff --git a/.gitignore b/.gitignore index 178135c..010ea12 100644 --- a/.gitignore +++ b/.gitignore @@ -1 +1,5 @@ /dist/ +.cabal-sandbox +cabal.sandbox.config +*.sw[a-z] +.stack-work/ diff --git a/README.md b/README.md index 04eff45..d175c28 100644 --- a/README.md +++ b/README.md @@ -1,8 +1,11 @@ hdevtools ========= +This project is active at https://github.com/hdevtools/hdevtools. Please visit +that repo! Persistent GHC powered background server for FAST Haskell development tools + About ----- @@ -72,6 +75,14 @@ details. [Flycheck][5] is a modern batteries-included syntax checker for Emacs, and there is a [flycheck-hdevtools][6] checker available. + +### Atom - [linter][8] ### + +There are *two* packages for the [Atom](https://atom.io) editor: + ++ [linter-hdevtools][8] quickly finds and underlines type errors in Haskell files, ++ [hover-tooltips-hdevtools][9] displays the types of identifiers under the mouse. + ### Manual Editor Integration for any Editor ### Most editors allow you to run a `make` command, and will then parse the output @@ -137,6 +148,16 @@ background process, not your current directory. This can cause problems, and therefore it is recommended that you leave the socket file as the default, and always run `hdevtools` from the same directory. +You can specify the path to a target file with the `--path` option. This is +useful for integration with IDEs that submit a *copy* of the original source +file (in a temporary directory) to `hdevtools` making it impossible to extract +the `.cabal` information for the file's project. In such cases, you can run as: + + $ hdevtools check -p /path/to/file.hs /tmp/file.hs + +and `hdevtools` will use the given path to obtain the `.cabal` information. + + ### Specifying GHC Options ### For most non-trivial projects, you will need to tell `hdevtools` about @@ -173,8 +194,7 @@ would pass to GHCi. Credits ------- -`hdevtools` was inspired by [ghcmod][4], but has the advantage that due to its -client-server architecture it is much faster. +`hdevtools` was inspired by [ghcmod][4]. [1]: http://hackage.haskell.org/package/hdevtools [2]: https://github.com/scrooloose/syntastic @@ -182,3 +202,6 @@ client-server architecture it is much faster. [4]: http://www.mew.org/~kazu/proj/ghc-mod/en/ [5]: https://github.com/flycheck/flycheck [6]: https://github.com/flycheck/flycheck-hdevtools +[7]: https://atom.io +[8]: https://atom.io/packages/linter-hdevtools +[9]: https://atom.io/packages/hover-tooltips-hdevtools diff --git a/hdevtools.cabal b/hdevtools.cabal index 2c34b96..625f838 100644 --- a/hdevtools.cabal +++ b/hdevtools.cabal @@ -1,5 +1,5 @@ name: hdevtools -version: 0.1.0.5 +version: 0.1.2.1 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 @@ -30,39 +30,60 @@ description: license: MIT license-file: LICENSE author: Bit Connor -maintainer: mutantlemon@gmail.com +maintainer: schell.scivally@synapsegroup.com copyright: See AUTHORS file category: Development -homepage: https://github.com/bitc/hdevtools/ -bug-reports: https://github.com/bitc/hdevtools/issues/ +homepage: https://github.com/schell/hdevtools/ +bug-reports: https://github.com/schell/hdevtools/issues/ build-type: Simple cabal-version: >=1.8 source-repository head type: git - location: git://github.com/bitc/hdevtools.git + location: git://github.com/schell/hdevtools.git executable hdevtools hs-source-dirs: src ghc-options: -Wall cpp-options: -DCABAL main-is: Main.hs - other-modules: Client, + other-modules: Cabal, + Client, CommandArgs, CommandLoop, Daemonize, + FindSymbol, Info, Main, Server, + Stack, Types, Util, Paths_hdevtools + build-depends: base == 4.*, cmdargs, directory, + filepath, ghc >= 7.2, ghc-paths, syb, network, + process, time, + transformers, unix + + if impl(ghc == 7.6.*) + build-depends: Cabal == 1.16.* + cpp-options: -DENABLE_CABAL + + if impl(ghc >= 7.7) + build-depends: Cabal >= 1.18 + cpp-options: -DENABLE_CABAL + + if impl(ghc >= 7.9) + build-depends: Cabal >= 1.22, + bin-package-db + + cpp-options: -DENABLE_CABAL diff --git a/src/Cabal.hs b/src/Cabal.hs new file mode 100644 index 0000000..427dd5c --- /dev/null +++ b/src/Cabal.hs @@ -0,0 +1,252 @@ +{-# LANGUAGE CPP #-} +module Cabal + ( getPackageGhcOpts + , findCabalFile + ) where + +#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 +import Control.Applicative ((<$>)) +import Data.Monoid (Monoid(..)) +#endif +import Distribution.Package (PackageIdentifier(..), PackageName) +import Distribution.PackageDescription (PackageDescription(..), Executable(..), TestSuite(..), Benchmark(..), emptyHookedBuildInfo, buildable, libBuildInfo) +import Distribution.PackageDescription.Parse (readPackageDescription) +import Distribution.Simple.Configure (configure) +import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..), ComponentLocalBuildInfo(..), + Component(..), ComponentName(..), +#if __GLASGOW_HASKELL__ < 707 + allComponentsBy, +#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, configureCommand, toFlag) +#if __GLASGOW_HASKELL__ >= 709 +import Distribution.Utils.NubList +import qualified Distribution.Simple.GHC as GHC(configure) +#endif +import Distribution.Verbosity (silent) +import Distribution.Version (Version(..)) + +import System.IO.Error (ioeGetErrorString) +import System.Directory (doesFileExist, getDirectoryContents) +import System.FilePath (takeDirectory, splitFileName, ()) + + +componentName :: Component -> ComponentName +componentName = + foldComponent (const CLibName) + (CExeName . exeName) + (CTestName . testName) + (CBenchName . benchmarkName) + +getComponentLocalBuildInfo :: LocalBuildInfo -> ComponentName -> ComponentLocalBuildInfo +#if __GLASGOW_HASKELL__ >= 707 +getComponentLocalBuildInfo lbi cname = getLocalBuildInfo cname $ componentsConfigs lbi + where getLocalBuildInfo cname' ((cname'', clbi, _):cfgs) = + if cname' == cname'' then clbi else getLocalBuildInfo cname' cfgs + getLocalBuildInfo _ [] = error $ "internal error: missing config" +#else +getComponentLocalBuildInfo lbi CLibName = + case libraryConfig lbi of + Nothing -> error $ "internal error: missing library config" + Just clbi -> clbi +getComponentLocalBuildInfo lbi (CExeName name) = + case lookup name (executableConfigs lbi) of + Nothing -> error $ "internal error: missing config for executable " ++ name + Just clbi -> clbi +getComponentLocalBuildInfo lbi (CTestName name) = + case lookup name (testSuiteConfigs lbi) of + Nothing -> error $ "internal error: missing config for test suite " ++ name + Just clbi -> clbi +getComponentLocalBuildInfo lbi (CBenchName name) = + case lookup name (testSuiteConfigs lbi) of + Nothing -> error $ "internal error: missing config for benchmark " ++ name + Just clbi -> clbi +#endif + +#if __GLASGOW_HASKELL__ >= 707 +-- TODO: Fix callsites so we don't need `allComponentsBy`. It was taken from +-- http://hackage.haskell.org/package/Cabal-1.16.0.3/docs/src/Distribution-Simple-LocalBuildInfo.html#allComponentsBy +-- since it doesn't exist in Cabal 1.18.* +-- +-- | Obtains all components (libs, exes, or test suites), transformed by the +-- given function. Useful for gathering dependencies with component context. +allComponentsBy :: PackageDescription + -> (Component -> a) + -> [a] +allComponentsBy pkg_descr f = + [ f (CLib lib) | Just lib <- [library pkg_descr] + , buildable (libBuildInfo lib) ] + ++ [ f (CExe exe) | exe <- executables pkg_descr + , buildable (buildInfo exe) ] + ++ [ f (CTest tst) | tst <- testSuites pkg_descr + , buildable (testBuildInfo tst) + , testEnabled tst ] + ++ [ f (CBench bm) | bm <- benchmarks pkg_descr + , buildable (benchmarkBuildInfo bm) + , 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 + +-- 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 -> [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 + distDir <- getDistDir + + let programCfg = defaultProgramConfiguration + let initCfgFlags = (defaultConfigFlags programCfg) + { configDistPref = toFlag distDir + -- TODO: figure out how to find out this flag + , configUserInstall = toFlag True + + -- configure with --enable-tests to include test dependencies/modules + , configTests = toFlag True + + -- configure with --enable-benchmarks to include benchmark dependencies/modules + , configBenchmarks = 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 + case getGhcVersion localBuildInfo of + Nothing -> return $ Left "GHC is not configured" + +#if __GLASGOW_HASKELL__ >= 709 + Just _ -> do + let mbLibName = pkgLibName pkgDescr + let ghcOpts' = foldl' mappend mempty $ map (getComponentGhcOptions localBuildInfo) $ flip allComponentsBy (\c -> c) . localPkgDescr $ localBuildInfo + -- FIX bug in GhcOptions' `mappend` + ghcOpts = ghcOpts' { ghcOptExtra = overNubListR (filter (/= "-Werror")) $ ghcOptExtra ghcOpts' + , ghcOptPackageDBs = sort $ nub (ghcOptPackageDBs ghcOpts') + , 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 + + return $ Right $ renderGhcOptions ghcInfo ghcOpts +#else + Just ghcVersion -> do + let mbLibName = pkgLibName pkgDescr + let ghcOpts' = foldl' mappend mempty $ map (getComponentGhcOptions localBuildInfo) $ flip allComponentsBy (\c -> c) . localPkgDescr $ localBuildInfo + + ghcOpts = ghcOpts' { ghcOptExtra = filter (/= "-Werror") $ nub $ ghcOptExtra ghcOpts' + , ghcOptPackages = filter (\(_, pkgId) -> Just (pkgName pkgId) /= mbLibName) $ nub (ghcOptPackages ghcOpts') + , ghcOptSourcePath = map (baseDir ) (ghcOptSourcePath ghcOpts') + } + return $ Right $ renderGhcOptions ghcVersion ghcOpts +#endif + + -- returns the right 'dist' directory in the case of a sandbox + getDistDir = do + let dir = takeDirectory path "dist" + contents <- getDirectoryContents dir + return $ case find ("dist-sandbox-" `isPrefixOf`) contents of + Just sbdir -> dir sbdir + Nothing -> dir + +pkgLibName :: PackageDescription -> Maybe PackageName +pkgLibName pkgDescr = if hasLibrary pkgDescr + then Just $ pkgName . package $ pkgDescr + else Nothing + +hasLibrary :: PackageDescription -> Bool +hasLibrary = maybe False (\_ -> True) . library + +getComponentGhcOptions :: LocalBuildInfo -> Component -> GhcOptions +getComponentGhcOptions lbi comp = + componentGhcOptions silent lbi bi clbi (buildDir lbi) + + where bi = componentBuildInfo comp + clbi = getComponentLocalBuildInfo lbi (componentName comp) + +getGhcVersion :: LocalBuildInfo -> Maybe Version +getGhcVersion lbi = let db = withPrograms lbi + in do ghc <- lookupProgram (simpleProgram "ghc") db + programVersion ghc + +getSandboxPackageDB :: FilePath -> IO PackageDB +getSandboxPackageDB sandboxPath = do + contents <- readFile sandboxPath + return $ SpecificPackageDB $ extractValue . parse $ contents + where + pkgDbKey = "package-db:" + parse = head . filter (pkgDbKey `isPrefixOf`) . lines + extractValue = fst . break isSpace . dropWhile isSpace . drop (length pkgDbKey) + + +findCabalFile :: FilePath -> IO (Maybe FilePath) +findCabalFile dir = do + allFiles <- getDirectoryContents dir + let mbCabalFile = find (isCabalFile) allFiles + case mbCabalFile of + Just cabalFile -> return $ Just $ dir cabalFile + Nothing -> + let parentDir = takeDirectory dir + in if parentDir == dir + then return Nothing + else findCabalFile parentDir + + where + + isCabalFile :: FilePath -> Bool + isCabalFile path = cabalExtension `isSuffixOf` path + && length path > length cabalExtension + where cabalExtension = ".cabal" + +# else + +getPackageGhcOpts :: FilePath -> [String] -> IO (Either String [String]) +getPackageGhcOpts _ _ = return $ Right [] + +findCabalFile :: FilePath -> IO (Maybe FilePath) +findCabalFile _ = return Nothing + +#endif diff --git a/src/Client.hs b/src/Client.hs index 71c14b8..c2268d4 100644 --- a/src/Client.hs +++ b/src/Client.hs @@ -13,12 +13,12 @@ import System.IO.Error (isDoesNotExistError) import Daemonize (daemonize) import Server (createListenSocket, startServer) -import Types (ClientDirective(..), Command(..), ServerDirective(..)) +import Types (ClientDirective(..), Command(..), CommandExtra(..), ServerDirective(..)) import Util (readMaybe) connect :: FilePath -> IO Handle connect sock = do - connectTo "" (UnixSocket sock) + connectTo "" (UnixSocket sock) getServerStatus :: FilePath -> IO () getServerStatus sock = do @@ -34,18 +34,18 @@ stopServer sock = do hFlush h startClientReadLoop h -serverCommand :: FilePath -> Command -> [String] -> IO () -serverCommand sock cmd ghcOpts = do +serverCommand :: FilePath -> Command -> CommandExtra -> IO () +serverCommand sock cmd cmdExtra = do r <- tryJust (guard . isDoesNotExistError) (connect sock) case r of Right h -> do - hPutStrLn h $ show (SrvCommand cmd ghcOpts) + hPutStrLn h $ show (SrvCommand cmd cmdExtra) hFlush h startClientReadLoop h Left _ -> do s <- createListenSocket sock daemonize False $ startServer sock (Just s) - serverCommand sock cmd ghcOpts + serverCommand sock cmd cmdExtra startClientReadLoop :: Handle -> IO () startClientReadLoop h = do diff --git a/src/CommandArgs.hs b/src/CommandArgs.hs index 2149b29..f026faf 100644 --- a/src/CommandArgs.hs +++ b/src/CommandArgs.hs @@ -24,113 +24,174 @@ programVersion = "unknown-version (not built with cabal)" #endif +cabalVersion :: String +cabalVersion = +#ifdef ENABLE_CABAL + "cabal-" ++ VERSION_Cabal +#else + "no cabal support" +#endif + fullVersion :: String fullVersion = concat [ programVersion - , " (ghc-", Config.cProjectVersion, "-", arch, "-", os, ")" + , " (" + , "ghc-", Config.cProjectVersion, "-", arch, "-", os + , ", ", cabalVersion + , ")" ] 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 + , cabalOpts :: [String] + , path :: Maybe String + , file :: String + , json :: Bool } | ModuleFile - { socket :: Maybe FilePath + { socket :: Maybe FilePath , ghcOpts :: [String] + , cabalOpts :: [String] , module_ :: String } | Info - { socket :: Maybe FilePath - , ghcOpts :: [String] - , file :: String + { 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 + , col :: Int + } + | FindSymbol { socket :: Maybe FilePath , ghcOpts :: [String] - , file :: String - , line :: Int - , col :: Int + , cabalOpts :: [String] + , symbol :: String + , files :: [String] } deriving (Show, Data, Typeable) dummyAdmin :: HDevTools dummyAdmin = Admin - { socket = Nothing + { socket = Nothing , start_server = False - , noDaemon = False - , status = False - , stop_server = False + , noDaemon = False + , status = False + , stop_server = False } dummyCheck :: HDevTools dummyCheck = Check - { socket = Nothing + { socket = Nothing , ghcOpts = [] - , file = "" + , cabalOpts = [] + , path = Nothing + , file = "" + , json = False } dummyModuleFile :: HDevTools dummyModuleFile = ModuleFile - { socket = Nothing + { socket = Nothing , ghcOpts = [] + , cabalOpts = [] , module_ = "" } dummyInfo :: HDevTools dummyInfo = Info - { socket = Nothing - , ghcOpts = [] - , file = "" + { socket = Nothing + , ghcOpts = [] + , cabalOpts = [] + , path = Nothing + , file = "" , identifier = "" } dummyType :: HDevTools dummyType = Type + { socket = Nothing + , ghcOpts = [] + , cabalOpts = [] + , path = Nothing + , file = "" + , line = 0 + , col = 0 + } + +dummyFindSymbol :: HDevTools +dummyFindSymbol = FindSymbol { socket = Nothing , ghcOpts = [] - , file = "" - , line = 0 - , col = 0 + , cabalOpts = [] + , symbol = "" + , files = [] } 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" +#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 "" + , json := def += help "render output as JSON" ] += help "Check a haskell source file for errors and warnings" 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" + [ 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 ] += help "Get info from GHC about the specified identifier" @@ -139,13 +200,32 @@ 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 , col := def += typ "COLUMN" += argPos 2 ] += help "Get the type of the expression at the specified line and column" +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" + full :: String -> Annotate Ann -full progName = modes_ [admin += auto, check, moduleFile, info, type_] +full progName = modes_ [admin += auto, check, moduleFile, info, type_, findSymbol] += helpArg [name "h", groupname "Help"] += versionArg [groupname "Help"] += program progName diff --git a/src/CommandLoop.hs b/src/CommandLoop.hs index 1a62ca3..3d044a2 100644 --- a/src/CommandLoop.hs +++ b/src/CommandLoop.hs @@ -1,24 +1,36 @@ {-# LANGUAGE CPP #-} module CommandLoop ( newCommandLoopState + , Config(..) + , CabalConfig(..) + , newConfig , startCommandLoop ) where import Control.Monad (when) import Data.IORef -import Data.List (find) +import Data.List (find, intercalate) +#if __GLASGOW_HASKELL__ < 709 +import Control.Applicative ((<$>)) +import Data.Traversable (traverse) +#endif import MonadUtils (MonadIO, liftIO) +import System.Directory (setCurrentDirectory) import System.Exit (ExitCode(ExitFailure, ExitSuccess)) +import System.FilePath (takeDirectory) import qualified ErrUtils import qualified Exception (ExceptionMonad) import qualified GHC import qualified GHC.Paths import qualified Outputable +import System.Posix.Types (EpochTime) +import System.Posix.Files (getFileStatus, modificationTime) -import Types (ClientDirective(..), Command(..)) +import Types (ClientDirective(..), Command(..), CommandExtra(..)) import Info (getIdentifierInfo, getType) - -type CommandObj = (Command, [String]) +import FindSymbol (findSymbol) +import Cabal (getPackageGhcOpts) +import Stack type ClientSend = ClientDirective -> IO () @@ -32,6 +44,40 @@ newCommandLoopState = do { stateWarningsEnabled = True } +data CabalConfig = CabalConfig + { cabalConfigPath :: FilePath + , cabalConfigOpts :: [String] + , cabalConfigLastUpdatedAt :: EpochTime + } + deriving Eq + +mkCabalConfig :: FilePath -> [String] -> IO CabalConfig +mkCabalConfig path opts = do + fileStatus <- getFileStatus path + return $ CabalConfig { cabalConfigPath = path + , cabalConfigOpts = opts + , cabalConfigLastUpdatedAt = modificationTime fileStatus + } + +data Config = Config + { configGhcOpts :: [String] + , configCabal :: Maybe CabalConfig + , configStack :: Maybe StackConfig + } + deriving Eq + +newConfig :: CommandExtra -> IO Config +newConfig cmdExtra = do + mbCabalConfig <- traverse (\path -> mkCabalConfig path (ceCabalOptions cmdExtra)) $ ceCabalConfig 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 withWarnings state warningsValue action = do beforeState <- liftIO $ getWarnings @@ -44,22 +90,26 @@ withWarnings state warningsValue action = do setWarnings :: Bool -> IO () setWarnings val = modifyIORef state $ \s -> s { stateWarningsEnabled = val } -startCommandLoop :: IORef State -> ClientSend -> IO (Maybe CommandObj) -> [String] -> Maybe Command -> IO () -startCommandLoop state clientSend getNextCommand initialGhcOpts mbInitial = do +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 - configOk <- GHC.gcatch (configSession state clientSend initialGhcOpts >> return True) - handleConfigError - if configOk - then do - doMaybe mbInitial $ \cmd -> sendErrors (runCommand state clientSend cmd) - processNextCommand False - else processNextCommand True + configResult <- configSession state clientSend initialConfig + case configResult of + Left e -> do + liftIO $ mapM_ clientSend + [ ClientStderr e + , ClientExit (ExitFailure 1) + ] + processNextCommand True + Right _ -> do + doMaybe mbInitialCommand $ \cmd -> sendErrors (runCommand state clientSend cmd) + processNextCommand False case continue of Nothing -> -- Exit return () - Just (cmd, ghcOpts) -> startCommandLoop state clientSend getNextCommand ghcOpts (Just cmd) + Just (cmd, config) -> startCommandLoop state clientSend getNextCommand config (Just cmd) where processNextCommand :: Bool -> GHC.Ghc (Maybe CommandObj) processNextCommand forceReconfig = do @@ -68,37 +118,52 @@ startCommandLoop state clientSend getNextCommand initialGhcOpts mbInitial = do Nothing -> -- Exit return Nothing - Just (cmd, ghcOpts) -> - if forceReconfig || (ghcOpts /= initialGhcOpts) - then return (Just (cmd, ghcOpts)) + Just (cmd, config) -> + if forceReconfig || (config /= initialConfig) + then return (Just (cmd, config)) else sendErrors (runCommand state clientSend cmd) >> processNextCommand False sendErrors :: GHC.Ghc () -> GHC.Ghc () - sendErrors action = GHC.gcatch action (\x -> handleConfigError x >> return ()) - - handleConfigError :: GHC.GhcException -> GHC.Ghc Bool - handleConfigError e = do + sendErrors action = GHC.gcatch action $ \e -> do liftIO $ mapM_ clientSend - [ ClientStderr (GHC.showGhcException e "") + [ ClientStderr $ GHC.showGhcException e "" , ClientExit (ExitFailure 1) ] - return False + return () doMaybe :: Monad m => Maybe a -> (a -> m ()) -> m () doMaybe Nothing _ = return () doMaybe (Just x) f = f x -configSession :: IORef State -> ClientSend -> [String] -> GHC.Ghc () -configSession state clientSend ghcOpts = do - initialDynFlags <- GHC.getSessionDynFlags - let updatedDynFlags = initialDynFlags - { 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 - return () +configSession :: IORef State -> ClientSend -> Config -> GHC.Ghc (Either String ()) +configSession state clientSend config = do + eCabalGhcOpts <- case configCabal config of + Nothing -> + return $ Right [] + Just cabalConfig -> do + liftIO $ setCurrentDirectory . takeDirectory $ cabalConfigPath cabalConfig + liftIO $ getPackageGhcOpts (cabalConfigPath cabalConfig) (configStack config) (cabalConfigOpts cabalConfig) + case eCabalGhcOpts of + Left e -> return $ Left e + Right cabalGhcOpts -> do + 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 + } + (finalDynFlags, _, _) <- GHC.parseDynamicFlags updatedDynFlags (map GHC.noLoc ghcOpts) + _ <- GHC.setSessionDynFlags finalDynFlags + return () + + handleGhcError :: GHC.GhcException -> GHC.Ghc String + handleGhcError e = return $ GHC.showGhcException e "" runCommand :: IORef State -> ClientSend -> Command -> GHC.Ghc () runCommand _ clientSend (CmdCheck file) = do @@ -168,6 +233,21 @@ runCommand state clientSend (CmdType file (line, col)) = do , show endCol , " " , "\"", t, "\"" ] +runCommand state clientSend (CmdFindSymbol symbol files) = do + result <- withWarnings state False $ findSymbol symbol files + case result of + [] -> liftIO $ mapM_ clientSend + [ ClientStderr $ "Couldn't find modules containing '" ++ symbol ++ "'" + , ClientExit (ExitFailure 1) + ] + modules -> liftIO $ mapM_ clientSend + [ ClientStdout (formatModules modules) + , ClientExit ExitSuccess + ] + where + formatModules = intercalate "\n" + + #if __GLASGOW_HASKELL__ >= 706 logAction :: IORef State -> ClientSend -> GHC.DynFlags -> GHC.Severity -> GHC.SrcSpan -> Outputable.PprStyle -> ErrUtils.MsgDoc -> IO () diff --git a/src/FindSymbol.hs b/src/FindSymbol.hs new file mode 100644 index 0000000..ea9b051 --- /dev/null +++ b/src/FindSymbol.hs @@ -0,0 +1,99 @@ +{-# Language ScopedTypeVariables, CPP #-} + +module FindSymbol + ( findSymbol + ) where + +#if __GLASGOW_HASKELL__ < 710 +import Control.Applicative ((<$>)) +import qualified UniqFM +#else +import GHC.PackageDb (exposedName) +import GhcMonad (liftIO) +#endif + +import Control.Monad (filterM) +import Control.Exception +import Data.List (find, nub) +import Data.Maybe (catMaybes, isJust) +import qualified GHC +import qualified Packages as PKG +import qualified Name +import Exception (ghandle) + +type SymbolName = String +type ModuleName = String + +findSymbol :: SymbolName -> [FilePath] -> GHC.Ghc [ModuleName] +findSymbol symbol files = do + -- for the findsymbol command GHC shouldn't output any warnings + -- or errors to stdout for the loaded source files, we're only + -- interested in the module graph of the loaded targets + dynFlags <- GHC.getSessionDynFlags + _ <- GHC.setSessionDynFlags dynFlags { GHC.log_action = \_ _ _ _ _ -> return () } + + fileMods <- concat <$> mapM (findSymbolInFile symbol) files + + -- reset the old log_action + _ <- GHC.setSessionDynFlags dynFlags + + pkgsMods <- findSymbolInPackages symbol + return . nub . map (GHC.moduleNameString . GHC.moduleName) $ fileMods ++ pkgsMods + + +findSymbolInFile :: SymbolName -> FilePath -> GHC.Ghc [GHC.Module] +findSymbolInFile symbol file = do + loadFile + filterM (containsSymbol symbol) =<< fileModules + where + loadFile = do + let noPhase = Nothing + target <- GHC.guessTarget file noPhase + GHC.setTargets [target] + let handler err = GHC.printException err >> return GHC.Failed + _ <- GHC.handleSourceError handler (GHC.load GHC.LoadAllTargets) + return () + + fileModules = map GHC.ms_mod <$> GHC.getModuleGraph + + +findSymbolInPackages :: SymbolName -> GHC.Ghc [GHC.Module] +findSymbolInPackages symbol = + filterM (containsSymbol symbol) =<< allExposedModules + where + allExposedModules :: GHC.Ghc [GHC.Module] + allExposedModules = do + modNames <- exposedModuleNames + catMaybes <$> mapM findModule modNames + where + exposedModuleNames :: GHC.Ghc [GHC.ModuleName] +#if __GLASGOW_HASKELL__ < 710 + exposedModuleNames = + concatMap exposedModules + . UniqFM.eltsUFM + . PKG.pkgIdMap + . GHC.pkgState + <$> GHC.getSessionDynFlags +#else + exposedModuleNames = do + dynFlags <- GHC.getSessionDynFlags + pkgConfigs <- liftIO $ PKG.readPackageConfigs dynFlags + return $ map exposedName (concatMap exposedModules pkgConfigs) +#endif + + exposedModules pkg = if PKG.exposed pkg then PKG.exposedModules pkg else [] + + findModule :: GHC.ModuleName -> GHC.Ghc (Maybe GHC.Module) + findModule moduleName = + ghandle (\(_ :: SomeException) -> return Nothing) + (Just <$> GHC.findModule moduleName Nothing) + + +containsSymbol :: SymbolName -> GHC.Module -> GHC.Ghc Bool +containsSymbol symbol module_ = + isJust . find (== symbol) <$> allExportedSymbols + where + allExportedSymbols = + ghandle (\(_ :: SomeException) -> return []) + (do info <- GHC.getModuleInfo module_ + return $ maybe [] (map Name.getOccString . GHC.modInfoExports) info) diff --git a/src/Info.hs b/src/Info.hs index b9dedb5..289a711 100644 --- a/src/Info.hs +++ b/src/Info.hs @@ -16,6 +16,11 @@ import qualified Desugar #if __GLASGOW_HASKELL__ >= 706 import qualified DynFlags #endif +#if __GLASGOW_HASKELL__ >= 708 +import qualified HsExpr +#else +import qualified TcRnTypes +#endif import qualified GHC import qualified HscTypes import qualified NameSet @@ -23,7 +28,6 @@ import qualified Outputable import qualified PprTyThing import qualified Pretty import qualified TcHsSyn -import qualified TcRnTypes getIdentifierInfo :: FilePath -> String -> GHC.Ghc (Either String String) getIdentifierInfo file identifier = @@ -127,21 +131,32 @@ getSrcSpan (GHC.RealSrcSpan spn) = getSrcSpan _ = Nothing getTypeLHsBind :: GHC.TypecheckedModule -> GHC.LHsBind GHC.Id -> GHC.Ghc (Maybe (GHC.SrcSpan, GHC.Type)) +#if __GLASGOW_HASKELL__ >= 708 +getTypeLHsBind _ (GHC.L spn GHC.FunBind{GHC.fun_matches = grp}) = return $ Just (spn, HsExpr.mg_res_ty grp) +#else getTypeLHsBind _ (GHC.L spn GHC.FunBind{GHC.fun_matches = GHC.MatchGroup _ typ}) = return $ Just (spn, typ) +#endif getTypeLHsBind _ _ = return Nothing getTypeLHsExpr :: GHC.TypecheckedModule -> GHC.LHsExpr GHC.Id -> GHC.Ghc (Maybe (GHC.SrcSpan, GHC.Type)) +#if __GLASGOW_HASKELL__ >= 708 +getTypeLHsExpr _ e = do +#else getTypeLHsExpr tcm e = do +#endif hs_env <- GHC.getSession +#if __GLASGOW_HASKELL__ >= 708 + (_, mbe) <- liftIO $ Desugar.deSugarExpr hs_env e +#else + let modu = GHC.ms_mod $ GHC.pm_mod_summary $ GHC.tm_parsed_module tcm + rn_env = TcRnTypes.tcg_rdr_env $ fst $ GHC.tm_internals_ tcm + ty_env = TcRnTypes.tcg_type_env $ fst $ GHC.tm_internals_ tcm (_, mbe) <- liftIO $ Desugar.deSugarExpr hs_env modu rn_env ty_env e +#endif return () case mbe of Nothing -> return Nothing Just expr -> return $ Just (GHC.getLoc e, CoreUtils.exprType expr) - where - modu = GHC.ms_mod $ GHC.pm_mod_summary $ GHC.tm_parsed_module tcm - rn_env = TcRnTypes.tcg_rdr_env $ fst $ GHC.tm_internals_ tcm - ty_env = TcRnTypes.tcg_type_env $ fst $ GHC.tm_internals_ tcm getTypeLPat :: GHC.TypecheckedModule -> GHC.LPat GHC.Id -> GHC.Ghc (Maybe (GHC.SrcSpan, GHC.Type)) getTypeLPat _ (GHC.L spn pat) = return $ Just (spn, TcHsSyn.hsPatType pat) @@ -161,14 +176,22 @@ pretty dflags = pretty :: GHC.Type -> String pretty = #endif +#if __GLASGOW_HASKELL__ >= 708 + Pretty.showDoc Pretty.OneLineMode 0 +#else Pretty.showDocWith Pretty.OneLineMode +#endif #if __GLASGOW_HASKELL__ >= 706 . Outputable.withPprStyleDoc dflags #else . Outputable.withPprStyleDoc #endif (Outputable.mkUserStyle Outputable.neverQualify Outputable.AllTheWay) +#if __GLASGOW_HASKELL__ >= 708 + . PprTyThing.pprTypeForUser +#else . PprTyThing.pprTypeForUser False +#endif ------------------------------------------------------------------------------ -- The following was taken from 'ghc-syb-utils' @@ -188,7 +211,11 @@ everythingStaged stage k z f x | (const False `extQ` postTcType `extQ` fixity `extQ` nameSet) x = z | otherwise = foldl k (f x) (gmapQ (everythingStaged stage k z f) x) where nameSet = const (stage `elem` [Parser,TypeChecker]) :: NameSet.NameSet -> Bool +#if __GLASGOW_HASKELL__ >= 709 + postTcType = const (stage Bool +#else postTcType = const (stage Bool +#endif fixity = const (stage Bool ------------------------------------------------------------------------------ @@ -198,8 +225,13 @@ everythingStaged stage k z f x infoThing :: String -> GHC.Ghc String infoThing str = do names <- GHC.parseName str +#if __GLASGOW_HASKELL__ >= 708 + mb_stuffs <- mapM (GHC.getInfo False) names + let filtered = filterOutChildren (\(t,_f,_i,_) -> t) (catMaybes mb_stuffs) +#else mb_stuffs <- mapM GHC.getInfo names let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs) +#endif unqual <- GHC.getPrintUnqual #if __GLASGOW_HASKELL__ >= 706 dflags <- DynFlags.getDynFlags @@ -207,7 +239,11 @@ infoThing str = do #else return $ Outputable.showSDocForUser unqual $ #endif +#if __GLASGOW_HASKELL__ >= 708 + Outputable.vcat (intersperse (Outputable.text "") $ map pprInfo filtered) +#else Outputable.vcat (intersperse (Outputable.text "") $ map (pprInfo False) filtered) +#endif -- Filter out names whose parent is also there Good -- example is '[]', which is both a type and data @@ -225,13 +261,19 @@ filterOutChildren get_thing xs Just p -> GHC.getName p `NameSet.elemNameSet` all_names Nothing -> False -#if __GLASGOW_HASKELL__ >= 706 +#if __GLASGOW_HASKELL__ >= 708 +pprInfo :: (HscTypes.TyThing, GHC.Fixity, [GHC.ClsInst], [GHC.FamInst]) -> Outputable.SDoc +pprInfo (thing, fixity, insts, _) = + PprTyThing.pprTyThingInContextLoc thing +#elif __GLASGOW_HASKELL__ >= 706 pprInfo :: PprTyThing.PrintExplicitForalls -> (HscTypes.TyThing, GHC.Fixity, [GHC.ClsInst]) -> Outputable.SDoc +pprInfo pefas (thing, fixity, insts) = + PprTyThing.pprTyThingInContextLoc pefas thing #else pprInfo :: PprTyThing.PrintExplicitForalls -> (HscTypes.TyThing, GHC.Fixity, [GHC.Instance]) -> Outputable.SDoc -#endif pprInfo pefas (thing, fixity, insts) = PprTyThing.pprTyThingInContextLoc pefas thing +#endif Outputable.$$ show_fixity fixity Outputable.$$ Outputable.vcat (map GHC.pprInstance insts) where diff --git a/src/Main.hs b/src/Main.hs index 517f224..f124206 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,34 +1,79 @@ +{-# LANGUAGE CPP #-} + module Main where +#if __GLASGOW_HASKELL__ < 709 +import Data.Traversable (traverse) +#endif + +import Data.Maybe (fromMaybe) +import System.Directory (getCurrentDirectory) import System.Environment (getProgName) import System.IO (hPutStrLn, stderr) +import System.FilePath ((), isAbsolute, takeDirectory) +import Cabal (findCabalFile) import Client (getServerStatus, serverCommand, stopServer) import CommandArgs import Daemonize (daemonize) import Server (startServer, createListenSocket) -import Types (Command(..)) +import Types (Command(..), CommandExtra(..), emptyCommandExtra) + +absoluteFilePath :: FilePath -> IO FilePath +absoluteFilePath p = if isAbsolute p then return p else do + dir <- getCurrentDirectory + return $ dir p + + +defaultSocketFile :: FilePath +defaultSocketFile = ".hdevtools.sock" -defaultSocketFilename :: FilePath -defaultSocketFilename = ".hdevtools.sock" -getSocketFilename :: Maybe FilePath -> FilePath -getSocketFilename Nothing = defaultSocketFilename -getSocketFilename (Just f) = f +fileArg :: HDevTools -> Maybe String +fileArg (Admin {}) = Nothing +fileArg (ModuleFile {}) = Nothing +fileArg args@(Check {}) = Just $ file args +fileArg args@(Info {}) = Just $ file args +fileArg args@(Type {}) = Just $ file args +fileArg (FindSymbol {}) = Nothing + +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' (FindSymbol {}) = Nothing + +pathArg :: HDevTools -> Maybe String +pathArg args = case pathArg' args of + Just x -> Just x + Nothing -> fileArg args main :: IO () main = do args <- loadHDevTools - let sock = getSocketFilename (socket args) + let argPath = pathArg args + dir <- maybe getCurrentDirectory (return . takeDirectory) argPath + mCabalFile <- findCabalFile dir >>= traverse absoluteFilePath + let extra = emptyCommandExtra + { ceGhcOptions = ghcOpts args + , ceCabalConfig = mCabalFile + , cePath = argPath + , ceCabalOptions = cabalOpts args + } + let defaultSocketPath = maybe "" takeDirectory mCabalFile defaultSocketFile + let sock = fromMaybe defaultSocketPath $ socket args case args of - Admin {} -> doAdmin sock args - Check {} -> doCheck sock args - ModuleFile {} -> doModuleFile sock args - Info {} -> doInfo sock args - Type {} -> doType sock args - -doAdmin :: FilePath -> HDevTools -> IO () -doAdmin sock args + Admin {} -> doAdmin sock args extra + Check {} -> doCheck sock args extra + ModuleFile {} -> doModuleFile sock args extra + Info {} -> doInfo sock args extra + Type {} -> doType sock args extra + FindSymbol {} -> doFindSymbol sock args extra + +doAdmin :: FilePath -> HDevTools -> CommandExtra -> IO () +doAdmin sock args _extra | start_server args = if noDaemon args then startServer sock Nothing else do @@ -41,26 +86,33 @@ doAdmin sock args hPutStrLn stderr "You must provide a command. See:" hPutStrLn stderr $ progName ++ " --help" -doModuleFile :: FilePath -> HDevTools -> IO () -doModuleFile sock args = - serverCommand sock (CmdModuleFile (module_ args)) (ghcOpts args) +doModuleFile :: FilePath -> HDevTools -> CommandExtra -> IO () +doModuleFile sock args extra = + serverCommand sock (CmdModuleFile (module_ args)) extra -doFileCommand :: String -> (HDevTools -> Command) -> FilePath -> HDevTools -> IO () -doFileCommand cmdName cmd sock args +doFileCommand :: String -> (HDevTools -> Command) -> FilePath -> HDevTools -> CommandExtra -> IO () +doFileCommand cmdName cmd sock args extra | null (file args) = do progName <- getProgName hPutStrLn stderr "You must provide a haskell source file. See:" hPutStrLn stderr $ progName ++ " " ++ cmdName ++ " --help" - | otherwise = serverCommand sock (cmd args) (ghcOpts args) + | otherwise = do + absFile <- absoluteFilePath $ file args + let args' = args { file = absFile } + serverCommand sock (cmd args') extra -doCheck :: FilePath -> HDevTools -> IO () +doCheck :: FilePath -> HDevTools -> CommandExtra -> IO () doCheck = doFileCommand "check" $ \args -> CmdCheck (file args) -doInfo :: FilePath -> HDevTools -> IO () +doInfo :: FilePath -> HDevTools -> CommandExtra -> IO () doInfo = doFileCommand "info" $ \args -> CmdInfo (file args) (identifier args) -doType :: FilePath -> HDevTools -> IO () +doType :: FilePath -> HDevTools -> CommandExtra -> IO () doType = doFileCommand "type" $ \args -> CmdType (file args) (line args, col args) + +doFindSymbol :: FilePath -> HDevTools -> CommandExtra -> IO () +doFindSymbol sock args extra = + serverCommand sock (CmdFindSymbol (symbol args) (files args)) extra diff --git a/src/Server.hs b/src/Server.hs index 551e2c4..f433ca2 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -8,15 +8,20 @@ import Network (PortID(UnixSocket), Socket, accept, listenOn, sClose) import System.Directory (removeFile) import System.Exit (ExitCode(ExitSuccess)) import System.IO (Handle, hClose, hFlush, hGetLine, hPutStrLn) -import System.IO.Error (ioeGetErrorType, isDoesNotExistError) +import System.IO.Error (ioeGetErrorType, isAlreadyInUseError, isDoesNotExistError) -import CommandLoop (newCommandLoopState, startCommandLoop) -import Types (ClientDirective(..), Command, ServerDirective(..)) +import CommandLoop (newCommandLoopState, Config, newConfig, startCommandLoop) +import Types (ClientDirective(..), Command, emptyCommandExtra, ServerDirective(..)) import Util (readMaybe) createListenSocket :: FilePath -> IO Socket -createListenSocket socketPath = - listenOn (UnixSocket socketPath) +createListenSocket socketPath = do + r <- tryJust (guard . isAlreadyInUseError) $ listenOn (UnixSocket socketPath) + case r of + Right socket -> return socket + Left _ -> do + removeFile socketPath + listenOn (UnixSocket socketPath) startServer :: FilePath -> Maybe Socket -> IO () startServer socketPath mbSock = do @@ -33,7 +38,8 @@ startServer socketPath mbSock = do go sock = do state <- newCommandLoopState currentClient <- newIORef Nothing - startCommandLoop state (clientSend currentClient) (getNextCommand currentClient sock) [] Nothing + config <- newConfig emptyCommandExtra + startCommandLoop state (clientSend currentClient) (getNextCommand currentClient sock) config Nothing removeSocketFile :: IO () removeSocketFile = do @@ -48,13 +54,13 @@ clientSend currentClient clientDirective = do Just h -> ignoreEPipe $ do hPutStrLn h (show clientDirective) hFlush h - Nothing -> error "This is impossible" + Nothing -> return () where -- EPIPE means that the client is no longer there. ignoreEPipe = handleJust (guard . isEPipe) (const $ return ()) isEPipe = (==ResourceVanished) . ioeGetErrorType -getNextCommand :: IORef (Maybe Handle) -> Socket -> IO (Maybe (Command, [String])) +getNextCommand :: IORef (Maybe Handle) -> Socket -> IO (Maybe (Command, Config)) getNextCommand currentClient sock = do checkCurrent <- readIORef currentClient case checkCurrent of @@ -69,8 +75,9 @@ getNextCommand currentClient sock = do clientSend currentClient $ ClientUnexpectedError $ "The client sent an invalid message to the server: " ++ show msg getNextCommand currentClient sock - Just (SrvCommand cmd ghcOpts) -> do - return $ Just (cmd, ghcOpts) + Just (SrvCommand cmd cmdExtra) -> do + config <- newConfig cmdExtra + return $ Just (cmd, config) Just SrvStatus -> do mapM_ (clientSend currentClient) $ [ ClientStdout "Server is running." diff --git a/src/Stack.hs b/src/Stack.hs new file mode 100644 index 0000000..f60f332 --- /dev/null +++ b/src/Stack.hs @@ -0,0 +1,148 @@ +{-# 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((<$>), (<*>)) +import System.IO +#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 + +#if __GLASGOW_HASKELL__ < 709 +execInPath :: String -> FilePath -> IO (Maybe String) +execInPath cmd p = do + eIOEstr <- try $ createProcess prc :: IO (Either IOError ProcH) + case eIOEstr of + Right (_, Just h, _, _) -> Just <$> getClose h + Right (_, Nothing, _, _) -> return Nothing + -- 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 _ -> return Nothing + where + prc = (shell cmd) { cwd = Just $ takeDirectory p } + +getClose :: Handle -> IO String +getClose h = do + str <- hGetContents h + hClose h + return str + +type ProcH = (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) + +-- Not deleting this because this is likely more robust than the above! (but +-- only works on process-1.2.3.0 onwards + +#else +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 } +#endif diff --git a/src/Types.hs b/src/Types.hs index 9b50707..eace685 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -2,12 +2,28 @@ module Types ( ServerDirective(..) , ClientDirective(..) , Command(..) + , CommandExtra(..) + , emptyCommandExtra ) where import System.Exit (ExitCode) +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 - = SrvCommand Command [String] + = SrvCommand Command CommandExtra | SrvStatus | SrvExit deriving (Read, Show) @@ -24,4 +40,5 @@ data Command | CmdModuleFile String | CmdInfo FilePath String | CmdType FilePath (Int, Int) + | CmdFindSymbol String [String] deriving (Read, Show) diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000..53c85fe --- /dev/null +++ b/stack.yaml @@ -0,0 +1,10 @@ +flags: {} +packages: +- '.' +extra-deps: [] + +# for GHC 7.8 +# resolver: lts-2.15 + +# for GHC 7.10 +resolver: nightly-2015-08-26