310 lines
11 KiB
Haskell
310 lines
11 KiB
Haskell
-- ghc-mod: Making Haskell development *more* fun
|
|
-- 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/>.
|
|
|
|
{-# LANGUAGE CPP #-}
|
|
module Language.Haskell.GhcMod.CabalHelper
|
|
#ifndef SPEC
|
|
( getComponents
|
|
, getGhcMergedPkgOptions
|
|
, getCabalPackageDbStack
|
|
, getStackPackageDbStack
|
|
, getCustomPkgDbStack
|
|
, prepareCabalHelper
|
|
)
|
|
#endif
|
|
where
|
|
|
|
import Control.Applicative
|
|
import Control.Monad
|
|
import Control.Category ((.))
|
|
import Data.Maybe
|
|
import Data.Monoid
|
|
import Data.Serialize (Serialize)
|
|
import Data.Traversable
|
|
import Distribution.Helper hiding (Programs(..))
|
|
import qualified Distribution.Helper as CH
|
|
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
|
|
import Language.Haskell.GhcMod.Output
|
|
import System.FilePath
|
|
import System.Directory (findExecutable)
|
|
import System.Process
|
|
import System.Exit
|
|
import Prelude hiding ((.))
|
|
|
|
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]
|
|
getGhcMergedPkgOptions = chCached $ \distdir -> Cached {
|
|
cacheLens = Just (lGmcMergedPkgOptions . lGmCaches),
|
|
cacheFile = mergedPkgOptsCacheFile distdir,
|
|
cachedAction = \ _tcf (progs, rootdir, _) _ma -> do
|
|
readProc <- gmReadProcess
|
|
opts <- withCabal $ runQuery'' readProc progs rootdir distdir $
|
|
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, rootdir, _) _ma -> do
|
|
crdl <- cradle
|
|
readProc <- gmReadProcess
|
|
dbs <- withCabal $ map chPkgToGhcPkg <$> runQuery'' readProc progs rootdir distdir 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)
|
|
=> m [GmComponent 'GMCRaw ChEntrypoint]
|
|
getComponents = chCached$ \distdir -> Cached {
|
|
cacheLens = Just (lGmcComponents . lGmCaches),
|
|
cacheFile = cabalHelperCacheFile distdir,
|
|
cachedAction = \ _tcf (progs, rootdir, _vers) _ma -> do
|
|
readProc <- gmReadProcess
|
|
runQuery'' readProc progs rootdir distdir $ 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'
|
|
]
|
|
|
|
prepareCabalHelper :: (IOish m, GmEnv m, GmOut m, GmLog m) => m ()
|
|
prepareCabalHelper = do
|
|
crdl <- cradle
|
|
let projdir = cradleRootDir crdl
|
|
distdir = projdir </> cradleDistDir crdl
|
|
readProc <- gmReadProcess
|
|
when (cradleProjectType crdl == CabalProject || cradleProjectType crdl == StackProject) $
|
|
withCabal $ liftIO $ prepare readProc projdir distdir
|
|
|
|
parseCustomPackageDb :: String -> [GhcPkgDb]
|
|
parseCustomPackageDb src = map parsePkgDb $ filter (not . null) $ lines src
|
|
where
|
|
parsePkgDb "global" = GlobalDb
|
|
parsePkgDb "user" = UserDb
|
|
parsePkgDb s = PackageDb s
|
|
|
|
getCustomPkgDbStack :: (IOish m, GmEnv m) => m (Maybe [GhcPkgDb])
|
|
getCustomPkgDbStack = do
|
|
mCusPkgDbFile <- liftIO . (traverse readFile <=< findCustomPackageDbFile) . cradleRootDir =<< cradle
|
|
return $ parseCustomPackageDb <$> mCusPkgDbFile
|
|
|
|
getStackPackageDbStack :: IOish m => m [GhcPkgDb]
|
|
getStackPackageDbStack = do
|
|
mstack <- liftIO $ findExecutable "stack"
|
|
case mstack of
|
|
Nothing -> return []
|
|
Just stack -> do
|
|
snapshotDb <- liftIO $ readProcess stack ["path", "--snapshot-pkg-db"] ""
|
|
localDb <- liftIO $ readProcess stack ["path", "--local-pkg-db"] ""
|
|
return $ map (PackageDb . takeWhile (/='\n')) [snapshotDb, localDb]
|
|
|
|
patchStackPrograms :: (IOish m, GmOut m) => Cradle -> Programs -> m Programs
|
|
patchStackPrograms crdl progs
|
|
| cradleProjectType crdl /= StackProject = return progs
|
|
patchStackPrograms crdl progs = do
|
|
let projdir = cradleRootDir crdl
|
|
Just ghc <- getStackGhcPath projdir
|
|
Just ghcPkg <- getStackGhcPkgPath projdir
|
|
return $ progs {
|
|
ghcProgram = ghc
|
|
, ghcPkgProgram = ghcPkg
|
|
}
|
|
|
|
withCabal :: (IOish m, GmEnv m, GmOut m, GmLog m) => m a -> m a
|
|
withCabal action = do
|
|
crdl <- cradle
|
|
opts <- options
|
|
readProc <- gmReadProcess
|
|
|
|
let projdir = cradleRootDir crdl
|
|
distdir = projdir </> cradleDistDir crdl
|
|
|
|
mCabalFile <- liftIO $ timeFile `traverse` cradleCabalFile crdl
|
|
mCabalConfig <- liftIO $ timeMaybe (setupConfigFile crdl)
|
|
mCabalSandboxConfig <- liftIO $ timeMaybe (sandboxConfigFile crdl)
|
|
|
|
mCusPkgDbStack <- getCustomPkgDbStack
|
|
|
|
pkgDbStackOutOfSync <-
|
|
case mCusPkgDbStack of
|
|
Just cusPkgDbStack -> do
|
|
pkgDb <- runQuery'' readProc (helperProgs $ optPrograms opts) projdir distdir $
|
|
map chPkgToGhcPkg <$> packageDbStack
|
|
return $ pkgDb /= cusPkgDbStack
|
|
|
|
Nothing -> return False
|
|
|
|
projType <- cradleProjectType <$> cradle
|
|
|
|
when (isSetupConfigOutOfDate mCabalFile mCabalConfig) $
|
|
gmLog GmDebug "" $ strDoc $ "setup configuration is out of date, reconfiguring Cabal project."
|
|
|
|
when (isSetupConfigOutOfDate mCabalSandboxConfig mCabalConfig) $
|
|
gmLog GmDebug "" $ strDoc $ "sandbox configuration is out of date, reconfiguring Cabal project."
|
|
|
|
when pkgDbStackOutOfSync $
|
|
gmLog GmDebug "" $ strDoc $ "package-db stack out of sync with ghc-mod.package-db-stack, reconfiguring Cabal project."
|
|
|
|
when ( isSetupConfigOutOfDate mCabalFile mCabalConfig
|
|
|| pkgDbStackOutOfSync
|
|
|| isSetupConfigOutOfDate mCabalSandboxConfig mCabalConfig) $
|
|
case projType of
|
|
CabalProject ->
|
|
cabalReconfigure readProc (optPrograms opts) crdl projdir distdir
|
|
StackProject ->
|
|
|
|
stackReconfigure crdl (optPrograms opts)
|
|
_ ->
|
|
error $ "withCabal: unsupported project type: " ++ show projType
|
|
|
|
action
|
|
|
|
where
|
|
writeAutogen projdir distdir = do
|
|
readProc <- gmReadProcess
|
|
gmLog GmDebug "" $ strDoc $ "writing Cabal autogen files"
|
|
liftIO $ writeAutogenFiles readProc projdir distdir
|
|
|
|
|
|
cabalReconfigure readProc progs crdl projdir distdir = do
|
|
withDirectory_ (cradleRootDir crdl) $ do
|
|
cusPkgStack <- maybe [] ((PackageDb "clear"):) <$> getCustomPkgDbStack
|
|
let progOpts =
|
|
[ "--with-ghc=" ++ T.ghcProgram progs ]
|
|
-- 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 ]
|
|
else []
|
|
++ map pkgDbArg cusPkgStack
|
|
liftIO $ void $ readProc (T.cabalProgram progs) ("configure":progOpts) ""
|
|
writeAutogen projdir distdir
|
|
|
|
stackReconfigure crdl progs = do
|
|
let projdir = cradleRootDir crdl
|
|
distdir = projdir </> cradleDistDir crdl
|
|
|
|
withDirectory_ (cradleRootDir crdl) $ do
|
|
supported <- haveStackSupport
|
|
if supported
|
|
then do
|
|
spawn [T.stackProgram progs, "build", "--only-dependencies"]
|
|
spawn [T.stackProgram progs, "build", "--only-configure"]
|
|
writeAutogen projdir distdir
|
|
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 1.4.0.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
|
|
|
|
-- * 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, Serialize a)
|
|
=> (FilePath -> Cached m GhcModState ChCacheData a) -> m a
|
|
chCached c = do
|
|
root <- cradleRootDir <$> cradle
|
|
dist <- cradleDistDir <$> cradle
|
|
d <- cacheInputData root
|
|
withCabal $ cached root (c dist) d
|
|
where
|
|
-- we don't need to include the disdir in the cache input because when it
|
|
-- changes the cache files will be gone anyways ;)
|
|
cacheInputData root = do
|
|
opts <- options
|
|
crdl <- cradle
|
|
progs' <- patchStackPrograms crdl (optPrograms opts)
|
|
return $ ( helperProgs progs'
|
|
, root
|
|
, (gmVer, chVer)
|
|
)
|
|
|
|
gmVer = GhcMod.version
|
|
chVer = VERSION_cabal_helper
|