hdevtools-0.1.2.2/src/0000755000000000000000000000000012636125202012635 5ustar0000000000000000hdevtools-0.1.2.2/src/Main.hs0000644000000000000000000001007512636125202014060 0ustar0000000000000000{-# 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(..), 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" 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 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 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 s <- createListenSocket sock daemonize True $ startServer sock (Just s) | status args = getServerStatus sock | stop_server args = stopServer sock | otherwise = do progName <- getProgName hPutStrLn stderr "You must provide a command. See:" hPutStrLn stderr $ progName ++ " --help" doModuleFile :: FilePath -> HDevTools -> CommandExtra -> IO () doModuleFile sock args extra = serverCommand sock (CmdModuleFile (module_ args)) extra 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 = do absFile <- absoluteFilePath $ file args let args' = args { file = absFile } serverCommand sock (cmd args') extra doCheck :: FilePath -> HDevTools -> CommandExtra -> IO () doCheck = doFileCommand "check" $ \args -> CmdCheck (file args) doInfo :: FilePath -> HDevTools -> CommandExtra -> IO () doInfo = doFileCommand "info" $ \args -> CmdInfo (file args) (identifier args) 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 hdevtools-0.1.2.2/src/Cabal.hs0000644000000000000000000002621512635015142014201 0ustar0000000000000000{-# 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, doesDirectoryExist, 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" exists <- doesDirectoryExist dir if not exists then return dir else do contents <- getDirectoryContents dir return . maybe dir (dir ) $ find ("dist-sandbox-" `isPrefixOf`) contents 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 hdevtools-0.1.2.2/src/Client.hs0000644000000000000000000000424112635015142014410 0ustar0000000000000000module Client ( getServerStatus , stopServer , serverCommand ) where import Control.Exception (tryJust) import Control.Monad (guard) import Network (PortID(UnixSocket), connectTo) import System.Exit (exitFailure, exitWith) import System.IO (Handle, hClose, hFlush, hGetLine, hPutStrLn, stderr) import System.IO.Error (isDoesNotExistError) import Daemonize (daemonize) import Server (createListenSocket, startServer) import Types (ClientDirective(..), Command(..), CommandExtra(..), ServerDirective(..)) import Util (readMaybe) connect :: FilePath -> IO Handle connect sock = do connectTo "" (UnixSocket sock) getServerStatus :: FilePath -> IO () getServerStatus sock = do h <- connect sock hPutStrLn h $ show SrvStatus hFlush h startClientReadLoop h stopServer :: FilePath -> IO () stopServer sock = do h <- connect sock hPutStrLn h $ show SrvExit hFlush h startClientReadLoop h 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 cmdExtra) hFlush h startClientReadLoop h Left _ -> do s <- createListenSocket sock daemonize False $ startServer sock (Just s) serverCommand sock cmd cmdExtra startClientReadLoop :: Handle -> IO () startClientReadLoop h = do msg <- hGetLine h let clientDirective = readMaybe msg case clientDirective of Just (ClientStdout out) -> putStrLn out >> startClientReadLoop h Just (ClientStderr err) -> hPutStrLn stderr err >> startClientReadLoop h Just (ClientExit exitCode) -> hClose h >> exitWith exitCode Just (ClientUnexpectedError err) -> hClose h >> unexpectedError err Nothing -> do hClose h unexpectedError $ "The server sent an invalid message to the client: " ++ show msg unexpectedError :: String -> IO () unexpectedError err = do hPutStrLn stderr banner hPutStrLn stderr err hPutStrLn stderr banner exitFailure where banner = replicate 78 '*' hdevtools-0.1.2.2/src/CommandArgs.hs0000644000000000000000000001475212635015142015375 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE CPP #-} module CommandArgs ( HDevTools(..) , loadHDevTools ) where import System.Console.CmdArgs.Implicit import System.Environment (getProgName) import System.Info (arch, os) import qualified Config #ifdef CABAL import Data.Version (showVersion) import Paths_hdevtools (version) #endif programVersion :: String programVersion = #ifdef CABAL "version " ++ showVersion version #else "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 , ", ", cabalVersion , ")" ] data HDevTools = Admin { socket :: Maybe FilePath , start_server :: Bool , noDaemon :: Bool , status :: Bool , stop_server :: Bool } | Check { socket :: Maybe FilePath , ghcOpts :: [String] , cabalOpts :: [String] , path :: Maybe String , file :: String , json :: Bool } | ModuleFile { socket :: Maybe FilePath , ghcOpts :: [String] , cabalOpts :: [String] , module_ :: String } | Info { 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] , cabalOpts :: [String] , symbol :: String , files :: [String] } deriving (Show, Data, Typeable) dummyAdmin :: HDevTools dummyAdmin = Admin { socket = Nothing , start_server = False , noDaemon = False , status = False , stop_server = False } dummyCheck :: HDevTools dummyCheck = Check { socket = Nothing , ghcOpts = [] , cabalOpts = [] , path = Nothing , file = "" , json = False } dummyModuleFile :: HDevTools dummyModuleFile = ModuleFile { socket = Nothing , ghcOpts = [] , cabalOpts = [] , module_ = "" } dummyInfo :: HDevTools dummyInfo = Info { 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 = [] , 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" ] += 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" #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" , 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" 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_, findSymbol] += helpArg [name "h", groupname "Help"] += versionArg [groupname "Help"] += program progName += summary (progName ++ ": " ++ fullVersion) loadHDevTools :: IO HDevTools loadHDevTools = do progName <- getProgName (cmdArgs_ (full progName) :: IO HDevTools) hdevtools-0.1.2.2/src/CommandLoop.hs0000644000000000000000000002441112635015142015403 0ustar0000000000000000{-# LANGUAGE CPP #-} module CommandLoop ( newCommandLoopState , Config(..) , CabalConfig(..) , newConfig , startCommandLoop ) where import Control.Monad (when) import Data.IORef 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(..), CommandExtra(..)) import Info (getIdentifierInfo, getType) import FindSymbol (findSymbol) import Cabal (getPackageGhcOpts) import Stack type ClientSend = ClientDirective -> IO () data State = State { stateWarningsEnabled :: Bool } newCommandLoopState :: IO (IORef State) newCommandLoopState = do newIORef $ State { 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 liftIO $ setWarnings warningsValue action `GHC.gfinally` (liftIO $ setWarnings beforeState) where getWarnings :: IO Bool getWarnings = readIORef state >>= return . stateWarningsEnabled setWarnings :: Bool -> IO () setWarnings val = modifyIORef state $ \s -> s { stateWarningsEnabled = val } 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 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, config) -> startCommandLoop state clientSend getNextCommand config (Just cmd) where processNextCommand :: Bool -> GHC.Ghc (Maybe CommandObj) processNextCommand forceReconfig = do mbNextCmd <- liftIO getNextCommand case mbNextCmd of Nothing -> -- Exit return Nothing 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 $ \e -> do liftIO $ mapM_ clientSend [ ClientStderr $ GHC.showGhcException e "" , ClientExit (ExitFailure 1) ] return () doMaybe :: Monad m => Maybe a -> (a -> m ()) -> m () doMaybe Nothing _ = return () doMaybe (Just x) f = f x 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 let noPhase = Nothing target <- GHC.guessTarget file noPhase GHC.setTargets [target] let handler err = GHC.printException err >> return GHC.Failed flag <- GHC.handleSourceError handler (GHC.load GHC.LoadAllTargets) liftIO $ case flag of GHC.Succeeded -> clientSend (ClientExit ExitSuccess) GHC.Failed -> clientSend (ClientExit (ExitFailure 1)) runCommand _ clientSend (CmdModuleFile moduleName) = do moduleGraph <- GHC.getModuleGraph case find (moduleSummaryMatchesModuleName moduleName) moduleGraph of Nothing -> liftIO $ mapM_ clientSend [ ClientStderr "Module not found" , ClientExit (ExitFailure 1) ] Just modSummary -> case GHC.ml_hs_file (GHC.ms_location modSummary) of Nothing -> liftIO $ mapM_ clientSend [ ClientStderr "Module does not have a source file" , ClientExit (ExitFailure 1) ] Just file -> liftIO $ mapM_ clientSend [ ClientStdout file , ClientExit ExitSuccess ] where moduleSummaryMatchesModuleName modName modSummary = modName == (GHC.moduleNameString . GHC.moduleName . GHC.ms_mod) modSummary runCommand state clientSend (CmdInfo file identifier) = do result <- withWarnings state False $ getIdentifierInfo file identifier case result of Left err -> liftIO $ mapM_ clientSend [ ClientStderr err , ClientExit (ExitFailure 1) ] Right info -> liftIO $ mapM_ clientSend [ ClientStdout info , ClientExit ExitSuccess ] runCommand state clientSend (CmdType file (line, col)) = do result <- withWarnings state False $ getType file (line, col) case result of Left err -> liftIO $ mapM_ clientSend [ ClientStderr err , ClientExit (ExitFailure 1) ] Right types -> liftIO $ do mapM_ (clientSend . ClientStdout . formatType) types clientSend (ClientExit ExitSuccess) where formatType :: ((Int, Int, Int, Int), String) -> String formatType ((startLine, startCol, endLine, endCol), t) = concat [ show startLine , " " , show startCol , " " , show endLine , " " , 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 () logAction state clientSend dflags severity srcspan style msg = let out = Outputable.renderWithStyle dflags fullMsg style _ = severity in logActionSend state clientSend severity out where fullMsg = ErrUtils.mkLocMessage severity srcspan msg #else logAction :: IORef State -> ClientSend -> GHC.Severity -> GHC.SrcSpan -> Outputable.PprStyle -> ErrUtils.Message -> IO () logAction state clientSend severity srcspan style msg = let out = Outputable.renderWithStyle fullMsg style _ = severity in logActionSend state clientSend severity out where fullMsg = ErrUtils.mkLocMessage srcspan msg #endif logActionSend :: IORef State -> ClientSend -> GHC.Severity -> String -> IO () logActionSend state clientSend severity out = do currentState <- readIORef state when (not (isWarning severity) || stateWarningsEnabled currentState) $ clientSend (ClientStdout out) where isWarning :: GHC.Severity -> Bool isWarning GHC.SevWarning = True isWarning _ = False hdevtools-0.1.2.2/src/Daemonize.hs0000644000000000000000000000161012635015142015102 0ustar0000000000000000module Daemonize ( daemonize ) where import Control.Monad (when) import System.Exit (ExitCode(ExitSuccess)) import System.Posix.Process (exitImmediately, createSession, forkProcess) import System.Posix.IO -- | This goes against the common daemon guidelines and does not change the -- current working directory! -- -- We need the daemon to stay in the current directory for the GHC API to work daemonize :: Bool -> IO () -> IO () daemonize exit program = do _ <- forkProcess child1 when exit $ exitImmediately ExitSuccess where child1 = do _ <- createSession _ <- forkProcess child2 exitImmediately ExitSuccess child2 = do mapM_ closeFd [stdInput, stdOutput, stdError] nullFd <- openFd "/dev/null" ReadWrite Nothing defaultFileFlags mapM_ (dupTo nullFd) [stdInput, stdOutput, stdError] closeFd nullFd program hdevtools-0.1.2.2/src/FindSymbol.hs0000644000000000000000000000615312635015142015244 0ustar0000000000000000{-# 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) hdevtools-0.1.2.2/src/Info.hs0000644000000000000000000002462312635015142014073 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} module Info ( getIdentifierInfo , getType ) where import Control.Monad (liftM) import Data.Generics (GenericQ, mkQ, extQ, gmapQ) import Data.List (find, sortBy, intersperse) import Data.Maybe (catMaybes, fromMaybe) import Data.Typeable (Typeable) import MonadUtils (liftIO) import qualified CoreUtils 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 import qualified Outputable import qualified PprTyThing import qualified Pretty import qualified TcHsSyn getIdentifierInfo :: FilePath -> String -> GHC.Ghc (Either String String) getIdentifierInfo file identifier = withModSummary file $ \m -> do #if __GLASGOW_HASKELL__ >= 706 GHC.setContext [GHC.IIModule (GHC.moduleName (GHC.ms_mod m))] #elif __GLASGOW_HASKELL__ >= 704 GHC.setContext [GHC.IIModule (GHC.ms_mod m)] #else GHC.setContext [GHC.ms_mod m] [] #endif GHC.handleSourceError (return . Left . show) $ liftM Right (infoThing identifier) getType :: FilePath -> (Int, Int) -> GHC.Ghc (Either String [((Int, Int, Int, Int), String)]) getType file (line, col) = withModSummary file $ \m -> do p <- GHC.parseModule m typechecked <- GHC.typecheckModule p types <- processTypeCheckedModule typechecked (line, col) return (Right types) withModSummary :: String -> (HscTypes.ModSummary -> GHC.Ghc (Either String a)) -> GHC.Ghc (Either String a) withModSummary file action = do let noPhase = Nothing target <- GHC.guessTarget file noPhase GHC.setTargets [target] let handler err = GHC.printException err >> return GHC.Failed flag <- GHC.handleSourceError handler (GHC.load GHC.LoadAllTargets) case flag of GHC.Failed -> return (Left "Error loading targets") GHC.Succeeded -> do modSummary <- getModuleSummary file case modSummary of Nothing -> return (Left "Module not found in module graph") Just m -> action m getModuleSummary :: FilePath -> GHC.Ghc (Maybe GHC.ModSummary) getModuleSummary file = do moduleGraph <- GHC.getModuleGraph case find (moduleSummaryMatchesFilePath file) moduleGraph of Nothing -> return Nothing Just moduleSummary -> return (Just moduleSummary) moduleSummaryMatchesFilePath :: FilePath -> GHC.ModSummary -> Bool moduleSummaryMatchesFilePath file moduleSummary = let location = GHC.ms_location moduleSummary location_file = GHC.ml_hs_file location in case location_file of Just f -> f == file Nothing -> False ------------------------------------------------------------------------------ -- Most of the following code was taken from the source code of 'ghc-mod' (with -- some stylistic changes) -- -- ghc-mod: -- http://www.mew.org/~kazu/proj/ghc-mod/ -- https://github.com/kazu-yamamoto/ghc-mod/ processTypeCheckedModule :: GHC.TypecheckedModule -> (Int, Int) -> GHC.Ghc [((Int, Int, Int, Int), String)] processTypeCheckedModule tcm (line, col) = do let tcs = GHC.tm_typechecked_source tcm bs = listifySpans tcs (line, col) :: [GHC.LHsBind GHC.Id] es = listifySpans tcs (line, col) :: [GHC.LHsExpr GHC.Id] ps = listifySpans tcs (line, col) :: [GHC.LPat GHC.Id] bts <- mapM (getTypeLHsBind tcm) bs ets <- mapM (getTypeLHsExpr tcm) es pts <- mapM (getTypeLPat tcm) ps #if __GLASGOW_HASKELL__ >= 706 dflags <- DynFlags.getDynFlags return $ map (toTup dflags) $ #else return $ map toTup $ #endif sortBy cmp $ catMaybes $ concat [ets, bts, pts] where cmp (a, _) (b, _) | a `GHC.isSubspanOf` b = LT | b `GHC.isSubspanOf` a = GT | otherwise = EQ #if __GLASGOW_HASKELL__ >= 706 toTup :: GHC.DynFlags -> (GHC.SrcSpan, GHC.Type) -> ((Int, Int, Int, Int), String) toTup dflags (spn, typ) = (fourInts spn, pretty dflags typ) #else toTup :: (GHC.SrcSpan, GHC.Type) -> ((Int, Int, Int, Int), String) toTup (spn, typ) = (fourInts spn, pretty typ) #endif fourInts :: GHC.SrcSpan -> (Int, Int, Int, Int) fourInts = fromMaybe (0, 0, 0, 0) . getSrcSpan getSrcSpan :: GHC.SrcSpan -> Maybe (Int, Int, Int, Int) getSrcSpan (GHC.RealSrcSpan spn) = Just (GHC.srcSpanStartLine spn , GHC.srcSpanStartCol spn , GHC.srcSpanEndLine spn , GHC.srcSpanEndCol 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) 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) listifySpans :: Typeable a => GHC.TypecheckedSource -> (Int, Int) -> [GHC.Located a] listifySpans tcs lc = listifyStaged TypeChecker p tcs where p (GHC.L spn _) = GHC.isGoodSrcSpan spn && spn `GHC.spans` lc listifyStaged :: Typeable r => Stage -> (r -> Bool) -> GenericQ [r] listifyStaged s p = everythingStaged s (++) [] ([] `mkQ` (\x -> [x | p x])) #if __GLASGOW_HASKELL__ >= 706 pretty :: GHC.DynFlags -> GHC.Type -> String pretty dflags = #else 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' -- -- ghc-syb-utils: -- https://github.com/nominolo/ghc-syb -- | Ghc Ast types tend to have undefined holes, to be filled -- by later compiler phases. We tag Asts with their source, -- so that we can avoid such holes based on who generated the Asts. data Stage = Parser | Renamer | TypeChecker deriving (Eq,Ord,Show) -- | Like 'everything', but avoid known potholes, based on the 'Stage' that -- generated the Ast. everythingStaged :: Stage -> (r -> r -> r) -> r -> GenericQ r -> GenericQ r 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 ------------------------------------------------------------------------------ -- The following code was taken from GHC's ghc/InteractiveUI.hs (with some -- stylistic changes) 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 return $ Outputable.showSDocForUser dflags unqual $ #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 -- constructor in the same type filterOutChildren :: (a -> HscTypes.TyThing) -> [a] -> [a] filterOutChildren get_thing xs = filter (not . has_parent) xs where all_names = NameSet.mkNameSet (map (GHC.getName . get_thing) xs) #if __GLASGOW_HASKELL__ >= 704 has_parent x = case HscTypes.tyThingParent_maybe (get_thing x) of #else has_parent x = case PprTyThing.pprTyThingParent_maybe (get_thing x) of #endif Just p -> GHC.getName p `NameSet.elemNameSet` all_names Nothing -> False #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 pprInfo pefas (thing, fixity, insts) = PprTyThing.pprTyThingInContextLoc pefas thing #endif Outputable.$$ show_fixity fixity Outputable.$$ Outputable.vcat (map GHC.pprInstance insts) where show_fixity fix | fix == GHC.defaultFixity = Outputable.empty | otherwise = Outputable.ppr fix Outputable.<+> Outputable.ppr (GHC.getName thing) hdevtools-0.1.2.2/src/Main.hs0000644000000000000000000001007512636125202014060 0ustar0000000000000000{-# 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(..), 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" 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 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 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 s <- createListenSocket sock daemonize True $ startServer sock (Just s) | status args = getServerStatus sock | stop_server args = stopServer sock | otherwise = do progName <- getProgName hPutStrLn stderr "You must provide a command. See:" hPutStrLn stderr $ progName ++ " --help" doModuleFile :: FilePath -> HDevTools -> CommandExtra -> IO () doModuleFile sock args extra = serverCommand sock (CmdModuleFile (module_ args)) extra 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 = do absFile <- absoluteFilePath $ file args let args' = args { file = absFile } serverCommand sock (cmd args') extra doCheck :: FilePath -> HDevTools -> CommandExtra -> IO () doCheck = doFileCommand "check" $ \args -> CmdCheck (file args) doInfo :: FilePath -> HDevTools -> CommandExtra -> IO () doInfo = doFileCommand "info" $ \args -> CmdInfo (file args) (identifier args) 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 hdevtools-0.1.2.2/src/Server.hs0000644000000000000000000000716112635015142014444 0ustar0000000000000000module Server where import Control.Exception (bracket, finally, handleJust, tryJust) import Control.Monad (guard) import Data.IORef (IORef, newIORef, readIORef, writeIORef) import GHC.IO.Exception (IOErrorType(ResourceVanished)) 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, isAlreadyInUseError, isDoesNotExistError) import CommandLoop (newCommandLoopState, Config, newConfig, startCommandLoop) import Types (ClientDirective(..), Command, emptyCommandExtra, ServerDirective(..)) import Util (readMaybe) createListenSocket :: FilePath -> IO Socket 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 case mbSock of Nothing -> bracket (createListenSocket socketPath) cleanup go Just sock -> (go sock) `finally` (cleanup sock) where cleanup :: Socket -> IO () cleanup sock = do sClose sock removeSocketFile go :: Socket -> IO () go sock = do state <- newCommandLoopState currentClient <- newIORef Nothing config <- newConfig emptyCommandExtra startCommandLoop state (clientSend currentClient) (getNextCommand currentClient sock) config Nothing removeSocketFile :: IO () removeSocketFile = do -- Ignore possible error if socket file does not exist _ <- tryJust (guard . isDoesNotExistError) $ removeFile socketPath return () clientSend :: IORef (Maybe Handle) -> ClientDirective -> IO () clientSend currentClient clientDirective = do mbH <- readIORef currentClient case mbH of Just h -> ignoreEPipe $ do hPutStrLn h (show clientDirective) hFlush h 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, Config)) getNextCommand currentClient sock = do checkCurrent <- readIORef currentClient case checkCurrent of Just h -> hClose h Nothing -> return () (h, _, _) <- accept sock writeIORef currentClient (Just h) msg <- hGetLine h -- TODO catch exception let serverDirective = readMaybe msg case serverDirective of Nothing -> do clientSend currentClient $ ClientUnexpectedError $ "The client sent an invalid message to the server: " ++ show msg getNextCommand currentClient sock Just (SrvCommand cmd cmdExtra) -> do config <- newConfig cmdExtra return $ Just (cmd, config) Just SrvStatus -> do mapM_ (clientSend currentClient) $ [ ClientStdout "Server is running." , ClientExit ExitSuccess ] getNextCommand currentClient sock Just SrvExit -> do mapM_ (clientSend currentClient) $ [ ClientStdout "Shutting down server." , ClientExit ExitSuccess ] -- Must close the handle here because we are exiting the loop so it -- won't be closed in the code above hClose h return Nothing hdevtools-0.1.2.2/src/Stack.hs0000644000000000000000000001165612635015142014247 0ustar0000000000000000{-# 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 hdevtools-0.1.2.2/src/Types.hs0000644000000000000000000000223512635015142014277 0ustar0000000000000000module 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 CommandExtra | SrvStatus | SrvExit deriving (Read, Show) data ClientDirective = ClientStdout String | ClientStderr String | ClientExit ExitCode | ClientUnexpectedError String -- ^ For unexpected errors that should not happen deriving (Read, Show) data Command = CmdCheck FilePath | CmdModuleFile String | CmdInfo FilePath String | CmdType FilePath (Int, Int) | CmdFindSymbol String [String] deriving (Read, Show) hdevtools-0.1.2.2/src/Util.hs0000644000000000000000000000055412635015142014112 0ustar0000000000000000module Util ( readMaybe ) where -- Taken from: -- http://stackoverflow.com/questions/8066850/why-doesnt-haskells-prelude-read-return-a-maybe/8080084#8080084 readMaybe :: (Read a) => String -> Maybe a readMaybe s = case [x | (x,t) <- reads s, ("","") <- lex t] of [x] -> Just x _ -> Nothing hdevtools-0.1.2.2/LICENSE0000644000000000000000000000207412635047727013074 0ustar0000000000000000Copyright (C) 2015 The hdevtools Authors (see AUTHORS file) Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. hdevtools-0.1.2.2/Setup.hs0000644000000000000000000000005612635015142013503 0ustar0000000000000000import Distribution.Simple main = defaultMain hdevtools-0.1.2.2/hdevtools.cabal0000644000000000000000000000662512645026110015050 0ustar0000000000000000name: hdevtools version: 0.1.2.2 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 syntax and type checking of Haskell code, and retrieving type information, all directly from within your text editor. . The advantage that 'hdevtools' has over competitors, is that it runs silently in a persistent background process, and therefore is able to keeps all of your Haskell modules and dependent libraries loaded in memory. This way, when you change only a single source file, only it needs to be reloaded and rechecked, instead of having to reload everything. . This makes 'hdevtools' very fast for checking syntax and type errors (runs just as fast as the ':reload' command in GHCi). . In fact, syntax and type checking is so fast, that you can safely enable auto checking on every save. Even for huge projects, checking is nearly instant. . Once you start using 'hdevtools' and you get used to having your errors shown to you instantly (without having to switch back and forth between GHCi and your editor), and shown directly on your code, in your editor (without having to wait forever for GHC to run) you will wonder how you ever lived without it. . In addition to checking Haskell source code for errors, 'hdevtools' has tools for getting info about identifiers, and getting type information for snippets of code. license: MIT license-file: LICENSE author: Bit Connor maintainer: Sebastian Nagel , Ranjit Jhala copyright: See AUTHORS file category: Development homepage: https://github.com/hdevtools/hdevtools/ bug-reports: https://github.com/hdevtools/hdevtools/issues/ build-type: Simple cabal-version: >=1.8 extra-source-files: CHANGELOG.md source-repository head type: git location: git://github.com/hdevtools/hdevtools.git executable hdevtools hs-source-dirs: src ghc-options: -Wall cpp-options: -DCABAL main-is: Main.hs 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 hdevtools-0.1.2.2/CHANGELOG.md0000644000000000000000000000016112645025706013665 0ustar0000000000000000# Changelog ## 0.1.2.2 - 2016-01-11 * Added type checking support for tests and benchmarks in stack projects.