Supporting sandbox sharing.

Braking backword compatibility of findCradle.

Language/Haskell/GhcMod/Cradle.hs

@@ -1,65 +1,40 @@
 module Language.Haskell.GhcMod.Cradle (findCradle) where
 
+import Data.Char (isSpace)
 import Control.Applicative ((<$>))
-import Control.Exception (throwIO)
-import Control.Monad (unless, filterM)
-import Data.List (isSuffixOf)
-import Distribution.System (buildPlatform)
-import qualified Distribution.Text as Text (display)
+import Control.Exception as E (catch, throwIO, SomeException)
+import Control.Monad (filterM)
+import Data.List (isPrefixOf, isSuffixOf)
 import Language.Haskell.GhcMod.Types
-import System.Directory (getCurrentDirectory, getDirectoryContents, doesFileExist, doesDirectoryExist)
+import System.Directory (getCurrentDirectory, getDirectoryContents, doesFileExist)
 import System.FilePath ((</>),takeDirectory)
 
 ----------------------------------------------------------------
 
 -- | Finding 'Cradle'.
---   An error would be thrown.
-findCradle :: Maybe FilePath -- ^ A 'FilePath' for a sandbox.
-           -> GHCVersion
-           -> IO Cradle
-findCradle (Just sbox) strver = do
-    (pkgConf,exist) <- checkPackageConf sbox strver
-    unless exist $  throwIO $ userError $ pkgConf ++ " not found"
+findCradle :: IO Cradle
+findCradle = do
     wdir <- getCurrentDirectory
-    cfiles <- cabalDir wdir
-    return $ case cfiles of
-        Nothing -> Cradle {
-            cradleCurrentDir  = wdir
-          , cradleCabalDir    = Nothing
-          , cradleCabalFile   = Nothing
-          , cradlePackageConf = Just pkgConf
-          }
-        Just (cdir,cfile,_) -> Cradle {
-            cradleCurrentDir  = wdir
-          , cradleCabalDir    = Just cdir
-          , cradleCabalFile   = Just cfile
-          , cradlePackageConf = Just pkgConf
-          }
-findCradle Nothing strver = do
-    wdir <- getCurrentDirectory
-    cfiles <- cabalDir wdir
-    case cfiles of
-        Nothing -> return Cradle {
-            cradleCurrentDir  = wdir
-          , cradleCabalDir    = Nothing
-          , cradleCabalFile   = Nothing
-          , cradlePackageConf = Nothing
-          }
-        Just (cdir,cfile,Nothing) -> do
-            return Cradle {
-                cradleCurrentDir  = wdir
-              , cradleCabalDir    = Just cdir
-              , cradleCabalFile   = Just cfile
-              , cradlePackageConf = Nothing
-              }
-        Just (cdir,cfile,Just sbox) -> do
-            (pkgConf,exist) <- checkPackageConf sbox strver
-            return Cradle {
-                cradleCurrentDir  = wdir
-              , cradleCabalDir    = Just cdir
-              , cradleCabalFile   = Just cfile
-              , cradlePackageConf = if exist then Just pkgConf else Nothing
-              }
+    findCradle' wdir `E.catch` handler wdir
+  where
+    handler :: FilePath -> SomeException -> IO Cradle
+    handler wdir _ = return Cradle {
+        cradleCurrentDir  = wdir
+      , cradleCabalDir    = Nothing
+      , cradleCabalFile   = Nothing
+      , cradlePackageConf = Nothing
+      }
+
+findCradle' :: FilePath -> IO Cradle
+findCradle' wdir = do
+    (cdir,cfile) <- cabalDir wdir
+    mPkgConf <- getPackageDbDir cdir
+    return Cradle {
+        cradleCurrentDir  = wdir
+      , cradleCabalDir    = Just cdir
+      , cradleCabalFile   = Just cfile
+      , cradlePackageConf = mPkgConf
+      }
 
 ----------------------------------------------------------------
 
@@ -72,52 +47,42 @@ cabalSuffixLength = length cabalSuffix
 -- Finding a Cabal file up to the root directory
 -- Input: a directly to investigate
 -- Output: (the path to the directory containing a Cabal file
---         ,the path to the Cabal file
---         ,Just the path to the sandbox directory)
-cabalDir :: FilePath -> IO (Maybe (FilePath,FilePath,Maybe FilePath))
+--         ,the path to the Cabal file)
+cabalDir :: FilePath -> IO (FilePath,FilePath)
 cabalDir dir = do
-    cnts <- (filter isCabal <$> getDirectoryContents dir)
-            >>= filterM (\file -> doesFileExist (dir </> file))
-    let dir' = takeDirectory dir
+    cnts <- getCabalFiles dir
     case cnts of
-        [] | dir' == dir -> return Nothing
+        [] | dir' == dir -> throwIO $ userError "cabal files not found"
            | otherwise   -> cabalDir dir'
-        cfile:_          -> do
-            msbox <- checkSandbox dir
-            return $ Just (dir,dir </> cfile, msbox)
+        cfile:_          -> return (dir,dir </> cfile)
+  where
+    dir' = takeDirectory dir
+
+getCabalFiles :: FilePath -> IO [FilePath]
+getCabalFiles dir = getFiles >>= filterM doesCabalFileExist
   where
     isCabal name = cabalSuffix `isSuffixOf` name
                 && length name > cabalSuffixLength
+    getFiles = filter isCabal <$> getDirectoryContents dir
+    doesCabalFileExist file = doesFileExist $ dir </> file
 
 ----------------------------------------------------------------
 
-sandboxConfig :: String
-sandboxConfig = "cabal.sandbox.config"
+configFile :: String
+configFile = "cabal.sandbox.config"
 
-sandboxDir :: String
-sandboxDir = ".cabal-sandbox"
+pkgDbKey :: String
+pkgDbKey = "package-db:"
 
-checkSandbox :: FilePath -> IO (Maybe FilePath)
-checkSandbox dir = do
-    let conf = dir </> sandboxConfig
-        sbox = dir </> sandboxDir
-    sandboxConfigExists <- doesFileExist conf
-    sandboxExists <- doesDirectoryExist sbox
-    if sandboxConfigExists && sandboxExists then
-        return (Just sbox)
-      else
-        return Nothing
+pkgDbKeyLen :: Int
+pkgDbKeyLen = length pkgDbKey
 
-----------------------------------------------------------------
-
-packageConfName :: GHCVersion -> FilePath
-packageConfName strver = Text.display buildPlatform
-                      ++ "-ghc-"
-                      ++ strver
-                      ++ "-packages.conf.d"
-
-checkPackageConf :: FilePath -> GHCVersion -> IO (FilePath, Bool)
-checkPackageConf path strver = do
-    let dir = path </> packageConfName strver
-    exist <- doesDirectoryExist dir
-    return (dir,exist)
+-- | Extract a package db directory from the sandbox config file.
+getPackageDbDir :: FilePath -> IO (Maybe FilePath)
+getPackageDbDir cdir = (Just <$> getPkgDb) `E.catch` handler
+  where
+    getPkgDb = extractValue . parse <$> readFile (cdir </> configFile)
+    parse = head . filter ("package-db:" `isPrefixOf`) . lines
+    extractValue = fst . break isSpace . dropWhile isSpace . drop pkgDbKeyLen
+    handler :: SomeException -> IO (Maybe FilePath)
+    handler _ = return Nothing

Language/Haskell/GhcMod/Types.hs

@@ -19,8 +19,6 @@ data Options = Options {
   , detailed      :: Bool
   -- | Whether or not Template Haskell should be expanded.
   , expandSplice  :: Bool
-  -- | The sandbox directory.
-  , sandbox       :: Maybe FilePath
   -- | Line separator string.
   , lineSeparator :: LineSeparator
   }
@@ -34,7 +32,6 @@ defaultOptions = Options {
   , operators     = False
   , detailed      = False
   , expandSplice  = False
-  , sandbox       = Nothing
   , lineSeparator = LineSeparator "\0"
   }