module Distribution.Helper (
Programs(..)
, defaultPrograms
, QueryEnv
, qeReadProcess
, qePrograms
, qeProjectDir
, qeDistDir
, qeCabalPkgDb
, qeCabalVer
, defaultQueryEnv
, Query
, runQuery
, packageDbStack
, entrypoints
, sourceDirs
, ghcOptions
, ghcSrcOptions
, ghcPkgOptions
, ghcMergedPkgOptions
, ghcLangOptions
, pkgLicenses
, ChModuleName(..)
, ChComponentName(..)
, ChPkgDb(..)
, ChEntrypoint(..)
, buildPlatform
, Distribution.Helper.getSandboxPkgDb
, prepare
, reconfigure
, writeAutogenFiles
, LibexecNotFoundError(..)
, libexecNotFoundError
) where
import Control.Applicative
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.State.Strict
import Control.Monad.Reader
import Control.Exception as E
import Data.Char
import Data.List
import Data.Version
import Data.Typeable
import Distribution.Simple.BuildPaths (exeExtension)
import System.Environment
import System.FilePath
import System.Directory
import System.Process
import System.IO.Unsafe
import Text.Printf
import GHC.Generics
import Prelude
import Paths_cabal_helper (getLibexecDir)
import CabalHelper.Types hiding (Options(..))
import CabalHelper.Sandbox
data Programs = Programs {
cabalProgram :: FilePath,
ghcProgram :: FilePath,
ghcPkgProgram :: FilePath
} deriving (Eq, Ord, Show, Read, Generic, Typeable)
defaultPrograms :: Programs
defaultPrograms = Programs "cabal" "ghc" "ghc-pkg"
data QueryEnv = QueryEnv {
qeReadProcess :: FilePath -> [String] -> String -> IO String,
qePrograms :: Programs,
qeProjectDir :: FilePath,
qeDistDir :: FilePath,
qeCabalPkgDb :: Maybe FilePath,
qeCabalVer :: Maybe Version
}
defaultQueryEnv :: FilePath
-> FilePath
-> QueryEnv
defaultQueryEnv projdir distdir = QueryEnv {
qeReadProcess = readProcess
, qePrograms = defaultPrograms
, qeProjectDir = projdir
, qeDistDir = distdir
, qeCabalPkgDb = Nothing
, qeCabalVer = Nothing
}
data SomeLocalBuildInfo = SomeLocalBuildInfo {
slbiPackageDbStack :: [ChPkgDb],
slbiEntrypoints :: [(ChComponentName, ChEntrypoint)],
slbiSourceDirs :: [(ChComponentName, [String])],
slbiGhcOptions :: [(ChComponentName, [String])],
slbiGhcSrcOptions :: [(ChComponentName, [String])],
slbiGhcPkgOptions :: [(ChComponentName, [String])],
slbiGhcMergedPkgOptions :: [String],
slbiGhcLangOptions :: [(ChComponentName, [String])],
slbiPkgLicenses :: [(String, [(String, Version)])]
} deriving (Eq, Ord, Read, Show)
newtype Query m a = Query { unQuery :: StateT (Maybe SomeLocalBuildInfo)
(ReaderT QueryEnv m) a }
deriving (Functor, Applicative, Monad, MonadIO)
type MonadQuery m = ( MonadIO m
, MonadState (Maybe SomeLocalBuildInfo) m
, MonadReader QueryEnv m)
run :: Monad m => QueryEnv -> Maybe SomeLocalBuildInfo -> Query m a -> m a
run e s action = flip runReaderT e (flip evalStateT s (unQuery action))
runQuery :: Monad m
=> QueryEnv
-> Query m a
-> m a
runQuery qe action = run qe Nothing action
getSlbi :: MonadQuery m => m SomeLocalBuildInfo
getSlbi = do
s <- get
case s of
Nothing -> do
slbi <- getSomeConfigState
put (Just slbi)
return slbi
Just slbi -> return slbi
packageDbStack :: MonadIO m => Query m [ChPkgDb]
entrypoints :: MonadIO m => Query m [(ChComponentName, ChEntrypoint)]
sourceDirs :: MonadIO m => Query m [(ChComponentName, [FilePath])]
ghcOptions :: MonadIO m => Query m [(ChComponentName, [String])]
ghcSrcOptions :: MonadIO m => Query m [(ChComponentName, [String])]
ghcPkgOptions :: MonadIO m => Query m [(ChComponentName, [String])]
ghcMergedPkgOptions :: MonadIO m => Query m [String]
ghcLangOptions :: MonadIO m => Query m [(ChComponentName, [String])]
pkgLicenses :: MonadIO m => Query m [(String, [(String, Version)])]
packageDbStack = Query $ slbiPackageDbStack `liftM` getSlbi
entrypoints = Query $ slbiEntrypoints `liftM` getSlbi
sourceDirs = Query $ slbiSourceDirs `liftM` getSlbi
ghcOptions = Query $ slbiGhcOptions `liftM` getSlbi
ghcSrcOptions = Query $ slbiGhcSrcOptions `liftM` getSlbi
ghcPkgOptions = Query $ slbiGhcPkgOptions `liftM` getSlbi
ghcMergedPkgOptions = Query $ slbiGhcMergedPkgOptions `liftM` getSlbi
ghcLangOptions = Query $ slbiGhcLangOptions `liftM` getSlbi
pkgLicenses = Query $ slbiPkgLicenses `liftM` getSlbi
reconfigure :: MonadIO m
=> (FilePath -> [String] -> String -> IO String)
-> Programs
-> [String]
-> m ()
reconfigure readProc progs cabalOpts = do
let progOpts =
[ "--with-ghc=" ++ ghcProgram progs ]
++ if ghcPkgProgram progs /= "ghc-pkg"
then [ "--with-ghc-pkg=" ++ ghcPkgProgram progs ]
else []
++ cabalOpts
_ <- liftIO $ readProc (cabalProgram progs) ("configure":progOpts) ""
return ()
getSomeConfigState :: MonadQuery m => m SomeLocalBuildInfo
getSomeConfigState = ask >>= \QueryEnv {..} -> do
let progs = qePrograms
projdir = qeProjectDir
distdir = qeDistDir
progArgs = [ "--with-ghc=" ++ ghcProgram progs
, "--with-ghc-pkg=" ++ ghcPkgProgram progs
, "--with-cabal=" ++ cabalProgram progs
]
args = [ "package-db-stack"
, "entrypoints"
, "source-dirs"
, "ghc-options"
, "ghc-src-options"
, "ghc-pkg-options"
, "ghc-merged-pkg-options"
, "ghc-lang-options"
, "licenses"
]
res <- liftIO $ do
exe <- findLibexecExe "cabal-helper-wrapper"
out <- qeReadProcess exe (progArgs ++ projdir:distdir:args) ""
evaluate (read out) `E.catch` \(SomeException _) ->
error $ concat ["getSomeConfigState", ": ", exe, " "
, intercalate " " (map show $ progArgs ++ projdir:distdir:args)
, " (read failed)"]
let [ Just (ChResponsePkgDbs pkgDbs),
Just (ChResponseEntrypoints eps),
Just (ChResponseCompList srcDirs),
Just (ChResponseCompList ghcOpts),
Just (ChResponseCompList ghcSrcOpts),
Just (ChResponseCompList ghcPkgOpts),
Just (ChResponseList ghcMergedPkgOpts),
Just (ChResponseCompList ghcLangOpts),
Just (ChResponseLicenses pkgLics)
] = res
return $ SomeLocalBuildInfo
pkgDbs eps srcDirs ghcOpts ghcSrcOpts ghcPkgOpts ghcMergedPkgOpts ghcLangOpts pkgLics
prepare :: MonadIO m
=> (FilePath -> [String] -> String -> IO String)
-> FilePath
-> FilePath
-> m ()
prepare readProc projdir distdir = liftIO $ do
exe <- findLibexecExe "cabal-helper-wrapper"
void $ readProc exe [projdir, distdir] ""
writeAutogenFiles :: MonadIO m
=> (FilePath -> [String] -> String -> IO String)
-> FilePath
-> FilePath
-> m ()
writeAutogenFiles readProc projdir distdir = liftIO $ do
exe <- findLibexecExe "cabal-helper-wrapper"
void $ readProc exe [projdir, distdir, "write-autogen-files"] ""
getSandboxPkgDb :: (FilePath -> [String] -> String -> IO String)
-> FilePath
-> Version
-> IO (Maybe FilePath)
getSandboxPkgDb readProc =
CabalHelper.Sandbox.getSandboxPkgDb $ unsafePerformIO $ buildPlatform readProc
buildPlatform :: (FilePath -> [String] -> String -> IO String) -> IO String
buildPlatform readProc = do
exe <- findLibexecExe "cabal-helper-wrapper"
CabalHelper.Sandbox.dropWhileEnd isSpace <$> readProc exe ["print-build-platform"] ""
data LibexecNotFoundError = LibexecNotFoundError String FilePath
deriving (Typeable)
instance Exception LibexecNotFoundError
instance Show LibexecNotFoundError where
show (LibexecNotFoundError exe dir) =
libexecNotFoundError exe dir "https://github.com/DanielG/cabal-helper/issues"
findLibexecExe :: String -> IO FilePath
findLibexecExe "cabal-helper-wrapper" = do
libexecdir <- getLibexecDir
let exeName = "cabal-helper-wrapper"
exe = libexecdir </> exeName <.> exeExtension
exists <- doesFileExist exe
if exists
then return exe
else do
mdir <- tryFindCabalHelperTreeLibexecDir
case mdir of
Nothing ->
error $ throw $ LibexecNotFoundError exeName libexecdir
Just dir ->
return $ dir </> "dist" </> "build" </> exeName </> exeName
findLibexecExe exe = error $ "findLibexecExe: Unknown executable: " ++ exe
tryFindCabalHelperTreeLibexecDir :: IO (Maybe FilePath)
tryFindCabalHelperTreeLibexecDir = do
exe <- getExecutablePath'
dir <- case takeFileName exe of
"ghc" -> do
getCurrentDirectory
_ ->
return $ (!!4) $ iterate takeDirectory exe
exists <- doesFileExist $ dir </> "cabal-helper.cabal"
return $ if exists
then Just dir
else Nothing
libexecNotFoundError :: String
-> FilePath
-> String
-> String
libexecNotFoundError exe dir reportBug = printf
( "Could not find $libexecdir/%s\n"
++"\n"
++"If you are a developer set the environment variable\n"
++"`cabal_helper_libexecdir' to override $libexecdir[1]. The following will\n"
++"work in the cabal-helper source tree:\n"
++"\n"
++" $ export cabal_helper_libexecdir=$PWD/dist/build/%s\n"
++"\n"
++"[1]: %s\n"
++"\n"
++"If you don't know what I'm talking about something went wrong with your\n"
++"installation. Please report this problem here:\n"
++"\n"
++" %s") exe exe dir reportBug
getExecutablePath' :: IO FilePath
getExecutablePath' =
#if MIN_VERSION_base(4,6,0)
getExecutablePath
#else
getProgName
#endif