module GhcMod.CabalHelper
( getComponents
, getGhcMergedPkgOptions
, getCabalPackageDbStack
, prepareCabalHelper
, withAutogen
, withCabal
) where
import Control.Applicative
import Control.Monad
import Control.Category ((.))
import Data.Maybe
import Data.Monoid
import Data.Version
import Data.Binary (Binary)
import Data.Traversable
import Distribution.Helper hiding (Programs(..))
import qualified Distribution.Helper as CH
import qualified GhcMod.Types as T
import GhcMod.Types
import GhcMod.Monad.Types
import GhcMod.Utils
import GhcMod.PathsAndFiles
import GhcMod.Logging
import GhcMod.Output
import GhcMod.CustomPackageDb
import GhcMod.Stack
import System.FilePath
import System.Process
import System.Exit
import Prelude hiding ((.))
import Paths_ghc_mod as GhcMod
getGhcMergedPkgOptions :: (Applicative m, IOish m, Gm m)
=> m [GHCOption]
getGhcMergedPkgOptions = chCached $ \distdir -> Cached {
cacheLens = Just (lGmcMergedPkgOptions . lGmCaches),
cacheFile = mergedPkgOptsCacheFile distdir,
cachedAction = \_tcf (_progs, _projdir, _ver) _ma -> do
opts <- runCHQuery ghcMergedPkgOptions
return ([setupConfigPath distdir], opts)
}
getCabalPackageDbStack :: (IOish m, Gm m) => m [GhcPkgDb]
getCabalPackageDbStack = chCached $ \distdir -> Cached {
cacheLens = Just (lGmcPackageDbStack . lGmCaches),
cacheFile = pkgDbStackCacheFile distdir,
cachedAction = \_tcf (_progs, _projdir, _ver) _ma -> do
crdl <- cradle
dbs <- map chPkgToGhcPkg <$>
runCHQuery packageDbStack
return ([setupConfigFile crdl, sandboxConfigFile crdl], dbs)
}
chPkgToGhcPkg :: ChPkgDb -> GhcPkgDb
chPkgToGhcPkg ChPkgGlobal = GlobalDb
chPkgToGhcPkg ChPkgUser = UserDb
chPkgToGhcPkg (ChPkgSpecific f) = PackageDb f
getComponents :: (Applicative m, IOish m, Gm m)
=> m [GmComponent 'GMCRaw ChEntrypoint]
getComponents = chCached $ \distdir -> Cached {
cacheLens = Just (lGmcComponents . lGmCaches),
cacheFile = cabalHelperCacheFile distdir,
cachedAction = \ _tcf (_progs, _projdir, _ver) _ma -> do
runCHQuery $ do
q <- join7
<$> ghcOptions
<*> ghcPkgOptions
<*> ghcSrcOptions
<*> ghcLangOptions
<*> entrypoints
<*> entrypoints
<*> sourceDirs
let cs = flip map q $ curry8 (GmComponent mempty)
return ([setupConfigPath distdir], cs)
}
where
curry8 fn (a, (b, (c, (d, (e, (f, (g, h))))))) = fn a b c d e f g h
join7 a b c d e f = join' a . join' b . join' c . join' d . join' e . join' f
join' :: Eq a => [(a,b)] -> [(a,c)] -> [(a,(b,c))]
join' lb lc = [ (a, (b, c))
| (a, b) <- lb
, (a', c) <- lc
, a == a'
]
getQueryEnv :: (IOish m, GmOut m, GmEnv m) => m QueryEnv
getQueryEnv = do
crdl <- cradle
progs <- patchStackPrograms crdl =<< (optPrograms <$> options)
readProc <- gmReadProcess
let projdir = cradleRootDir crdl
distdir = projdir </> cradleDistDir crdl
return (defaultQueryEnv projdir distdir) {
qeReadProcess = readProc
, qePrograms = helperProgs progs
}
runCHQuery :: (IOish m, GmOut m, GmEnv m) => Query m b -> m b
runCHQuery a = do
qe <- getQueryEnv
runQuery qe a
prepareCabalHelper :: (IOish m, GmEnv m, GmOut m, GmLog m) => m ()
prepareCabalHelper = do
crdl <- cradle
when (isCabalHelperProject $ cradleProject crdl) $
withCabal $ prepare' =<< getQueryEnv
withAutogen :: (IOish m, GmEnv m, GmOut m, GmLog m) => m a -> m a
withAutogen action = do
gmLog GmDebug "" $ strDoc $ "making sure autogen files exist"
crdl <- cradle
let projdir = cradleRootDir crdl
distdir = projdir </> cradleDistDir crdl
(pkgName', _) <- runCHQuery packageId
mCabalFile <- liftIO $ timeFile `traverse` cradleCabalFile crdl
mCabalMacroHeader <- liftIO $ timeMaybe (distdir </> macrosHeaderPath)
mCabalPathsModule <- liftIO $ timeMaybe (distdir </> autogenModulePath pkgName')
when (mCabalMacroHeader < mCabalFile || mCabalPathsModule < mCabalFile) $ do
gmLog GmDebug "" $ strDoc $ "autogen files out of sync"
writeAutogen
action
where
writeAutogen = do
gmLog GmDebug "" $ strDoc $ "writing Cabal autogen files"
writeAutogenFiles' =<< getQueryEnv
withCabal :: (IOish m, GmEnv m, GmOut m, GmLog m) => m a -> m a
withCabal action = do
crdl <- cradle
mCabalFile <- liftIO $ timeFile `traverse` cradleCabalFile crdl
mCabalConfig <- liftIO $ timeMaybe (setupConfigFile crdl)
mCabalSandboxConfig <- liftIO $ timeMaybe (sandboxConfigFile crdl)
let haveSetupConfig = isJust mCabalConfig
cusPkgDb <- getCustomPkgDbStack
(flgs, pkgDbStackOutOfSync) <- do
if haveSetupConfig
then runCHQuery $ do
flgs <- nonDefaultConfigFlags
pkgDb <- map chPkgToGhcPkg <$> packageDbStack
return (flgs, fromMaybe False $ (pkgDb /=) <$> cusPkgDb)
else return ([], False)
when (isSetupConfigOutOfDate mCabalFile mCabalConfig) $
gmLog GmDebug "" $ strDoc $ "setup configuration is out of date"
when (isSetupConfigOutOfDate mCabalSandboxConfig mCabalConfig) $
gmLog GmDebug "" $ strDoc $ "sandbox configuration is out of date"
when pkgDbStackOutOfSync $
gmLog GmDebug "" $ strDoc $ "package-db stack out of sync with ghc-mod.package-db-stack"
when ( isSetupConfigOutOfDate mCabalFile mCabalConfig
|| pkgDbStackOutOfSync
|| isSetupConfigOutOfDate mCabalSandboxConfig mCabalConfig) $ do
proj <- cradleProject <$> cradle
opts <- options
case proj of
CabalProject -> do
gmLog GmDebug "" $ strDoc "reconfiguring Cabal project"
cabalReconfigure (optPrograms opts) crdl flgs
StackProject {} -> do
gmLog GmDebug "" $ strDoc "reconfiguring Stack project"
stackReconfigure (optStackBuildDeps opts) crdl (optPrograms opts)
_ ->
error $ "withCabal: unsupported project type: " ++ show proj
action
where
cabalReconfigure progs crdl flgs = do
readProc <- gmReadProcess
withDirectory_ (cradleRootDir crdl) $ do
cusPkgStack <- maybe [] ((PackageDb "clear"):) <$> getCustomPkgDbStack
let progOpts =
[ "--with-ghc=" ++ T.ghcProgram progs ]
++ if T.ghcPkgProgram progs /= T.ghcPkgProgram (optPrograms defaultOptions)
then [ "--with-ghc-pkg=" ++ T.ghcPkgProgram progs ]
else []
++ map pkgDbArg cusPkgStack
++ flagOpt
toFlag (f, True) = f
toFlag (f, False) = '-':f
flagOpt = ["--flags", unwords $ map toFlag flgs]
liftIO $ void $ readProc (T.cabalProgram progs) ("configure":progOpts) ""
stackReconfigure deps crdl progs = do
withDirectory_ (cradleRootDir crdl) $ do
supported <- haveStackSupport
if supported
then do
when deps $
spawn [T.stackProgram progs, "build", "--only-dependencies", "."]
spawn [T.stackProgram progs, "build", "--only-configure", "."]
else
gmLog GmWarning "" $ strDoc $ "Stack project configuration is out of date, please reconfigure manually using 'stack build' as your stack version is too old (need at least 0.1.4.0)"
spawn [] = return ()
spawn (exe:args) = do
readProc <- gmReadProcess
liftIO $ void $ readProc exe args ""
haveStackSupport = do
(rv, _, _) <-
liftIO $ readProcessWithExitCode "stack" ["--numeric-version"] ""
case rv of
ExitSuccess -> return True
ExitFailure _ -> return False
pkgDbArg :: GhcPkgDb -> String
pkgDbArg GlobalDb = "--package-db=global"
pkgDbArg UserDb = "--package-db=user"
pkgDbArg (PackageDb p) = "--package-db=" ++ p
isSetupConfigOutOfDate :: Maybe TimedFile -> Maybe TimedFile -> Bool
isSetupConfigOutOfDate worldCabalFile worldCabalConfig = do
worldCabalConfig < worldCabalFile
helperProgs :: Programs -> CH.Programs
helperProgs progs = CH.Programs {
cabalProgram = T.cabalProgram progs,
ghcProgram = T.ghcProgram progs,
ghcPkgProgram = T.ghcPkgProgram progs
}
chCached :: (Applicative m, IOish m, Gm m, Binary a)
=> (FilePath -> Cached m GhcModState ChCacheData a) -> m a
chCached c = do
projdir <- cradleRootDir <$> cradle
distdir <- (projdir </>) . cradleDistDir <$> cradle
d <- cacheInputData projdir
withCabal $ cached projdir (c distdir) d
where
cacheInputData projdir = do
opts <- options
crdl <- cradle
progs' <- patchStackPrograms crdl (optPrograms opts)
return $ ( helperProgs progs'
, projdir
, (showVersion gmVer, chVer)
)
gmVer = GhcMod.version
chVer = VERSION_cabal_helper