248 lines
7.7 KiB
Haskell
248 lines
7.7 KiB
Haskell
{-# LANGUAGE CPP, RecordWildCards #-}
|
|
-- 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/>.
|
|
module Language.Haskell.GhcMod.Monad (
|
|
-- * Monad Types
|
|
GhcModT
|
|
, IOish
|
|
-- ** Environment, state and logging
|
|
, GhcModEnv(..)
|
|
, newGhcModEnv
|
|
, GhcModState(..)
|
|
, defaultState
|
|
, CompilerMode(..)
|
|
, GhcModLog
|
|
, GhcModError(..)
|
|
-- * Monad utilities
|
|
, runGhcModT
|
|
, runGhcModT'
|
|
, hoistGhcModT
|
|
-- ** Accessing 'GhcModEnv', 'GhcModState' and 'GhcModLog'
|
|
, gmsGet
|
|
, gmsPut
|
|
, gmLog
|
|
, options
|
|
, cradle
|
|
, getCompilerMode
|
|
, setCompilerMode
|
|
, withOptions
|
|
, withTempSession
|
|
-- ** Re-exporting convenient stuff
|
|
, liftIO
|
|
, module Control.Monad.Reader.Class
|
|
) where
|
|
|
|
import Language.Haskell.GhcMod.Types
|
|
import Language.Haskell.GhcMod.Monad.Types
|
|
import Language.Haskell.GhcMod.Logging
|
|
import Language.Haskell.GhcMod.Error
|
|
import Language.Haskell.GhcMod.Cradle
|
|
import Language.Haskell.GhcMod.DynFlags
|
|
import Language.Haskell.GhcMod.GhcPkg
|
|
import Language.Haskell.GhcMod.CabalApi
|
|
import Language.Haskell.GhcMod.CabalConfig
|
|
import qualified Language.Haskell.GhcMod.Gap as Gap
|
|
|
|
import GHC
|
|
import qualified GHC as G
|
|
import GHC.Paths (libdir)
|
|
import GhcMonad hiding (withTempSession)
|
|
#if __GLASGOW_HASKELL__ <= 702
|
|
import HscTypes
|
|
#endif
|
|
|
|
-- MonadUtils of GHC 7.6 or earlier defines its own MonadIO.
|
|
-- RWST does not automatically become an instance of MonadIO.
|
|
-- MonadUtils of GHC 7.8 or later imports MonadIO in Monad.Control.IO.Class.
|
|
-- So, RWST automatically becomes an instance of MonadIO.
|
|
import MonadUtils
|
|
|
|
import Control.Arrow (first)
|
|
import Control.Monad (void)
|
|
#if !MIN_VERSION_monad_control(1,0,0)
|
|
import Control.Monad (liftM)
|
|
#endif
|
|
import Control.Monad.Base (liftBase)
|
|
|
|
import Control.Monad.Reader.Class
|
|
import Control.Monad.State.Class (MonadState(..))
|
|
|
|
import Control.Monad.Error (runErrorT)
|
|
import Control.Monad.Reader (runReaderT)
|
|
import Control.Monad.State.Strict (runStateT)
|
|
import Control.Monad.Trans.Journal (runJournalT)
|
|
|
|
import Data.Maybe (isJust)
|
|
import Data.IORef
|
|
import System.Directory (getCurrentDirectory)
|
|
|
|
----------------------------------------------------------------
|
|
|
|
-- | Initialize the 'DynFlags' relating to the compilation of a single
|
|
-- file or GHC session according to the 'Cradle' and 'Options'
|
|
-- provided.
|
|
initializeFlagsWithCradle :: (IOish m, GhcMonad m, GmError m, GmLog m)
|
|
=> Options
|
|
-> Cradle
|
|
-> CabalConfig
|
|
-> m ()
|
|
initializeFlagsWithCradle opt c config
|
|
| cabal = withCabal
|
|
| otherwise = withSandbox
|
|
where
|
|
mCabalFile = cradleCabalFile c
|
|
|
|
cabal = isJust mCabalFile
|
|
|
|
ghcopts = ghcUserOptions opt
|
|
|
|
withCabal = do
|
|
let Just cabalFile = mCabalFile
|
|
pkgDesc <- parseCabalFile config cabalFile
|
|
compOpts <- getCompilerOptions ghcopts c config 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, rdir) = (cradleCurrentDir c, cradleRootDir c)
|
|
|
|
initSession :: GhcMonad m
|
|
=> Build
|
|
-> Options
|
|
-> CompilerOptions
|
|
-> m ()
|
|
initSession build Options {..} CompilerOptions {..} = do
|
|
df <- G.getSessionDynFlags
|
|
void $ G.setSessionDynFlags =<< addCmdOpts ghcOptions
|
|
( setModeSimple
|
|
$ Gap.setFlags
|
|
$ setIncludeDirs includeDirs
|
|
$ setBuildEnv build
|
|
$ setEmptyLogger
|
|
$ Gap.addPackageFlags depPackages df)
|
|
|
|
----------------------------------------------------------------
|
|
|
|
newGhcModEnv :: Options -> FilePath -> IO GhcModEnv
|
|
newGhcModEnv opt dir = do
|
|
session <- newIORef (error "empty session")
|
|
c <- findCradle' dir
|
|
return GhcModEnv {
|
|
gmGhcSession = session
|
|
, gmOptions = opt
|
|
, gmCradle = c
|
|
}
|
|
|
|
cleanupGhcModEnv :: GhcModEnv -> IO ()
|
|
cleanupGhcModEnv env = cleanupCradle $ gmCradle env
|
|
|
|
-- | Run a @GhcModT m@ computation.
|
|
runGhcModT :: IOish m
|
|
=> Options
|
|
-> GhcModT m a
|
|
-> m (Either GhcModError a, GhcModLog)
|
|
runGhcModT opt action = gbracket newEnv delEnv $ \env -> do
|
|
r <- first (fst <$>) <$> (runGhcModT' env defaultState $ do
|
|
dflags <- getSessionDynFlags
|
|
defaultCleanupHandler dflags $ do
|
|
config <- cabalGetConfig =<< cradle
|
|
initializeFlagsWithCradle opt (gmCradle env) config
|
|
action )
|
|
return r
|
|
|
|
where
|
|
newEnv = liftBase $ newGhcModEnv opt =<< getCurrentDirectory
|
|
delEnv = liftBase . cleanupGhcModEnv
|
|
|
|
-- | @hoistGhcModT result@. Embed a GhcModT computation's result into a GhcModT
|
|
-- computation. Note that if the computation that returned @result@ modified the
|
|
-- state part of GhcModT this cannot be restored.
|
|
hoistGhcModT :: IOish m
|
|
=> (Either GhcModError a, GhcModLog)
|
|
-> GhcModT m a
|
|
hoistGhcModT (r,l) = do
|
|
gmJournal l >> case r of
|
|
Left e -> throwError e
|
|
Right a -> return a
|
|
|
|
-- | Run a computation inside @GhcModT@ providing the RWST environment and
|
|
-- initial state. This is a low level function, use it only if you know what to
|
|
-- do with 'GhcModEnv' and 'GhcModState'.
|
|
--
|
|
-- You should probably look at 'runGhcModT' instead.
|
|
runGhcModT' :: IOish m
|
|
=> GhcModEnv
|
|
-> GhcModState
|
|
-> GhcModT m a
|
|
-> m (Either GhcModError (a, GhcModState), GhcModLog)
|
|
runGhcModT' r s a = do
|
|
(res, w') <-
|
|
flip runReaderT r $ runJournalT $ runErrorT $
|
|
runStateT (unGhcModT $ initGhcMonad (Just libdir) >> a) s
|
|
return (res, w')
|
|
----------------------------------------------------------------
|
|
-- | Make a copy of the 'gmGhcSession' IORef, run the action and restore the
|
|
-- original 'HscEnv'.
|
|
withTempSession :: IOish m => GhcModT m a -> GhcModT m a
|
|
withTempSession action = do
|
|
session <- gmGhcSession <$> ask
|
|
savedHscEnv <- liftIO $ readIORef session
|
|
a <- action
|
|
liftIO $ writeIORef session savedHscEnv
|
|
return a
|
|
|
|
----------------------------------------------------------------
|
|
|
|
gmeAsk :: IOish m => GhcModT m GhcModEnv
|
|
gmeAsk = ask
|
|
|
|
gmsGet :: IOish m => GhcModT m GhcModState
|
|
gmsGet = GhcModT get
|
|
|
|
gmsPut :: IOish m => GhcModState -> GhcModT m ()
|
|
gmsPut = GhcModT . put
|
|
|
|
options :: IOish m => GhcModT m Options
|
|
options = gmOptions <$> gmeAsk
|
|
|
|
cradle :: IOish m => GhcModT m Cradle
|
|
cradle = gmCradle <$> gmeAsk
|
|
|
|
getCompilerMode :: IOish m => GhcModT m CompilerMode
|
|
getCompilerMode = gmCompilerMode <$> gmsGet
|
|
|
|
setCompilerMode :: IOish m => CompilerMode -> GhcModT m ()
|
|
setCompilerMode mode = (\s -> gmsPut s { gmCompilerMode = mode } ) =<< gmsGet
|
|
|
|
----------------------------------------------------------------
|
|
|
|
withOptions :: IOish m => (Options -> Options) -> GhcModT m a -> GhcModT m a
|
|
withOptions changeOpt action = local changeEnv action
|
|
where
|
|
changeEnv e = e { gmOptions = changeOpt opt }
|
|
where
|
|
opt = gmOptions e
|
|
|
|
----------------------------------------------------------------
|