Find cabal file and sandbox at the same time.
This commit is contained in:
parent
12bb30b097
commit
f43af4be29
52
CabalDev.hs
52
CabalDev.hs
@ -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
99
Cradle.hs
Normal 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"]
|
10
GHCMod.hs
10
GHCMod.hs
@ -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
|
||||
|
11
Types.hs
11
Types.hs
@ -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
|
||||
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user