Merge branch 'dev-dynflags' of https://github.com/DanielG/ghc-mod into DanielG-dev-dynflags

Conflicts:
	Language/Haskell/GhcMod/GHCApi.hs
This commit is contained in:
Kazu Yamamoto 2014-04-23 12:20:18 +09:00
commit 3b3b767556
4 changed files with 68 additions and 54 deletions

View File

@ -1,9 +1,8 @@
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables, RecordWildCards #-}
module Language.Haskell.GhcMod.GHCApi ( module Language.Haskell.GhcMod.GHCApi (
withGHC withGHC
, withGHCDummyFile , withGHCDummyFile
, initializeFlags
, initializeFlagsWithCradle , initializeFlagsWithCradle
, setTargetFiles , setTargetFiles
, addTargetFiles , addTargetFiles
@ -17,7 +16,7 @@ import Language.Haskell.GhcMod.GHCChoice
import Language.Haskell.GhcMod.GhcPkg import Language.Haskell.GhcMod.GhcPkg
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
import Control.Monad (void, forM) import Control.Monad (forM)
import CoreMonad (liftIO) import CoreMonad (liftIO)
import Data.Maybe (isJust, fromJust) import Data.Maybe (isJust, fromJust)
import Distribution.PackageDescription (PackageDescription) import Distribution.PackageDescription (PackageDescription)
@ -74,7 +73,12 @@ data Build = CabalPkg | SingleFile deriving Eq
-- | Initialize the 'DynFlags' relating to the compilation of a single -- | Initialize the 'DynFlags' relating to the compilation of a single
-- file or GHC session according to the 'Cradle' and 'Options' -- file or GHC session according to the 'Cradle' and 'Options'
-- provided. -- provided.
initializeFlagsWithCradle :: GhcMonad m => Options -> Cradle -> [GHCOption] -> Bool -> m (LogReader, Maybe PackageDescription) initializeFlagsWithCradle :: GhcMonad m
=> Options
-> Cradle
-> [GHCOption]
-> Bool
-> m (LogReader, Maybe PackageDescription)
initializeFlagsWithCradle opt cradle ghcopts logging initializeFlagsWithCradle opt cradle ghcopts logging
| cabal = withCabal |||> withSandbox | cabal = withCabal |||> withSandbox
| otherwise = withSandbox | otherwise = withSandbox
@ -99,60 +103,69 @@ initializeFlagsWithCradle opt cradle ghcopts logging
---------------------------------------------------------------- ----------------------------------------------------------------
initSession :: GhcMonad m => Build initSession :: GhcMonad m
=> Build
-> Options -> Options
-> CompilerOptions -> CompilerOptions
-> Bool -> Bool
-> m LogReader -> m LogReader
initSession build opt compOpts logging = do initSession build opt compOpts logging = do
dflags0 <- G.getSessionDynFlags df <- initDynFlags build opt compOpts
(dflags1,readLog) <- setupDynamicFlags dflags0 (df', lg) <- liftIO $ setLogger logging df opt
_ <- G.setSessionDynFlags dflags1 _ <- G.setSessionDynFlags df'
return readLog return lg
where
cmdOpts = ghcOptions compOpts initDynFlags :: GhcMonad m => Build -> Options -> CompilerOptions -> m DynFlags
idirs = includeDirs compOpts initDynFlags build Options {..} CompilerOptions {..} = do
depPkgs = depPackages compOpts df <- G.getSessionDynFlags
setupDynamicFlags df0 = do _ <- G.setSessionDynFlags =<< (addCmdOpts ghcOptions
df1 <- modifyFlagsWithOpts df0 cmdOpts $ setLinkerOptions
let df2 = modifyFlags df1 idirs depPkgs (expandSplice opt) build $ setIncludeDirs includeDirs
df3 <- modifyFlagsWithOpts df2 $ ghcOpts opt $ setSplice expandSplice
liftIO $ setLogger logging df3 opt $ setBuildEnv build
$ Gap.addPackageFlags depPackages df)
G.getSessionDynFlags
---------------------------------------------------------------- ----------------------------------------------------------------
-- | Initialize the 'DynFlags' relating to the compilation of a single -- we don't want to generate object code so we compile to bytecode
-- file or GHC session. -- (HscInterpreted) which implies LinkInMemory
initializeFlags :: GhcMonad m => Options -> m () -- HscInterpreted
initializeFlags opt = do setLinkerOptions :: DynFlags -> DynFlags
dflags0 <- G.getSessionDynFlags setLinkerOptions df = df {
dflags1 <- modifyFlagsWithOpts dflags0 $ ghcOpts opt
void $ G.setSessionDynFlags dflags1
----------------------------------------------------------------
modifyFlags :: DynFlags -> [IncludeDir] -> [Package] -> Bool -> Build -> DynFlags
modifyFlags d0 idirs depPkgs splice build
| splice = setSplice d4
| otherwise = d4
where
d1 = d0 { importPaths = idirs }
d2 = d1 {
ghcLink = LinkInMemory ghcLink = LinkInMemory
, hscTarget = HscInterpreted , hscTarget = HscInterpreted
} }
d3 = Gap.addDevPkgs d2 depPkgs
d4 | build == CabalPkg = Gap.setCabalPkg d3
| otherwise = d3
setSplice :: DynFlags -> DynFlags setIncludeDirs :: [IncludeDir] -> DynFlags -> DynFlags
setSplice dflag = dopt_set dflag Gap.dumpSplicesFlag setIncludeDirs idirs df = df { importPaths = idirs }
---------------------------------------------------------------- setBuildEnv :: Build -> DynFlags -> DynFlags
setBuildEnv build = setHideAllPackages build . setCabalPackage build
modifyFlagsWithOpts :: GhcMonad m => DynFlags -> [GHCOption] -> m DynFlags -- | Set option in 'DynFlags' to Expand template haskell if first argument is
modifyFlagsWithOpts dflags cmdOpts = -- True
tfst <$> G.parseDynamicFlags dflags (map G.noLoc cmdOpts) setSplice :: Bool -> DynFlags -> DynFlags
setSplice False df = df
setSplice True df = dopt_set df Gap.dumpSplicesFlag
-- At the moment with this option set ghc only prints different error messages,
-- suggesting the user to add a hidden package to the build-depends in his cabal
-- file for example
setCabalPackage :: Build -> DynFlags -> DynFlags
setCabalPackage CabalPkg df = Gap.setCabalPkg df
setCabalPackage _ df = df
-- | Enable hiding of all package not explicitly exposed (like Cabal does)
setHideAllPackages :: Build -> DynFlags -> DynFlags
setHideAllPackages CabalPkg df = Gap.setHideAllPackages df
setHideAllPackages _ df = df
-- | Parse command line ghc options and add them to the 'DynFlags' passed
addCmdOpts :: GhcMonad m => [GHCOption] -> DynFlags -> m DynFlags
addCmdOpts cmdOpts df =
tfst <$> G.parseDynamicFlags df (map G.noLoc cmdOpts)
where where
tfst (a,_,_) = a tfst (a,_,_) = a

View File

@ -13,7 +13,8 @@ module Language.Haskell.GhcMod.Gap (
, toStringBuffer , toStringBuffer
, showSeverityCaption , showSeverityCaption
, setCabalPkg , setCabalPkg
, addDevPkgs , setHideAllPackages
, addPackageFlags
, filterOutChildren , filterOutChildren
, infoThing , infoThing
, pprInfo , pprInfo
@ -232,18 +233,19 @@ setCabalPkg dflag = dopt_set dflag Opt_BuildingCabalPackage
---------------------------------------------------------------- ----------------------------------------------------------------
addDevPkgs :: DynFlags -> [Package] -> DynFlags setHideAllPackages :: DynFlags -> DynFlags
addDevPkgs df [] = df setHideAllPackages df = df'
addDevPkgs df pkgs = df''
where where
#if __GLASGOW_HASKELL__ >= 707 #if __GLASGOW_HASKELL__ >= 707
df' = gopt_set df Opt_HideAllPackages df' = gopt_set df Opt_HideAllPackages
#else #else
df' = dopt_set df Opt_HideAllPackages df' = dopt_set df Opt_HideAllPackages
#endif #endif
df'' = df' {
packageFlags = map expose pkgs ++ packageFlags df addPackageFlags :: [Package] -> DynFlags -> DynFlags
} addPackageFlags pkgs df =
df { packageFlags = packageFlags df ++ expose `map` pkgs }
where
expose pkg = ExposePackageId $ showPkgId pkg expose pkg = ExposePackageId $ showPkgId pkg
---------------------------------------------------------------- ----------------------------------------------------------------

View File

@ -18,7 +18,6 @@ module Language.Haskell.GhcMod.Internal (
, getSystemLibDir , getSystemLibDir
, getDynamicFlags , getDynamicFlags
-- * Initializing 'DynFlags' -- * Initializing 'DynFlags'
, initializeFlags
, initializeFlagsWithCradle , initializeFlagsWithCradle
-- * 'Ghc' Monad -- * 'Ghc' Monad
, setTargetFiles , setTargetFiles

View File

@ -14,7 +14,7 @@ newtype LineSeparator = LineSeparator String
data Options = Options { data Options = Options {
outputStyle :: OutputStyle outputStyle :: OutputStyle
, hlintOpts :: [String] , hlintOpts :: [String]
, ghcOpts :: [String] , ghcOpts :: [GHCOption]
-- | If 'True', 'browse' also returns operators. -- | If 'True', 'browse' also returns operators.
, operators :: Bool , operators :: Bool
-- | If 'True', 'browse' also returns types. -- | If 'True', 'browse' also returns types.