ghc-mod/Language/Haskell/GhcMod/Monad.hs

257 lines
7.2 KiB
Haskell
Raw Normal View History

2014-07-03 05:22:43 +00:00
{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, RankNTypes #-}
{-# LANGUAGE TypeFamilies, UndecidableInstances #-}
2014-05-08 06:26:26 +00:00
{-# OPTIONS_GHC -fno-warn-orphans #-}
2014-07-03 05:22:43 +00:00
module Language.Haskell.GhcMod.Monad (
GhcMod
, GhcModT
, GhcModEnv(..)
, GhcModWriter
, GhcModState(..)
, runGhcMod'
, runGhcMod
, runGhcModT'
, runGhcModT
, newGhcModEnv
2014-05-10 13:10:34 +00:00
, withErrorHandler
, toGhcMod
2014-05-10 11:51:35 +00:00
, options
, cradle
, module Control.Monad.Reader.Class
, module Control.Monad.Writer.Class
, module Control.Monad.State.Class
) where
import Language.Haskell.GhcMod.Cradle
import Language.Haskell.GhcMod.GHCApi
2014-07-03 05:22:43 +00:00
import Language.Haskell.GhcMod.Types
2014-07-03 05:22:43 +00:00
import DynFlags
import Exception
import GHC
import GHC.Paths (libdir)
import GhcMonad
2014-07-03 05:19:36 +00:00
#if __GLASGOW_HASKELL__ <= 702
import HscTypes
#endif
2014-05-09 18:38:35 +00:00
2014-07-03 05:26:39 +00:00
-- 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
2014-07-03 05:19:36 +00:00
#if __GLASGOW_HASKELL__ < 708
2014-07-03 05:26:39 +00:00
-- To make RWST an instance of MonadIO.
2014-05-09 18:38:35 +00:00
import Control.Monad.Trans.Class (lift)
2014-07-03 05:22:43 +00:00
import Data.Monoid (Monoid)
2014-05-09 18:38:35 +00:00
#endif
import Control.Applicative (Alternative)
import Control.Monad (MonadPlus, liftM)
2014-07-11 02:51:27 +00:00
import Control.Monad.Base (MonadBase, liftBase)
import Control.Monad.Reader.Class
import Control.Monad.State.Class
import Control.Monad.Trans.Class
2014-07-03 05:22:43 +00:00
import Control.Monad.Trans.Control (MonadBaseControl(..), StM, liftBaseWith, control, liftBaseOp, liftBaseOp_)
2014-07-11 02:51:27 +00:00
import Control.Monad.Trans.RWS.Lazy (RWST(..), runRWST)
2014-07-03 05:22:43 +00:00
import Control.Monad.Writer.Class
2014-07-03 05:22:43 +00:00
import Data.IORef (IORef, readIORef, writeIORef, newIORef)
2014-05-10 13:10:34 +00:00
import System.Exit (exitSuccess)
2014-07-03 05:22:43 +00:00
import System.IO (hPutStr, hPrint, stderr)
import System.Directory (getCurrentDirectory)
2014-05-10 13:10:34 +00:00
2014-07-03 05:22:43 +00:00
----------------------------------------------------------------
2014-05-10 13:10:34 +00:00
data GhcModEnv = GhcModEnv {
gmGhcSession :: !(IORef HscEnv)
, gmOptions :: Options
, gmCradle :: Cradle
}
data GhcModState = GhcModState
defaultState :: GhcModState
defaultState = GhcModState
type GhcModWriter = ()
2014-07-03 05:22:43 +00:00
----------------------------------------------------------------
type GhcMod a = GhcModT IO a
2014-07-03 05:22:43 +00:00
newtype GhcModT m a = GhcModT {
unGhcModT :: RWST GhcModEnv GhcModWriter GhcModState m a
2014-07-03 05:22:43 +00:00
} deriving (Functor
2014-07-11 02:51:27 +00:00
, Applicative
, Alternative
, Monad
, MonadPlus
, MonadIO
, MonadReader GhcModEnv
, MonadWriter GhcModWriter
, MonadState GhcModState
, MonadTrans
2014-07-03 05:22:43 +00:00
)
2014-05-08 06:26:26 +00:00
#if __GLASGOW_HASKELL__ < 708
instance (Monoid w, MonadIO m) => MonadIO (RWST r w s m) where
2014-05-08 07:51:15 +00:00
-- liftIO :: MonadIO m => IO a -> m a
2014-05-08 06:26:26 +00:00
liftIO = lift . liftIO
#endif
2014-07-03 05:22:43 +00:00
----------------------------------------------------------------
runGhcModT' :: (MonadIO m, MonadBaseControl IO m)
=> GhcModEnv
-> GhcModState
-> GhcModT m a
-> m (a,(GhcModState, GhcModWriter))
runGhcModT' r s a = do
(a',s',w) <- runRWST (unGhcModT $ initGhcMonad (Just libdir) >> a) r s
return (a',(s',w))
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
}
2014-05-10 13:10:34 +00:00
runGhcModT :: (MonadIO m, MonadBaseControl IO m) => Options -> GhcModT m a -> m a
runGhcModT opt action = do
env <- liftBase $ newGhcModEnv opt =<< getCurrentDirectory
(a,(_,_)) <- runGhcModT' env defaultState $ do
2014-05-10 13:10:34 +00:00
dflags <- getSessionDynFlags
defaultCleanupHandler dflags $ do
initializeFlagsWithCradle opt (gmCradle env)
2014-05-10 13:10:34 +00:00
action
return a
runGhcMod' :: GhcModEnv
-> GhcModState
-> GhcModT IO a
-> IO (a,(GhcModState, GhcModWriter))
runGhcMod' = runGhcModT'
runGhcMod :: Options -> GhcMod a -> IO a
runGhcMod = runGhcModT
2014-07-03 05:22:43 +00:00
----------------------------------------------------------------
2014-05-10 13:10:34 +00:00
withErrorHandler :: String -> GhcMod a -> GhcMod a
withErrorHandler label = ghandle ignore
where
ignore :: SomeException -> GhcMod a
ignore e = liftIO $ do
hPutStr stderr $ label ++ ":0:0:Error:"
hPrint stderr e
exitSuccess
-- | This is only a transitional mechanism don't use it for new code.
toGhcMod :: (Functor m, MonadIO m) => Ghc a -> GhcModT m a
toGhcMod a = do
s <- gmGhcSession <$> ask
liftIO $ unGhc a $ Session s
2014-07-03 05:22:43 +00:00
----------------------------------------------------------------
2014-05-10 11:51:35 +00:00
options :: GhcMod Options
options = gmOptions <$> ask
cradle :: GhcMod Cradle
cradle = gmCradle <$> ask
instance (MonadBaseControl IO m) => MonadBase IO (GhcModT m) where
liftBase = GhcModT . liftBase
instance (MonadBaseControl IO m) => MonadBaseControl IO (GhcModT m) where
newtype StM (GhcModT m) a = StGhcMod {
unStGhcMod :: StM (RWST GhcModEnv () GhcModState m) a }
liftBaseWith f = GhcModT . liftBaseWith $ \runInBase ->
f $ liftM StGhcMod . runInBase . unGhcModT
restoreM = GhcModT . restoreM . unStGhcMod
{-# INLINE liftBaseWith #-}
{-# INLINE restoreM #-}
-- GHC cannot prove the following instances to be decidable automatically using
-- the FlexibleContexts extension as they violate the second Paterson Condition,
-- namely that: The assertion has fewer constructors and variables (taken
-- together and counting repetitions) than the head. Specifically the
-- @MonadBaseControl IO m@ constraint is causing this violation.
--
-- Proof of termination:
--
-- Assuming all constraints containing the variable `m' exist and are decidable
-- we show termination by manually replacing the current set of constraints with
-- their own set of constraints and show that this, after a finite number of
-- steps, results in the empty set, i.e. not having to check any more
-- constraints.
--
-- We start by setting the constraints to be those immediate constraints of the
-- instance declaration which cannot be proven decidable automatically for the
-- type under consideration.
--
-- @
-- { MonadBaseControl IO m }
-- @
--
-- Classes used:
--
-- * @class MonadBase b m => MonadBaseControl b m@
--
-- @
-- { MonadBase IO m }
-- @
--
-- Classes used:
--
-- * @class (Applicative b, Applicative m, Monad b, Monad m) => MonadBase b m@
--
-- @
-- { Applicative IO, Applicative m, Monad IO, Monad m }
-- @
--
-- Classes used:
--
-- * @class Monad m@
-- * @class Applicative f => Functor f@
--
-- @
-- { Functor m }
-- @
--
-- Classes used:
--
-- * @class Functor f@
--
-- @
-- { }
-- @
-- ∎
instance (Functor m, MonadIO m, MonadBaseControl IO m)
=> GhcMonad (GhcModT m) where
getSession = (liftIO . readIORef) . gmGhcSession =<< ask
setSession a = (liftIO . flip writeIORef a) . gmGhcSession =<< ask
2014-05-08 08:01:01 +00:00
#if __GLASGOW_HASKELL__ >= 706
instance (Functor m, MonadIO m, MonadBaseControl IO m)
=> HasDynFlags (GhcModT m) where
getDynFlags = getSessionDynFlags
2014-05-08 08:01:01 +00:00
#endif
instance (MonadIO m, MonadBaseControl IO m)
=> ExceptionMonad (GhcModT m) where
gcatch act handler = control $ \run ->
run act `gcatch` (run . handler)
gmask = liftBaseOp gmask . liftRestore
where liftRestore f r = f $ liftBaseOp_ r