Fix #387, Pattern match failure in GhcPkg
This commit is contained in:
parent
dbe66cbaa3
commit
9ac128aa6f
@ -2,6 +2,7 @@ module Language.Haskell.GhcMod.Cradle (
|
||||
findCradle
|
||||
, findCradle'
|
||||
, findCradleWithoutSandbox
|
||||
, cleanupCradle
|
||||
) where
|
||||
|
||||
import Language.Haskell.GhcMod.Types
|
||||
@ -12,8 +13,10 @@ import qualified Control.Exception as E
|
||||
import Control.Exception.IOChoice ((||>))
|
||||
import Control.Monad (filterM)
|
||||
import Data.List (isSuffixOf)
|
||||
import System.Directory (getCurrentDirectory, getDirectoryContents, doesFileExist)
|
||||
import System.Directory (getCurrentDirectory, getDirectoryContents, doesFileExist, getTemporaryDirectory, removeDirectoryRecursive)
|
||||
import System.FilePath ((</>), takeDirectory)
|
||||
import System.IO.Temp
|
||||
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
@ -27,13 +30,26 @@ findCradle = findCradle' =<< getCurrentDirectory
|
||||
findCradle' :: FilePath -> IO Cradle
|
||||
findCradle' dir = cabalCradle dir ||> sandboxCradle dir ||> plainCradle dir
|
||||
|
||||
newTempDir :: FilePath -> IO FilePath
|
||||
newTempDir dir =
|
||||
flip createTempDirectory uniqPathName =<< getTemporaryDirectory
|
||||
where
|
||||
uniqPathName = "ghc-mod" ++ map escapeSlash dir
|
||||
escapeSlash '/' = '-'
|
||||
escapeSlash c = c
|
||||
|
||||
cleanupCradle :: Cradle -> IO ()
|
||||
cleanupCradle crdl = removeDirectoryRecursive $ cradleTempDir crdl
|
||||
|
||||
cabalCradle :: FilePath -> IO Cradle
|
||||
cabalCradle wdir = do
|
||||
(rdir,cfile) <- cabalDir wdir
|
||||
pkgDbStack <- getPackageDbStack rdir
|
||||
tmpDir <- newTempDir rdir
|
||||
return Cradle {
|
||||
cradleCurrentDir = wdir
|
||||
, cradleRootDir = rdir
|
||||
, cradleTempDir = tmpDir
|
||||
, cradleCabalFile = Just cfile
|
||||
, cradlePkgDbStack = pkgDbStack
|
||||
}
|
||||
@ -42,17 +58,22 @@ sandboxCradle :: FilePath -> IO Cradle
|
||||
sandboxCradle wdir = do
|
||||
rdir <- getSandboxDir wdir
|
||||
pkgDbStack <- getPackageDbStack rdir
|
||||
tmpDir <- newTempDir rdir
|
||||
return Cradle {
|
||||
cradleCurrentDir = wdir
|
||||
, cradleRootDir = rdir
|
||||
, cradleTempDir = tmpDir
|
||||
, cradleCabalFile = Nothing
|
||||
, cradlePkgDbStack = pkgDbStack
|
||||
}
|
||||
|
||||
plainCradle :: FilePath -> IO Cradle
|
||||
plainCradle wdir = return Cradle {
|
||||
plainCradle wdir = do
|
||||
tmpDir <- newTempDir wdir
|
||||
return Cradle {
|
||||
cradleCurrentDir = wdir
|
||||
, cradleRootDir = wdir
|
||||
, cradleTempDir = tmpDir
|
||||
, cradleCabalFile = Nothing
|
||||
, cradlePkgDbStack = [GlobalDb, UserDb]
|
||||
}
|
||||
|
@ -17,7 +17,6 @@ module Language.Haskell.GhcMod.Find
|
||||
|
||||
import Control.Applicative ((<$>))
|
||||
import Control.Monad (when, void)
|
||||
import Control.Monad.Error.Class
|
||||
import Data.Function (on)
|
||||
import Data.List (groupBy, sort)
|
||||
import Data.Maybe (fromMaybe)
|
||||
@ -87,10 +86,11 @@ lookupSym sym db = fromMaybe [] $ M.lookup sym $ table db
|
||||
---------------------------------------------------------------
|
||||
|
||||
-- | Loading a file and creates 'SymbolDb'.
|
||||
loadSymbolDb :: (IOish m, MonadError GhcModError m) => m SymbolDb
|
||||
loadSymbolDb :: IOish m => GhcModT m SymbolDb
|
||||
loadSymbolDb = do
|
||||
ghcMod <- liftIO ghcModExecutable
|
||||
file <- chop <$> readProcess' ghcMod ["dumpsym"]
|
||||
tmpdir <- liftIO . getPackageCachePath =<< cradle
|
||||
file <- chop <$> readProcess' ghcMod ["dumpsym", tmpdir]
|
||||
!db <- M.fromAscList . map conv . lines <$> liftIO (readFile file)
|
||||
return $ SymbolDb {
|
||||
table = db
|
||||
@ -110,10 +110,8 @@ loadSymbolDb = do
|
||||
-- if the file does not exist or is invalid.
|
||||
-- The file name is printed.
|
||||
|
||||
dumpSymbol :: IOish m => GhcModT m String
|
||||
dumpSymbol = do
|
||||
crdl <- cradle
|
||||
dir <- liftIO $ getPackageCachePath crdl
|
||||
dumpSymbol :: IOish m => FilePath -> GhcModT m String
|
||||
dumpSymbol dir = do
|
||||
let cache = dir </> symbolCache
|
||||
pkgdb = dir </> packageCache
|
||||
|
||||
|
@ -16,16 +16,19 @@ module Language.Haskell.GhcMod.GhcPkg (
|
||||
import Config (cProjectVersion, cTargetPlatformString, cProjectVersionInt)
|
||||
import Control.Applicative ((<$>))
|
||||
import Control.Exception (SomeException(..))
|
||||
import Control.Monad
|
||||
import qualified Control.Exception as E
|
||||
import Data.Char (isSpace)
|
||||
import Data.List (isPrefixOf, intercalate)
|
||||
import Data.List.Split (splitOn)
|
||||
import Data.Maybe
|
||||
import Distribution.Package (InstalledPackageId(..))
|
||||
import Exception (handleIO)
|
||||
import Language.Haskell.GhcMod.Types
|
||||
import Language.Haskell.GhcMod.Utils
|
||||
import System.Directory (doesDirectoryExist, getAppUserDataDirectory)
|
||||
import System.FilePath ((</>))
|
||||
import qualified Data.Traversable as T
|
||||
|
||||
ghcVersion :: Int
|
||||
ghcVersion = read cProjectVersionInt
|
||||
@ -117,12 +120,14 @@ packageCache = "package.cache"
|
||||
packageConfDir :: String
|
||||
packageConfDir = "package.conf.d"
|
||||
|
||||
-- fixme: error handling
|
||||
getPackageCachePath :: Cradle -> IO FilePath
|
||||
getPackageCachePath crdl = do
|
||||
let u:_ = filter (/= GlobalDb) $ cradlePkgDbStack crdl
|
||||
Just db <- resolvePath u
|
||||
return db
|
||||
let mu = listToMaybe $ filter (/= GlobalDb) $ cradlePkgDbStack crdl
|
||||
mdb <- join <$> resolvePath `T.traverse` mu
|
||||
let dir = case mdb of
|
||||
Just db -> db
|
||||
Nothing -> cradleTempDir crdl
|
||||
return dir
|
||||
|
||||
--- Copied from ghc module `Packages' unfortunately it's not exported :/
|
||||
resolvePath :: GhcPkgDb -> IO (Maybe FilePath)
|
||||
|
@ -244,6 +244,9 @@ newGhcModEnv opt dir = do
|
||||
, gmCradle = c
|
||||
}
|
||||
|
||||
cleanupGhcModEnv :: GhcModEnv -> IO ()
|
||||
cleanupGhcModEnv env = cleanupCradle $ gmCradle env
|
||||
|
||||
-- | Run a @GhcModT m@ computation.
|
||||
runGhcModT :: IOish m
|
||||
=> Options
|
||||
@ -251,11 +254,13 @@ runGhcModT :: IOish m
|
||||
-> m (Either GhcModError a, GhcModLog)
|
||||
runGhcModT opt action = do
|
||||
env <- liftBase $ newGhcModEnv opt =<< getCurrentDirectory
|
||||
first (fst <$>) <$> (runGhcModT' env defaultState $ do
|
||||
r <- first (fst <$>) <$> (runGhcModT' env defaultState $ do
|
||||
dflags <- getSessionDynFlags
|
||||
defaultCleanupHandler dflags $ do
|
||||
initializeFlagsWithCradle opt (gmCradle env)
|
||||
action)
|
||||
liftBase $ cleanupGhcModEnv env
|
||||
return r
|
||||
|
||||
-- | @hoistGhcModT result@. Embed a GhcModT computation's result into a GhcModT
|
||||
-- computation. Note that if the computation that returned @result@ modified the
|
||||
|
@ -65,6 +65,8 @@ data Cradle = Cradle {
|
||||
cradleCurrentDir :: FilePath
|
||||
-- | The project root directory.
|
||||
, cradleRootDir :: FilePath
|
||||
-- | Per-Project temporary directory
|
||||
, cradleTempDir :: FilePath
|
||||
-- | The file name of the found cabal file.
|
||||
, cradleCabalFile :: Maybe FilePath
|
||||
-- | Package database stack
|
||||
|
@ -109,6 +109,7 @@ Library
|
||||
, pretty
|
||||
, process
|
||||
, syb
|
||||
, temporary
|
||||
, time
|
||||
, transformers
|
||||
, transformers-base
|
||||
@ -212,6 +213,7 @@ Test-Suite spec
|
||||
, pretty
|
||||
, process
|
||||
, syb
|
||||
, temporary
|
||||
, time
|
||||
, transformers
|
||||
, transformers-base
|
||||
|
@ -409,9 +409,9 @@ flagsCmd = withParseCmd [] $ \[] -> flags
|
||||
debugInfoCmd = withParseCmd [] $ \[] -> debugInfo
|
||||
rootInfoCmd = withParseCmd [] $ \[] -> rootInfo
|
||||
-- internal
|
||||
dumpSymbolCmd = withParseCmd [] $ \[] -> dumpSymbol
|
||||
bootCmd = withParseCmd [] $ \[] -> boot
|
||||
|
||||
dumpSymbolCmd = withParseCmd [] $ \[tmpdir] -> dumpSymbol tmpdir
|
||||
findSymbolCmd = withParseCmd [] $ \[sym] -> findSymbol sym
|
||||
pkgDocCmd = withParseCmd [] $ \[mdl] -> pkgDoc mdl
|
||||
lintCmd = withParseCmd s $ \[file] -> lint file
|
||||
|
@ -17,31 +17,27 @@ spec = do
|
||||
withDirectory_ "/" $ do
|
||||
curDir <- stripLastDot <$> canonicalizePath "/"
|
||||
res <- findCradle
|
||||
res `shouldBe` Cradle {
|
||||
cradleCurrentDir = curDir
|
||||
, cradleRootDir = curDir
|
||||
, cradleCabalFile = Nothing
|
||||
, cradlePkgDbStack = [GlobalDb,UserDb]
|
||||
}
|
||||
cradleCurrentDir res `shouldBe` curDir
|
||||
cradleRootDir res `shouldBe` curDir
|
||||
cradleCabalFile res `shouldBe` Nothing
|
||||
cradlePkgDbStack res `shouldBe` [GlobalDb,UserDb]
|
||||
|
||||
it "finds a cabal file and a sandbox" $ do
|
||||
cwd <- getCurrentDirectory
|
||||
withDirectory "test/data/subdir1/subdir2" $ \dir -> do
|
||||
res <- relativeCradle dir <$> findCradle
|
||||
res `shouldBe` Cradle {
|
||||
cradleCurrentDir = "test" </> "data" </> "subdir1" </> "subdir2"
|
||||
, cradleRootDir = "test" </> "data"
|
||||
, cradleCabalFile = Just ("test" </> "data" </> "cabalapi.cabal")
|
||||
, cradlePkgDbStack = [GlobalDb, PackageDb (cwd </> "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d")]
|
||||
}
|
||||
cradleCurrentDir res `shouldBe` "test" </> "data" </> "subdir1" </> "subdir2"
|
||||
cradleRootDir res `shouldBe` "test" </> "data"
|
||||
cradleCabalFile res `shouldBe` Just ("test" </> "data" </> "cabalapi.cabal")
|
||||
cradlePkgDbStack res `shouldBe` [GlobalDb, PackageDb (cwd </> "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d")]
|
||||
|
||||
it "works even if a sandbox config file is broken" $ do
|
||||
withDirectory "test/data/broken-sandbox" $ \dir -> do
|
||||
res <- relativeCradle dir <$> findCradle
|
||||
res `shouldBe` Cradle {
|
||||
cradleCurrentDir = "test" </> "data" </> "broken-sandbox"
|
||||
, cradleRootDir = "test" </> "data" </> "broken-sandbox"
|
||||
, cradleCabalFile = Just ("test" </> "data" </> "broken-sandbox" </> "dummy.cabal")
|
||||
, cradlePkgDbStack = [GlobalDb, UserDb]
|
||||
}
|
||||
cradleCurrentDir res `shouldBe` "test" </> "data" </> "broken-sandbox"
|
||||
cradleRootDir res `shouldBe` "test" </> "data" </> "broken-sandbox"
|
||||
cradleCabalFile res `shouldBe` Just ("test" </> "data" </> "broken-sandbox" </> "dummy.cabal")
|
||||
cradlePkgDbStack res `shouldBe` [GlobalDb, UserDb]
|
||||
|
||||
relativeCradle :: FilePath -> Cradle -> Cradle
|
||||
relativeCradle dir cradle = cradle {
|
||||
|
Loading…
Reference in New Issue
Block a user