module HsDev.Cabal (
Cabal(..), sandbox,
isPackageDb, findPackageDb, locateSandbox, getSandbox, searchSandbox,
cabalOpt
) where
import Control.Applicative
import Control.DeepSeq (NFData(..))
import Control.Monad.Except
import Data.Aeson
import Data.List
import System.Directory
import System.FilePath
import HsDev.Util (searchPath, liftE)
data Cabal = Cabal | Sandbox FilePath deriving (Eq, Ord)
sandbox :: Cabal -> Maybe FilePath
sandbox Cabal = Nothing
sandbox (Sandbox f) = Just f
instance NFData Cabal where
rnf Cabal = ()
rnf (Sandbox p) = rnf p
instance Show Cabal where
show Cabal = "<cabal>"
show (Sandbox p) = p
instance ToJSON Cabal where
toJSON Cabal = toJSON ("cabal" :: String)
toJSON (Sandbox p) = toJSON $ object [
"sandbox" .= p]
instance FromJSON Cabal where
parseJSON v = cabalP v <|> sandboxP v where
cabalP = withText "cabal" cabalText where
cabalText "cabal" = return Cabal
cabalText _ = fail "Unknown cabal string"
sandboxP = withObject "sandbox" sandboxPath where
sandboxPath obj = fmap Sandbox $ obj .: "sandbox"
isPackageDb :: FilePath -> Bool
isPackageDb p = cabalDev p || cabalSandbox p where
cabalDev dir = "packages-" `isPrefixOf` dir && ".conf" `isSuffixOf` dir
cabalSandbox dir = "-packages.conf.d" `isSuffixOf` dir
cabalSandboxDir :: FilePath -> Bool
cabalSandboxDir p = takeFileName p == ".cabal-sandbox"
findPackageDb :: FilePath -> IO (Maybe FilePath)
findPackageDb sand = do
sand' <- canonicalizePath sand
isDir <- doesDirectoryExist sand'
if
| isDir && isPackageDb sand' -> return $ Just sand'
| isDir -> do
cts <- getDirectoryContents sand'
(dir', cts') <- case find cabalSandboxDir cts of
Nothing -> return (sand', cts)
Just sbox -> (,) <$> pure (sand' </> sbox) <*> getDirectoryContents (sand' </> sbox)
return $ fmap (dir' </>) $ find isPackageDb cts'
| otherwise -> return Nothing
locateSandbox :: FilePath -> ExceptT String IO Cabal
locateSandbox p = liftE (findPackageDb p) >>= maybe
(throwError $ "Can't locate package-db in sandbox: " ++ p)
(return . Sandbox)
getSandbox :: FilePath -> IO Cabal
getSandbox = liftM (either (const Cabal) id) . runExceptT . locateSandbox
searchSandbox :: FilePath -> IO Cabal
searchSandbox p = runExceptT (searchPath p locateSandbox) >>= either (const $ return Cabal) return
cabalOpt :: Cabal -> [String]
cabalOpt Cabal = []
cabalOpt (Sandbox p) = ["-package-db " ++ p]