From 0ee6a4105983d03a177bcc36e99a8c95d42d157d Mon Sep 17 00:00:00 2001 From: Maxim Kulkin Date: Thu, 20 Feb 2014 02:49:48 +0400 Subject: [PATCH] Support running from cabal package subdirectories --- src/Cabal.hs | 35 ++++++++++++++++++++++++++++++----- src/CommandLoop.hs | 21 ++++----------------- src/Main.hs | 34 +++++++++++++++++++++++++++------- 3 files changed, 61 insertions(+), 29 deletions(-) diff --git a/src/Cabal.hs b/src/Cabal.hs index b087baa..5bb752a 100644 --- a/src/Cabal.hs +++ b/src/Cabal.hs @@ -1,10 +1,11 @@ module Cabal ( getPackageGhcOpts + , findCabalFile ) where import Control.Exception (IOException, catch) import Data.Char (isSpace) -import Data.List (foldl', nub, isPrefixOf) +import Data.List (foldl', nub, sort, find, isPrefixOf, isSuffixOf) import Data.Monoid (Monoid(..)) import Distribution.PackageDescription (Executable(..), TestSuite(..), Benchmark(..), emptyHookedBuildInfo) import Distribution.PackageDescription.Parse (readPackageDescription) @@ -16,12 +17,12 @@ 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) +import Distribution.Simple.Setup (ConfigFlags(..), defaultConfigFlags, toFlag) import Distribution.Verbosity (silent) import Distribution.Version (Version(..)) import System.IO.Error (ioeGetErrorString) -import System.Directory (doesFileExist) +import System.Directory (doesFileExist, getDirectoryContents) import System.FilePath (takeDirectory, splitFileName, ()) componentName :: Component -> ComponentName @@ -60,6 +61,10 @@ getPackageGhcOpts path = do genPkgDescr <- readPackageDescription silent path let cfgFlags' = (defaultConfigFlags defaultProgramConfiguration) + { configDistPref = toFlag $ takeDirectory path "dist" + -- TODO: figure out how to find out this flag + , configUserInstall = toFlag True + } let sandboxConfig = takeDirectory path "cabal.sandbox.config" exists <- doesFileExist sandboxConfig @@ -69,7 +74,7 @@ getPackageGhcOpts path = do True -> do sandboxPackageDb <- getSandboxPackageDB sandboxConfig return $ cfgFlags' - { configPackageDBs = [Just $ sandboxPackageDb] + { configPackageDBs = [Just sandboxPackageDb] } localBuildInfo <- configure (genPkgDescr, emptyHookedBuildInfo) cfgFlags @@ -79,7 +84,7 @@ getPackageGhcOpts path = do Just ghcVersion -> do let ghcOpts' = foldl' mappend mempty $ map (getComponentGhcOptions localBuildInfo) $ flip allComponentsBy (\c -> c) . localPkgDescr $ localBuildInfo -- FIX bug in GhcOptions' `mappend` - ghcOpts = ghcOpts' { ghcOptPackageDBs = nub (ghcOptPackageDBs ghcOpts') + ghcOpts = ghcOpts' { ghcOptPackageDBs = sort $ nub (ghcOptPackageDBs ghcOpts') , ghcOptPackages = nub (ghcOptPackages ghcOpts') , ghcOptSourcePath = map (baseDir ) (ghcOptSourcePath ghcOpts') } @@ -105,3 +110,23 @@ getPackageGhcOpts path = do 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" diff --git a/src/CommandLoop.hs b/src/CommandLoop.hs index 38b3ea6..f573f7a 100644 --- a/src/CommandLoop.hs +++ b/src/CommandLoop.hs @@ -9,7 +9,7 @@ module CommandLoop import Control.Monad (when) import Data.IORef -import Data.List (find, isSuffixOf) +import Data.List (find) import MonadUtils (MonadIO, liftIO) import System.Exit (ExitCode(ExitFailure, ExitSuccess)) import qualified ErrUtils @@ -17,14 +17,13 @@ import qualified Exception (ExceptionMonad) import qualified GHC import qualified GHC.Paths import qualified Outputable -import System.Directory (getCurrentDirectory, getDirectoryContents) -import System.FilePath (()) +import System.Directory (getCurrentDirectory) import System.Posix.Types (EpochTime) import System.Posix.Files (getFileStatus, modificationTime) import Types (ClientDirective(..), Command(..)) import Info (getIdentifierInfo, getType) -import Cabal (getPackageGhcOpts) +import Cabal (getPackageGhcOpts, findCabalFile) type ClientSend = ClientDirective -> IO () @@ -59,7 +58,7 @@ data Config = Config newConfig :: [String] -> IO Config newConfig ghcOpts = do - mbCabalFile <- findCabalFile + mbCabalFile <- getCurrentDirectory >>= findCabalFile mbCabalConfig <- maybe (return Nothing) (fmap Just . mkCabalConfig) mbCabalFile return $ Config { configGhcOpts = ghcOpts , configCabal = mbCabalConfig @@ -250,15 +249,3 @@ logActionSend state clientSend severity out = do isWarning :: GHC.Severity -> Bool isWarning GHC.SevWarning = True isWarning _ = False - -findCabalFile :: IO (Maybe FilePath) -findCabalFile = do - curDir <- getCurrentDirectory - allFiles <- getDirectoryContents curDir - return $ fmap (curDir ) $ find (isCabalFile) allFiles - - where - isCabalFile :: FilePath -> Bool - isCabalFile path = cabalExtension `isSuffixOf` path - && length path > length cabalExtension - where cabalExtension = ".cabal" diff --git a/src/Main.hs b/src/Main.hs index 517f224..2880eda 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,25 +1,42 @@ module Main where +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(..)) -defaultSocketFilename :: FilePath -defaultSocketFilename = ".hdevtools.sock" +absoluteFilePath :: FilePath -> IO FilePath +absoluteFilePath path = if isAbsolute path then return path else do + dir <- getCurrentDirectory + return $ dir path -getSocketFilename :: Maybe FilePath -> FilePath -getSocketFilename Nothing = defaultSocketFilename -getSocketFilename (Just f) = f + +defaultSocketPath :: IO FilePath +defaultSocketPath = do + mbCabalFile <- getCurrentDirectory >>= findCabalFile + case mbCabalFile of + Nothing -> return socketFile + Just cabalFile -> return $ takeDirectory cabalFile socketFile + + where socketFile :: FilePath + socketFile = ".hdevtools.sock" + + +getSocketFilename :: Maybe FilePath -> IO FilePath +getSocketFilename Nothing = defaultSocketPath +getSocketFilename (Just f) = return f main :: IO () main = do args <- loadHDevTools - let sock = getSocketFilename (socket args) + sock <- getSocketFilename (socket args) case args of Admin {} -> doAdmin sock args Check {} -> doCheck sock args @@ -51,7 +68,10 @@ doFileCommand cmdName cmd sock args 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') (ghcOpts args') doCheck :: FilePath -> HDevTools -> IO () doCheck = doFileCommand "check" $