From b6896a481a7fe14ab4db420b7304ac3f7abdd7de Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Sat, 12 Jul 2014 03:30:06 +0200 Subject: [PATCH] Move `initializeFlagsWithCradle` to Monad.hs --- Language/Haskell/GhcMod/Browse.hs | 2 +- Language/Haskell/GhcMod/Check.hs | 2 +- Language/Haskell/GhcMod/Debug.hs | 6 +-- Language/Haskell/GhcMod/GHCApi.hs | 81 +---------------------------- Language/Haskell/GhcMod/Ghc.hs | 1 - Language/Haskell/GhcMod/Internal.hs | 12 +++-- Language/Haskell/GhcMod/Logger.hs | 2 +- Language/Haskell/GhcMod/Monad.hs | 60 +++++++++++++++++++-- Language/Haskell/GhcMod/SrcUtils.hs | 2 +- 9 files changed, 71 insertions(+), 97 deletions(-) diff --git a/Language/Haskell/GhcMod/Browse.hs b/Language/Haskell/GhcMod/Browse.hs index a984235..72419b8 100644 --- a/Language/Haskell/GhcMod/Browse.hs +++ b/Language/Haskell/GhcMod/Browse.hs @@ -13,7 +13,7 @@ import FastString (mkFastString) import GHC (GhcException(CmdLineError), ModuleInfo, Name, TyThing, DynFlags, Type, TyCon) import qualified GHC as G 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.Monad import Language.Haskell.GhcMod.Convert diff --git a/Language/Haskell/GhcMod/Check.hs b/Language/Haskell/GhcMod/Check.hs index 48dacc3..736c42f 100644 --- a/Language/Haskell/GhcMod/Check.hs +++ b/Language/Haskell/GhcMod/Check.hs @@ -6,7 +6,7 @@ module Language.Haskell.GhcMod.Check ( ) where import Control.Applicative ((<$>)) -import Language.Haskell.GhcMod.GHCApi +import Language.Haskell.GhcMod.DynFlags import qualified Language.Haskell.GhcMod.Gap as Gap import Language.Haskell.GhcMod.Logger import Language.Haskell.GhcMod.Monad diff --git a/Language/Haskell/GhcMod/Debug.hs b/Language/Haskell/GhcMod/Debug.hs index b3ce715..2278ad2 100644 --- a/Language/Haskell/GhcMod/Debug.hs +++ b/Language/Haskell/GhcMod/Debug.hs @@ -4,12 +4,10 @@ import Control.Applicative ((<$>)) import CoreMonad (liftIO) import Data.List (intercalate) 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.Monad import Language.Haskell.GhcMod.Types +import Language.Haskell.GhcMod.Internal ---------------------------------------------------------------- @@ -28,7 +26,7 @@ debugInfo = cradle >>= \c -> convert' =<< do , "GHC options: " ++ unwords gopts , "Include directories: " ++ unwords incDir , "Dependent packages: " ++ intercalate ", " (map showPkg pkgs) - , "System libraries: " ++ systemLibDir + , "System libraries: " ++ ghcLibDir ] where simpleCompilerOption = options >>= \op -> diff --git a/Language/Haskell/GhcMod/GHCApi.hs b/Language/Haskell/GhcMod/GHCApi.hs index 4a28bfa..b765698 100644 --- a/Language/Haskell/GhcMod/GHCApi.hs +++ b/Language/Haskell/GhcMod/GHCApi.hs @@ -1,15 +1,7 @@ {-# LANGUAGE ScopedTypeVariables, RecordWildCards #-} module Language.Haskell.GhcMod.GHCApi ( - initializeFlagsWithCradle - , setTargetFiles - , getDynamicFlags - , systemLibDir - , withDynFlags - , withCmdFlags - , setNoWaringFlags - , setAllWaringFlags - , ghcPkgDb + ghcPkgDb , package , modules , findModule @@ -18,80 +10,20 @@ module Language.Haskell.GhcMod.GHCApi ( , bindings ) where -import Language.Haskell.GhcMod.CabalApi -import Language.Haskell.GhcMod.GHCChoice import Language.Haskell.GhcMod.GhcPkg import Language.Haskell.GhcMod.DynFlags -import qualified Language.Haskell.GhcMod.Gap as Gap import Language.Haskell.GhcMod.Types import Control.Applicative ((<$>)) -import Control.Monad (void) import Distribution.Package (InstalledPackageId(..)) -import Data.Maybe (isJust, fromJust) import qualified Data.Map as M import GHC (DynFlags(..)) import qualified GHC as G import GhcMonad -import GHC.Paths (libdir) import qualified Packages as G import qualified Module 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 @@ -153,14 +85,3 @@ localModuleInfo mdl = moduleInfo Nothing mdl bindings :: G.ModuleInfo -> [Binding] bindings minfo = do 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" diff --git a/Language/Haskell/GhcMod/Ghc.hs b/Language/Haskell/GhcMod/Ghc.hs index 0d2cd20..074a218 100644 --- a/Language/Haskell/GhcMod/Ghc.hs +++ b/Language/Haskell/GhcMod/Ghc.hs @@ -8,4 +8,3 @@ module Language.Haskell.GhcMod.Ghc ( ) where import Language.Haskell.GhcMod.Find -import Language.Haskell.GhcMod.GHCApi diff --git a/Language/Haskell/GhcMod/Internal.hs b/Language/Haskell/GhcMod/Internal.hs index 99566e6..a405ff5 100644 --- a/Language/Haskell/GhcMod/Internal.hs +++ b/Language/Haskell/GhcMod/Internal.hs @@ -17,11 +17,9 @@ module Language.Haskell.GhcMod.Internal ( , cabalSourceDirs , cabalAllTargets -- * GHC.Paths - , systemLibDir + , ghcLibDir -- * IO , getDynamicFlags - -- * Initializing 'DynFlags' - , initializeFlagsWithCradle -- * Targets , setTargetFiles -- * Logging @@ -36,8 +34,14 @@ module Language.Haskell.GhcMod.Internal ( , (|||>) ) where +import GHC.Paths (libdir) + import Language.Haskell.GhcMod.CabalApi -import Language.Haskell.GhcMod.GHCApi +import Language.Haskell.GhcMod.DynFlags import Language.Haskell.GhcMod.GHCChoice import Language.Haskell.GhcMod.Logger import Language.Haskell.GhcMod.Types + +-- | Obtaining the directory for ghc system libraries. +ghcLibDir :: FilePath +ghcLibDir = libdir diff --git a/Language/Haskell/GhcMod/Logger.hs b/Language/Haskell/GhcMod/Logger.hs index dfe0363..5d16788 100644 --- a/Language/Haskell/GhcMod/Logger.hs +++ b/Language/Haskell/GhcMod/Logger.hs @@ -17,7 +17,7 @@ import GHC (DynFlags, SrcSpan, Severity(SevError)) import qualified GHC as G import HscTypes (SourceError, srcErrorMessages) 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 Language.Haskell.GhcMod.Convert (convert') import Language.Haskell.GhcMod.Monad diff --git a/Language/Haskell/GhcMod/Monad.hs b/Language/Haskell/GhcMod/Monad.hs index 9220e22..bf92caa 100644 --- a/Language/Haskell/GhcMod/Monad.hs +++ b/Language/Haskell/GhcMod/Monad.hs @@ -1,6 +1,6 @@ {-# LANGUAGE CPP, GeneralizedNewtypeDeriving, FlexibleInstances #-} {-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, RankNTypes #-} -{-# LANGUAGE TypeFamilies, UndecidableInstances #-} +{-# LANGUAGE TypeFamilies, UndecidableInstances, RecordWildCards #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Language.Haskell.GhcMod.Monad ( @@ -23,13 +23,18 @@ module Language.Haskell.GhcMod.Monad ( , module Control.Monad.State.Class ) where -import Language.Haskell.GhcMod.Cradle -import Language.Haskell.GhcMod.GHCApi 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 Exception import GHC +import qualified GHC as G import GHC.Paths (libdir) import GhcMonad #if __GLASGOW_HASKELL__ <= 702 @@ -49,7 +54,7 @@ import Data.Monoid (Monoid) #endif import Control.Applicative (Alternative) -import Control.Monad (MonadPlus, liftM) +import Control.Monad (MonadPlus, liftM, void) import Control.Monad.Base (MonadBase, liftBase) 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.Writer.Class +import Data.Maybe (fromJust, isJust) import Data.IORef (IORef, readIORef, writeIORef, newIORef) import System.Exit (exitSuccess) import System.IO (hPutStr, hPrint, stderr) @@ -80,6 +86,7 @@ defaultState = GhcModState type GhcModWriter = () ---------------------------------------------------------------- + type GhcMod a = GhcModT IO a newtype GhcModT m a = GhcModT { @@ -103,6 +110,51 @@ instance (Monoid w, MonadIO m) => MonadIO (RWST r w s m) where #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) => GhcModEnv -> GhcModState diff --git a/Language/Haskell/GhcMod/SrcUtils.hs b/Language/Haskell/GhcMod/SrcUtils.hs index c5438a2..059bcad 100644 --- a/Language/Haskell/GhcMod/SrcUtils.hs +++ b/Language/Haskell/GhcMod/SrcUtils.hs @@ -13,7 +13,7 @@ import GhcMonad import qualified GHC as G import GHC.SYB.Utils (Stage(..), everythingStaged) 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 qualified Language.Haskell.GhcMod.Gap as Gap import Outputable (PprStyle)