Supporting sandbox sharing.

Braking backword compatibility of findCradle.
This commit is contained in:
Kazu Yamamoto 2013-09-20 15:48:50 +09:00
parent d58c11bcc3
commit 49791fb6ea
8 changed files with 74 additions and 122 deletions

View File

@ -1,64 +1,39 @@
module Language.Haskell.GhcMod.Cradle (findCradle) where module Language.Haskell.GhcMod.Cradle (findCradle) where
import Data.Char (isSpace)
import Control.Applicative ((<$>)) 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 Language.Haskell.GhcMod.Types
import System.Directory (getCurrentDirectory, getDirectoryContents, doesFileExist, doesDirectoryExist) import System.Directory (getCurrentDirectory, getDirectoryContents, doesFileExist)
import System.FilePath ((</>),takeDirectory) import System.FilePath ((</>),takeDirectory)
---------------------------------------------------------------- ----------------------------------------------------------------
-- | Finding 'Cradle'. -- | 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 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
, 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 cradleCurrentDir = wdir
, cradleCabalDir = Nothing , cradleCabalDir = Nothing
, cradleCabalFile = Nothing , cradleCabalFile = Nothing
, cradlePackageConf = Nothing , cradlePackageConf = Nothing
} }
Just (cdir,cfile,Nothing) -> do
findCradle' :: FilePath -> IO Cradle
findCradle' wdir = do
(cdir,cfile) <- cabalDir wdir
mPkgConf <- getPackageDbDir cdir
return Cradle { return Cradle {
cradleCurrentDir = wdir cradleCurrentDir = wdir
, cradleCabalDir = Just cdir , cradleCabalDir = Just cdir
, cradleCabalFile = Just cfile , cradleCabalFile = Just cfile
, cradlePackageConf = Nothing , cradlePackageConf = mPkgConf
}
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 -- Finding a Cabal file up to the root directory
-- Input: a directly to investigate -- Input: a directly to investigate
-- Output: (the path to the directory containing a Cabal file -- 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 cabalDir dir = do
cnts <- (filter isCabal <$> getDirectoryContents dir) cnts <- getCabalFiles dir
>>= filterM (\file -> doesFileExist (dir </> file))
let dir' = takeDirectory dir
case cnts of case cnts of
[] | dir' == dir -> return Nothing [] | dir' == dir -> throwIO $ userError "cabal files not found"
| otherwise -> cabalDir dir' | 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 where
isCabal name = cabalSuffix `isSuffixOf` name isCabal name = cabalSuffix `isSuffixOf` name
&& length name > cabalSuffixLength && 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)

View File

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

View File

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

View File

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

View File

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

View File

@ -3,7 +3,7 @@ module CradleSpec where
import Control.Applicative import Control.Applicative
import Language.Haskell.GhcMod import Language.Haskell.GhcMod
import System.Directory (canonicalizePath) import System.Directory (canonicalizePath)
import System.FilePath (addTrailingPathSeparator, (</>)) import System.FilePath ((</>))
import Test.Hspec import Test.Hspec
import Dir import Dir
@ -14,7 +14,7 @@ spec = do
it "returns the current directory" $ do it "returns the current directory" $ do
withDirectory_ "/" $ do withDirectory_ "/" $ do
curDir <- canonicalizePath "/" curDir <- canonicalizePath "/"
res <- findCradle Nothing "7.4.1" res <- findCradle
res `shouldBe` Cradle { res `shouldBe` Cradle {
cradleCurrentDir = curDir cradleCurrentDir = curDir
, cradleCabalDir = Nothing , cradleCabalDir = Nothing
@ -24,7 +24,7 @@ spec = do
it "finds a cabal file" $ do it "finds a cabal file" $ do
withDirectory "test/data/subdir1/subdir2" $ \dir -> do withDirectory "test/data/subdir1/subdir2" $ \dir -> do
res <- relativeCradle dir <$> findCradle Nothing "7.4.1" res <- relativeCradle dir <$> findCradle
res `shouldBe` Cradle { res `shouldBe` Cradle {
cradleCurrentDir = "test" </> "data" </> "subdir1" </> "subdir2" cradleCurrentDir = "test" </> "data" </> "subdir1" </> "subdir2"
, cradleCabalDir = Just ("test" </> "data") , cradleCabalDir = Just ("test" </> "data")
@ -34,7 +34,7 @@ spec = do
it "finds a sandbox" $ do it "finds a sandbox" $ do
withDirectory "test/data/subdir1/subdir2" $ \dir -> do withDirectory "test/data/subdir1/subdir2" $ \dir -> do
res <- relativeCradle dir <$> findCradle Nothing "7.6.3" res <- relativeCradle dir <$> findCradle
res `shouldBe` Cradle { res `shouldBe` Cradle {
cradleCurrentDir = "test" </> "data" </> "subdir1" </> "subdir2" cradleCurrentDir = "test" </> "data" </> "subdir1" </> "subdir2"
, cradleCabalDir = Just ("test" </> "data") , 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") , 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 withDirectory "/" $ \dir -> do
curDir <- canonicalizePath "/" curDir <- canonicalizePath "/"
res <- relativeCradle dir <$> findCradle (Just $ addTrailingPathSeparator dir ++ ("test" </> "data" </> ".cabal-sandbox")) "7.6.3" res <- relativeCradle dir <$> findCradle
res `shouldBe` Cradle { res `shouldBe` Cradle {
cradleCurrentDir = curDir cradleCurrentDir = curDir
, cradleCabalDir = Nothing , cradleCabalDir = Nothing
, cradleCabalFile = 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 :: FilePath -> Cradle -> Cradle
relativeCradle dir cradle = Cradle { relativeCradle dir cradle = Cradle {
cradleCurrentDir = toRelativeDir dir $ cradleCurrentDir cradle cradleCurrentDir = toRelativeDir dir $ cradleCurrentDir cradle

View File

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

View File

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