{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Language.Haskell.Tools.Daemon.PackageDB (PackageDB(..), decidePkgDB, packageDBLoc, detectAutogen) where
import Control.Applicative (Alternative(..))
import Control.Exception (SomeException, try)
import Control.Monad
import Data.Aeson (FromJSON(..))
import Data.Char (isSpace)
import Data.List
import Data.Maybe
import GHC.Generics (Generic(..))
import System.Directory
import System.Exit (ExitCode(..))
import System.FilePath (FilePath, (</>))
import System.Process (shell, readCreateProcessWithExitCode)
data PackageDB = DefaultDB
| CabalSandboxDB
| StackDB
| ExplicitDB { packageDBPath :: [FilePath] }
deriving (Eq, Show, Generic)
instance FromJSON PackageDB
decidePkgDB :: [FilePath] -> IO (Maybe PackageDB)
decidePkgDB [] = return Nothing
decidePkgDB (firstRoot:packageRoots) = do
fstRes <- decidePkgDB' firstRoot
res <- mapM decidePkgDB' packageRoots
if any (fstRes /=) res || (fstRes == CabalSandboxDB && not (null res))
then return Nothing
else return (Just fstRes)
decidePkgDB' :: FilePath -> IO PackageDB
decidePkgDB' root = do isSandbox <- checkSandbox
if isSandbox then return CabalSandboxDB
else do isStack <- checkStack
if isStack then return StackDB
else return DefaultDB
where
checkStack =
withCurrentDirectory root $ (fmap $ either (\(_ :: SomeException) -> False) id) $ try $ do
projRoot <- runCommandExpectOK "stack path --allow-different-user --project-root"
absPath <- canonicalizePath root
return $ maybe False (`isPrefixOf` absPath) projRoot
checkSandbox = do
hasConfigFile <- doesFileExist (root </> "cabal.config")
hasSandboxFile <- doesFileExist (root </> "cabal.sandbox.config")
return $ hasConfigFile || hasSandboxFile
packageDBLoc :: PackageDB -> FilePath -> IO [FilePath]
packageDBLoc DefaultDB _ = do
dbs <- runCommandExpectOK "ghc-pkg list base"
return $ maybe [] (filter (\l -> not (null l) && not (" " `isPrefixOf` l)) . lines) dbs
packageDBLoc CabalSandboxDB path = do
hasConfigFile <- doesFileExist (path </> "cabal.config")
config <- if hasConfigFile then readFile (path </> "cabal.config")
else readFile (path </> "cabal.sandbox.config")
return $ map (drop (length "package-db: ")) $ filter ("package-db: " `isPrefixOf`) $ lines config
packageDBLoc StackDB path = withCurrentDirectory path $ do
globalDB <- runCommandExpectOK "stack path --allow-different-user --global-pkg-db"
snapshotDB <- runCommandExpectOK "stack path --allow-different-user --snapshot-pkg-db"
localDB <- runCommandExpectOK "stack path --allow-different-user --local-pkg-db"
return $ maybeToList localDB ++ maybeToList snapshotDB ++ maybeToList globalDB
packageDBLoc (ExplicitDB dirs) _ = return dirs
detectAutogen :: FilePath -> PackageDB -> IO (Maybe FilePath)
detectAutogen root DefaultDB = ifExists (root </> "dist" </> "build" </> "autogen")
detectAutogen root (ExplicitDB _) = ifExists (root </> "dist" </> "build" </> "autogen")
detectAutogen root CabalSandboxDB = ifExists (root </> "dist" </> "build" </> "autogen")
detectAutogen root StackDB = (fmap $ either (\(_ :: SomeException) -> Nothing) id) $ try $ do
dir <- withCurrentDirectory root $ do
distDir <- runCommandExpectOK "stack path --allow-different-user --dist-dir"
return $ trim (fromMaybe "" distDir)
genExists <- doesDirectoryExist (root </> dir </> "build" </> "autogen")
buildExists <- doesDirectoryExist (root </> dir </> "build")
if | genExists -> return $ Just (root </> dir </> "build" </> "autogen")
| buildExists -> do
cont <- filterM doesDirectoryExist . map ((root </> dir </> "build") </>)
=<< listDirectory (root </> dir </> "build")
existing <- mapM ifExists (map (</> "autogen") cont)
return $ choose existing
| otherwise -> return Nothing
runCommandExpectOK :: String -> IO (Maybe String)
runCommandExpectOK cmd = do
(exitCode, res, errs) <- readCreateProcessWithExitCode (shell cmd) ""
case exitCode of ExitSuccess -> return (Just $ trim res)
ExitFailure code -> do putStrLn ("The command '" ++ cmd ++ "' exited with "
++ show code ++ ":\n" ++ errs)
return Nothing
trim :: String -> String
trim = f . f
where f = reverse . dropWhile isSpace
choose :: (Eq (f a), Alternative f) => [f a] -> f a
choose = fromMaybe empty . find (/= empty)
ifExists :: FilePath -> IO (Maybe FilePath)
ifExists fp = do exists <- doesDirectoryExist fp
if exists then return (Just fp)
else return Nothing