ghc-mod/Language/Haskell/GhcMod/Cradle.hs

233 lines
7.8 KiB
Haskell
Raw Normal View History

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
, getPackageDbPackages
, userPackageDbOptsForGhc
, userPackageDbOptsForGhcPkg
, getSandboxDir
2013-09-21 09:37:33 +00:00
) where
import Control.Applicative ((<$>))
2014-03-27 06:21:18 +00:00
import Control.Exception (SomeException(..))
import qualified Control.Exception as E
import Control.Exception.IOChoice ((||>))
import Control.Monad (filterM)
2014-03-27 06:21:18 +00:00
import Data.Char (isSpace)
import Data.List (isPrefixOf, isSuffixOf, tails)
2013-05-17 01:00:01 +00:00
import Language.Haskell.GhcMod.Types
import System.Directory (getCurrentDirectory, getDirectoryContents, doesFileExist)
import System.FilePath ((</>), takeDirectory, takeFileName)
----------------------------------------------------------------
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.
findCradle :: IO Cradle
findCradle = do
wdir <- getCurrentDirectory
cabalCradle wdir ||> sandboxCradle wdir ||> plainCradle wdir
cabalCradle :: FilePath -> IO Cradle
cabalCradle wdir = do
(rdir,cfile) <- cabalDir wdir
pkgDbOpts <- getPackageDb rdir
return Cradle {
cradleCurrentDir = wdir
, cradleRootDir = rdir
, cradleCabalFile = Just cfile
, cradlePackageDb = pkgDbOpts
, cradlePackages = []
}
sandboxCradle :: FilePath -> IO Cradle
sandboxCradle wdir = do
rdir <- getSandboxDir wdir
pkgDbOpts <- getPackageDb rdir
return Cradle {
cradleCurrentDir = wdir
, cradleRootDir = rdir
, cradleCabalFile = Nothing
, cradlePackageDb = pkgDbOpts
, cradlePackages = []
}
plainCradle :: FilePath -> IO Cradle
plainCradle wdir = return Cradle {
cradleCurrentDir = wdir
, cradleRootDir = wdir
, cradleCabalFile = Nothing
, cradlePackageDb = Nothing
, cradlePackages = []
}
2013-09-21 09:37:33 +00:00
-- Just for testing
findCradleWithoutSandbox :: IO Cradle
findCradleWithoutSandbox = do
cradle <- findCradle
return cradle { cradlePackageDb = Nothing, cradlePackages = [] }
2013-09-21 09:37:33 +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
-- ,the path to the Cabal file)
cabalDir :: FilePath -> IO (FilePath,FilePath)
cabalDir dir = do
cnts <- getCabalFiles dir
case cnts of
2014-03-27 06:21:18 +00:00
[] | dir' == dir -> E.throwIO $ userError "cabal files not found"
| otherwise -> cabalDir dir'
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
----------------------------------------------------------------
configFile :: String
configFile = "cabal.sandbox.config"
pkgDbKey :: String
pkgDbKey = "package-db:"
pkgDbKeyLen :: Int
pkgDbKeyLen = length pkgDbKey
2013-09-21 06:10:43 +00:00
-- | Obtaining GHC options relating to a package db directory
getPackageDb :: FilePath -> IO (Maybe FilePath)
getPackageDb cdir = (Just <$> getPkgDb) `E.catch` handler
where
2013-09-21 06:10:43 +00:00
getPkgDb = getPackageDbDir (cdir </> configFile)
handler :: SomeException -> IO (Maybe FilePath)
handler _ = return Nothing
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
2014-03-26 06:38:02 +00:00
extractValue = dropWhileEnd isSpace . dropWhile isSpace . drop pkgDbKeyLen
-- dropWhileEnd is not provided prior to base 4.5.0.0.
dropWhileEnd :: (a -> Bool) -> [a] -> [a]
dropWhileEnd p = foldr (\x xs -> if p x && null xs then [] else x : xs) []
2013-09-21 06:10:43 +00:00
-- | Creating user package db options for GHC.
--
-- >>> userPackageDbOptsForGhc (Just "/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"]
-- >>> userPackageDbOptsForGhc (Just "/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"]
userPackageDbOptsForGhc :: Maybe FilePath -> [String]
userPackageDbOptsForGhc Nothing = []
userPackageDbOptsForGhc (Just pkgDb) = [noUserPkgDbOpt, pkgDbOpt, pkgDb]
where
ver = extractGhcVer pkgDb
(noUserPkgDbOpt,pkgDbOpt)
| ver < 706 = ("-no-user-package-conf", "-package-conf")
| otherwise = ("-no-user-package-db", "-package-db")
-- | Creating user package db options for ghc-pkg.
--
-- >>> userPackageDbOptsForGhcPkg (Just "/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"]
-- >>> userPackageDbOptsForGhcPkg (Just "/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"]
userPackageDbOptsForGhcPkg :: Maybe FilePath -> [String]
userPackageDbOptsForGhcPkg Nothing = []
userPackageDbOptsForGhcPkg (Just pkgDb) = [noUserPkgDbOpt, pkgDbOpt]
where
ver = extractGhcVer pkgDb
(noUserPkgDbOpt,pkgDbOpt)
| ver < 706 = ("--no-user-package-conf", "--package-conf=" ++ pkgDb)
| otherwise = ("--no-user-package-db", "--package-db=" ++ pkgDb)
-- | 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
-- | 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
2014-03-27 07:35:41 +00:00
mapM (extractPackage . (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`)
2014-03-27 07:35:41 +00:00
extract keylen = takeWhile (not . isSpace) . dropWhile isSpace . drop keylen
nameKey :: String
nameKey = "name:"
idKey :: String
idKey = "id:"
nameKeyLength :: Int
nameKeyLength = length nameKey
idKeyLength :: Int
idKeyLength = length idKey
getSandboxDir :: FilePath -> IO FilePath
getSandboxDir dir = do
exist <- doesFileExist sfile
if exist then
return dir
else if dir == dir' then
E.throwIO $ userError "sandbox not found"
else
getSandboxDir dir'
where
sfile = dir </> configFile
dir' = takeDirectory dir