Move initializeFlagsWithCradle to Monad.hs

This commit is contained in:
Daniel Gröber 2014-07-12 03:30:06 +02:00
parent 503e8cbe06
commit b6896a481a
9 changed files with 71 additions and 97 deletions

View File

@ -13,7 +13,7 @@ import FastString (mkFastString)
import GHC (GhcException(CmdLineError), ModuleInfo, Name, TyThing, DynFlags, Type, TyCon) import GHC (GhcException(CmdLineError), ModuleInfo, Name, TyThing, DynFlags, Type, TyCon)
import qualified GHC as G import qualified GHC as G
import Language.Haskell.GhcMod.Doc (showPage, showOneLine, styleUnqualified) import Language.Haskell.GhcMod.Doc (showPage, showOneLine, styleUnqualified)
import Language.Haskell.GhcMod.GHCApi import Language.Haskell.GhcMod.DynFlags
import Language.Haskell.GhcMod.Gap import Language.Haskell.GhcMod.Gap
import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Monad
import Language.Haskell.GhcMod.Convert import Language.Haskell.GhcMod.Convert

View File

@ -6,7 +6,7 @@ module Language.Haskell.GhcMod.Check (
) where ) where
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
import Language.Haskell.GhcMod.GHCApi import Language.Haskell.GhcMod.DynFlags
import qualified Language.Haskell.GhcMod.Gap as Gap import qualified Language.Haskell.GhcMod.Gap as Gap
import Language.Haskell.GhcMod.Logger import Language.Haskell.GhcMod.Logger
import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Monad

View File

@ -4,12 +4,10 @@ import Control.Applicative ((<$>))
import CoreMonad (liftIO) import CoreMonad (liftIO)
import Data.List (intercalate) import Data.List (intercalate)
import Data.Maybe (isJust, fromJust) import Data.Maybe (isJust, fromJust)
import Language.Haskell.GhcMod.CabalApi
import Language.Haskell.GhcMod.GHCApi
import Language.Haskell.GhcMod.GHCChoice ((||>))
import Language.Haskell.GhcMod.Convert 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
---------------------------------------------------------------- ----------------------------------------------------------------
@ -28,7 +26,7 @@ debugInfo = cradle >>= \c -> convert' =<< do
, "GHC options: " ++ unwords gopts , "GHC options: " ++ unwords gopts
, "Include directories: " ++ unwords incDir , "Include directories: " ++ unwords incDir
, "Dependent packages: " ++ intercalate ", " (map showPkg pkgs) , "Dependent packages: " ++ intercalate ", " (map showPkg pkgs)
, "System libraries: " ++ systemLibDir , "System libraries: " ++ ghcLibDir
] ]
where where
simpleCompilerOption = options >>= \op -> simpleCompilerOption = options >>= \op ->

View File

@ -1,15 +1,7 @@
{-# LANGUAGE ScopedTypeVariables, RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables, RecordWildCards #-}
module Language.Haskell.GhcMod.GHCApi ( module Language.Haskell.GhcMod.GHCApi (
initializeFlagsWithCradle ghcPkgDb
, setTargetFiles
, getDynamicFlags
, systemLibDir
, withDynFlags
, withCmdFlags
, setNoWaringFlags
, setAllWaringFlags
, ghcPkgDb
, package , package
, modules , modules
, findModule , findModule
@ -18,80 +10,20 @@ module Language.Haskell.GhcMod.GHCApi (
, bindings , bindings
) where ) where
import Language.Haskell.GhcMod.CabalApi
import Language.Haskell.GhcMod.GHCChoice
import Language.Haskell.GhcMod.GhcPkg import Language.Haskell.GhcMod.GhcPkg
import Language.Haskell.GhcMod.DynFlags import Language.Haskell.GhcMod.DynFlags
import qualified Language.Haskell.GhcMod.Gap as Gap
import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Types
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
import Control.Monad (void)
import Distribution.Package (InstalledPackageId(..)) import Distribution.Package (InstalledPackageId(..))
import Data.Maybe (isJust, fromJust)
import qualified Data.Map as M import qualified Data.Map as M
import GHC (DynFlags(..)) import GHC (DynFlags(..))
import qualified GHC as G import qualified GHC as G
import GhcMonad import GhcMonad
import GHC.Paths (libdir)
import qualified Packages as G import qualified Packages as G
import qualified Module as G import qualified Module as G
import qualified OccName as G import qualified OccName as G
----------------------------------------------------------------
-- | Obtaining the directory for system libraries.
systemLibDir :: FilePath
systemLibDir = libdir
----------------------------------------------------------------
importDirs :: [IncludeDir]
importDirs = [".","..","../..","../../..","../../../..","../../../../.."]
-- | Initialize the 'DynFlags' relating to the compilation of a single
-- file or GHC session according to the 'Cradle' and 'Options'
-- provided.
initializeFlagsWithCradle :: GhcMonad m
=> Options
-> Cradle
-> m ()
initializeFlagsWithCradle opt cradle
| cabal = withCabal |||> withSandbox
| otherwise = withSandbox
where
mCradleFile = cradleCabalFile cradle
cabal = isJust mCradleFile
ghcopts = ghcOpts opt
withCabal = do
pkgDesc <- liftIO $ parseCabalFile $ fromJust mCradleFile
compOpts <- liftIO $ getCompilerOptions ghcopts cradle pkgDesc
initSession CabalPkg opt compOpts
withSandbox = initSession SingleFile opt compOpts
where
pkgOpts = ghcDbStackOpts $ cradlePkgDbStack cradle
compOpts
| null pkgOpts = CompilerOptions ghcopts importDirs []
| otherwise = CompilerOptions (ghcopts ++ pkgOpts) [wdir,rdir] []
wdir = cradleCurrentDir cradle
rdir = cradleRootDir cradle
----------------------------------------------------------------
initSession :: GhcMonad m
=> Build
-> Options
-> CompilerOptions
-> m ()
initSession build Options {..} CompilerOptions {..} = do
df <- G.getSessionDynFlags
void $ G.setSessionDynFlags =<< (addCmdOpts ghcOptions
$ setLinkerOptions
$ setIncludeDirs includeDirs
$ setBuildEnv build
$ setEmptyLogger
$ Gap.addPackageFlags depPackages df)
---------------------------------------------------------------- ----------------------------------------------------------------
-- get Packages,Modules,Bindings -- get Packages,Modules,Bindings
@ -153,14 +85,3 @@ localModuleInfo mdl = moduleInfo Nothing mdl
bindings :: G.ModuleInfo -> [Binding] bindings :: G.ModuleInfo -> [Binding]
bindings minfo = do bindings minfo = do
map (G.occNameString . G.getOccName) $ G.modInfoExports minfo map (G.occNameString . G.getOccName) $ G.modInfoExports minfo
----------------------------------------------------------------
-- for PkgDoc
-- import Distribution.InstalledPackageInfo (showInstalledPackageInfoField)
-- haddockHtml :: GhcMonad m => Package -> m String
-- haddockHtml pkg = do
-- extractField info . fromJust . lookup pkg <$> ghcPkgDb
-- where
-- extractField = fromJust $ showInstalledPackageInfoField "haddock-html"

View File

@ -8,4 +8,3 @@ module Language.Haskell.GhcMod.Ghc (
) where ) where
import Language.Haskell.GhcMod.Find import Language.Haskell.GhcMod.Find
import Language.Haskell.GhcMod.GHCApi

View File

@ -17,11 +17,9 @@ module Language.Haskell.GhcMod.Internal (
, cabalSourceDirs , cabalSourceDirs
, cabalAllTargets , cabalAllTargets
-- * GHC.Paths -- * GHC.Paths
, systemLibDir , ghcLibDir
-- * IO -- * IO
, getDynamicFlags , getDynamicFlags
-- * Initializing 'DynFlags'
, initializeFlagsWithCradle
-- * Targets -- * Targets
, setTargetFiles , setTargetFiles
-- * Logging -- * Logging
@ -36,8 +34,14 @@ module Language.Haskell.GhcMod.Internal (
, (|||>) , (|||>)
) where ) where
import GHC.Paths (libdir)
import Language.Haskell.GhcMod.CabalApi import Language.Haskell.GhcMod.CabalApi
import Language.Haskell.GhcMod.GHCApi import Language.Haskell.GhcMod.DynFlags
import Language.Haskell.GhcMod.GHCChoice import Language.Haskell.GhcMod.GHCChoice
import Language.Haskell.GhcMod.Logger import Language.Haskell.GhcMod.Logger
import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Types
-- | Obtaining the directory for ghc system libraries.
ghcLibDir :: FilePath
ghcLibDir = libdir

View File

@ -17,7 +17,7 @@ import GHC (DynFlags, SrcSpan, Severity(SevError))
import qualified GHC as G import qualified GHC as G
import HscTypes (SourceError, srcErrorMessages) import HscTypes (SourceError, srcErrorMessages)
import Language.Haskell.GhcMod.Doc (showPage, getStyle) import Language.Haskell.GhcMod.Doc (showPage, getStyle)
import Language.Haskell.GhcMod.GHCApi (withDynFlags, withCmdFlags) import Language.Haskell.GhcMod.DynFlags (withDynFlags, withCmdFlags)
import qualified Language.Haskell.GhcMod.Gap as Gap import qualified Language.Haskell.GhcMod.Gap as Gap
import Language.Haskell.GhcMod.Convert (convert') import Language.Haskell.GhcMod.Convert (convert')
import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Monad

View File

@ -1,6 +1,6 @@
{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, FlexibleInstances #-} {-# LANGUAGE CPP, GeneralizedNewtypeDeriving, FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, RankNTypes #-} {-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, RankNTypes #-}
{-# LANGUAGE TypeFamilies, UndecidableInstances #-} {-# LANGUAGE TypeFamilies, UndecidableInstances, RecordWildCards #-}
{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-orphans #-}
module Language.Haskell.GhcMod.Monad ( module Language.Haskell.GhcMod.Monad (
@ -23,13 +23,18 @@ module Language.Haskell.GhcMod.Monad (
, module Control.Monad.State.Class , module Control.Monad.State.Class
) where ) where
import Language.Haskell.GhcMod.Cradle
import Language.Haskell.GhcMod.GHCApi
import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Cradle
import Language.Haskell.GhcMod.DynFlags
import Language.Haskell.GhcMod.GhcPkg
import Language.Haskell.GhcMod.GHCChoice
import Language.Haskell.GhcMod.CabalApi
import qualified Language.Haskell.GhcMod.Gap as Gap
import DynFlags import DynFlags
import Exception import Exception
import GHC import GHC
import qualified GHC as G
import GHC.Paths (libdir) import GHC.Paths (libdir)
import GhcMonad import GhcMonad
#if __GLASGOW_HASKELL__ <= 702 #if __GLASGOW_HASKELL__ <= 702
@ -49,7 +54,7 @@ import Data.Monoid (Monoid)
#endif #endif
import Control.Applicative (Alternative) import Control.Applicative (Alternative)
import Control.Monad (MonadPlus, liftM) import Control.Monad (MonadPlus, liftM, void)
import Control.Monad.Base (MonadBase, liftBase) import Control.Monad.Base (MonadBase, liftBase)
import Control.Monad.Reader.Class import Control.Monad.Reader.Class
@ -59,6 +64,7 @@ import Control.Monad.Trans.Control (MonadBaseControl(..), StM, liftBaseWith, con
import Control.Monad.Trans.RWS.Lazy (RWST(..), runRWST) import Control.Monad.Trans.RWS.Lazy (RWST(..), runRWST)
import Control.Monad.Writer.Class import Control.Monad.Writer.Class
import Data.Maybe (fromJust, isJust)
import Data.IORef (IORef, readIORef, writeIORef, newIORef) import Data.IORef (IORef, readIORef, writeIORef, newIORef)
import System.Exit (exitSuccess) import System.Exit (exitSuccess)
import System.IO (hPutStr, hPrint, stderr) import System.IO (hPutStr, hPrint, stderr)
@ -80,6 +86,7 @@ defaultState = GhcModState
type GhcModWriter = () type GhcModWriter = ()
---------------------------------------------------------------- ----------------------------------------------------------------
type GhcMod a = GhcModT IO a type GhcMod a = GhcModT IO a
newtype GhcModT m a = GhcModT { newtype GhcModT m a = GhcModT {
@ -103,6 +110,51 @@ instance (Monoid w, MonadIO m) => MonadIO (RWST r w s m) where
#endif #endif
---------------------------------------------------------------- ----------------------------------------------------------------
-- | Initialize the 'DynFlags' relating to the compilation of a single
-- file or GHC session according to the 'Cradle' and 'Options'
-- provided.
initializeFlagsWithCradle :: GhcMonad m
=> Options
-> Cradle
-> m ()
initializeFlagsWithCradle opt c
| cabal = withCabal |||> withSandbox
| otherwise = withSandbox
where
mCradleFile = cradleCabalFile c
cabal = isJust mCradleFile
ghcopts = ghcOpts opt
withCabal = do
pkgDesc <- liftIO $ parseCabalFile $ fromJust mCradleFile
compOpts <- liftIO $ getCompilerOptions ghcopts c pkgDesc
initSession CabalPkg opt compOpts
withSandbox = initSession SingleFile opt compOpts
where
importDirs = [".","..","../..","../../..","../../../..","../../../../.."]
pkgOpts = ghcDbStackOpts $ cradlePkgDbStack c
compOpts
| null pkgOpts = CompilerOptions ghcopts importDirs []
| otherwise = CompilerOptions (ghcopts ++ pkgOpts) [wdir,rdir] []
wdir = cradleCurrentDir c
rdir = cradleRootDir c
initSession :: GhcMonad m
=> Build
-> Options
-> CompilerOptions
-> m ()
initSession build Options {..} CompilerOptions {..} = do
df <- G.getSessionDynFlags
void $ G.setSessionDynFlags =<< (addCmdOpts ghcOptions
$ setLinkerOptions
$ setIncludeDirs includeDirs
$ setBuildEnv build
$ setEmptyLogger
$ Gap.addPackageFlags depPackages df)
----------------------------------------------------------------
runGhcModT' :: (MonadIO m, MonadBaseControl IO m) runGhcModT' :: (MonadIO m, MonadBaseControl IO m)
=> GhcModEnv => GhcModEnv
-> GhcModState -> GhcModState

View File

@ -13,7 +13,7 @@ import GhcMonad
import qualified GHC as G import qualified GHC as G
import GHC.SYB.Utils (Stage(..), everythingStaged) import GHC.SYB.Utils (Stage(..), everythingStaged)
import Language.Haskell.GhcMod.Doc (showOneLine, getStyle) import Language.Haskell.GhcMod.Doc (showOneLine, getStyle)
import Language.Haskell.GhcMod.GHCApi import Language.Haskell.GhcMod.DynFlags
import Language.Haskell.GhcMod.Gap (HasType(..), setWarnTypedHoles, setDeferTypeErrors) import Language.Haskell.GhcMod.Gap (HasType(..), setWarnTypedHoles, setDeferTypeErrors)
import qualified Language.Haskell.GhcMod.Gap as Gap import qualified Language.Haskell.GhcMod.Gap as Gap
import Outputable (PprStyle) import Outputable (PprStyle)