124 lines
4.2 KiB
Haskell
124 lines
4.2 KiB
Haskell
module Language.Haskell.GhcMod.Cradle (findCradle) where
|
|
|
|
import Control.Applicative ((<$>))
|
|
import Control.Exception (throwIO)
|
|
import Control.Monad (unless, filterM)
|
|
import Data.List (isSuffixOf)
|
|
import Distribution.System (buildPlatform)
|
|
import qualified Distribution.Text as Text (display)
|
|
import Language.Haskell.GhcMod.Types
|
|
import System.Directory (getCurrentDirectory, getDirectoryContents, doesFileExist, doesDirectoryExist)
|
|
import System.FilePath ((</>),takeDirectory)
|
|
|
|
----------------------------------------------------------------
|
|
|
|
-- | Finding 'Cradle'.
|
|
-- An error would be thrown.
|
|
findCradle :: Maybe FilePath -- ^ A 'FilePath' for a sandbox.
|
|
-> GHCVersion
|
|
-> IO Cradle
|
|
findCradle (Just sbox) strver = do
|
|
(pkgConf,exist) <- checkPackageConf sbox strver
|
|
unless exist $ throwIO $ userError $ pkgConf ++ " not found"
|
|
wdir <- getCurrentDirectory
|
|
cfiles <- cabalDir wdir
|
|
return $ case cfiles of
|
|
Nothing -> Cradle {
|
|
cradleCurrentDir = wdir
|
|
, cradleCabalDir = Nothing
|
|
, cradleCabalFile = Nothing
|
|
, cradlePackageConf = Just pkgConf
|
|
}
|
|
Just (cdir,cfile,_) -> Cradle {
|
|
cradleCurrentDir = wdir
|
|
, cradleCabalDir = Just cdir
|
|
, cradleCabalFile = Just cfile
|
|
, cradlePackageConf = Just pkgConf
|
|
}
|
|
findCradle Nothing strver = do
|
|
wdir <- getCurrentDirectory
|
|
cfiles <- cabalDir wdir
|
|
case cfiles of
|
|
Nothing -> return Cradle {
|
|
cradleCurrentDir = wdir
|
|
, cradleCabalDir = Nothing
|
|
, cradleCabalFile = Nothing
|
|
, cradlePackageConf = Nothing
|
|
}
|
|
Just (cdir,cfile,Nothing) -> do
|
|
return Cradle {
|
|
cradleCurrentDir = wdir
|
|
, cradleCabalDir = Just cdir
|
|
, cradleCabalFile = Just cfile
|
|
, cradlePackageConf = Nothing
|
|
}
|
|
Just (cdir,cfile,Just sbox) -> do
|
|
(pkgConf,exist) <- checkPackageConf sbox strver
|
|
return Cradle {
|
|
cradleCurrentDir = wdir
|
|
, cradleCabalDir = Just cdir
|
|
, cradleCabalFile = Just cfile
|
|
, cradlePackageConf = if exist then Just pkgConf else Nothing
|
|
}
|
|
|
|
----------------------------------------------------------------
|
|
|
|
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
|
|
-- ,Just the path to the sandbox directory)
|
|
cabalDir :: FilePath -> IO (Maybe (FilePath,FilePath,Maybe 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:_ -> do
|
|
msbox <- checkSandbox dir
|
|
return $ Just (dir,dir </> cfile, msbox)
|
|
where
|
|
isCabal name = cabalSuffix `isSuffixOf` name
|
|
&& length name > cabalSuffixLength
|
|
|
|
----------------------------------------------------------------
|
|
|
|
sandboxConfig :: String
|
|
sandboxConfig = "cabal.sandbox.config"
|
|
|
|
sandboxDir :: String
|
|
sandboxDir = ".cabal-sandbox"
|
|
|
|
checkSandbox :: FilePath -> IO (Maybe FilePath)
|
|
checkSandbox dir = do
|
|
let conf = dir </> sandboxConfig
|
|
sbox = dir </> sandboxDir
|
|
sandboxConfigExists <- doesFileExist conf
|
|
sandboxExists <- doesDirectoryExist sbox
|
|
if sandboxConfigExists && sandboxExists then
|
|
return (Just sbox)
|
|
else
|
|
return Nothing
|
|
|
|
----------------------------------------------------------------
|
|
|
|
packageConfName :: GHCVersion -> FilePath
|
|
packageConfName strver = Text.display buildPlatform
|
|
++ "-ghc-"
|
|
++ strver
|
|
++ "-packages.conf.d"
|
|
|
|
checkPackageConf :: FilePath -> GHCVersion -> IO (FilePath, Bool)
|
|
checkPackageConf path strver = do
|
|
let dir = path </> packageConfName strver
|
|
exist <- doesDirectoryExist dir
|
|
return (dir,exist)
|