diff --git a/CabalDev.hs b/CabalDev.hs deleted file mode 100644 index 5aba6f3..0000000 --- a/CabalDev.hs +++ /dev/null @@ -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 diff --git a/Cradle.hs b/Cradle.hs new file mode 100644 index 0000000..97dc6ff --- /dev/null +++ b/Cradle.hs @@ -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"] diff --git a/GHCMod.hs b/GHCMod.hs index 5544838..ebe5a36 100644 --- a/GHCMod.hs +++ b/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 diff --git a/Types.hs b/Types.hs index 45bb3ca..d8036da 100644 --- a/Types.hs +++ b/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 diff --git a/ghc-mod.cabal b/ghc-mod.cabal index e1a9cdc..45283d1 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -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