ghc-mod/core/Language/Haskell/GhcMod/CabalHelper.hs

310 lines
11 KiB
Haskell
Raw Normal View History

2017-03-06 23:19:57 +00:00
-- ghc-mod: Happy Haskell Hacking
-- Copyright (C) 2015 Daniel Gröber <dxld ÄT darkboxed DOT org>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
2015-03-28 01:33:42 +00:00
{-# LANGUAGE CPP #-}
module Language.Haskell.GhcMod.CabalHelper
( getComponents
, getGhcMergedPkgOptions
, getCabalPackageDbStack
, prepareCabalHelper
, withAutogen
2017-01-12 16:03:31 +00:00
, 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
2015-03-15 19:48:55 +00:00
import qualified Language.Haskell.GhcMod.Types as T
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Monad.Types
import Language.Haskell.GhcMod.Utils
import Language.Haskell.GhcMod.PathsAndFiles
import Language.Haskell.GhcMod.Logging
2015-08-13 07:01:58 +00:00
import Language.Haskell.GhcMod.Output
import Language.Haskell.GhcMod.CustomPackageDb
2015-09-15 03:25:00 +00:00
import Language.Haskell.GhcMod.Stack
import System.FilePath
import System.Process
import System.Exit
import Prelude hiding ((.))
2015-03-28 01:33:42 +00:00
import Paths_ghc_mod as GhcMod
-- | Only package related GHC options, sufficient for things that don't need to
-- access home modules
getGhcMergedPkgOptions :: (Applicative m, IOish m, Gm m)
=> m [GHCOption]
2015-08-19 04:48:27 +00:00
getGhcMergedPkgOptions = chCached $ \distdir -> Cached {
cacheLens = Just (lGmcMergedPkgOptions . lGmCaches),
2015-08-19 04:48:27 +00:00
cacheFile = mergedPkgOptsCacheFile distdir,
2015-09-07 03:15:29 +00:00
cachedAction = \_tcf (_progs, _projdir, _ver) _ma -> do
opts <- runCHQuery ghcMergedPkgOptions
2015-08-19 04:48:27 +00:00
return ([setupConfigPath distdir], opts)
}
getCabalPackageDbStack :: (IOish m, Gm m) => m [GhcPkgDb]
2015-08-19 04:48:27 +00:00
getCabalPackageDbStack = chCached $ \distdir -> Cached {
cacheLens = Just (lGmcPackageDbStack . lGmCaches),
2015-08-19 04:48:27 +00:00
cacheFile = pkgDbStackCacheFile distdir,
2015-09-07 03:15:29 +00:00
cachedAction = \_tcf (_progs, _projdir, _ver) _ma -> do
crdl <- cradle
dbs <- map chPkgToGhcPkg <$>
2015-09-07 03:15:29 +00:00
runCHQuery packageDbStack
return ([setupConfigFile crdl, sandboxConfigFile crdl], dbs)
}
chPkgToGhcPkg :: ChPkgDb -> GhcPkgDb
chPkgToGhcPkg ChPkgGlobal = GlobalDb
chPkgToGhcPkg ChPkgUser = UserDb
chPkgToGhcPkg (ChPkgSpecific f) = PackageDb f
-- | Primary interface to cabal-helper and intended single entrypoint to
-- constructing 'GmComponent's
--
-- The Component\'s 'gmcHomeModuleGraph' will be empty and has to be resolved by
-- 'resolveGmComponents'.
getComponents :: (Applicative m, IOish m, Gm m)
2015-08-03 01:09:56 +00:00
=> m [GmComponent 'GMCRaw ChEntrypoint]
getComponents = chCached $ \distdir -> Cached {
cacheLens = Just (lGmcComponents . lGmCaches),
2015-08-19 04:48:27 +00:00
cacheFile = cabalHelperCacheFile distdir,
2015-09-07 03:15:29 +00:00
cachedAction = \ _tcf (_progs, _projdir, _ver) _ma -> do
runCHQuery $ do
q <- join7
<$> ghcOptions
<*> ghcPkgOptions
<*> ghcSrcOptions
<*> ghcLangOptions
<*> entrypoints
<*> entrypoints
<*> sourceDirs
2015-05-05 12:44:42 +00:00
let cs = flip map q $ curry8 (GmComponent mempty)
2015-08-19 04:48:27 +00:00
return ([setupConfigPath distdir], cs)
}
2015-03-15 19:48:55 +00:00
where
2015-05-05 12:44:42 +00:00
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
2015-03-15 19:48:55 +00:00
join' :: Eq a => [(a,b)] -> [(a,c)] -> [(a,(b,c))]
join' lb lc = [ (a, (b, c))
| (a, b) <- lb
2015-05-05 12:44:42 +00:00
, (a', c) <- lc
, a == a'
]
getQueryEnv :: (IOish m, GmOut m, GmEnv m) => m QueryEnv
getQueryEnv = do
2015-09-07 03:15:29 +00:00
crdl <- cradle
progs <- patchStackPrograms crdl =<< (optPrograms <$> options)
readProc <- gmReadProcess
2015-09-07 03:15:29 +00:00
let projdir = cradleRootDir crdl
distdir = projdir </> cradleDistDir crdl
return (defaultQueryEnv projdir distdir) {
qeReadProcess = readProc
, qePrograms = helperProgs progs
}
2015-09-07 03:15:29 +00:00
runCHQuery :: (IOish m, GmOut m, GmEnv m) => Query m b -> m b
runCHQuery a = do
qe <- getQueryEnv
2015-09-07 03:15:29 +00:00
runQuery qe a
2015-03-28 01:33:42 +00:00
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"
-- TODO: we could support flags for stack too, but it seems
-- you're supposed to put those in stack.yaml so detecting which
-- flags to pass down would be more difficult
-- "--flag PACKAGE:[-]FLAG Override flags set in stack.yaml
-- (applies to local packages and extra-deps)"
stackReconfigure (optStackBuildDeps opts) crdl (optPrograms opts)
2015-08-19 07:04:25 +00:00
_ ->
error $ "withCabal: unsupported project type: " ++ show proj
2015-08-19 07:04:25 +00:00
action
2015-03-03 11:18:54 +00:00
2015-08-19 07:04:25 +00:00
where
cabalReconfigure progs crdl flgs = do
readProc <- gmReadProcess
2015-08-19 07:04:25 +00:00
withDirectory_ (cradleRootDir crdl) $ do
cusPkgStack <- maybe [] ((PackageDb "clear"):) <$> getCustomPkgDbStack
let progOpts =
[ "--with-ghc=" ++ T.ghcProgram progs ]
2015-08-19 07:04:25 +00:00
-- Only pass ghc-pkg if it was actually set otherwise we
-- might break cabal's guessing logic
++ if T.ghcPkgProgram progs /= T.ghcPkgProgram (optPrograms defaultOptions)
then [ "--with-ghc-pkg=" ++ T.ghcPkgProgram progs ]
2015-08-19 07:04:25 +00:00
else []
++ map pkgDbArg cusPkgStack
++ flagOpt
toFlag (f, True) = f
toFlag (f, False) = '-':f
flagOpt = ["--flags", unwords $ map toFlag flgs]
2015-08-19 07:04:25 +00:00
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", "."]
2015-09-08 01:54:29 +00:00
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
2015-08-19 07:04:25 +00:00
2015-03-03 11:18:54 +00:00
pkgDbArg :: GhcPkgDb -> String
pkgDbArg GlobalDb = "--package-db=global"
pkgDbArg UserDb = "--package-db=user"
pkgDbArg (PackageDb p) = "--package-db=" ++ p
-- * Neither file exists -> should return False:
-- @Nothing < Nothing = False@
-- (since we don't need to @cabal configure@ when no cabal file exists.)
--
-- * Cabal file doesn't exist (impossible since cabal-helper is only used with
-- cabal projects) -> should return False
-- @Just cc < Nothing = False@
--
-- * dist/setup-config doesn't exist yet -> should return True:
-- @Nothing < Just cf = True@
--
-- * Both files exist
-- @Just cc < Just cf = cc < cf = cc `olderThan` cf@
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)
2015-08-18 09:41:14 +00:00
=> (FilePath -> Cached m GhcModState ChCacheData a) -> m a
chCached c = do
2015-09-07 03:15:29 +00:00
projdir <- cradleRootDir <$> cradle
distdir <- (projdir </>) . cradleDistDir <$> cradle
d <- cacheInputData projdir
withCabal $ cached projdir (c distdir) d
where
2015-11-18 19:54:12 +00:00
-- we don't need to include the distdir in the cache input because when it
2015-08-19 04:48:27 +00:00
-- changes the cache files will be gone anyways ;)
2015-09-07 03:15:29 +00:00
cacheInputData projdir = do
opts <- options
crdl <- cradle
progs' <- patchStackPrograms crdl (optPrograms opts)
return $ ( helperProgs progs'
2015-09-07 03:15:29 +00:00
, projdir
, (showVersion gmVer, chVer)
)
gmVer = GhcMod.version
chVer = VERSION_cabal_helper