Hello community, here is the log from the commit of package hdevtools for openSUSE:Factory checked in at 2015-08-25 07:19:31 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/hdevtools (Old) and /work/SRC/openSUSE:Factory/.hdevtools.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "hdevtools" Changes: -------- --- /work/SRC/openSUSE:Factory/hdevtools/hdevtools.changes 2015-06-08 08:29:53.000000000 +0200 +++ /work/SRC/openSUSE:Factory/.hdevtools.new/hdevtools.changes 2015-08-25 08:49:19.000000000 +0200 @@ -1,0 +2,10 @@ +Sun Aug 16 17:48:41 UTC 2015 - [email protected] + +- update to 0.1.2.1 + +------------------------------------------------------------------- +Thu Aug 6 18:08:35 UTC 2015 - [email protected] + +- update 0.1.1.9 + +------------------------------------------------------------------- Old: ---- hdevtools-0.1.0.9.tar.gz New: ---- hdevtools-0.1.2.1.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ hdevtools.spec ++++++ --- /var/tmp/diff_new_pack.LM5DeZ/_old 2015-08-25 08:49:20.000000000 +0200 +++ /var/tmp/diff_new_pack.LM5DeZ/_new 2015-08-25 08:49:20.000000000 +0200 @@ -18,7 +18,7 @@ %global debug_package %{nil} Name: hdevtools -Version: 0.1.0.9 +Version: 0.1.2.1 Release: 0 Summary: Persistent GHC powered background server for FAST haskell development tools License: MIT @@ -35,6 +35,7 @@ BuildRequires: ghc-ghc-paths-devel BuildRequires: ghc-network-devel BuildRequires: ghc-rpm-macros +BuildRequires: ghc-process-devel BuildRequires: ghc-syb-devel BuildRequires: ghc-time-devel BuildRequires: ghc-unix-devel ++++++ hdevtools-0.1.0.9.tar.gz -> hdevtools-0.1.2.1.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hdevtools-0.1.0.9/hdevtools.cabal new/hdevtools-0.1.2.1/hdevtools.cabal --- old/hdevtools-0.1.0.9/hdevtools.cabal 2015-05-31 19:12:29.000000000 +0200 +++ new/hdevtools-0.1.2.1/hdevtools.cabal 2015-08-14 00:18:29.000000000 +0200 @@ -1,5 +1,5 @@ name: hdevtools -version: 0.1.0.9 +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 @@ -52,9 +52,11 @@ CommandArgs, CommandLoop, Daemonize, + FindSymbol, Info, Main, Server, + Stack, Types, Util, Paths_hdevtools @@ -67,6 +69,7 @@ ghc-paths, syb, network, + process >= 1.2.3.0, time, unix @@ -79,5 +82,7 @@ cpp-options: -DENABLE_CABAL if impl(ghc >= 7.9) - build-depends: Cabal >= 1.22 + build-depends: Cabal >= 1.22, + bin-package-db + cpp-options: -DENABLE_CABAL diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hdevtools-0.1.0.9/src/Cabal.hs new/hdevtools-0.1.2.1/src/Cabal.hs --- old/hdevtools-0.1.0.9/src/Cabal.hs 2015-05-31 19:12:29.000000000 +0200 +++ new/hdevtools-0.1.2.1/src/Cabal.hs 2015-08-14 00:18:29.000000000 +0200 @@ -5,11 +5,12 @@ ) where #ifdef ENABLE_CABAL - +import Stack import Control.Exception (IOException, catch) 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) @@ -40,6 +41,7 @@ import System.Directory (doesFileExist, getDirectoryContents) import System.FilePath (takeDirectory, splitFileName, (</>)) + componentName :: Component -> ComponentName componentName = foldComponent (const CLibName) @@ -95,22 +97,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 + +-- 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 -> IO (Either String [String]) -getPackageGhcOpts path = do +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,30 +134,31 @@ 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 - let mbLibName = pkgLibName pkgDescr - let ghcOpts' = foldl' mappend mempty $ map (getComponentGhcOptions localBuildInfo) $ flip allComponentsBy (\c -> c) . localPkgDescr $ localBuildInfo #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') diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hdevtools-0.1.0.9/src/Client.hs new/hdevtools-0.1.2.1/src/Client.hs --- old/hdevtools-0.1.0.9/src/Client.hs 2015-05-31 19:12:29.000000000 +0200 +++ new/hdevtools-0.1.2.1/src/Client.hs 2015-08-14 00:18:29.000000000 +0200 @@ -18,7 +18,7 @@ connect :: FilePath -> IO Handle connect sock = do - connectTo "" (UnixSocket sock) + connectTo "" (UnixSocket sock) getServerStatus :: FilePath -> IO () getServerStatus sock = do diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hdevtools-0.1.0.9/src/CommandArgs.hs new/hdevtools-0.1.2.1/src/CommandArgs.hs --- old/hdevtools-0.1.0.9/src/CommandArgs.hs 2015-05-31 19:12:29.000000000 +0200 +++ new/hdevtools-0.1.2.1/src/CommandArgs.hs 2015-08-14 00:18:29.000000000 +0200 @@ -44,34 +44,43 @@ 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 + , ghcOpts :: [String] + , path :: Maybe String + , file :: String + , line :: Int + , col :: Int + } + | FindSymbol { socket :: Maybe FilePath , ghcOpts :: [String] - , file :: String - , line :: Int - , col :: Int + , symbol :: String + , files :: [String] } deriving (Show, Data, Typeable) @@ -86,48 +95,60 @@ 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 + , ghcOpts = [] + , path = Nothing + , file = "" + , line = 0 + , col = 0 + } + +dummyFindSymbol :: HDevTools +dummyFindSymbol = FindSymbol { socket = Nothing , ghcOpts = [] - , file = "" - , line = 0 - , col = 0 + , 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" + , 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 +161,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,13 +172,22 @@ 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 ] += 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" + , 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 -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hdevtools-0.1.0.9/src/CommandLoop.hs new/hdevtools-0.1.2.1/src/CommandLoop.hs --- old/hdevtools-0.1.0.9/src/CommandLoop.hs 2015-05-31 19:12:29.000000000 +0200 +++ new/hdevtools-0.1.2.1/src/CommandLoop.hs 2015-08-14 00:18:29.000000000 +0200 @@ -9,8 +9,11 @@ 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)) @@ -25,7 +28,9 @@ import Types (ClientDirective(..), Command(..), CommandExtra(..)) import Info (getIdentifierInfo, getType) +import FindSymbol (findSymbol) import Cabal (getPackageGhcOpts) +import Stack type ClientSend = ClientDirective -> IO () @@ -54,18 +59,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 +140,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 @@ -156,7 +163,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 let noPhase = Nothing @@ -225,6 +231,21 @@ , 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 -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hdevtools-0.1.0.9/src/FindSymbol.hs new/hdevtools-0.1.2.1/src/FindSymbol.hs --- old/hdevtools-0.1.0.9/src/FindSymbol.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/hdevtools-0.1.2.1/src/FindSymbol.hs 2015-08-14 00:18:29.000000000 +0200 @@ -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 -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hdevtools-0.1.0.9/src/Main.hs new/hdevtools-0.1.2.1/src/Main.hs --- old/hdevtools-0.1.0.9/src/Main.hs 2015-05-31 19:12:29.000000000 +0200 +++ new/hdevtools-0.1.2.1/src/Main.hs 2015-08-14 00:18:29.000000000 +0200 @@ -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 @@ -30,27 +35,41 @@ 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 - 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 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 @@ -92,3 +111,7 @@ 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 -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hdevtools-0.1.0.9/src/Stack.hs new/hdevtools-0.1.2.1/src/Stack.hs --- old/hdevtools-0.1.0.9/src/Stack.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/hdevtools-0.1.2.1/src/Stack.hs 2015-08-14 00:18:29.000000000 +0200 @@ -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 -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hdevtools-0.1.0.9/src/Types.hs new/hdevtools-0.1.2.1/src/Types.hs --- old/hdevtools-0.1.0.9/src/Types.hs 2015-05-31 19:12:29.000000000 +0200 +++ new/hdevtools-0.1.2.1/src/Types.hs 2015-08-14 00:18:29.000000000 +0200 @@ -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 @@ -36,4 +38,5 @@ | CmdModuleFile String | CmdInfo FilePath String | CmdType FilePath (Int, Int) + | CmdFindSymbol String [String] deriving (Read, Show)
