diff --git a/Language/Haskell/GhcMod/Monad.hs b/Language/Haskell/GhcMod/Monad.hs new file mode 100644 index 0000000..82c3806 --- /dev/null +++ b/Language/Haskell/GhcMod/Monad.hs @@ -0,0 +1,110 @@ +{-# 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 diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 7141c4b..509a088 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -74,12 +74,14 @@ Library Language.Haskell.GhcMod.PkgDoc Language.Haskell.GhcMod.Utils Language.Haskell.GhcMod.Types + Language.Haskell.GhcMod.Monad Build-Depends: base >= 4.0 && < 5 , containers , deepseq , directory , filepath , ghc + , ghc-paths , ghc-syb-utils , hlint >= 1.8.61 , io-choice @@ -88,6 +90,9 @@ Library , syb , time , transformers + , transformers-base + , mtl + , monad-control , split if impl(ghc < 7.7) Build-Depends: convertible @@ -151,6 +156,7 @@ Test-Suite spec , directory , filepath , ghc + , ghc-paths , ghc-syb-utils , hlint >= 1.7.1 , io-choice @@ -159,6 +165,9 @@ Test-Suite spec , syb , time , transformers + , transformers-base + , mtl + , monad-control , hspec >= 1.8.2 , split if impl(ghc < 7.7)