hasufell/ghc-mod
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Supporting sandbox sharing.

Browse Source 
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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

143
Language/Haskell/GhcMod/Cradle.hs
View File

@ -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

3
Language/Haskell/GhcMod/Types.hs
View File

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

5
src/GHCMod.hs
View File

@ -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

2
test/CabalApiSpec.hs
View File

@ -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) }

10
test/CheckSpec.hs
View File

@ -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 Nothing strVer
cradle <- findCradle
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 Nothing strVer
cradle <- findCradle
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`)

18
test/CradleSpec.hs
View File

@ -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

2
test/DebugSpec.hs
View File

@ -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]

13
test/InfoSpec.hs
View File

@ -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 Nothing strVer
cradle <- findCradle
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`)