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.Exception as E (catch, throwIO, SomeException)
-import Control.Monad (unless, filterM)
+import Control.Monad (filterM)
-import Data.List (isSuffixOf)
+import Data.List (isPrefixOf, isSuffixOf)
-import Distribution.System (buildPlatform)
-import qualified Distribution.Text as Text (display)
 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 :: IO Cradle
-findCradle :: Maybe FilePath -- ^ A 'FilePath' for a sandbox.
+findCradle = do
-           -> GHCVersion
-           -> IO Cradle
-findCradle (Just sbox) strver = do
-    (pkgConf,exist) <- checkPackageConf sbox strver
-    unless exist $  throwIO $ userError $ pkgConf ++ " not found"
     wdir <- getCurrentDirectory
-    cfiles <- cabalDir wdir
+    findCradle' wdir `E.catch` handler wdir
-    return $ case cfiles of
+  where
-        Nothing -> Cradle {
+    handler :: FilePath -> SomeException -> IO Cradle
-            cradleCurrentDir  = wdir
+    handler wdir _ = return Cradle {
-          , cradleCabalDir    = Nothing
+        cradleCurrentDir  = wdir
-          , cradleCabalFile   = Nothing
+      , cradleCabalDir    = Nothing
-          , cradlePackageConf = Just pkgConf
+      , cradleCabalFile   = Nothing
-          }
+      , cradlePackageConf = Nothing
-        Just (cdir,cfile,_) -> Cradle {
+      }
-            cradleCurrentDir  = wdir
+
-          , cradleCabalDir    = Just cdir
+findCradle' :: FilePath -> IO Cradle
-          , cradleCabalFile   = Just cfile
+findCradle' wdir = do
-          , cradlePackageConf = Just pkgConf
+    (cdir,cfile) <- cabalDir wdir
-          }
+    mPkgConf <- getPackageDbDir cdir
-findCradle Nothing strver = do
+    return Cradle {
-    wdir <- getCurrentDirectory
+        cradleCurrentDir  = wdir
-    cfiles <- cabalDir wdir
+      , cradleCabalDir    = Just cdir
-    case cfiles of
+      , cradleCabalFile   = Just cfile
-        Nothing -> return Cradle {
+      , cradlePackageConf = mPkgConf
-            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
-              }
 
 ----------------------------------------------------------------
 
@@ -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
+--         ,the path to the Cabal file)
---         ,Just the path to the sandbox directory)
+cabalDir :: FilePath -> IO (FilePath,FilePath)
-cabalDir :: FilePath -> IO (Maybe (FilePath,FilePath,Maybe FilePath))
 cabalDir dir = do
-    cnts <- (filter isCabal <$> getDirectoryContents dir)
+    cnts <- getCabalFiles dir
-            >>= filterM (\file -> doesFileExist (dir </> file))
-    let dir' = takeDirectory dir
     case cnts of
-        [] | dir' == dir -> return Nothing
+        [] | dir' == dir -> throwIO $ userError "cabal files not found"
            | otherwise   -> cabalDir dir'
-        cfile:_          -> do
+        cfile:_          -> return (dir,dir </> cfile)
-            msbox <- checkSandbox dir
+  where
-            return $ Just (dir,dir </> cfile, msbox)
+    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
+configFile :: String
-sandboxConfig = "cabal.sandbox.config"
+configFile = "cabal.sandbox.config"
 
-sandboxDir :: String
+pkgDbKey :: String
-sandboxDir = ".cabal-sandbox"
+pkgDbKey = "package-db:"
 
-checkSandbox :: FilePath -> IO (Maybe FilePath)
+pkgDbKeyLen :: Int
-checkSandbox dir = do
+pkgDbKeyLen = length pkgDbKey
-    let conf = dir </> sandboxConfig
-        sbox = dir </> sandboxDir
-    sandboxConfigExists <- doesFileExist conf
-    sandboxExists <- doesDirectoryExist sbox
-    if sandboxConfigExists && sandboxExists then
-        return (Just sbox)
-      else
-        return Nothing
 
-----------------------------------------------------------------
+-- | Extract a package db directory from the sandbox config file.
-
+getPackageDbDir :: FilePath -> IO (Maybe FilePath)
-packageConfName :: GHCVersion -> FilePath
+getPackageDbDir cdir = (Just <$> getPkgDb) `E.catch` handler
-packageConfName strver = Text.display buildPlatform
+  where
-                      ++ "-ghc-"
+    getPkgDb = extractValue . parse <$> readFile (cdir </> configFile)
-                      ++ strver
+    parse = head . filter ("package-db:" `isPrefixOf`) . lines
-                      ++ "-packages.conf.d"
+    extractValue = fst . break isSpace . dropWhile isSpace . drop pkgDbKeyLen
-
+    handler :: SomeException -> IO (Maybe FilePath)
-checkPackageConf :: FilePath -> GHCVersion -> IO (FilePath, Bool)
+    handler _ = return Nothing
-checkPackageConf path strver = do
-    let dir = path </> packageConfName strver
-    exist <- doesDirectoryExist dir
-    return (dir,exist)

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

src/GHCMod.hs

@@ -55,9 +55,6 @@ argspec = [ Option "l" ["tolisp"]
           , Option "d" ["detailed"]
             (NoArg (\opts -> opts { detailed = True }))
             "print detailed info"
-          , Option "s" ["sandbox"]
-            (ReqArg (\s opts -> opts { sandbox = Just s }) "path")
-            "specify a sandbox"
           , Option "b" ["boundary"]
             (ReqArg (\s opts -> opts { lineSeparator = LineSeparator s }) "sep")
             "specify line separator (default is Nul string)"
@@ -89,7 +86,7 @@ main = flip catches handlers $ do
     args <- getArgs
     let (opt',cmdArg) = parseArgs argspec args
     (strVer,ver) <- getGHCVersion
-    cradle <- findCradle (sandbox opt') strVer
+    cradle <- findCradle
     let opt = adjustOpts opt' cradle ver
         cmdArg0 = cmdArg !. 0
         cmdArg1 = cmdArg !. 1

test/CabalApiSpec.hs

@@ -21,7 +21,7 @@ spec = do
     describe "getCompilerOptions" $ do
         it "gets necessary CompilerOptions" $ do
             withDirectory "test/data/subdir1/subdir2" $ \dir -> do
-                cradle <- findCradle Nothing "7.6.3"
+                cradle <- findCradle
                 pkgDesc <- parseCabalFile $ fromJust $ cradleCabalFile cradle
                 res <- getCompilerOptions [] cradle pkgDesc
                 let res' = res { includeDirs = map (toRelativeDir dir) (includeDirs res) }

test/CheckSpec.hs

@@ -12,26 +12,24 @@ spec = do
     describe "checkSyntax" $ do
         it "can check even if an executable depends on its library" $ do
             withDirectory_ "test/data/ghc-mod-check" $ do
-                (strVer,_) <- getGHCVersion
+                cradle <- findCradle
-                cradle <- findCradle Nothing strVer
                 res <- checkSyntax defaultOptions cradle ["main.hs"]
                 res `shouldBe` "main.hs:5:1:Warning: Top-level binding with no type signature: main :: IO ()\NUL\n"
 
         it "can check even if a test module imports another test module located at different directory" $ do
             withDirectory_ "test/data/check-test-subdir" $ do
-                cradle <- getGHCVersion >>= findCradle Nothing . fst
+                cradle <- findCradle
                 res <- checkSyntax defaultOptions cradle ["test/Bar/Baz.hs"]
                 res `shouldSatisfy` (("test" </> "Foo.hs:3:1:Warning: Top-level binding with no type signature: foo :: [Char]\NUL\n") `isSuffixOf`)
 
         it "can detect mutually imported modules" $ do
             withDirectory_ "test/data" $ do
-                (strVer,_) <- getGHCVersion
+                cradle <- findCradle
-                cradle <- findCradle Nothing strVer
                 res <- checkSyntax defaultOptions cradle ["Mutual1.hs"]
                 res `shouldSatisfy` ("Module imports form a cycle" `isInfixOf`)
 
         it "can check a module using QuasiQuotes" $ do
             withDirectory_ "test/data" $ do
-                cradle <- getGHCVersion >>= findCradle Nothing . fst
+                cradle <- findCradle
                 res <- checkSyntax defaultOptions cradle ["Baz.hs"]
                 res `shouldSatisfy` ("Baz.hs:5:1:Warning:" `isPrefixOf`)

test/CradleSpec.hs

@@ -3,7 +3,7 @@ module CradleSpec where
 import Control.Applicative
 import Language.Haskell.GhcMod
 import System.Directory (canonicalizePath)
-import System.FilePath (addTrailingPathSeparator, (</>))
+import System.FilePath ((</>))
 import Test.Hspec
 
 import Dir
@@ -14,7 +14,7 @@ spec = do
         it "returns the current directory" $ do
             withDirectory_ "/" $ do
                 curDir <- canonicalizePath "/"
-                res <- findCradle Nothing "7.4.1"
+                res <- findCradle
                 res `shouldBe` Cradle {
                     cradleCurrentDir = curDir
                   , cradleCabalDir = Nothing
@@ -24,7 +24,7 @@ spec = do
 
         it "finds a cabal file" $ do
             withDirectory "test/data/subdir1/subdir2" $ \dir -> do
-                res <- relativeCradle dir <$> findCradle Nothing "7.4.1"
+                res <- relativeCradle dir <$> findCradle
                 res `shouldBe` Cradle {
                     cradleCurrentDir = "test" </> "data" </> "subdir1" </> "subdir2"
                   , cradleCabalDir = Just ("test" </> "data")
@@ -34,7 +34,7 @@ spec = do
 
         it "finds a sandbox" $ do
             withDirectory "test/data/subdir1/subdir2" $ \dir -> do
-                res <- relativeCradle dir <$> findCradle Nothing "7.6.3"
+                res <- relativeCradle dir <$> findCradle
                 res `shouldBe` Cradle {
                     cradleCurrentDir = "test" </> "data" </> "subdir1" </> "subdir2"
                   , cradleCabalDir = Just ("test" </> "data")
@@ -42,21 +42,17 @@ spec = do
                   , cradlePackageConf = Just ("test" </> "data" </> ".cabal-sandbox" </> "i386-osx-ghc-7.6.3-packages.conf.d")
                   }
 
-        it "finds a sandbox if exists" $ do
+        it "works even if no cabal and no sandbox exist" $ do
             withDirectory "/" $ \dir -> do
                 curDir <- canonicalizePath "/"
-                res <- relativeCradle dir <$> findCradle (Just $ addTrailingPathSeparator dir ++ ("test" </> "data" </> ".cabal-sandbox")) "7.6.3"
+                res <- relativeCradle dir <$> findCradle
                 res `shouldBe` Cradle {
                     cradleCurrentDir = curDir
                   , cradleCabalDir = Nothing
                   , cradleCabalFile = Nothing
-                  , cradlePackageConf = Just ("test" </> "data" </> ".cabal-sandbox" </> "i386-osx-ghc-7.6.3-packages.conf.d")
+                  , cradlePackageConf = Nothing
                   }
 
-        it "throws an error if the sandbox does not exist" $ do
-            withDirectory_ "/" $
-                findCradle (Just "/") "7.4.1" `shouldThrow` anyIOException
-
 relativeCradle :: FilePath -> Cradle -> Cradle
 relativeCradle dir cradle = Cradle {
     cradleCurrentDir  = toRelativeDir dir  $  cradleCurrentDir  cradle

test/DebugSpec.hs

@@ -8,7 +8,7 @@ import Dir
 checkFast :: String -> String -> IO ()
 checkFast file ans = withDirectory_ "test/data" $ do
     (strVer,_) <- getGHCVersion
-    cradle <- findCradle Nothing strVer
+    cradle <- findCradle
     res <- debugInfo defaultOptions cradle strVer file
     lines res `shouldContain` [ans]
 

test/InfoSpec.hs

@@ -13,39 +13,38 @@ spec = do
     describe "typeExpr" $ do
         it "shows types of the expression and its outers" $ do
             withDirectory_ "test/data/ghc-mod-check" $ do
-                (strVer,_) <- getGHCVersion
+                cradle <- findCradle
-                cradle <- findCradle Nothing strVer
                 res <- typeExpr defaultOptions cradle "Data/Foo.hs" "Data.Foo" 9 5
                 res `shouldBe` "9 5 11 40 \"Int -> a -> a -> a\"\n7 1 11 40 \"Int -> Integer\"\n"
 
         it "works with a module using TemplateHaskell" $ do
             withDirectory_ "test/data" $ do
-                cradle <- getGHCVersion >>= findCradle Nothing . fst
+                cradle <- findCradle
                 res <- typeExpr defaultOptions cradle "Bar.hs" "Bar" 5 1
                 res `shouldBe` unlines ["5 1 5 20 \"[Char]\""]
 
         it "works with a module that imports another module using TemplateHaskell" $ do
             withDirectory_ "test/data" $ do
-                cradle <- getGHCVersion >>= findCradle Nothing . fst
+                cradle <- findCradle
                 res <- typeExpr defaultOptions cradle "Main.hs" "Main" 3 8
                 res `shouldBe` unlines ["3 8 3 16 \"String -> IO ()\"", "3 8 3 20 \"IO ()\"", "3 1 3 20 \"IO ()\""]
 
     describe "infoExpr" $ do
         it "works for non-export functions" $ do
             withDirectory_ "test/data" $ do
-                cradle <- getGHCVersion >>= findCradle Nothing . fst
+                cradle <- findCradle
                 res <- infoExpr defaultOptions cradle "Info.hs" "Info" "fib"
                 res `shouldSatisfy` ("fib :: Int -> Int" `isPrefixOf`)
 
         it "works with a module using TemplateHaskell" $ do
             withDirectory_ "test/data" $ do
-                cradle <- getGHCVersion >>= findCradle Nothing . fst
+                cradle <- findCradle
                 res <- infoExpr defaultOptions cradle "Bar.hs" "Bar" "foo"
                 res `shouldSatisfy` ("foo :: ExpQ" `isPrefixOf`)
 
         it "works with a module that imports another module using TemplateHaskell" $ do
             withDirectory_ "test/data" $ do
-                cradle <- getGHCVersion >>= findCradle Nothing . fst
+                cradle <- findCradle
                 res <- infoExpr defaultOptions cradle "Main.hs" "Main" "bar"
                 res `shouldSatisfy` ("bar :: [Char]" `isPrefixOf`)