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
|