From 49791fb6ea6c4fae38d9cf8fd3b1faebb18edcf3 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Fri, 20 Sep 2013 15:48:50 +0900 Subject: [PATCH] Supporting sandbox sharing. Braking backword compatibility of findCradle. --- Language/Haskell/GhcMod/Cradle.hs | 143 +++++++++++------------------- Language/Haskell/GhcMod/Types.hs | 3 - src/GHCMod.hs | 5 +- test/CabalApiSpec.hs | 2 +- test/CheckSpec.hs | 10 +-- test/CradleSpec.hs | 18 ++-- test/DebugSpec.hs | 2 +- test/InfoSpec.hs | 13 ++- 8 files changed, 74 insertions(+), 122 deletions(-) diff --git a/Language/Haskell/GhcMod/Cradle.hs b/Language/Haskell/GhcMod/Cradle.hs index b1e2401..c5fa6ec 100644 --- a/Language/Haskell/GhcMod/Cradle.hs +++ b/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 \ No newline at end of file diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index 9b65b44..489bc46 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/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" } diff --git a/src/GHCMod.hs b/src/GHCMod.hs index 22ae144..4de9ae2 100644 --- a/src/GHCMod.hs +++ b/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 diff --git a/test/CabalApiSpec.hs b/test/CabalApiSpec.hs index 4f75dff..a1e4969 100644 --- a/test/CabalApiSpec.hs +++ b/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) } diff --git a/test/CheckSpec.hs b/test/CheckSpec.hs index a2f57f8..d289a08 100644 --- a/test/CheckSpec.hs +++ b/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 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`) diff --git a/test/CradleSpec.hs b/test/CradleSpec.hs index aaa5198..8ffcb28 100644 --- a/test/CradleSpec.hs +++ b/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 diff --git a/test/DebugSpec.hs b/test/DebugSpec.hs index aa448e2..15f8958 100644 --- a/test/DebugSpec.hs +++ b/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] diff --git a/test/InfoSpec.hs b/test/InfoSpec.hs index bce686c..02d5a61 100644 --- a/test/InfoSpec.hs +++ b/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 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`)