Find cabal file and sandbox at the same time.

CabalDev.hs

@@ -1,52 +0,0 @@
-module CabalDev (modifyOptions) where
-
-{-
-  If the directory 'cabal-dev/packages-X.X.X.conf' exists, add it to the
-  options ghc-mod uses to check the source.  Otherwise just pass it on.
--}
-
-import Control.Applicative ((<$>))
-import Control.Exception (throwIO)
-import Control.Exception.IOChoice
-import Data.List (find)
-import System.Directory
-import System.FilePath (splitPath,joinPath,(</>))
-import Text.Regex.Posix ((=~))
-import Types
-
-modifyOptions :: Options -> IO Options
-modifyOptions opts = found ||> notFound
-  where
-    found = addPath opts <$> findCabalDev (sandbox opts)
-    notFound = return opts
-
-findCabalDev :: Maybe String -> IO FilePath
-findCabalDev Nothing = getCurrentDirectory >>= searchIt . splitPath
-findCabalDev (Just path) = do
-    exist <- doesDirectoryExist path
-    if exist then
-        findConf path
-      else
-        findCabalDev Nothing
-
-addPath :: Options -> String -> Options
-addPath orig_opts path = orig_opts { ghcOpts = opts' }
-  where
-    orig_ghcopt = ghcOpts orig_opts
-    opts' = orig_ghcopt ++ ["-package-conf", path, "-no-user-package-conf"]
-
-searchIt :: [FilePath] -> IO FilePath
-searchIt [] = throwIO $ userError "Not found"
-searchIt path = do
-    exist <- doesDirectoryExist cabalDir
-    if exist then
-        findConf cabalDir
-      else
-        searchIt $ init path
-  where
-    cabalDir = joinPath path </> "cabal-dev/"
-
-findConf :: FilePath -> IO FilePath
-findConf path = do
-    Just f <- find (=~ "packages.*\\.conf") <$> getDirectoryContents path
-    return $ path </> f

Cradle.hs

@@ -0,0 +1,99 @@
+module Cradle where
+
+import Control.Applicative ((<$>))
+import Control.Exception (throwIO)
+import Control.Monad
+import Data.List (isSuffixOf, intercalate)
+import Distribution.Simple.Program (ghcProgram)
+import Distribution.Simple.Program.Types (programName, programFindVersion)
+import Distribution.Verbosity (silent)
+import Distribution.Version (versionBranch)
+import System.Directory
+import System.FilePath ((</>),takeDirectory)
+import Types
+
+-- An error would be thrown
+checkEnv :: Maybe FilePath -> IO Cradle
+checkEnv (Just sbox) = do
+    (strver, ver) <- ghcVersion
+    conf <- checkPackageConf sbox strver
+    let confOpts = ghcPackageConfOptions ver conf
+    wdir <- getCurrentDirectory
+    cfiles <- cabalDir wdir
+    return $ case cfiles of
+        Nothing -> Cradle {
+            cradleCurrentDir  = wdir
+          , cradleCabalDir    = Nothing
+          , cradleCabalFile   = Nothing
+          , cradlePackageConfOpts = Just confOpts
+          }
+        Just (cdir,cfile) -> Cradle {
+            cradleCurrentDir  = wdir
+          , cradleCabalDir    = Just cdir
+          , cradleCabalFile   = Just cfile
+          , cradlePackageConfOpts = Just confOpts
+          }
+checkEnv Nothing = do
+    (strver, ver) <- ghcVersion
+    wdir <- getCurrentDirectory
+    cfiles <- cabalDir wdir
+    case cfiles of
+        Nothing -> return $ Cradle {
+            cradleCurrentDir  = wdir
+          , cradleCabalDir    = Nothing
+          , cradleCabalFile   = Nothing
+          , cradlePackageConfOpts = Nothing
+          }
+        Just (cdir,cfile) -> do
+            let sbox = cdir </> "cabal-dev/"
+                conf = packageConfName sbox strver
+                confOpts = ghcPackageConfOptions ver conf
+            exist <- doesFileExist conf
+            return $ Cradle {
+                cradleCurrentDir      = wdir
+              , cradleCabalDir        = Just cdir
+              , cradleCabalFile       = Just cfile
+              , cradlePackageConfOpts = if exist then Just confOpts else Nothing
+              }
+
+cabalDir :: FilePath -> IO (Maybe (FilePath,FilePath))
+cabalDir dir = do
+    cnts <- (filter isCabal <$> getDirectoryContents dir)
+            >>= filterM (\file -> doesFileExist (dir </> file))
+    let dir' = takeDirectory dir
+    case cnts of
+        [] | dir' == dir -> return Nothing
+           | otherwise   -> cabalDir dir'
+        cfile:_          -> return $ Just (dir,dir </> cfile)
+  where
+    isCabal name = ".cabal" `isSuffixOf` name && length name > 6
+
+ghcVersion :: IO (String, Int)
+ghcVersion = ghcVer >>= cook
+  where
+    ghcVer = programFindVersion ghcProgram silent (programName ghcProgram)
+    cook Nothing      = throwIO $ userError $ "ghc not found"
+    cook (Just v)
+      | length vs < 2 = return (verstr, 0)
+      | otherwise     = return (verstr, ver)
+      where
+        vs = versionBranch v
+        ver = (vs !! 0) * 100 + (vs !! 1)
+        verstr = intercalate "." . map show $ vs
+
+packageConfName :: FilePath -> String -> FilePath
+packageConfName path ver = path </> "packages-" ++ ver ++ ".conf"
+
+checkPackageConf :: FilePath -> String -> IO FilePath
+checkPackageConf path ver = do
+    let conf = packageConfName path ver
+    exist <- doesFileExist conf
+    if exist then
+        return conf
+      else
+        throwIO $ userError $ conf ++ " not found"
+
+ghcPackageConfOptions :: Int -> String -> [String]
+ghcPackageConfOptions ver file
+  | ver >= 706 = ["-package-db",   file, "-no-user-package-conf"]
+  | otherwise  = ["-package-conf", file, "-no-user-package-conf"]

GHCMod.hs

@@ -3,15 +3,15 @@
 module Main where
 
 import Browse
-import CabalDev (modifyOptions)
 import Check
 import Control.Applicative
 import Control.Exception
+import Cradle
 import Data.Typeable
 import Data.Version
+import Flag
 import Info
 import Lang
-import Flag
 import Lint
 import List
 import Paths_ghc_mod
@@ -86,7 +86,11 @@ main :: IO ()
 main = flip catches handlers $ do
     args <- getArgs
     let (opt',cmdArg) = parseArgs argspec args
-    opt <- modifyOptions opt'
+    cradle <- checkEnv $ sandbox opt'
+    let mpkgopts = cradlePackageConfOpts cradle
+        opt = case mpkgopts of
+            Nothing      -> opt'
+            Just pkgopts -> opt' { ghcOpts = pkgopts ++ ghcOpts opt' }
     res <- case safelist cmdArg 0 of
       "browse" -> concat <$> mapM (browseModule opt) (tail cmdArg)
       "list"   -> listModules opt

Types.hs

@@ -62,6 +62,17 @@ quote x = "\"" ++ x ++ "\""
 addNewLine :: String -> String
 addNewLine = (++ "\n")
 
+----------------------------------------------------------------
+
+data Cradle = Cradle {
+    cradleCurrentDir  :: FilePath
+  , cradleCabalDir    :: Maybe FilePath
+  , cradleCabalFile   :: Maybe FilePath
+  , cradlePackageConfOpts :: Maybe [String]
+  } deriving Show
+
+----------------------------------------------------------------
+
 type GHCOption  = String
 type IncludeDir = FilePath
 type Package    = String

ghc-mod.cabal

@@ -36,10 +36,10 @@ Executable ghc-mod
   Default-Language:     Haskell2010
   Main-Is:              GHCMod.hs
   Other-Modules:        Browse
-                        CabalApi
                         Cabal
-                        CabalDev
+                        CabalApi
                         Check
+                        Cradle
                         ErrMsg
                         Flag
                         GHCApi
@@ -65,7 +65,6 @@ Executable ghc-mod
                       , io-choice
                       , old-time
                       , process
-                      , regex-posix
                       , syb
                       , time
                       , transformers
@@ -98,7 +97,6 @@ Test-Suite spec
                       , io-choice
                       , old-time
                       , process
-                      , regex-posix
                       , syb
                       , time
                       , transformers