{-# LANGUAGE CPP, BangPatterns #-}

module Sandbox
    ( getSandboxArguments
    , getPackageDbDir
    , getSandboxConfigFile
    ) where

#if __GLASGOW_HASKELL__ < 710
import Data.Functor ((<$>))
#endif
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 :: String
configFile = "cabal.sandbox.config"

pkgDbKey :: String
pkgDbKey :: String
pkgDbKey = "package-db:"

pkgDbKeyLen :: Int
pkgDbKeyLen :: Int
pkgDbKeyLen = String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
pkgDbKey

getSandboxArguments :: IO [String]
getSandboxArguments :: IO [String]
getSandboxArguments = (String -> [String]
sandboxArguments (String -> [String]) -> IO String -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO String
getPkgDb) IO [String] -> (SomeException -> IO [String]) -> IO [String]
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` SomeException -> IO [String]
handler
  where
    getPkgDb :: IO String
getPkgDb = IO String
getCurrentDirectory IO String -> (String -> IO String) -> IO String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> IO String
getSandboxConfigFile IO String -> (String -> IO String) -> IO String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> IO String
getPackageDbDir
    handler :: SomeException -> IO [String]
    handler :: SomeException -> IO [String]
handler _ = [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return []

-- | Find a sandbox config file by tracing ancestor directories.
--   Exception is thrown if not found
getSandboxConfigFile :: FilePath -> IO FilePath
getSandboxConfigFile :: String -> IO String
getSandboxConfigFile dir :: String
dir = do
    let cfile :: String
cfile = String
dir String -> String -> String
</> String
configFile
    Bool
exist <- String -> IO Bool
doesFileExist String
cfile
    if Bool
exist then
        String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
cfile
      else do
        let dir' :: String
dir' = String -> String
takeDirectory String
dir
        if String
dir String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
dir' then
            IOError -> IO String
forall e a. Exception e => e -> IO a
throwIO (IOError -> IO String) -> IOError -> IO String
forall a b. (a -> b) -> a -> b
$ String -> IOError
userError "sandbox config file not found"
          else
            String -> IO String
getSandboxConfigFile String
dir'

-- | Extract a package db directory from the sandbox config file.
--   Exception is thrown if the sandbox config file is broken.
getPackageDbDir :: FilePath -> IO FilePath
getPackageDbDir :: String -> IO String
getPackageDbDir sconf :: String
sconf = do
    -- Be strict to ensure that an error can be caught.
    !String
path <- String -> String
extractValue (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
parse (String -> String) -> IO String -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO String
readFile String
sconf
    String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
path
  where
    parse :: String -> String
parse = [String] -> String
forall a. [a] -> a
head ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter ("package-db:" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines
    extractValue :: String -> String
extractValue = (String, String) -> String
forall a b. (a, b) -> a
fst ((String, String) -> String)
-> (String -> (String, String)) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
isSpace (String -> (String, String))
-> (String -> String) -> String -> (String, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
pkgDbKeyLen

-- | Adding necessary GHC options to the package db.
--   Exception is thrown if the string argument is incorrect.
--
-- >>> sandboxArguments "/foo/bar/i386-osx-ghc-7.6.3-packages.conf.d"
-- ["-no-user-package-db","-package-db","/foo/bar/i386-osx-ghc-7.6.3-packages.conf.d"]
-- >>> sandboxArguments "/foo/bar/i386-osx-ghc-7.4.1-packages.conf.d"
-- ["-no-user-package-conf","-package-conf","/foo/bar/i386-osx-ghc-7.4.1-packages.conf.d"]
sandboxArguments :: FilePath -> [String]
sandboxArguments :: String -> [String]
sandboxArguments pkgDb :: String
pkgDb = [String
noUserPkgDbOpt, String
pkgDbOpt, String
pkgDb]
  where
    ver :: Int
ver = String -> Int
extractGhcVer String
pkgDb
    (pkgDbOpt :: String
pkgDbOpt,noUserPkgDbOpt :: String
noUserPkgDbOpt)
      | Int
ver Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 706 = ("-package-conf","-no-user-package-conf")
      | Bool
otherwise = ("-package-db",  "-no-user-package-db")

-- | Extracting GHC version from the path of package db.
--   Exception is thrown if the string argument is incorrect.
--
-- >>> extractGhcVer "/foo/bar/i386-osx-ghc-7.6.3-packages.conf.d"
-- 706
extractGhcVer :: String -> Int
extractGhcVer :: String -> Int
extractGhcVer dir :: String
dir = Int
ver
  where
    file :: String
file = String -> String
takeFileName String
dir
    findVer :: String -> String
findVer = Int -> String -> String
forall a. Int -> [a] -> [a]
drop 4 (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
forall a. [a] -> a
head ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter ("ghc-" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
forall a. [a] -> [[a]]
tails
    (verStr1 :: String
verStr1,_:left :: String
left) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '.') (String -> (String, String)) -> String -> (String, String)
forall a b. (a -> b) -> a -> b
$ String -> String
findVer String
file
    (verStr2 :: String
verStr2,_)      = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '.') String
left
    ver :: Int
ver = String -> Int
forall a. Read a => String -> a
read String
verStr1 Int -> Int -> Int
forall a. Num a => a -> a -> a
* 100 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ String -> Int
forall a. Read a => String -> a
read String
verStr2