82bb0090c0
This turned out to be quite involved but save for this huge commit it's actually quite awesome and squashes quite a few bugs and nasty problems (hopefully). Most importantly we now have native cabal component support without the user having to do anything to get it! To do this we traverse imports starting from each component's entrypoints (library modules or Main source file for executables) and use this information to find which component's options each module will build with. Under the assumption that these modules have to build with every component they're used in we can now just pick one. Quite a few internal assumptions have been invalidated by this change. Most importantly the runGhcModT* family of cuntions now change the current working directory to `cradleRootDir`.
335 lines
11 KiB
Haskell
335 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, ViewPatterns, NamedFieldPuns, RankNTypes #-}
|
|
module Language.Haskell.GhcMod.Target where
|
|
|
|
import Control.Arrow
|
|
import Control.Applicative ((<$>))
|
|
import Control.Monad.Reader (runReaderT)
|
|
import GHC
|
|
import GHC.Paths (libdir)
|
|
import StaticFlags
|
|
import SysTools
|
|
import DynFlags
|
|
import HscMain
|
|
import HscTypes
|
|
|
|
import Language.Haskell.GhcMod.DynFlags
|
|
import Language.Haskell.GhcMod.Monad.Types
|
|
import Language.Haskell.GhcMod.CabalHelper
|
|
import Language.Haskell.GhcMod.HomeModuleGraph
|
|
import Language.Haskell.GhcMod.GhcPkg
|
|
import Language.Haskell.GhcMod.Error
|
|
import Language.Haskell.GhcMod.Logging
|
|
import Language.Haskell.GhcMod.Types
|
|
|
|
import Data.Maybe
|
|
import Data.Either
|
|
import Data.Foldable (foldrM)
|
|
import Data.IORef
|
|
import Data.Map.Strict (Map)
|
|
import qualified Data.Map.Strict as Map
|
|
import Data.Set (Set)
|
|
import qualified Data.Set as Set
|
|
|
|
import System.Directory
|
|
import System.FilePath
|
|
|
|
withLightHscEnv :: forall m a. IOish m
|
|
=> [GHCOption] -> (HscEnv -> m a) -> m a
|
|
withLightHscEnv opts action = gbracket initEnv teardownEnv (action)
|
|
|
|
where
|
|
teardownEnv :: HscEnv -> m ()
|
|
teardownEnv env = liftIO $ do
|
|
let dflags = hsc_dflags env
|
|
cleanTempFiles dflags
|
|
cleanTempDirs dflags
|
|
|
|
initEnv :: m HscEnv
|
|
initEnv = liftIO $ do
|
|
initStaticOpts
|
|
settings <- initSysTools (Just libdir)
|
|
dflags <- initDynFlags (defaultDynFlags settings)
|
|
env <- newHscEnv dflags
|
|
dflags' <- runLightGhc env $ do
|
|
-- HomeModuleGraph and probably all other clients get into all sorts of
|
|
-- trouble if the package state isn't initialized here
|
|
_ <- setSessionDynFlags =<< getSessionDynFlags
|
|
addCmdOpts opts =<< getSessionDynFlags
|
|
newHscEnv dflags'
|
|
|
|
runLightGhc :: HscEnv -> LightGhc a -> IO a
|
|
runLightGhc env action = do
|
|
renv <- newIORef env
|
|
flip runReaderT renv $ unLightGhc action
|
|
|
|
runGmPkgGhc :: (IOish m, GmEnv m) => LightGhc a -> m a
|
|
runGmPkgGhc action = do
|
|
pkgOpts <- packageGhcOptions
|
|
withLightHscEnv pkgOpts $ \env -> liftIO $ runLightGhc env action
|
|
|
|
initSession :: IOish m
|
|
=> [GHCOption] -> (DynFlags -> Ghc DynFlags) -> GhcModT m ()
|
|
initSession opts mdf = do
|
|
s <- gmsGet
|
|
case gmGhcSession s of
|
|
Just GmGhcSession {..} -> do
|
|
if gmgsOptions == opts
|
|
then return ()
|
|
else error "TODO: reload stuff"
|
|
Nothing -> do
|
|
Cradle { cradleTempDir } <- cradle
|
|
ghc <- liftIO $ runGhc (Just libdir) $ do
|
|
let setDf df =
|
|
setTmpDir cradleTempDir <$> (mdf =<< addCmdOpts opts df)
|
|
_ <- setSessionDynFlags =<< setDf =<< getSessionDynFlags
|
|
getSession
|
|
|
|
rghc <- liftIO $ newIORef ghc
|
|
gmsPut s { gmGhcSession = Just $ GmGhcSession opts rghc }
|
|
|
|
|
|
-- $ do
|
|
-- dflags <- getSessionDynFlags
|
|
-- defaultCleanupHandler dflags $ do
|
|
-- initializeFlagsWithCradle opt (gmCradle env)
|
|
--
|
|
|
|
-- initSession :: GhcMonad m => Options -> [GHCOption] -> m ()
|
|
-- initSession Options {..} ghcOpts = do
|
|
-- df <- G.getSessionDynFlags
|
|
-- void $
|
|
-- ( setModeSimple -- $ setEmptyLogger
|
|
-- df)
|
|
|
|
runGmLoadedT :: IOish m
|
|
=> [Either FilePath ModuleName] -> GmLoadedT m a -> GhcModT m a
|
|
runGmLoadedT fns action = runGmLoadedT' fns return action
|
|
|
|
runGmLoadedT' :: IOish m
|
|
=> [Either FilePath ModuleName]
|
|
-> (DynFlags -> Ghc DynFlags)
|
|
-> GmLoadedT m a
|
|
-> GhcModT m a
|
|
runGmLoadedT' fns mdf action = runGmLoadedTWith fns mdf id action
|
|
|
|
runGmLoadedTWith :: IOish m
|
|
=> [Either FilePath ModuleName]
|
|
-> (DynFlags -> Ghc DynFlags)
|
|
-> (GmLoadedT m a -> GmLoadedT m b)
|
|
-> GmLoadedT m a
|
|
-> GhcModT m b
|
|
runGmLoadedTWith efnmns' mdf wrapper action = do
|
|
crdl <- cradle
|
|
Options { ghcUserOptions } <- options
|
|
|
|
let (fns, mns) = partitionEithers efnmns'
|
|
ccfns = map (cradleCurrentDir crdl </>) fns
|
|
cfns <- liftIO $ mapM canonicalizePath ccfns
|
|
let rfns = map (makeRelative $ cradleRootDir crdl) cfns
|
|
serfnmn = Set.fromList $ map Right mns ++ map Left rfns
|
|
|
|
opts <- targetGhcOptions crdl serfnmn
|
|
let opts' = opts ++ ghcUserOptions
|
|
|
|
initSession opts' $
|
|
setModeSimple >>> setEmptyLogger >>> mdf
|
|
|
|
unGmLoadedT $ wrapper $ do
|
|
loadTargets (map moduleNameString mns ++ rfns)
|
|
action
|
|
|
|
targetGhcOptions :: IOish m
|
|
=> Cradle
|
|
-> Set (Either FilePath ModuleName)
|
|
-> GhcModT m [GHCOption]
|
|
targetGhcOptions crdl sefnmn = do
|
|
when (Set.null sefnmn) $ error "targetGhcOptions: no targets given"
|
|
|
|
case cradleCabalFile crdl of
|
|
Just _ -> cabalOpts
|
|
Nothing -> sandboxOpts crdl
|
|
where
|
|
zipMap f l = l `zip` (f `map` l)
|
|
cabalOpts = do
|
|
mcs <- resolveGmComponents Nothing =<< getComponents
|
|
|
|
let mdlcs = moduleComponents mcs `zipMap` Set.toList sefnmn
|
|
candidates = Set.unions $ map snd mdlcs
|
|
|
|
when (Set.null candidates) $
|
|
throwError $ GMECabalCompAssignment mdlcs
|
|
|
|
let cn = pickComponent candidates
|
|
return $ gmcGhcOpts $ fromJust $ Map.lookup cn mcs
|
|
|
|
moduleComponents :: Map GmComponentName (GmComponent (Set ModulePath))
|
|
-> Either FilePath ModuleName
|
|
-> Set GmComponentName
|
|
moduleComponents m efnmn =
|
|
foldr' Set.empty m $ \c s ->
|
|
let
|
|
memb =
|
|
case efnmn of
|
|
Left fn -> fn `Set.member` Set.map mpPath (smp c)
|
|
Right mn -> mn `Set.member` Set.map mpModule (smp c)
|
|
in if memb
|
|
then Set.insert (gmcName c) s
|
|
else s
|
|
where
|
|
smp c = Map.keysSet $ gmgGraph $ gmcHomeModuleGraph c
|
|
|
|
foldr' b as f = Map.foldr f b as
|
|
|
|
pickComponent :: Set GmComponentName -> GmComponentName
|
|
pickComponent scn = Set.findMin scn
|
|
|
|
|
|
packageGhcOptions :: (MonadIO m, GmEnv m) => m [GHCOption]
|
|
packageGhcOptions = do
|
|
crdl <- cradle
|
|
case cradleCabalFile crdl of
|
|
Just _ -> do
|
|
(Set.toList . Set.fromList . concat . map snd) `liftM` getGhcPkgOptions
|
|
Nothing -> sandboxOpts crdl
|
|
|
|
sandboxOpts :: Monad m => Cradle -> m [String]
|
|
sandboxOpts crdl = return $ ["-i" ++ d | d <- [wdir,rdir]] ++ pkgOpts
|
|
where
|
|
pkgOpts = ghcDbStackOpts $ cradlePkgDbStack crdl
|
|
(wdir, rdir) = (cradleCurrentDir crdl, cradleRootDir crdl)
|
|
|
|
resolveGmComponent :: (IOish m, GmLog m, GmEnv m)
|
|
=> Maybe [Either FilePath ModuleName] -- ^ Updated modules
|
|
-> GmComponent (Either FilePath [ModuleName])
|
|
-> m (GmComponent (Set ModulePath))
|
|
resolveGmComponent mums c@GmComponent {..} =
|
|
withLightHscEnv gmcGhcSrcOpts $ \env -> do
|
|
let srcDirs = gmcSourceDirs
|
|
mg = gmcHomeModuleGraph
|
|
|
|
let eps = either (return . Left) (map Right) gmcEntrypoints
|
|
simp <- liftIO $ resolveEntrypoints env srcDirs eps
|
|
sump <- liftIO $ case mums of
|
|
Nothing -> return simp
|
|
Just ums -> resolveEntrypoints env srcDirs ums
|
|
|
|
mg' <- updateHomeModuleGraph env mg simp sump
|
|
|
|
return $ c { gmcEntrypoints = simp, gmcHomeModuleGraph = mg' }
|
|
|
|
resolveEntrypoints :: MonadIO m
|
|
=> HscEnv -> [FilePath] -> [Either FilePath ModuleName] -> m (Set ModulePath)
|
|
resolveEntrypoints env srcDirs ms =
|
|
liftIO $ Set.fromList . catMaybes <$> resolve `mapM` ms
|
|
where
|
|
resolve :: Either FilePath ModuleName -> IO (Maybe ModulePath)
|
|
resolve (Right mn) = findModulePath env mn
|
|
resolve (Left fn') = do
|
|
mfn <- findFile srcDirs fn'
|
|
case mfn of
|
|
Nothing -> return Nothing
|
|
Just fn'' -> do
|
|
let fn = normalise fn''
|
|
emn <- fileModuleName env fn
|
|
return $ case emn of
|
|
Left _ -> Nothing
|
|
Right mmn -> Just $
|
|
case mmn of
|
|
Nothing -> mkMainModulePath fn
|
|
Just mn -> ModulePath mn fn
|
|
|
|
resolveGmComponents :: (IOish m, GmState m, GmLog m, GmEnv m)
|
|
=> Maybe [Either FilePath ModuleName]
|
|
-- ^ Updated modules
|
|
-> [GmComponent (Either FilePath [ModuleName])]
|
|
-> m (Map GmComponentName (GmComponent (Set ModulePath)))
|
|
resolveGmComponents mumns cs = do
|
|
s <- gmsGet
|
|
m' <- foldrM' (gmComponents s) cs $ \c m -> do
|
|
case Map.lookup (gmcName c) m of
|
|
Nothing -> insertUpdated m c
|
|
Just c' -> if same gmcRawEntrypoints c c' && same gmcGhcSrcOpts c c'
|
|
then return m
|
|
else insertUpdated m c
|
|
gmsPut s { gmComponents = m' }
|
|
return m'
|
|
|
|
where
|
|
foldrM' b fa f = foldrM f b fa
|
|
insertUpdated m c = do
|
|
rc <- resolveGmComponent mumns c
|
|
return $ Map.insert (gmcName rc) rc m
|
|
|
|
same :: Eq b
|
|
=> (forall a. GmComponent a -> b)
|
|
-> GmComponent c -> GmComponent d -> Bool
|
|
same f a b = (f a) == (f b)
|
|
|
|
|
|
-- | Set the files as targets and load them.
|
|
loadTargets :: IOish m => [String] -> GmLoadedT m ()
|
|
loadTargets filesOrModules = do
|
|
gmLog GmDebug "loadTargets" $
|
|
text "Loading" <+>: fsep (map text filesOrModules)
|
|
|
|
targets <- forM filesOrModules (flip guessTarget Nothing)
|
|
setTargets targets
|
|
|
|
mode <- getCompilerMode
|
|
if mode == Intelligent
|
|
then loadTargets' Intelligent
|
|
else do
|
|
mdls <- depanal [] False
|
|
let fallback = needsFallback mdls
|
|
if fallback then do
|
|
resetTargets targets
|
|
setIntelligent
|
|
gmLog GmInfo "loadTargets" $
|
|
text "Switching to LinkInMemory/HscInterpreted (memory hungry)"
|
|
loadTargets' Intelligent
|
|
else
|
|
loadTargets' Simple
|
|
where
|
|
loadTargets' Simple = do
|
|
void $ load LoadAllTargets
|
|
|
|
loadTargets' Intelligent = do
|
|
df <- getSessionDynFlags
|
|
void $ setSessionDynFlags (setModeIntelligent df)
|
|
void $ load LoadAllTargets
|
|
|
|
resetTargets targets = do
|
|
setTargets []
|
|
void $ load LoadAllTargets
|
|
setTargets targets
|
|
|
|
setIntelligent = do
|
|
newdf <- setModeIntelligent <$> getSessionDynFlags
|
|
void $ setSessionDynFlags newdf
|
|
setCompilerMode Intelligent
|
|
|
|
needsFallback :: ModuleGraph -> Bool
|
|
needsFallback = any $ \ms ->
|
|
let df = ms_hspp_opts ms in
|
|
Opt_TemplateHaskell `xopt` df
|
|
|| Opt_QuasiQuotes `xopt` df
|
|
#if __GLASGOW_HASKELL__ >= 708
|
|
|| (Opt_PatternSynonyms `xopt` df)
|
|
#endif
|