ghc-mod/Language/Haskell/GhcMod/Monad.hs
Daniel Gröber c50b4f5a38 ghc-mod deserves it's own monad
Having to call `findCradle` and `initializeFlagsWithCradle` everywhere
we interact with ghc-mod's API doesn't seem very Haskell-like to me I
think we should provide a Monad that has a run function that already
does all those tedious tasks for us.

The `GhcMod` monad is basically a wrapper around `RWST r w s IO` with an
instance for `GhcMonad`

Having a `Reader` allows us to pass `Options` to runGhcMod and not have
to worry about passing it everywhere, `Cradle` is also stored in the
reader environment on initialization.

Writer and State are just there for future use.

I've included a `toGhcMod` function that turns a `Ghc a` into a `GhcMod
a` this will make it easy to transition everyting to using the `GhcMod`
monad instead of `Ghc` without breaking the build or test suite for
extended periods of time.

Conflicts:
	ghc-mod.cabal
2014-05-04 04:57:38 +02:00

111 lines
3.1 KiB
Haskell

{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses, RankNTypes, TypeFamilies #-}
module Language.Haskell.GhcMod.Monad (
GhcMod
, GhcModEnv(..)
, GhcModWriter
, GhcModState(..)
, runGhcMod'
, runGhcMod
, toGhcMod
, module Control.Monad.Reader.Class
, module Control.Monad.Writer.Class
, module Control.Monad.State.Class
) where
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Cradle
import Language.Haskell.GhcMod.GHCApi
import GHC
import GHC.Paths (libdir)
import GhcMonad
import Exception
import MonadUtils
import DynFlags
import Data.IORef (IORef, readIORef, writeIORef, newIORef)
import Control.Monad (liftM)
import Control.Monad.Base (MonadBase,liftBase)
import Control.Monad.Trans.RWS.Lazy (RWST,runRWST)
import Control.Monad.Trans.Control (MonadBaseControl(..), StM, liftBaseWith
, control, liftBaseOp, liftBaseOp_)
import Control.Monad.Reader.Class
import Control.Monad.Writer.Class
import Control.Monad.State.Class
data GhcModEnv = GhcModEnv {
gmGhcSession :: !(IORef HscEnv)
, gmOptions :: Options
, gmCradle :: Cradle
}
data GhcModState = GhcModState
defaultState :: GhcModState
defaultState = GhcModState
type GhcModWriter = ()
newtype GhcMod a = GhcMod {
unGhcMod :: RWST GhcModEnv GhcModWriter GhcModState IO a }
deriving (Functor,
Applicative,
Monad,
MonadIO,
MonadReader GhcModEnv,
MonadWriter GhcModWriter,
MonadState GhcModState)
runGhcMod' :: GhcModEnv
-> GhcModState
-> GhcMod a
-> IO (a,(GhcModState, GhcModWriter))
runGhcMod' r s a = do
(a', s',w) <- runRWST (unGhcMod $ initGhcMonad (Just libdir) >> a) r s
return (a',(s',w))
runGhcMod :: Options -> GhcMod a -> IO a
runGhcMod opt a = do
session <- newIORef (error "empty session")
cradle <- findCradle
let env = GhcModEnv { gmGhcSession = session
, gmOptions = opt
, gmCradle = cradle }
fst <$> runGhcMod' env defaultState (a' cradle)
where
a' cradle = (toGhcMod $ initializeFlagsWithCradle opt cradle) >> a
toGhcMod :: Ghc a -> GhcMod a
toGhcMod a = do
s <- gmGhcSession <$> ask
liftIO $ unGhc a $ Session s
instance MonadBase IO GhcMod where
liftBase = GhcMod . liftBase
instance MonadBaseControl IO GhcMod where
newtype StM GhcMod a = StGhcMod {
unStGhcMod :: StM (RWST GhcModEnv () GhcModState IO) a }
liftBaseWith f = GhcMod . liftBaseWith $ \runInBase ->
f $ liftM StGhcMod . runInBase . unGhcMod
restoreM = GhcMod . restoreM . unStGhcMod
{-# INLINE liftBaseWith #-}
{-# INLINE restoreM #-}
instance GhcMonad GhcMod where
getSession = liftIO . readIORef . gmGhcSession =<< ask
setSession a = liftIO . flip writeIORef a . gmGhcSession =<< ask
instance HasDynFlags GhcMod where
getDynFlags = getSessionDynFlags
instance ExceptionMonad GhcMod where
gcatch act handler = control $ \run ->
run act `gcatch` (run . handler)
gmask = liftBaseOp gmask . liftRestore
where liftRestore f r = f $ liftBaseOp_ r