This commit is contained in:
Daniel Gröber 2015-08-13 10:17:14 +02:00
commit 312a8c81fb
7 changed files with 51 additions and 13 deletions

2
.gitignore vendored
View File

@ -16,3 +16,5 @@ cabal.sandbox.config
# For instance, .#Help.page # For instance, .#Help.page
# .#* # .#*
cabal-dev cabal-dev
/TAGS
/tags

View File

@ -12,7 +12,6 @@ import Language.Haskell.GhcMod.Convert
import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Monad
import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Internal import Language.Haskell.GhcMod.Internal
import Language.Haskell.GhcMod.CabalHelper
import Language.Haskell.GhcMod.Target import Language.Haskell.GhcMod.Target
import Language.Haskell.GhcMod.Pretty import Language.Haskell.GhcMod.Pretty
import Language.Haskell.GhcMod.Utils import Language.Haskell.GhcMod.Utils
@ -44,8 +43,8 @@ debugInfo = do
cabalDebug :: IOish m => GhcModT m [String] cabalDebug :: IOish m => GhcModT m [String]
cabalDebug = do cabalDebug = do
crdl@Cradle {..} <- cradle Cradle {..} <- cradle
mcs <- resolveGmComponents Nothing =<< mapM (resolveEntrypoint crdl) =<< getComponents mcs <- cabalResolvedComponents
let entrypoints = Map.map gmcEntrypoints mcs let entrypoints = Map.map gmcEntrypoints mcs
graphs = Map.map gmcHomeModuleGraph mcs graphs = Map.map gmcHomeModuleGraph mcs
opts = Map.map gmcGhcOpts mcs opts = Map.map gmcGhcOpts mcs
@ -69,8 +68,7 @@ componentInfo ts = do
-- useful function from there. -- useful function from there.
crdl <- cradle crdl <- cradle
sefnmn <- Set.fromList `liftM` mapM guessModuleFile ts sefnmn <- Set.fromList `liftM` mapM guessModuleFile ts
comps <- mapM (resolveEntrypoint crdl) =<< getComponents mcs <- cabalResolvedComponents
mcs <- resolveGmComponents Nothing comps
let let
mdlcs = moduleComponents mcs `zipMap` Set.toList sefnmn mdlcs = moduleComponents mcs `zipMap` Set.toList sefnmn
candidates = findCandidates $ map snd mdlcs candidates = findCandidates $ map snd mdlcs

View File

@ -8,6 +8,9 @@ module Language.Haskell.GhcMod.Internal (
, PackageVersion , PackageVersion
, PackageId , PackageId
, IncludeDir , IncludeDir
, GmlT(..)
, MonadIO(..)
, GmEnv(..)
-- * Various Paths -- * Various Paths
, ghcLibDir , ghcLibDir
, ghcModExecutable , ghcModExecutable
@ -20,9 +23,18 @@ module Language.Haskell.GhcMod.Internal (
, GhcModState , GhcModState
, CompilerMode(..) , CompilerMode(..)
, GhcModLog , GhcModLog
, GmLog(..)
, GmLogLevel(..)
, gmSetLogLevel
-- * Monad utilities -- * Monad utilities
, runGhcModT' , runGhcModT'
, hoistGhcModT , hoistGhcModT
, runGmlT
, runGmlT'
, gmlGetSession
, gmlSetSession
, loadTargets
, cabalResolvedComponents
-- ** Accessing 'GhcModEnv' and 'GhcModState' -- ** Accessing 'GhcModEnv' and 'GhcModState'
, options , options
, cradle , cradle
@ -35,13 +47,20 @@ module Language.Haskell.GhcMod.Internal (
, World , World
, getCurrentWorld , getCurrentWorld
, didWorldChange , didWorldChange
-- * Cabal Helper
, ModulePath(..)
, GmComponent(..)
, GmComponentType(..)
, GmModuleGraph(..)
) where ) where
import GHC.Paths (libdir) import GHC.Paths (libdir)
import Language.Haskell.GhcMod.Target
import Language.Haskell.GhcMod.DynFlags import Language.Haskell.GhcMod.DynFlags
import Language.Haskell.GhcMod.Error import Language.Haskell.GhcMod.Error
import Language.Haskell.GhcMod.Logger import Language.Haskell.GhcMod.Logger
import Language.Haskell.GhcMod.Logging
import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Monad
import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Utils import Language.Haskell.GhcMod.Utils

View File

@ -51,6 +51,8 @@ module Language.Haskell.GhcMod.Monad.Types (
-- * Re-exporting convenient stuff -- * Re-exporting convenient stuff
, MonadIO , MonadIO
, liftIO , liftIO
, gmlGetSession
, gmlSetSession
) where ) where
-- MonadUtils of GHC 7.6 or earlier defines its own MonadIO. -- MonadUtils of GHC 7.6 or earlier defines its own MonadIO.
@ -352,13 +354,22 @@ gmLiftWithInner f = liftWith f >>= restoreT . return
type GmGhc m = (IOish m, GhcMonad m) type GmGhc m = (IOish m, GhcMonad m)
instance (MonadIO m, MonadBaseControl IO m) => GhcMonad (GmlT m) where instance (MonadIO m, MonadBaseControl IO m) => GhcMonad (GmlT m) where
getSession = do getSession = gmlGetSession
setSession = gmlSetSession
-- ---------------------------------------------------------------------
gmlGetSession :: (MonadIO m, MonadBaseControl IO m) => GmlT m HscEnv
gmlGetSession = do
ref <- gmgsSession . fromJust . gmGhcSession <$> gmsGet ref <- gmgsSession . fromJust . gmGhcSession <$> gmsGet
GHC.liftIO $ readIORef ref GHC.liftIO $ readIORef ref
setSession a = do
gmlSetSession :: (MonadIO m, MonadBaseControl IO m) => HscEnv -> GmlT m ()
gmlSetSession a = do
ref <- gmgsSession . fromJust . gmGhcSession <$> gmsGet ref <- gmgsSession . fromJust . gmGhcSession <$> gmsGet
GHC.liftIO $ flip writeIORef a ref GHC.liftIO $ flip writeIORef a ref
-- ---------------------------------------------------------------------
instance GhcMonad LightGhc where instance GhcMonad LightGhc where
getSession = (GHC.liftIO . readIORef) =<< LightGhc ask getSession = (GHC.liftIO . readIORef) =<< LightGhc ask
setSession a = (GHC.liftIO . flip writeIORef a) =<< LightGhc ask setSession a = (GHC.liftIO . flip writeIORef a) =<< LightGhc ask

View File

@ -184,11 +184,9 @@ targetGhcOptions crdl sefnmn = do
cabalOpts :: Cradle -> GhcModT m [String] cabalOpts :: Cradle -> GhcModT m [String]
cabalOpts Cradle{..} = do cabalOpts Cradle{..} = do
comps <- mapM (resolveEntrypoint crdl) =<< getComponents mcs <- cabalResolvedComponents
mcs <- cached cradleRootDir resolvedComponentsCache comps
let mdlcs = moduleComponents mcs `zipMap` Set.toList sefnmn let mdlcs = moduleComponents mcs `zipMap` Set.toList sefnmn
cns = map gmcName comps
candidates = findCandidates $ map snd mdlcs candidates = findCandidates $ map snd mdlcs
let noCandidates = Set.null candidates let noCandidates = Set.null candidates
@ -196,7 +194,10 @@ targetGhcOptions crdl sefnmn = do
if noCandidates && noModuleHasAnyAssignment if noCandidates && noModuleHasAnyAssignment
then do then do
gmLog GmWarning "" $ strDoc $ "Could not find a component assignment, falling back to picking first component in cabal file." -- First component should be ChLibName, if no lib will take lexically first exe.
let cns = filter (/= ChSetupHsName) $ Map.keys mcs
gmLog GmWarning "" $ strDoc $ "Could not find a component assignment, falling back to picking library component in cabal file."
return $ gmcGhcOpts $ fromJust $ Map.lookup (head cns) mcs return $ gmcGhcOpts $ fromJust $ Map.lookup (head cns) mcs
else do else do
when noCandidates $ when noCandidates $
@ -476,3 +477,10 @@ needsFallback = any $ \ms ->
#if __GLASGOW_HASKELL__ >= 708 #if __GLASGOW_HASKELL__ >= 708
|| (Opt_PatternSynonyms `xopt` df) || (Opt_PatternSynonyms `xopt` df)
#endif #endif
cabalResolvedComponents :: (IOish m) =>
GhcModT m (Map ChComponentName (GmComponent 'GMCResolved (Set ModulePath)))
cabalResolvedComponents = do
crdl@(Cradle{..}) <- cradle
comps <- mapM (resolveEntrypoint crdl) =<< getComponents
cached cradleRootDir resolvedComponentsCache comps

View File

@ -14,7 +14,7 @@ import Data.Char (isSpace)
import Data.Maybe import Data.Maybe
import Exception import Exception
import Language.Haskell.GhcMod import Language.Haskell.GhcMod
import Language.Haskell.GhcMod.Internal import Language.Haskell.GhcMod.Internal hiding (MonadIO,liftIO)
import Paths_ghc_mod import Paths_ghc_mod
import System.Console.GetOpt (OptDescr(..), ArgDescr(..), ArgOrder(..)) import System.Console.GetOpt (OptDescr(..), ArgDescr(..), ArgOrder(..))
import qualified System.Console.GetOpt as O import qualified System.Console.GetOpt as O

View File

@ -13,7 +13,7 @@ import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Prelude import Prelude
import Language.Haskell.GhcMod import Language.Haskell.GhcMod
import Language.Haskell.GhcMod.Internal import Language.Haskell.GhcMod.Internal hiding (MonadIO,liftIO)
---------------------------------------------------------------- ----------------------------------------------------------------