module Distribution.Helper (
Programs(..)
, Query
, runQuery
, runQuery'
, entrypoints
, sourceDirs
, ghcOptions
, ghcSrcOptions
, ghcPkgOptions
, ChModuleName(..)
, ChComponentName(..)
, ChEntrypoint(..)
, reconfigure
, writeAutogenFiles
, LibexecNotFoundError(..)
, libexecNotFoundError
) where
import Control.Applicative
import Control.Arrow
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.State.Strict
import Control.Monad.Reader
import Control.Exception as E
import Data.Monoid
import Data.List
import Data.Default
import Data.Typeable
import System.Environment
import System.FilePath
import System.Directory
import System.Process
import Text.Printf
import GHC.Generics
import Paths_cabal_helper (getLibexecDir)
import CabalHelper.Types
data Programs = Programs {
cabalProgram :: FilePath,
ghcProgram :: FilePath,
ghcPkgProgram :: FilePath
} deriving (Eq, Ord, Show, Read, Generic, Typeable)
instance Default Programs where
def = Programs "cabal" "ghc" "ghc-pkg"
data SomeLocalBuildInfo = SomeLocalBuildInfo {
slbiEntrypoints :: [(ChComponentName, ChEntrypoint)],
slbiSourceDirs :: [(ChComponentName, [String])],
slbiGhcOptions :: [(ChComponentName, [String])],
slbiGhcSrcOptions :: [(ChComponentName, [String])],
slbiGhcPkgOptions :: [(ChComponentName, [String])]
} deriving (Eq, Ord, Read, Show)
newtype Query m a = Query { unQuery :: StateT (Maybe SomeLocalBuildInfo)
(ReaderT (Programs, FilePath) m) a }
deriving (Functor, Applicative, Monad)
type MonadQuery m = ( MonadIO m
, MonadState (Maybe SomeLocalBuildInfo) m
, MonadReader (Programs, FilePath) m)
run r s action = flip runReaderT r (flip evalStateT s (unQuery action))
runQuery :: Monad m
=> FilePath
-> Query m a
-> m a
runQuery fp action = run (def, fp) Nothing action
runQuery' :: Monad m
=> Programs
-> FilePath
-> Query m a
-> m a
runQuery' progs fp action = run (progs, fp) 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
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])]
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
reconfigure :: MonadIO m
=> Programs
-> [String]
-> m ()
reconfigure progs cabalOpts = do
let progOpts =
[ "--with-ghc=" ++ ghcProgram progs ]
++ if ghcPkgProgram progs /= ghcPkgProgram def
then [ "--with-ghc-pkg=" ++ ghcPkgProgram progs ]
else []
++ cabalOpts
_ <- liftIO $ readProcess (cabalProgram progs) ("configure":progOpts) ""
return ()
getSomeConfigState :: MonadQuery m => m SomeLocalBuildInfo
getSomeConfigState = ask >>= \(progs, distdir) -> do
let progArgs = [ "--with-ghc=" ++ ghcProgram progs
, "--with-ghc-pkg=" ++ ghcPkgProgram progs
, "--with-cabal=" ++ cabalProgram progs
]
let args = [ "entrypoints"
, "source-dirs"
, "ghc-options"
, "ghc-src-options"
, "ghc-pkg-options"
] ++ progArgs
res <- liftIO $ do
exe <- findLibexecExe "cabal-helper-wrapper"
out <- readProcess exe (distdir:args) ""
evaluate (read out) `E.catch` \(SomeException _) ->
error $ concat ["getSomeConfigState", ": ", exe, " "
, intercalate " " (map show $ distdir:args)
, " (read failed)"]
let [ Just (ChResponseEntrypoints eps),
Just (ChResponseStrings srcDirs),
Just (ChResponseStrings ghcOpts),
Just (ChResponseStrings ghcSrcOpts),
Just (ChResponseStrings ghcPkgOpts) ] = res
return $ SomeLocalBuildInfo eps srcDirs ghcOpts ghcSrcOpts ghcPkgOpts
writeAutogenFiles :: MonadIO m
=> FilePath
-> m ()
writeAutogenFiles distdir = liftIO $ do
exe <- findLibexecExe "cabal-helper-wrapper"
callProcess' exe [distdir, "write-autogen-files"]
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
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
callProcess' exe args =
#if MIN_VERSION_process(1,2,0)
callProcess exe args
#else
void $ readProcess exe args ""
#endif