Find cabal file and sandbox at the same time.

This commit is contained in:
Kazu Yamamoto 2013-03-02 12:18:55 +09:00
parent 12bb30b097
commit f43af4be29
5 changed files with 119 additions and 59 deletions

View File

@ -1,52 +0,0 @@
module CabalDev (modifyOptions) where
{-
If the directory 'cabal-dev/packages-X.X.X.conf' exists, add it to the
options ghc-mod uses to check the source. Otherwise just pass it on.
-}
import Control.Applicative ((<$>))
import Control.Exception (throwIO)
import Control.Exception.IOChoice
import Data.List (find)
import System.Directory
import System.FilePath (splitPath,joinPath,(</>))
import Text.Regex.Posix ((=~))
import Types
modifyOptions :: Options -> IO Options
modifyOptions opts = found ||> notFound
where
found = addPath opts <$> findCabalDev (sandbox opts)
notFound = return opts
findCabalDev :: Maybe String -> IO FilePath
findCabalDev Nothing = getCurrentDirectory >>= searchIt . splitPath
findCabalDev (Just path) = do
exist <- doesDirectoryExist path
if exist then
findConf path
else
findCabalDev Nothing
addPath :: Options -> String -> Options
addPath orig_opts path = orig_opts { ghcOpts = opts' }
where
orig_ghcopt = ghcOpts orig_opts
opts' = orig_ghcopt ++ ["-package-conf", path, "-no-user-package-conf"]
searchIt :: [FilePath] -> IO FilePath
searchIt [] = throwIO $ userError "Not found"
searchIt path = do
exist <- doesDirectoryExist cabalDir
if exist then
findConf cabalDir
else
searchIt $ init path
where
cabalDir = joinPath path </> "cabal-dev/"
findConf :: FilePath -> IO FilePath
findConf path = do
Just f <- find (=~ "packages.*\\.conf") <$> getDirectoryContents path
return $ path </> f

99
Cradle.hs Normal file
View File

@ -0,0 +1,99 @@
module Cradle where
import Control.Applicative ((<$>))
import Control.Exception (throwIO)
import Control.Monad
import Data.List (isSuffixOf, intercalate)
import Distribution.Simple.Program (ghcProgram)
import Distribution.Simple.Program.Types (programName, programFindVersion)
import Distribution.Verbosity (silent)
import Distribution.Version (versionBranch)
import System.Directory
import System.FilePath ((</>),takeDirectory)
import Types
-- An error would be thrown
checkEnv :: Maybe FilePath -> IO Cradle
checkEnv (Just sbox) = do
(strver, ver) <- ghcVersion
conf <- checkPackageConf sbox strver
let confOpts = ghcPackageConfOptions ver conf
wdir <- getCurrentDirectory
cfiles <- cabalDir wdir
return $ case cfiles of
Nothing -> Cradle {
cradleCurrentDir = wdir
, cradleCabalDir = Nothing
, cradleCabalFile = Nothing
, cradlePackageConfOpts = Just confOpts
}
Just (cdir,cfile) -> Cradle {
cradleCurrentDir = wdir
, cradleCabalDir = Just cdir
, cradleCabalFile = Just cfile
, cradlePackageConfOpts = Just confOpts
}
checkEnv Nothing = do
(strver, ver) <- ghcVersion
wdir <- getCurrentDirectory
cfiles <- cabalDir wdir
case cfiles of
Nothing -> return $ Cradle {
cradleCurrentDir = wdir
, cradleCabalDir = Nothing
, cradleCabalFile = Nothing
, cradlePackageConfOpts = Nothing
}
Just (cdir,cfile) -> do
let sbox = cdir </> "cabal-dev/"
conf = packageConfName sbox strver
confOpts = ghcPackageConfOptions ver conf
exist <- doesFileExist conf
return $ Cradle {
cradleCurrentDir = wdir
, cradleCabalDir = Just cdir
, cradleCabalFile = Just cfile
, cradlePackageConfOpts = if exist then Just confOpts else Nothing
}
cabalDir :: FilePath -> IO (Maybe (FilePath,FilePath))
cabalDir dir = do
cnts <- (filter isCabal <$> getDirectoryContents dir)
>>= filterM (\file -> doesFileExist (dir </> file))
let dir' = takeDirectory dir
case cnts of
[] | dir' == dir -> return Nothing
| otherwise -> cabalDir dir'
cfile:_ -> return $ Just (dir,dir </> cfile)
where
isCabal name = ".cabal" `isSuffixOf` name && length name > 6
ghcVersion :: IO (String, Int)
ghcVersion = ghcVer >>= cook
where
ghcVer = programFindVersion ghcProgram silent (programName ghcProgram)
cook Nothing = throwIO $ userError $ "ghc not found"
cook (Just v)
| length vs < 2 = return (verstr, 0)
| otherwise = return (verstr, ver)
where
vs = versionBranch v
ver = (vs !! 0) * 100 + (vs !! 1)
verstr = intercalate "." . map show $ vs
packageConfName :: FilePath -> String -> FilePath
packageConfName path ver = path </> "packages-" ++ ver ++ ".conf"
checkPackageConf :: FilePath -> String -> IO FilePath
checkPackageConf path ver = do
let conf = packageConfName path ver
exist <- doesFileExist conf
if exist then
return conf
else
throwIO $ userError $ conf ++ " not found"
ghcPackageConfOptions :: Int -> String -> [String]
ghcPackageConfOptions ver file
| ver >= 706 = ["-package-db", file, "-no-user-package-conf"]
| otherwise = ["-package-conf", file, "-no-user-package-conf"]

View File

@ -3,15 +3,15 @@
module Main where
import Browse
import CabalDev (modifyOptions)
import Check
import Control.Applicative
import Control.Exception
import Cradle
import Data.Typeable
import Data.Version
import Flag
import Info
import Lang
import Flag
import Lint
import List
import Paths_ghc_mod
@ -86,7 +86,11 @@ main :: IO ()
main = flip catches handlers $ do
args <- getArgs
let (opt',cmdArg) = parseArgs argspec args
opt <- modifyOptions opt'
cradle <- checkEnv $ sandbox opt'
let mpkgopts = cradlePackageConfOpts cradle
opt = case mpkgopts of
Nothing -> opt'
Just pkgopts -> opt' { ghcOpts = pkgopts ++ ghcOpts opt' }
res <- case safelist cmdArg 0 of
"browse" -> concat <$> mapM (browseModule opt) (tail cmdArg)
"list" -> listModules opt

View File

@ -62,6 +62,17 @@ quote x = "\"" ++ x ++ "\""
addNewLine :: String -> String
addNewLine = (++ "\n")
----------------------------------------------------------------
data Cradle = Cradle {
cradleCurrentDir :: FilePath
, cradleCabalDir :: Maybe FilePath
, cradleCabalFile :: Maybe FilePath
, cradlePackageConfOpts :: Maybe [String]
} deriving Show
----------------------------------------------------------------
type GHCOption = String
type IncludeDir = FilePath
type Package = String

View File

@ -36,10 +36,10 @@ Executable ghc-mod
Default-Language: Haskell2010
Main-Is: GHCMod.hs
Other-Modules: Browse
CabalApi
Cabal
CabalDev
CabalApi
Check
Cradle
ErrMsg
Flag
GHCApi
@ -65,7 +65,6 @@ Executable ghc-mod
, io-choice
, old-time
, process
, regex-posix
, syb
, time
, transformers
@ -98,7 +97,6 @@ Test-Suite spec
, io-choice
, old-time
, process
, regex-posix
, syb
, time
, transformers