{-# LANGUAGE BangPatterns #-}
module Distribution.Cab.Sandbox (
getSandbox
, getSandboxOpts
, getSandboxOpts2
) where
import Control.Exception as E (catch, SomeException, throwIO)
import Data.Char (isSpace)
import Data.List (isPrefixOf, tails)
import System.Directory (getCurrentDirectory, doesFileExist)
import System.FilePath ((</>), takeDirectory, takeFileName)
configFile :: String
configFile :: FilePath
configFile = FilePath
"cabal.sandbox.config"
pkgDbKey :: String
pkgDbKey :: FilePath
pkgDbKey = FilePath
"package-db:"
pkgDbKeyLen :: Int
pkgDbKeyLen :: Int
pkgDbKeyLen = FilePath -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length FilePath
pkgDbKey
getSandbox :: IO (Maybe FilePath)
getSandbox :: IO (Maybe FilePath)
getSandbox = (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (FilePath -> Maybe FilePath) -> IO FilePath -> IO (Maybe FilePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO FilePath
getPkgDb) IO (Maybe FilePath)
-> (SomeException -> IO (Maybe FilePath)) -> IO (Maybe FilePath)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` SomeException -> IO (Maybe FilePath)
handler
where
getPkgDb :: IO FilePath
getPkgDb = IO FilePath
getCurrentDirectory IO FilePath -> (FilePath -> IO FilePath) -> IO FilePath
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FilePath -> IO FilePath
getSandboxConfigFile IO FilePath -> (FilePath -> IO FilePath) -> IO FilePath
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FilePath -> IO FilePath
getPackageDbDir
handler :: SomeException -> IO (Maybe String)
handler :: SomeException -> IO (Maybe FilePath)
handler SomeException
_ = Maybe FilePath -> IO (Maybe FilePath)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe FilePath
forall a. Maybe a
Nothing
getSandboxConfigFile :: FilePath -> IO FilePath
getSandboxConfigFile :: FilePath -> IO FilePath
getSandboxConfigFile FilePath
dir = do
let cfile :: FilePath
cfile = FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
configFile
Bool
exist <- FilePath -> IO Bool
doesFileExist FilePath
cfile
if Bool
exist then
FilePath -> IO FilePath
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
cfile
else do
let dir' :: FilePath
dir' = FilePath -> FilePath
takeDirectory FilePath
dir
if FilePath
dir FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
dir' then
IOError -> IO FilePath
forall e a. Exception e => e -> IO a
throwIO (IOError -> IO FilePath) -> IOError -> IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> IOError
userError FilePath
"sandbox config file not found"
else
FilePath -> IO FilePath
getSandboxConfigFile FilePath
dir'
getPackageDbDir :: FilePath -> IO FilePath
getPackageDbDir :: FilePath -> IO FilePath
getPackageDbDir FilePath
sconf = do
!FilePath
path <- FilePath -> FilePath
extractValue (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
parse (FilePath -> FilePath) -> IO FilePath -> IO FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO FilePath
readFile FilePath
sconf
FilePath -> IO FilePath
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
path
where
parse :: FilePath -> FilePath
parse = [FilePath] -> FilePath
forall a. HasCallStack => [a] -> a
head ([FilePath] -> FilePath)
-> (FilePath -> [FilePath]) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter (FilePath
"package-db:" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) ([FilePath] -> [FilePath])
-> (FilePath -> [FilePath]) -> FilePath -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath]
lines
extractValue :: FilePath -> FilePath
extractValue = (FilePath, FilePath) -> FilePath
forall a b. (a, b) -> a
fst ((FilePath, FilePath) -> FilePath)
-> (FilePath -> (FilePath, FilePath)) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> FilePath -> (FilePath, FilePath)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
isSpace (FilePath -> (FilePath, FilePath))
-> (FilePath -> FilePath) -> FilePath -> (FilePath, FilePath)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> FilePath -> FilePath
forall a. Int -> [a] -> [a]
drop Int
pkgDbKeyLen
getSandboxOpts :: Maybe FilePath -> String
getSandboxOpts :: Maybe FilePath -> FilePath
getSandboxOpts Maybe FilePath
Nothing = FilePath
""
getSandboxOpts (Just FilePath
path) = FilePath
pkgOpt FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
path
where
ghcver :: Int
ghcver = FilePath -> Int
extractGhcVer FilePath
path
pkgOpt :: FilePath
pkgOpt | Int
ghcver Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
706 = FilePath
"-package-db "
| Bool
otherwise = FilePath
"-package-conf "
getSandboxOpts2 :: Maybe FilePath -> String
getSandboxOpts2 :: Maybe FilePath -> FilePath
getSandboxOpts2 Maybe FilePath
Nothing = FilePath
""
getSandboxOpts2 (Just FilePath
path) = FilePath
pkgOpt FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
path
where
ghcver :: Int
ghcver = FilePath -> Int
extractGhcVer FilePath
path
pkgOpt :: FilePath
pkgOpt | Int
ghcver Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
706 = FilePath
"--package-db"
| Bool
otherwise = FilePath
"--package-conf"
extractGhcVer :: String -> Int
FilePath
dir = Int
ver
where
file :: FilePath
file = FilePath -> FilePath
takeFileName FilePath
dir
findVer :: FilePath -> FilePath
findVer = Int -> FilePath -> FilePath
forall a. Int -> [a] -> [a]
drop Int
4 (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath] -> FilePath
forall a. HasCallStack => [a] -> a
head ([FilePath] -> FilePath)
-> (FilePath -> [FilePath]) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter (FilePath
"ghc-" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) ([FilePath] -> [FilePath])
-> (FilePath -> [FilePath]) -> FilePath -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath]
forall a. [a] -> [[a]]
tails
(FilePath
verStr1,FilePath
left) = (Char -> Bool) -> FilePath -> (FilePath, FilePath)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.') (FilePath -> (FilePath, FilePath))
-> FilePath -> (FilePath, FilePath)
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
findVer FilePath
file
(FilePath
verStr2,FilePath
_) = (Char -> Bool) -> FilePath -> (FilePath, FilePath)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.') (FilePath -> (FilePath, FilePath))
-> FilePath -> (FilePath, FilePath)
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
forall a. HasCallStack => [a] -> [a]
tail FilePath
left
ver :: Int
ver = FilePath -> Int
forall a. Read a => FilePath -> a
read FilePath
verStr1 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
100 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ FilePath -> Int
forall a. Read a => FilePath -> a
read FilePath
verStr2