2013-09-21 06:10:43 +00:00
|
|
|
{-# LANGUAGE BangPatterns #-}
|
|
|
|
|
2013-09-21 09:37:33 +00:00
|
|
|
module Language.Haskell.GhcMod.Cradle (
|
|
|
|
findCradle
|
|
|
|
, findCradleWithoutSandbox
|
|
|
|
, getPackageDbDir
|
2014-01-30 11:09:57 +00:00
|
|
|
, getPackageDbPackages
|
2013-09-21 09:37:33 +00:00
|
|
|
) where
|
2013-03-02 03:18:55 +00:00
|
|
|
|
2013-09-20 06:48:50 +00:00
|
|
|
import Data.Char (isSpace)
|
2013-03-02 03:18:55 +00:00
|
|
|
import Control.Applicative ((<$>))
|
2013-09-20 06:48:50 +00:00
|
|
|
import Control.Exception as E (catch, throwIO, SomeException)
|
|
|
|
import Control.Monad (filterM)
|
2013-09-20 08:15:41 +00:00
|
|
|
import Data.List (isPrefixOf, isSuffixOf, tails)
|
2013-05-17 01:00:01 +00:00
|
|
|
import Language.Haskell.GhcMod.Types
|
2013-09-20 06:48:50 +00:00
|
|
|
import System.Directory (getCurrentDirectory, getDirectoryContents, doesFileExist)
|
2013-09-20 08:15:41 +00:00
|
|
|
import System.FilePath ((</>), takeDirectory, takeFileName)
|
2013-03-02 03:18:55 +00:00
|
|
|
|
2013-09-05 07:38:17 +00:00
|
|
|
----------------------------------------------------------------
|
|
|
|
|
2013-05-20 05:28:56 +00:00
|
|
|
-- | Finding 'Cradle'.
|
2013-09-20 06:53:51 +00:00
|
|
|
-- Find a cabal file by tracing ancestor directories.
|
|
|
|
-- Find a sandbox according to a cabal sandbox config
|
|
|
|
-- in a cabal directory.
|
2013-09-20 06:48:50 +00:00
|
|
|
findCradle :: IO Cradle
|
|
|
|
findCradle = do
|
2013-03-02 03:18:55 +00:00
|
|
|
wdir <- getCurrentDirectory
|
2013-09-20 06:48:50 +00:00
|
|
|
findCradle' wdir `E.catch` handler wdir
|
|
|
|
where
|
|
|
|
handler :: FilePath -> SomeException -> IO Cradle
|
|
|
|
handler wdir _ = return Cradle {
|
2013-09-20 08:15:41 +00:00
|
|
|
cradleCurrentDir = wdir
|
|
|
|
, cradleCabalDir = Nothing
|
|
|
|
, cradleCabalFile = Nothing
|
|
|
|
, cradlePackageDbOpts = []
|
2014-01-30 11:42:25 +00:00
|
|
|
, cradlePackages = []
|
2013-09-20 06:48:50 +00:00
|
|
|
}
|
|
|
|
|
|
|
|
findCradle' :: FilePath -> IO Cradle
|
|
|
|
findCradle' wdir = do
|
|
|
|
(cdir,cfile) <- cabalDir wdir
|
2013-09-20 08:15:41 +00:00
|
|
|
pkgDbOpts <- getPackageDbOpts cdir
|
2013-09-20 06:48:50 +00:00
|
|
|
return Cradle {
|
2013-09-20 08:15:41 +00:00
|
|
|
cradleCurrentDir = wdir
|
|
|
|
, cradleCabalDir = Just cdir
|
|
|
|
, cradleCabalFile = Just cfile
|
|
|
|
, cradlePackageDbOpts = pkgDbOpts
|
2014-01-30 11:42:25 +00:00
|
|
|
, cradlePackages = []
|
2013-09-20 06:48:50 +00:00
|
|
|
}
|
2013-03-02 03:18:55 +00:00
|
|
|
|
2013-09-21 09:37:33 +00:00
|
|
|
-- Just for testing
|
|
|
|
findCradleWithoutSandbox :: IO Cradle
|
|
|
|
findCradleWithoutSandbox = do
|
|
|
|
cradle <- findCradle
|
2014-01-30 11:42:25 +00:00
|
|
|
return cradle { cradlePackageDbOpts = [], cradlePackages = [] }
|
2013-09-21 09:37:33 +00:00
|
|
|
|
2013-09-05 07:38:17 +00:00
|
|
|
----------------------------------------------------------------
|
|
|
|
|
|
|
|
cabalSuffix :: String
|
|
|
|
cabalSuffix = ".cabal"
|
|
|
|
|
|
|
|
cabalSuffixLength :: Int
|
|
|
|
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
|
2013-09-20 06:48:50 +00:00
|
|
|
-- ,the path to the Cabal file)
|
|
|
|
cabalDir :: FilePath -> IO (FilePath,FilePath)
|
2013-03-02 03:18:55 +00:00
|
|
|
cabalDir dir = do
|
2013-09-20 06:48:50 +00:00
|
|
|
cnts <- getCabalFiles dir
|
2013-03-02 03:18:55 +00:00
|
|
|
case cnts of
|
2013-09-20 06:48:50 +00:00
|
|
|
[] | dir' == dir -> throwIO $ userError "cabal files not found"
|
2013-03-02 03:18:55 +00:00
|
|
|
| otherwise -> cabalDir dir'
|
2013-09-20 06:48:50 +00:00
|
|
|
cfile:_ -> return (dir,dir </> cfile)
|
|
|
|
where
|
|
|
|
dir' = takeDirectory dir
|
|
|
|
|
|
|
|
getCabalFiles :: FilePath -> IO [FilePath]
|
|
|
|
getCabalFiles dir = getFiles >>= filterM doesCabalFileExist
|
2013-03-02 03:18:55 +00:00
|
|
|
where
|
2013-09-05 07:38:17 +00:00
|
|
|
isCabal name = cabalSuffix `isSuffixOf` name
|
|
|
|
&& length name > cabalSuffixLength
|
2013-09-20 06:48:50 +00:00
|
|
|
getFiles = filter isCabal <$> getDirectoryContents dir
|
|
|
|
doesCabalFileExist file = doesFileExist $ dir </> file
|
2013-09-05 07:38:17 +00:00
|
|
|
|
|
|
|
----------------------------------------------------------------
|
|
|
|
|
2013-09-20 06:48:50 +00:00
|
|
|
configFile :: String
|
|
|
|
configFile = "cabal.sandbox.config"
|
2013-03-02 03:18:55 +00:00
|
|
|
|
2013-09-20 06:48:50 +00:00
|
|
|
pkgDbKey :: String
|
|
|
|
pkgDbKey = "package-db:"
|
2013-03-02 03:18:55 +00:00
|
|
|
|
2013-09-20 06:48:50 +00:00
|
|
|
pkgDbKeyLen :: Int
|
|
|
|
pkgDbKeyLen = length pkgDbKey
|
2013-09-05 07:38:17 +00:00
|
|
|
|
2013-09-21 06:10:43 +00:00
|
|
|
-- | Obtaining GHC options relating to a package db directory
|
2013-09-20 08:15:41 +00:00
|
|
|
getPackageDbOpts :: FilePath -> IO [GHCOption]
|
2013-09-21 06:10:43 +00:00
|
|
|
getPackageDbOpts cdir = (sandboxArguments <$> getPkgDb) `E.catch` handler
|
2013-09-20 06:48:50 +00:00
|
|
|
where
|
2013-09-21 06:10:43 +00:00
|
|
|
getPkgDb = getPackageDbDir (cdir </> configFile)
|
2013-09-20 08:15:41 +00:00
|
|
|
handler :: SomeException -> IO [GHCOption]
|
|
|
|
handler _ = return []
|
|
|
|
|
2013-09-21 06:10:43 +00:00
|
|
|
-- | Extract a package db directory from the sandbox config file.
|
|
|
|
-- Exception is thrown if the sandbox config file is broken.
|
|
|
|
getPackageDbDir :: FilePath -> IO FilePath
|
|
|
|
getPackageDbDir sconf = do
|
|
|
|
-- Be strict to ensure that an error can be caught.
|
|
|
|
!path <- extractValue . parse <$> readFile sconf
|
|
|
|
return path
|
|
|
|
where
|
|
|
|
parse = head . filter ("package-db:" `isPrefixOf`) . lines
|
|
|
|
extractValue = fst . break isSpace . dropWhile isSpace . drop pkgDbKeyLen
|
|
|
|
|
2013-09-20 08:15:41 +00:00
|
|
|
-- | Adding necessary GHC options to the package db.
|
|
|
|
-- Exception is thrown if the string argument is incorrect.
|
|
|
|
--
|
|
|
|
-- >>> sandboxArguments "/foo/bar/i386-osx-ghc-7.6.3-packages.conf.d"
|
|
|
|
-- ["-no-user-package-db","-package-db","/foo/bar/i386-osx-ghc-7.6.3-packages.conf.d"]
|
|
|
|
-- >>> sandboxArguments "/foo/bar/i386-osx-ghc-7.4.1-packages.conf.d"
|
|
|
|
-- ["-no-user-package-conf","-package-conf","/foo/bar/i386-osx-ghc-7.4.1-packages.conf.d"]
|
|
|
|
sandboxArguments :: FilePath -> [String]
|
|
|
|
sandboxArguments pkgDb = [noUserPkgDbOpt, pkgDbOpt, pkgDb]
|
|
|
|
where
|
|
|
|
ver = extractGhcVer pkgDb
|
|
|
|
(pkgDbOpt,noUserPkgDbOpt)
|
|
|
|
| ver < 706 = ("-package-conf","-no-user-package-conf")
|
|
|
|
| otherwise = ("-package-db", "-no-user-package-db")
|
|
|
|
|
|
|
|
-- | Extracting GHC version from the path of package db.
|
|
|
|
-- Exception is thrown if the string argument is incorrect.
|
|
|
|
--
|
|
|
|
-- >>> extractGhcVer "/foo/bar/i386-osx-ghc-7.6.3-packages.conf.d"
|
|
|
|
-- 706
|
|
|
|
extractGhcVer :: String -> Int
|
|
|
|
extractGhcVer dir = ver
|
|
|
|
where
|
|
|
|
file = takeFileName dir
|
|
|
|
findVer = drop 4 . head . filter ("ghc-" `isPrefixOf`) . tails
|
|
|
|
(verStr1,_:left) = break (== '.') $ findVer file
|
|
|
|
(verStr2,_) = break (== '.') left
|
|
|
|
ver = read verStr1 * 100 + read verStr2
|
2014-01-30 11:09:57 +00:00
|
|
|
|
|
|
|
-- | Obtaining packages installed in a package db directory.
|
|
|
|
getPackageDbPackages :: FilePath -> IO [Package]
|
|
|
|
getPackageDbPackages cdir = (getPkgDb >>= listDbPackages) `E.catch` handler
|
|
|
|
where
|
|
|
|
getPkgDb = getPackageDbDir (cdir </> configFile)
|
|
|
|
handler :: SomeException -> IO [Package]
|
|
|
|
handler _ = return []
|
|
|
|
|
|
|
|
listDbPackages :: FilePath -> IO [Package]
|
|
|
|
listDbPackages pkgdir = do
|
|
|
|
files <- filter (".conf" `isSuffixOf`) <$> getDirectoryContents pkgdir
|
|
|
|
mapM extractPackage $ map (pkgdir </>) files
|
|
|
|
|
|
|
|
extractPackage :: FilePath -> IO Package
|
|
|
|
extractPackage pconf = do
|
|
|
|
contents <- lines <$> readFile pconf
|
|
|
|
-- Be strict to ensure that an error can be caught.
|
|
|
|
let !name = extractName $ parseName contents
|
|
|
|
!pid = extractId $ parseId contents
|
|
|
|
return (name, Just pid)
|
|
|
|
where
|
|
|
|
parseName = parse nameKey
|
|
|
|
extractName = extract nameKeyLength
|
|
|
|
parseId = parse idKey
|
|
|
|
extractId = extract idKeyLength
|
|
|
|
parse key = head . filter (key `isPrefixOf`)
|
|
|
|
extract keylen = fst . break isSpace . dropWhile isSpace . drop keylen
|
|
|
|
|
|
|
|
nameKey :: String
|
|
|
|
nameKey = "name:"
|
|
|
|
|
|
|
|
idKey :: String
|
|
|
|
idKey = "id:"
|
|
|
|
|
|
|
|
nameKeyLength :: Int
|
|
|
|
nameKeyLength = length nameKey
|
|
|
|
|
|
|
|
idKeyLength :: Int
|
|
|
|
idKeyLength = length idKey
|