Support running from cabal package subdirectories

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"

src/CommandLoop.hs

@@ -9,22 +9,21 @@ 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
 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"

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" $