{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, RankNTypes #-}
{-# LANGUAGE TypeFamilies, UndecidableInstances, BangPatterns #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Language.Haskell.GhcMod.Monad.Types (
GhcModT
, GmOutT(..)
, GmT(..)
, GmlT(..)
, LightGhc(..)
, GmGhc
, IOish
, GhcModEnv(..)
, GhcModState(..)
, GhcModCaches(..)
, defaultGhcModState
, GmGhcSession(..)
, GmComponent(..)
, GmLogLevel(..)
, GhcModLog(..)
, GhcModError(..)
, Gm
, GmEnv(..)
, GmState(..)
, GmLog(..)
, GmOut(..)
, cradle
, options
, outputOpts
, withOptions
, getMMappedFiles
, setMMappedFiles
, addMMappedFile
, delMMappedFile
, lookupMMappedFile
, getMMappedFilePaths
, MonadIO
, liftIO
, gmlGetSession
, gmlSetSession
) where
#include "Compat.hs_h"
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Monad.Env
import Language.Haskell.GhcMod.Monad.State
import Language.Haskell.GhcMod.Monad.Log
import Language.Haskell.GhcMod.Monad.Out
import Language.Haskell.GhcMod.Monad.Newtypes
import Language.Haskell.GhcMod.Monad.Orphans ()
import Safe
import GHC
import DynFlags
import Exception
import HscTypes
import Control.Applicative
import Control.Monad
import Control.Monad.Reader (ReaderT(..))
import Control.Monad.State.Strict (StateT(..))
import Control.Monad.Trans.Journal (JournalT)
import Control.Monad.Trans.Maybe (MaybeT)
import Control.Monad.Trans.Control
import Control.Monad.Reader.Class
import qualified Data.Map as M
import Data.Maybe
import Data.Monoid
import Data.IORef
import Prelude
type Gm m = (GmEnv m, GmState m, GmLog m, GmOut m)
type GmGhc m = (IOish m, GhcMonad m)
instance (MonadIO m, MonadBaseControl IO m) => GhcMonad (GmlT m) where
getSession = gmlGetSession
setSession = gmlSetSession
gmlGetSession :: (MonadIO m, MonadBaseControl IO m) => GmlT m HscEnv
gmlGetSession = do
ref <- gmgsSession . fromJustNote "gmlGetSession" . gmGhcSession <$> gmsGet
liftIO $ readIORef ref
gmlSetSession :: (MonadIO m, MonadBaseControl IO m) => HscEnv -> GmlT m ()
gmlSetSession a = do
ref <- gmgsSession . fromJustNote "gmlSetSession" . gmGhcSession <$> gmsGet
liftIO $ flip writeIORef a ref
instance GhcMonad LightGhc where
getSession = (liftIO . readIORef) =<< LightGhc ask
setSession a = (liftIO . flip writeIORef a) =<< LightGhc ask
#if __GLASGOW_HASKELL__ >= 706
instance (MonadIO m, MonadBaseControl IO m) => HasDynFlags (GmlT m) where
getDynFlags = hsc_dflags <$> getSession
instance HasDynFlags LightGhc where
getDynFlags = hsc_dflags <$> getSession
#endif
instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (GmOutT m) where
gcatch act handler = control $ \run ->
run act `gcatch` (run . handler)
gmask = liftBaseOp gmask . liftRestore
where liftRestore f r = f $ liftBaseOp_ r
instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (GmT m) where
gcatch act handler = control $ \run ->
run act `gcatch` (run . handler)
gmask = liftBaseOp gmask . liftRestore
where liftRestore f r = f $ liftBaseOp_ r
instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (GmlT m) where
gcatch act handler = control $ \run ->
run act `gcatch` (run . handler)
gmask = liftBaseOp gmask . liftRestore
where liftRestore f r = f $ liftBaseOp_ r
instance ExceptionMonad LightGhc where
gcatch act handl =
LightGhc $ unLightGhc act `gcatch` \e -> unLightGhc (handl e)
gmask f =
LightGhc $ gmask $ \io_restore ->let
g_restore (LightGhc m) = LightGhc $ io_restore m
in
unLightGhc (f g_restore)
instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (StateT s m) where
gcatch act handler = control $ \run ->
run act `gcatch` (run . handler)
gmask = liftBaseOp gmask . liftRestore
where liftRestore f r = f $ liftBaseOp_ r
instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (ReaderT s m) where
gcatch act handler = control $ \run ->
run act `gcatch` (run . handler)
gmask = liftBaseOp gmask . liftRestore
where liftRestore f r = f $ liftBaseOp_ r
instance (Monoid w, MonadIO m, MonadBaseControl IO m) => ExceptionMonad (JournalT w m) where
gcatch act handler = control $ \run ->
run act `gcatch` (run . handler)
gmask = liftBaseOp gmask . liftRestore
where liftRestore f r = f $ liftBaseOp_ r
instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (MaybeT m) where
gcatch act handler = control $ \run ->
run act `gcatch` (run . handler)
gmask = liftBaseOp gmask . liftRestore
where liftRestore f r = f $ liftBaseOp_ r
options :: GmEnv m => m Options
options = gmOptions `liftM` gmeAsk
outputOpts :: GmOut m => m OutputOpts
outputOpts = gmoOptions `liftM` gmoAsk
cradle :: GmEnv m => m Cradle
cradle = gmCradle `liftM` gmeAsk
getMMappedFiles :: GmState m => m FileMappingMap
getMMappedFiles = gmMMappedFiles `liftM` gmsGet
setMMappedFiles :: GmState m => FileMappingMap -> m ()
setMMappedFiles mf = (\s -> gmsPut s { gmMMappedFiles = mf } ) =<< gmsGet
addMMappedFile :: GmState m => FilePath -> FileMapping -> m ()
addMMappedFile t fm =
getMMappedFiles >>= setMMappedFiles . M.insert t fm
delMMappedFile :: GmState m => FilePath -> m ()
delMMappedFile t =
getMMappedFiles >>= setMMappedFiles . M.delete t
lookupMMappedFile :: GmState m => FilePath -> m (Maybe FileMapping)
lookupMMappedFile t =
M.lookup t `liftM` getMMappedFiles
getMMappedFilePaths :: GmState m => m [FilePath]
getMMappedFilePaths = M.keys `liftM` getMMappedFiles
withOptions :: GmEnv m => (Options -> Options) -> m a -> m a
withOptions changeOpt action = gmeLocal changeEnv action
where
changeEnv e = e { gmOptions = changeOpt opt }
where
opt = gmOptions e