module Distribution.Helper (
Programs(..)
, defaultPrograms
, QueryEnv
, qeReadProcess
, qePrograms
, qeProjectDir
, qeDistDir
, qeCabalPkgDb
, qeCabalVer
, defaultQueryEnv
, Query
, runQuery
, packageDbStack
, entrypoints
, sourceDirs
, ghcOptions
, ghcSrcOptions
, ghcPkgOptions
, ghcMergedPkgOptions
, ghcLangOptions
, pkgLicenses
, flags
, configFlags
, nonDefaultConfigFlags
, packageId
, 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)])],
slbiFlags :: [(String, Bool)],
slbiConfigFlags :: [(String, Bool)],
slbiNonDefaultConfigFlags :: [(String, Bool)]
} 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)])]
flags :: MonadIO m => Query m [(String, Bool)]
configFlags :: MonadIO m => Query m [(String, Bool)]
nonDefaultConfigFlags :: MonadIO m => Query m [(String, Bool)]
packageId :: MonadIO m => Query m (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
flags = Query $ slbiFlags `liftM` getSlbi
configFlags = Query $ slbiConfigFlags `liftM` getSlbi
nonDefaultConfigFlags = Query $ slbiNonDefaultConfigFlags `liftM` getSlbi
packageId = Query $ getPackageId
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 ()
invokeHelper :: MonadQuery m => [String] -> m [Maybe ChResponse]
invokeHelper args = ask >>= \QueryEnv {..} -> do
let progs = qePrograms
projdir = qeProjectDir
distdir = qeDistDir
progArgs = [ "--with-ghc=" ++ ghcProgram progs
, "--with-ghc-pkg=" ++ ghcPkgProgram progs
, "--with-cabal=" ++ cabalProgram progs
]
liftIO $ do
exe <- findLibexecExe "cabal-helper-wrapper"
let args' = progArgs ++ projdir:distdir:args
out <- qeReadProcess exe args' ""
evaluate (read out) `E.catch` \(SomeException _) ->
error $ concat ["invokeHelper", ": ", exe, " "
, intercalate " " (map show args')
, " (read failed)"
]
getPackageId :: MonadQuery m => m (String, Version)
getPackageId = ask >>= \QueryEnv {..} -> do
[ Just (ChResponseVersion pkgName pkgVer) ] <- invokeHelper [ "package-id" ]
return (pkgName, pkgVer)
getSomeConfigState :: MonadQuery m => m SomeLocalBuildInfo
getSomeConfigState = ask >>= \QueryEnv {..} -> do
res <- invokeHelper [ "package-db-stack"
, "entrypoints"
, "source-dirs"
, "ghc-options"
, "ghc-src-options"
, "ghc-pkg-options"
, "ghc-merged-pkg-options"
, "ghc-lang-options"
, "licenses"
, "flags"
, "config-flags"
, "non-default-config-flags"
]
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),
Just (ChResponseFlags fls),
Just (ChResponseFlags cfls),
Just (ChResponseFlags ndcfls)
] = res
return $ SomeLocalBuildInfo
pkgDbs eps srcDirs ghcOpts ghcSrcOpts ghcPkgOpts ghcMergedPkgOpts ghcLangOpts pkgLics fls cfls ndcfls
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