hasufell/ghc-mod
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

layout.

Browse Source
This commit is contained in:
Kazu Yamamoto 2014-07-03 14:22:43 +09:00
parent 826d42f824
commit 640140608e
1 changed files with 30 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

51
Language/Haskell/GhcMod/Monad.hs
View File

@ -1,5 +1,7 @@
{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, FlexibleInstances, MultiParamTypeClasses, RankNTypes, TypeFamilies #-} {-# LANGUAGE CPP, GeneralizedNewtypeDeriving, FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses, RankNTypes, TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-orphans #-}
module Language.Haskell.GhcMod.Monad ( module Language.Haskell.GhcMod.Monad (
GhcMod GhcMod
, GhcModEnv(..) , GhcModEnv(..)
@ -15,40 +17,38 @@ module Language.Haskell.GhcMod.Monad (
, module Control.Monad.State.Class , module Control.Monad.State.Class
) where ) where
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Cradle import Language.Haskell.GhcMod.Cradle
import Language.Haskell.GhcMod.GHCApi import Language.Haskell.GhcMod.GHCApi
import Language.Haskell.GhcMod.Types
import DynFlags
import Exception
import GHC import GHC
import GHC.Paths (libdir) import GHC.Paths (libdir)
import GhcMonad import GhcMonad
import Exception
import MonadUtils import MonadUtils
import DynFlags
#if __GLASGOW_HASKELL__ <= 702 #if __GLASGOW_HASKELL__ <= 702
import HscTypes import HscTypes
#endif #endif
#if __GLASGOW_HASKELL__ < 708 #if __GLASGOW_HASKELL__ < 708
import Data.Monoid (Monoid)
import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Class (lift)
import Data.Monoid (Monoid)
#endif #endif
import Data.IORef (IORef, readIORef, writeIORef, newIORef)
import Control.Monad (liftM) import Control.Monad (liftM)
import Control.Monad.Base (MonadBase,liftBase) import Control.Monad.Base (MonadBase,liftBase)
import Control.Monad.IO.Class () -- MonadIO
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.Reader.Class
import Control.Monad.Writer.Class
import Control.Monad.State.Class import Control.Monad.State.Class
import Control.Monad.Trans.Control (MonadBaseControl(..), StM, liftBaseWith, control, liftBaseOp, liftBaseOp_)
import Control.Monad.Trans.RWS.Lazy (RWST(..),runRWST)
import Control.Monad.Writer.Class
import System.IO (hPutStr, hPrint, stderr) import Data.IORef (IORef, readIORef, writeIORef, newIORef)
import System.Exit (exitSuccess) import System.Exit (exitSuccess)
import System.IO (hPutStr, hPrint, stderr)
----------------------------------------------------------------
data GhcModEnv = GhcModEnv { data GhcModEnv = GhcModEnv {
gmGhcSession :: !(IORef HscEnv) gmGhcSession :: !(IORef HscEnv)
@ -63,15 +63,18 @@ defaultState = GhcModState
type GhcModWriter = () type GhcModWriter = ()
----------------------------------------------------------------
newtype GhcMod a = GhcMod { newtype GhcMod a = GhcMod {
unGhcMod :: RWST GhcModEnv GhcModWriter GhcModState IO a } unGhcMod :: RWST GhcModEnv GhcModWriter GhcModState IO a
deriving (Functor, } deriving (Functor
Applicative, ,Applicative
Monad, ,Monad
MonadIO, ,MonadIO
MonadReader GhcModEnv, ,MonadReader GhcModEnv
MonadWriter GhcModWriter, ,MonadWriter GhcModWriter
MonadState GhcModState) ,MonadState GhcModState
)
#if __GLASGOW_HASKELL__ < 708 #if __GLASGOW_HASKELL__ < 708
instance (Monoid w, MonadIO m) => MonadIO (RWST r w s m) where instance (Monoid w, MonadIO m) => MonadIO (RWST r w s m) where
@ -79,6 +82,8 @@ instance (Monoid w, MonadIO m) => MonadIO (RWST r w s m) where
liftIO = lift . liftIO liftIO = lift . liftIO
#endif #endif
----------------------------------------------------------------
runGhcMod' :: GhcModEnv runGhcMod' :: GhcModEnv
-> GhcModState -> GhcModState
-> GhcMod a -> GhcMod a
@ -102,6 +107,8 @@ runGhcMod opt action = do
action action
return a return a
----------------------------------------------------------------
withErrorHandler :: String -> GhcMod a -> GhcMod a withErrorHandler :: String -> GhcMod a -> GhcMod a
withErrorHandler label = ghandle ignore withErrorHandler label = ghandle ignore
where where
@ -116,6 +123,8 @@ toGhcMod a = do
s <- gmGhcSession <$> ask s <- gmGhcSession <$> ask
liftIO $ unGhc a $ Session s liftIO $ unGhc a $ Session s
----------------------------------------------------------------
options :: GhcMod Options options :: GhcMod Options
options = gmOptions <$> ask options = gmOptions <$> ask