Split L.H.GM.Monad.Types module
This commit is contained in:
Daniel Gröber
parent
13632817a4
commit
4c956057ec
|
|
@ -0,0 +1,32 @@
|
|||
-- ghc-mod: Making Haskell development *more* fun
|
||||
-- Copyright (C) 2015,2016 Daniel Gröber <dxld ÄT darkboxed DOT org>
|
||||
--
|
||||
-- This program is free software: you can redistribute it and/or modify
|
||||
-- it under the terms of the GNU Affero General Public License as published by
|
||||
-- the Free Software Foundation, either version 3 of the License, or
|
||||
-- (at your option) any later version.
|
||||
--
|
||||
-- This program is distributed in the hope that it will be useful,
|
||||
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
-- GNU Affero General Public License for more details.
|
||||
--
|
||||
-- You should have received a copy of the GNU Affero General Public License
|
||||
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
-- 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
|
||||
#if __GLASGOW_HASKELL__ < 708
|
||||
-- 'CoreMonad.MonadIO' and 'Control.Monad.IO.Class.MonadIO' are different
|
||||
-- classes before ghc 7.8
|
||||
#define DIFFERENT_MONADIO 1
|
||||
|
||||
-- RWST doen't have a MonadIO instance before ghc 7.8
|
||||
#define MONADIO_INSTANCES 1
|
||||
#endif
|
||||
|
||||
#if DIFFERENT_MONADIO
|
||||
import Data.Monoid (Monoid)
|
||||
#endif
|
||||
|
|
@ -0,0 +1,68 @@
|
|||
-- ghc-mod: Making Haskell development *more* fun
|
||||
-- Copyright (C) 2015,2016 Daniel Gröber <dxld ÄT darkboxed DOT org>
|
||||
--
|
||||
-- This program is free software: you can redistribute it and/or modify
|
||||
-- it under the terms of the GNU Affero General Public License as published by
|
||||
-- the Free Software Foundation, either version 3 of the License, or
|
||||
-- (at your option) any later version.
|
||||
--
|
||||
-- This program is distributed in the hope that it will be useful,
|
||||
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
-- GNU Affero General Public License for more details.
|
||||
--
|
||||
-- You should have received a copy of the GNU Affero General Public License
|
||||
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-}
|
||||
{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}
|
||||
|
||||
module Language.Haskell.GhcMod.Monad.Env where
|
||||
|
||||
import Language.Haskell.GhcMod.Types
|
||||
import Language.Haskell.GhcMod.Monad.Newtypes
|
||||
|
||||
import Control.Monad
|
||||
import Control.Monad.Trans.Journal (JournalT)
|
||||
import Control.Monad.State.Strict (StateT(..))
|
||||
import Control.Monad.Error (ErrorT(..))
|
||||
import Control.Monad.Reader.Class
|
||||
import Control.Monad.Trans.Class (MonadTrans(..))
|
||||
import Prelude
|
||||
|
||||
class Monad m => GmEnv m where
|
||||
gmeAsk :: m GhcModEnv
|
||||
gmeAsk = gmeReader id
|
||||
|
||||
gmeReader :: (GhcModEnv -> a) -> m a
|
||||
gmeReader f = f `liftM` gmeAsk
|
||||
|
||||
gmeLocal :: (GhcModEnv -> GhcModEnv) -> m a -> m a
|
||||
{-# MINIMAL (gmeAsk | gmeReader), gmeLocal #-}
|
||||
|
||||
instance Monad m => GmEnv (GmT m) where
|
||||
gmeAsk = GmT ask
|
||||
gmeReader = GmT . reader
|
||||
gmeLocal f a = GmT $ local f (unGmT a)
|
||||
|
||||
instance GmEnv m => GmEnv (GmOutT m) where
|
||||
gmeAsk = lift gmeAsk
|
||||
gmeReader = lift . gmeReader
|
||||
gmeLocal f ma = gmLiftWithInner (\run -> gmeLocal f (run ma))
|
||||
|
||||
instance GmEnv m => GmEnv (StateT s m) where
|
||||
gmeAsk = lift gmeAsk
|
||||
gmeReader = lift . gmeReader
|
||||
gmeLocal f ma = gmLiftWithInner (\run -> gmeLocal f (run ma))
|
||||
|
||||
instance GmEnv m => GmEnv (JournalT GhcModLog m) where
|
||||
gmeAsk = lift gmeAsk
|
||||
gmeReader = lift . gmeReader
|
||||
gmeLocal f ma = gmLiftWithInner (\run -> gmeLocal f (run ma))
|
||||
|
||||
instance GmEnv m => GmEnv (ErrorT GhcModError m) where
|
||||
gmeAsk = lift gmeAsk
|
||||
gmeReader = lift . gmeReader
|
||||
gmeLocal f ma = gmLiftWithInner (\run -> gmeLocal f (run ma))
|
||||
|
||||
deriving instance (Monad m, GmEnv (GhcModT m)) => GmEnv (GmlT m)
|
||||
|
|
@ -0,0 +1,71 @@
|
|||
-- ghc-mod: Making Haskell development *more* fun
|
||||
-- Copyright (C) 2015,2016 Daniel Gröber <dxld ÄT darkboxed DOT org>
|
||||
--
|
||||
-- This program is free software: you can redistribute it and/or modify
|
||||
-- it under the terms of the GNU Affero General Public License as published by
|
||||
-- the Free Software Foundation, either version 3 of the License, or
|
||||
-- (at your option) any later version.
|
||||
--
|
||||
-- This program is distributed in the hope that it will be useful,
|
||||
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
-- GNU Affero General Public License for more details.
|
||||
--
|
||||
-- You should have received a copy of the GNU Affero General Public License
|
||||
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-}
|
||||
{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}
|
||||
|
||||
module Language.Haskell.GhcMod.Monad.Log where
|
||||
|
||||
import Language.Haskell.GhcMod.Types
|
||||
import Language.Haskell.GhcMod.Monad.Newtypes
|
||||
|
||||
import Control.Monad
|
||||
import Control.Monad.Trans.Journal (JournalT)
|
||||
import Control.Monad.Reader (ReaderT(..))
|
||||
import Control.Monad.State.Strict (StateT(..))
|
||||
import Control.Monad.Error (Error, ErrorT(..))
|
||||
import Control.Monad.Trans.Maybe (MaybeT(..))
|
||||
import Control.Monad.Journal.Class (MonadJournal(..))
|
||||
import Control.Monad.Trans.Class (MonadTrans(..))
|
||||
import Prelude
|
||||
|
||||
class Monad m => GmLog m where
|
||||
gmlJournal :: GhcModLog -> m ()
|
||||
gmlHistory :: m GhcModLog
|
||||
gmlClear :: m ()
|
||||
|
||||
instance Monad m => GmLog (JournalT GhcModLog m) where
|
||||
gmlJournal = journal
|
||||
gmlHistory = history
|
||||
gmlClear = clear
|
||||
|
||||
instance Monad m => GmLog (GmT m) where
|
||||
gmlJournal = GmT . lift . lift . journal
|
||||
gmlHistory = GmT $ lift $ lift history
|
||||
gmlClear = GmT $ lift $ lift clear
|
||||
|
||||
instance (Monad m, GmLog m) => GmLog (ReaderT r m) where
|
||||
gmlJournal = lift . gmlJournal
|
||||
gmlHistory = lift gmlHistory
|
||||
gmlClear = lift gmlClear
|
||||
|
||||
instance (Monad m, GmLog m) => GmLog (StateT s m) where
|
||||
gmlJournal = lift . gmlJournal
|
||||
gmlHistory = lift gmlHistory
|
||||
gmlClear = lift gmlClear
|
||||
|
||||
instance (Monad m, GmLog m, Error e) => GmLog (ErrorT e m) where
|
||||
gmlJournal = lift . gmlJournal
|
||||
gmlHistory = lift gmlHistory
|
||||
gmlClear = lift gmlClear
|
||||
|
||||
instance (Monad m, GmLog m) => GmLog (MaybeT m) where
|
||||
gmlJournal = lift . gmlJournal
|
||||
gmlHistory = lift gmlHistory
|
||||
gmlClear = lift gmlClear
|
||||
|
||||
deriving instance GmLog m => GmLog (GmOutT m)
|
||||
deriving instance (Monad m, GmLog (GhcModT m)) => GmLog (GmlT m)
|
||||
|
|
@ -0,0 +1,198 @@
|
|||
-- ghc-mod: Making Haskell development *more* fun
|
||||
-- Copyright (C) 2015,2016 Daniel Gröber <dxld ÄT darkboxed DOT org>
|
||||
--
|
||||
-- This program is free software: you can redistribute it and/or modify
|
||||
-- it under the terms of the GNU Affero General Public License as published by
|
||||
-- the Free Software Foundation, either version 3 of the License, or
|
||||
-- (at your option) any later version.
|
||||
--
|
||||
-- This program is distributed in the hope that it will be useful,
|
||||
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
-- GNU Affero General Public License for more details.
|
||||
--
|
||||
-- You should have received a copy of the GNU Affero General Public License
|
||||
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, DeriveFunctor #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, UndecidableInstances #-}
|
||||
{-# LANGUAGE RankNTypes, FlexibleInstances #-}
|
||||
|
||||
module Language.Haskell.GhcMod.Monad.Newtypes where
|
||||
|
||||
#include "Compat.hs_h"
|
||||
|
||||
import Language.Haskell.GhcMod.Types
|
||||
|
||||
import GHC
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Monad
|
||||
|
||||
import Control.Monad.Reader (ReaderT(..))
|
||||
import Control.Monad.Error (ErrorT(..), MonadError(..))
|
||||
import Control.Monad.State.Strict (StateT(..))
|
||||
import Control.Monad.Trans.Journal (JournalT)
|
||||
import Control.Monad.Reader.Class
|
||||
import Control.Monad.State.Class (MonadState(..))
|
||||
import Control.Monad.Journal.Class (MonadJournal(..))
|
||||
import Control.Monad.Trans.Class (MonadTrans(..))
|
||||
import Control.Monad.Trans.Control
|
||||
import Control.Monad.Base (MonadBase(..), liftBase)
|
||||
|
||||
#if DIFFERENT_MONADIO
|
||||
import qualified MonadUtils as GHC (MonadIO(..))
|
||||
#endif
|
||||
import qualified Control.Monad.IO.Class as MTL
|
||||
|
||||
import Data.IORef
|
||||
import Prelude
|
||||
|
||||
|
||||
type GhcModT m = GmT (GmOutT m)
|
||||
|
||||
newtype GmOutT m a = GmOutT {
|
||||
unGmOutT :: ReaderT GhcModOut m a
|
||||
} deriving ( Functor
|
||||
, Applicative
|
||||
, Alternative
|
||||
, Monad
|
||||
, MonadPlus
|
||||
, MonadTrans
|
||||
, MTL.MonadIO
|
||||
#if DIFFERENT_MONADIO
|
||||
, GHC.MonadIO
|
||||
#endif
|
||||
)
|
||||
|
||||
newtype GmT m a = GmT {
|
||||
unGmT :: StateT GhcModState
|
||||
(ErrorT GhcModError
|
||||
(JournalT GhcModLog
|
||||
(ReaderT GhcModEnv m) ) ) a
|
||||
} deriving ( Functor
|
||||
, Applicative
|
||||
, Alternative
|
||||
, Monad
|
||||
, MonadPlus
|
||||
, MTL.MonadIO
|
||||
#if DIFFERENT_MONADIO
|
||||
, GHC.MonadIO
|
||||
#endif
|
||||
, MonadError GhcModError
|
||||
)
|
||||
|
||||
newtype GmlT m a = GmlT { unGmlT :: GhcModT m a }
|
||||
deriving ( Functor
|
||||
, Applicative
|
||||
, Alternative
|
||||
, Monad
|
||||
, MonadPlus
|
||||
, MTL.MonadIO
|
||||
#if DIFFERENT_MONADIO
|
||||
, GHC.MonadIO
|
||||
#endif
|
||||
, MonadError GhcModError
|
||||
)
|
||||
|
||||
newtype LightGhc a = LightGhc { unLightGhc :: ReaderT (IORef HscEnv) IO a }
|
||||
deriving ( Functor
|
||||
, Applicative
|
||||
, Monad
|
||||
, MTL.MonadIO
|
||||
#if DIFFERENT_MONADIO
|
||||
, GHC.MonadIO
|
||||
#endif
|
||||
)
|
||||
|
||||
-- GmOutT ----------------------------------------
|
||||
instance (MonadBaseControl IO m) => MonadBase IO (GmOutT m) where
|
||||
liftBase = GmOutT . liftBase
|
||||
|
||||
instance (MonadBaseControl IO m) => MonadBaseControl IO (GmOutT m) where
|
||||
type StM (GmOutT m) a = StM (ReaderT GhcModEnv m) a
|
||||
liftBaseWith = defaultLiftBaseWith
|
||||
restoreM = defaultRestoreM
|
||||
{-# INLINE liftBaseWith #-}
|
||||
{-# INLINE restoreM #-}
|
||||
|
||||
instance MonadTransControl GmOutT where
|
||||
type StT GmOutT a = StT (ReaderT GhcModEnv) a
|
||||
liftWith = defaultLiftWith GmOutT unGmOutT
|
||||
restoreT = defaultRestoreT GmOutT
|
||||
|
||||
|
||||
-- GmlT ------------------------------------------
|
||||
instance (MonadBaseControl IO m) => MonadBase IO (GmlT m) where
|
||||
liftBase = GmlT . liftBase
|
||||
|
||||
instance (MonadBaseControl IO m) => MonadBaseControl IO (GmlT m) where
|
||||
type StM (GmlT m) a = StM (GmT m) a
|
||||
liftBaseWith = defaultLiftBaseWith
|
||||
restoreM = defaultRestoreM
|
||||
{-# INLINE liftBaseWith #-}
|
||||
{-# INLINE restoreM #-}
|
||||
|
||||
instance MonadTransControl GmlT where
|
||||
type StT GmlT a = StT GmT a
|
||||
liftWith f = GmlT $
|
||||
liftWith $ \runGm ->
|
||||
liftWith $ \runEnv ->
|
||||
f $ \ma -> runEnv $ runGm $ unGmlT ma
|
||||
restoreT = GmlT . restoreT . restoreT
|
||||
|
||||
instance MonadTrans GmlT where
|
||||
lift = GmlT . lift . lift
|
||||
|
||||
-- GmT ------------------------------------------
|
||||
|
||||
instance forall r m. MonadReader r m => MonadReader r (GmT m) where
|
||||
local f ma = gmLiftWithInner (\run -> local f (run ma))
|
||||
ask = gmLiftInner ask
|
||||
|
||||
instance MonadState s m => MonadState s (GmT m) where
|
||||
get = GmT $ lift $ lift $ lift get
|
||||
put = GmT . lift . lift . lift . put
|
||||
state = GmT . lift . lift . lift . state
|
||||
|
||||
instance Monad m => MonadJournal GhcModLog (GmT m) where
|
||||
journal w = GmT $ lift $ lift $ (journal w)
|
||||
history = GmT $ lift $ lift $ history
|
||||
clear = GmT $ lift $ lift $ clear
|
||||
|
||||
instance (MonadBaseControl IO m) => MonadBase IO (GmT m) where
|
||||
liftBase = GmT . liftBase
|
||||
|
||||
instance (MonadBaseControl IO m) => MonadBaseControl IO (GmT m) where
|
||||
type StM (GmT m) a =
|
||||
StM (StateT GhcModState
|
||||
(ErrorT GhcModError
|
||||
(JournalT GhcModLog
|
||||
(ReaderT GhcModEnv m) ) ) ) a
|
||||
liftBaseWith f = GmT (liftBaseWith $ \runInBase ->
|
||||
f $ runInBase . unGmT)
|
||||
restoreM = GmT . restoreM
|
||||
{-# INLINE liftBaseWith #-}
|
||||
{-# INLINE restoreM #-}
|
||||
|
||||
instance MonadTransControl GmT where
|
||||
type StT GmT a = (Either GhcModError (a, GhcModState), GhcModLog)
|
||||
liftWith f = GmT $
|
||||
liftWith $ \runS ->
|
||||
liftWith $ \runE ->
|
||||
liftWith $ \runJ ->
|
||||
liftWith $ \runR ->
|
||||
f $ \ma -> runR $ runJ $ runE $ runS $ unGmT ma
|
||||
restoreT = GmT . restoreT . restoreT . restoreT . restoreT
|
||||
{-# INLINE liftWith #-}
|
||||
{-# INLINE restoreT #-}
|
||||
|
||||
instance MonadTrans GmT where
|
||||
lift = GmT . lift . lift . lift . lift
|
||||
|
||||
gmLiftInner :: Monad m => m a -> GmT m a
|
||||
gmLiftInner = GmT . lift . lift . lift . lift
|
||||
|
||||
gmLiftWithInner :: (MonadTransControl t, Monad m, Monad (t m))
|
||||
=> (Run t -> m (StT t a)) -> t m a
|
||||
gmLiftWithInner f = liftWith f >>= restoreT . return
|
||||
|
|
@ -0,0 +1,69 @@
|
|||
-- ghc-mod: Making Haskell development *more* fun
|
||||
-- Copyright (C) 2015,2016 Daniel Gröber <dxld ÄT darkboxed DOT org>
|
||||
--
|
||||
-- This program is free software: you can redistribute it and/or modify
|
||||
-- it under the terms of the GNU Affero General Public License as published by
|
||||
-- the Free Software Foundation, either version 3 of the License, or
|
||||
-- (at your option) any later version.
|
||||
--
|
||||
-- This program is distributed in the hope that it will be useful,
|
||||
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
-- GNU Affero General Public License for more details.
|
||||
--
|
||||
-- You should have received a copy of the GNU Affero General Public License
|
||||
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
module Language.Haskell.GhcMod.Monad.Orphans where
|
||||
|
||||
#include "Compat.hs_h"
|
||||
|
||||
import Language.Haskell.GhcMod.Types
|
||||
import Language.Haskell.GhcMod.Monad.Newtypes
|
||||
|
||||
import qualified Control.Monad.IO.Class as MTL
|
||||
|
||||
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.Error (Error(..), ErrorT(..))
|
||||
|
||||
--------------------------------------------------
|
||||
-- Miscellaneous instances
|
||||
|
||||
#if DIFFERENT_MONADIO
|
||||
instance MTL.MonadIO m => GHC.MonadIO (ReaderT x m) where
|
||||
liftIO = MTL.liftIO
|
||||
instance MTL.MonadIO m => GHC.MonadIO (StateT x m) where
|
||||
liftIO = MTL.liftIO
|
||||
instance (Error e, MTL.MonadIO m) => GHC.MonadIO (ErrorT e m) where
|
||||
liftIO = MTL.liftIO
|
||||
instance MTL.MonadIO m => GHC.MonadIO (JournalT x m) where
|
||||
liftIO = MTL.liftIO
|
||||
instance MTL.MonadIO m => GHC.MonadIO (MaybeT m) where
|
||||
liftIO = MTL.liftIO
|
||||
#endif
|
||||
|
||||
instance MonadIO IO where
|
||||
liftIO = id
|
||||
instance MonadIO m => MonadIO (ReaderT x m) where
|
||||
liftIO = MTL.liftIO
|
||||
instance MonadIO m => MonadIO (StateT x m) where
|
||||
liftIO = MTL.liftIO
|
||||
instance (Error e, MonadIO m) => MonadIO (ErrorT e m) where
|
||||
liftIO = MTL.liftIO
|
||||
instance MonadIO m => MonadIO (JournalT x m) where
|
||||
liftIO = MTL.liftIO
|
||||
instance MonadIO m => MonadIO (MaybeT m) where
|
||||
liftIO = MTL.liftIO
|
||||
instance MonadIOC m => MonadIO (GmOutT m) where
|
||||
liftIO = MTL.liftIO
|
||||
instance MonadIOC m => MonadIO (GmT m) where
|
||||
liftIO = MTL.liftIO
|
||||
instance MonadIOC m => MonadIO (GmlT m) where
|
||||
liftIO = MTL.liftIO
|
||||
instance MonadIO LightGhc where
|
||||
liftIO = MTL.liftIO
|
||||
|
|
@ -0,0 +1,52 @@
|
|||
-- ghc-mod: Making Haskell development *more* fun
|
||||
-- Copyright (C) 2015,2016 Daniel Gröber <dxld ÄT darkboxed DOT org>
|
||||
--
|
||||
-- This program is free software: you can redistribute it and/or modify
|
||||
-- it under the terms of the GNU Affero General Public License as published by
|
||||
-- the Free Software Foundation, either version 3 of the License, or
|
||||
-- (at your option) any later version.
|
||||
--
|
||||
-- This program is distributed in the hope that it will be useful,
|
||||
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
-- GNU Affero General Public License for more details.
|
||||
--
|
||||
-- You should have received a copy of the GNU Affero General Public License
|
||||
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-}
|
||||
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-}
|
||||
|
||||
module Language.Haskell.GhcMod.Monad.Out where
|
||||
|
||||
import Language.Haskell.GhcMod.Types
|
||||
import Language.Haskell.GhcMod.Monad.Newtypes
|
||||
|
||||
import Control.Monad
|
||||
import Control.Monad.State.Strict (StateT(..))
|
||||
import Control.Monad.Trans.Journal (JournalT)
|
||||
import Control.Monad.Trans.Maybe (MaybeT(..))
|
||||
import Control.Monad.Reader.Class
|
||||
import Control.Monad.Trans.Class (MonadTrans(..))
|
||||
import Prelude
|
||||
|
||||
class Monad m => GmOut m where
|
||||
gmoAsk :: m GhcModOut
|
||||
|
||||
instance Monad m => GmOut (GmOutT m) where
|
||||
gmoAsk = GmOutT ask
|
||||
|
||||
instance Monad m => GmOut (GmlT m) where
|
||||
gmoAsk = GmlT $ lift $ GmOutT ask
|
||||
|
||||
instance GmOut m => GmOut (GmT m) where
|
||||
gmoAsk = lift gmoAsk
|
||||
|
||||
instance GmOut m => GmOut (StateT s m) where
|
||||
gmoAsk = lift gmoAsk
|
||||
|
||||
instance GmOut m => GmOut (JournalT w m) where
|
||||
gmoAsk = lift gmoAsk
|
||||
|
||||
instance GmOut m => GmOut (MaybeT m) where
|
||||
gmoAsk = lift gmoAsk
|
||||
|
|
@ -0,0 +1,67 @@
|
|||
-- ghc-mod: Making Haskell development *more* fun
|
||||
-- Copyright (C) 2015,2016 Daniel Gröber <dxld ÄT darkboxed DOT org>
|
||||
--
|
||||
-- This program is free software: you can redistribute it and/or modify
|
||||
-- it under the terms of the GNU Affero General Public License as published by
|
||||
-- the Free Software Foundation, either version 3 of the License, or
|
||||
-- (at your option) any later version.
|
||||
--
|
||||
-- This program is distributed in the hope that it will be useful,
|
||||
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
-- GNU Affero General Public License for more details.
|
||||
--
|
||||
-- You should have received a copy of the GNU Affero General Public License
|
||||
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-}
|
||||
{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}
|
||||
|
||||
module Language.Haskell.GhcMod.Monad.State where
|
||||
|
||||
import Language.Haskell.GhcMod.Types
|
||||
import Language.Haskell.GhcMod.Monad.Newtypes
|
||||
|
||||
import Control.Monad
|
||||
import Control.Monad.State.Strict (StateT(..))
|
||||
import Control.Monad.Trans.Maybe (MaybeT(..))
|
||||
import Control.Monad.State.Class (MonadState(..))
|
||||
import Control.Monad.Trans.Class (MonadTrans(..))
|
||||
import Prelude
|
||||
|
||||
class Monad m => GmState m where
|
||||
gmsGet :: m GhcModState
|
||||
gmsGet = gmsState (\s -> (s, s))
|
||||
|
||||
gmsPut :: GhcModState -> m ()
|
||||
gmsPut s = gmsState (\_ -> ((), s))
|
||||
|
||||
gmsState :: (GhcModState -> (a, GhcModState)) -> m a
|
||||
gmsState f = do
|
||||
s <- gmsGet
|
||||
let ~(a, s') = f s
|
||||
gmsPut s'
|
||||
return a
|
||||
{-# MINIMAL gmsState | gmsGet, gmsPut #-}
|
||||
|
||||
instance GmState m => GmState (StateT s m) where
|
||||
gmsGet = lift gmsGet
|
||||
gmsPut = lift . gmsPut
|
||||
gmsState = lift . gmsState
|
||||
|
||||
instance Monad m => GmState (StateT GhcModState m) where
|
||||
gmsGet = get
|
||||
gmsPut = put
|
||||
gmsState = state
|
||||
|
||||
instance Monad m => GmState (GmT m) where
|
||||
gmsGet = GmT get
|
||||
gmsPut = GmT . put
|
||||
gmsState = GmT . state
|
||||
|
||||
instance GmState m => GmState (MaybeT m) where
|
||||
gmsGet = MaybeT $ Just `liftM` gmsGet
|
||||
gmsPut = MaybeT . (Just `liftM`) . gmsPut
|
||||
gmsState = MaybeT . (Just `liftM`) . gmsState
|
||||
|
||||
deriving instance (Monad m, GmState (GhcModT m)) => GmState (GmlT m)
|
||||
|
|
@ -62,21 +62,17 @@ module Language.Haskell.GhcMod.Monad.Types (
|
|||
, gmlSetSession
|
||||
) where
|
||||
|
||||
-- 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
|
||||
#if __GLASGOW_HASKELL__ < 708
|
||||
-- 'CoreMonad.MonadIO' and 'Control.Monad.IO.Class.MonadIO' are different
|
||||
-- classes before ghc 7.8
|
||||
#define DIFFERENT_MONADIO 1
|
||||
|
||||
-- RWST doen't have a MonadIO instance before ghc 7.8
|
||||
#define MONADIO_INSTANCES 1
|
||||
#endif
|
||||
#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 GHC
|
||||
import DynFlags
|
||||
import Exception
|
||||
|
|
@ -86,25 +82,12 @@ import Control.Applicative
|
|||
import Control.Monad
|
||||
|
||||
import Control.Monad.Reader (ReaderT(..))
|
||||
import Control.Monad.Error (ErrorT(..), MonadError(..))
|
||||
import Control.Monad.State.Strict (StateT(..))
|
||||
import Control.Monad.Trans.Journal (JournalT)
|
||||
import Control.Monad.Trans.Maybe (MaybeT(..))
|
||||
|
||||
import Control.Monad.Base (MonadBase(..), liftBase)
|
||||
import Control.Monad.Trans.Control
|
||||
|
||||
import Control.Monad.Reader.Class
|
||||
import Control.Monad.Writer.Class
|
||||
import Control.Monad.State.Class (MonadState(..))
|
||||
import Control.Monad.Journal.Class (MonadJournal(..))
|
||||
import Control.Monad.Trans.Class (MonadTrans(..))
|
||||
import Control.Monad.Error (Error(..))
|
||||
import qualified Control.Monad.IO.Class as MTL
|
||||
|
||||
#if DIFFERENT_MONADIO
|
||||
import Data.Monoid (Monoid)
|
||||
#endif
|
||||
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe
|
||||
|
|
@ -112,339 +95,8 @@ import Data.Monoid
|
|||
import Data.IORef
|
||||
import Prelude
|
||||
|
||||
import qualified MonadUtils as GHC (MonadIO(..))
|
||||
|
||||
type GhcModT m = GmT (GmOutT m)
|
||||
|
||||
newtype GmOutT m a = GmOutT {
|
||||
unGmOutT :: ReaderT GhcModOut m a
|
||||
} deriving ( Functor
|
||||
, Applicative
|
||||
, Alternative
|
||||
, Monad
|
||||
, MonadPlus
|
||||
, MonadTrans
|
||||
, MTL.MonadIO
|
||||
#if DIFFERENT_MONADIO
|
||||
, GHC.MonadIO
|
||||
#endif
|
||||
, GmLog
|
||||
)
|
||||
|
||||
newtype GmT m a = GmT {
|
||||
unGmT :: StateT GhcModState
|
||||
(ErrorT GhcModError
|
||||
(JournalT GhcModLog
|
||||
(ReaderT GhcModEnv m) ) ) a
|
||||
} deriving ( Functor
|
||||
, Applicative
|
||||
, Alternative
|
||||
, Monad
|
||||
, MonadPlus
|
||||
, MTL.MonadIO
|
||||
#if DIFFERENT_MONADIO
|
||||
, GHC.MonadIO
|
||||
#endif
|
||||
, MonadError GhcModError
|
||||
)
|
||||
|
||||
newtype GmlT m a = GmlT { unGmlT :: GhcModT m a }
|
||||
deriving ( Functor
|
||||
, Applicative
|
||||
, Alternative
|
||||
, Monad
|
||||
, MonadPlus
|
||||
, MTL.MonadIO
|
||||
#if DIFFERENT_MONADIO
|
||||
, GHC.MonadIO
|
||||
#endif
|
||||
, MonadError GhcModError
|
||||
, GmEnv
|
||||
, GmState
|
||||
, GmLog
|
||||
)
|
||||
|
||||
newtype LightGhc a = LightGhc { unLightGhc :: ReaderT (IORef HscEnv) IO a }
|
||||
deriving ( Functor
|
||||
, Applicative
|
||||
, Monad
|
||||
, MTL.MonadIO
|
||||
#if DIFFERENT_MONADIO
|
||||
, GHC.MonadIO
|
||||
#endif
|
||||
)
|
||||
|
||||
--------------------------------------------------
|
||||
-- Miscellaneous instances
|
||||
|
||||
#if DIFFERENT_MONADIO
|
||||
instance MTL.MonadIO m => GHC.MonadIO (ReaderT x m) where
|
||||
liftIO = MTL.liftIO
|
||||
instance MTL.MonadIO m => GHC.MonadIO (StateT x m) where
|
||||
liftIO = MTL.liftIO
|
||||
instance (Error e, MTL.MonadIO m) => GHC.MonadIO (ErrorT e m) where
|
||||
liftIO = MTL.liftIO
|
||||
instance MTL.MonadIO m => GHC.MonadIO (JournalT x m) where
|
||||
liftIO = MTL.liftIO
|
||||
instance MTL.MonadIO m => GHC.MonadIO (MaybeT m) where
|
||||
liftIO = MTL.liftIO
|
||||
#endif
|
||||
|
||||
instance MonadIO IO where
|
||||
liftIO = id
|
||||
instance MonadIO m => MonadIO (ReaderT x m) where
|
||||
liftIO = MTL.liftIO
|
||||
instance MonadIO m => MonadIO (StateT x m) where
|
||||
liftIO = MTL.liftIO
|
||||
instance (Error e, MonadIO m) => MonadIO (ErrorT e m) where
|
||||
liftIO = MTL.liftIO
|
||||
instance MonadIO m => MonadIO (JournalT x m) where
|
||||
liftIO = MTL.liftIO
|
||||
instance MonadIO m => MonadIO (MaybeT m) where
|
||||
liftIO = MTL.liftIO
|
||||
instance MonadIOC m => MonadIO (GmOutT m) where
|
||||
liftIO = MTL.liftIO
|
||||
instance MonadIOC m => MonadIO (GmT m) where
|
||||
liftIO = MTL.liftIO
|
||||
instance MonadIOC m => MonadIO (GmlT m) where
|
||||
liftIO = MTL.liftIO
|
||||
instance MonadIO LightGhc where
|
||||
liftIO = MTL.liftIO
|
||||
|
||||
instance MonadTrans GmT where
|
||||
lift = GmT . lift . lift . lift . lift
|
||||
instance MonadTrans GmlT where
|
||||
lift = GmlT . lift . lift
|
||||
|
||||
--------------------------------------------------
|
||||
-- Gm Classes
|
||||
|
||||
type Gm m = (GmEnv m, GmState m, GmLog m, GmOut m)
|
||||
|
||||
-- GmEnv -----------------------------------------
|
||||
class Monad m => GmEnv m where
|
||||
gmeAsk :: m GhcModEnv
|
||||
gmeAsk = gmeReader id
|
||||
|
||||
gmeReader :: (GhcModEnv -> a) -> m a
|
||||
gmeReader f = f `liftM` gmeAsk
|
||||
|
||||
gmeLocal :: (GhcModEnv -> GhcModEnv) -> m a -> m a
|
||||
{-# MINIMAL (gmeAsk | gmeReader), gmeLocal #-}
|
||||
|
||||
instance Monad m => GmEnv (GmT m) where
|
||||
gmeAsk = GmT ask
|
||||
gmeReader = GmT . reader
|
||||
gmeLocal f a = GmT $ local f (unGmT a)
|
||||
|
||||
instance GmEnv m => GmEnv (GmOutT m) where
|
||||
gmeAsk = lift gmeAsk
|
||||
gmeReader = lift . gmeReader
|
||||
gmeLocal f ma = gmLiftWithInner (\run -> gmeLocal f (run ma))
|
||||
|
||||
instance GmEnv m => GmEnv (StateT s m) where
|
||||
gmeAsk = lift gmeAsk
|
||||
gmeReader = lift . gmeReader
|
||||
gmeLocal f ma = gmLiftWithInner (\run -> gmeLocal f (run ma))
|
||||
|
||||
instance GmEnv m => GmEnv (JournalT GhcModLog m) where
|
||||
gmeAsk = lift gmeAsk
|
||||
gmeReader = lift . gmeReader
|
||||
gmeLocal f ma = gmLiftWithInner (\run -> gmeLocal f (run ma))
|
||||
|
||||
instance GmEnv m => GmEnv (ErrorT GhcModError m) where
|
||||
gmeAsk = lift gmeAsk
|
||||
gmeReader = lift . gmeReader
|
||||
gmeLocal f ma = gmLiftWithInner (\run -> gmeLocal f (run ma))
|
||||
|
||||
-- GmState ---------------------------------------
|
||||
class Monad m => GmState m where
|
||||
gmsGet :: m GhcModState
|
||||
gmsGet = gmsState (\s -> (s, s))
|
||||
|
||||
gmsPut :: GhcModState -> m ()
|
||||
gmsPut s = gmsState (\_ -> ((), s))
|
||||
|
||||
gmsState :: (GhcModState -> (a, GhcModState)) -> m a
|
||||
gmsState f = do
|
||||
s <- gmsGet
|
||||
let ~(a, s') = f s
|
||||
gmsPut s'
|
||||
return a
|
||||
{-# MINIMAL gmsState | gmsGet, gmsPut #-}
|
||||
|
||||
instance GmState m => GmState (StateT s m) where
|
||||
gmsGet = lift gmsGet
|
||||
gmsPut = lift . gmsPut
|
||||
gmsState = lift . gmsState
|
||||
|
||||
instance Monad m => GmState (StateT GhcModState m) where
|
||||
gmsGet = get
|
||||
gmsPut = put
|
||||
gmsState = state
|
||||
|
||||
instance Monad m => GmState (GmT m) where
|
||||
gmsGet = GmT get
|
||||
gmsPut = GmT . put
|
||||
gmsState = GmT . state
|
||||
|
||||
instance GmState m => GmState (MaybeT m) where
|
||||
gmsGet = MaybeT $ Just `liftM` gmsGet
|
||||
gmsPut = MaybeT . (Just `liftM`) . gmsPut
|
||||
gmsState = MaybeT . (Just `liftM`) . gmsState
|
||||
|
||||
-- GmLog -----------------------------------------
|
||||
class Monad m => GmLog m where
|
||||
gmlJournal :: GhcModLog -> m ()
|
||||
gmlHistory :: m GhcModLog
|
||||
gmlClear :: m ()
|
||||
|
||||
instance Monad m => GmLog (JournalT GhcModLog m) where
|
||||
gmlJournal = journal
|
||||
gmlHistory = history
|
||||
gmlClear = clear
|
||||
|
||||
instance Monad m => GmLog (GmT m) where
|
||||
gmlJournal = GmT . lift . lift . journal
|
||||
gmlHistory = GmT $ lift $ lift history
|
||||
gmlClear = GmT $ lift $ lift clear
|
||||
|
||||
instance (Monad m, GmLog m) => GmLog (ReaderT r m) where
|
||||
gmlJournal = lift . gmlJournal
|
||||
gmlHistory = lift gmlHistory
|
||||
gmlClear = lift gmlClear
|
||||
|
||||
instance (Monad m, GmLog m) => GmLog (StateT s m) where
|
||||
gmlJournal = lift . gmlJournal
|
||||
gmlHistory = lift gmlHistory
|
||||
gmlClear = lift gmlClear
|
||||
|
||||
instance (Monad m, GmLog m) => GmLog (MaybeT m) where
|
||||
gmlJournal = lift . gmlJournal
|
||||
gmlHistory = lift gmlHistory
|
||||
gmlClear = lift gmlClear
|
||||
|
||||
-- GmOut -----------------------------------------
|
||||
class Monad m => GmOut m where
|
||||
gmoAsk :: m GhcModOut
|
||||
|
||||
instance Monad m => GmOut (GmOutT m) where
|
||||
gmoAsk = GmOutT ask
|
||||
|
||||
instance Monad m => GmOut (GmlT m) where
|
||||
gmoAsk = GmlT $ lift $ GmOutT ask
|
||||
|
||||
instance GmOut m => GmOut (GmT m) where
|
||||
gmoAsk = lift gmoAsk
|
||||
|
||||
instance GmOut m => GmOut (StateT s m) where
|
||||
gmoAsk = lift gmoAsk
|
||||
|
||||
instance GmOut m => GmOut (JournalT w m) where
|
||||
gmoAsk = lift gmoAsk
|
||||
|
||||
instance GmOut m => GmOut (MaybeT m) where
|
||||
gmoAsk = lift gmoAsk
|
||||
|
||||
instance Monad m => MonadJournal GhcModLog (GmT m) where
|
||||
journal !w = GmT $ lift $ lift $ (journal w)
|
||||
history = GmT $ lift $ lift $ history
|
||||
clear = GmT $ lift $ lift $ clear
|
||||
|
||||
instance forall r m. MonadReader r m => MonadReader r (GmT m) where
|
||||
local f ma = gmLiftWithInner (\run -> local f (run ma))
|
||||
ask = gmLiftInner ask
|
||||
|
||||
instance (Monoid w, MonadWriter w m) => MonadWriter w (GmT m) where
|
||||
tell = gmLiftInner . tell
|
||||
listen ma =
|
||||
liftWith (\run -> listen (run ma)) >>= \(sta, w) ->
|
||||
flip (,) w `liftM` restoreT (return sta)
|
||||
|
||||
pass maww = maww >>= gmLiftInner . pass . return
|
||||
|
||||
instance MonadState s m => MonadState s (GmT m) where
|
||||
get = GmT $ lift $ lift $ lift get
|
||||
put = GmT . lift . lift . lift . put
|
||||
state = GmT . lift . lift . lift . state
|
||||
|
||||
|
||||
--------------------------------------------------
|
||||
-- monad-control instances
|
||||
|
||||
-- GmOutT ----------------------------------------
|
||||
instance (MonadBaseControl IO m) => MonadBase IO (GmOutT m) where
|
||||
liftBase = GmOutT . liftBase
|
||||
|
||||
instance (MonadBaseControl IO m) => MonadBaseControl IO (GmOutT m) where
|
||||
type StM (GmOutT m) a = StM (ReaderT GhcModEnv m) a
|
||||
liftBaseWith = defaultLiftBaseWith
|
||||
restoreM = defaultRestoreM
|
||||
{-# INLINE liftBaseWith #-}
|
||||
{-# INLINE restoreM #-}
|
||||
|
||||
instance MonadTransControl GmOutT where
|
||||
type StT GmOutT a = StT (ReaderT GhcModEnv) a
|
||||
liftWith = defaultLiftWith GmOutT unGmOutT
|
||||
restoreT = defaultRestoreT GmOutT
|
||||
|
||||
|
||||
-- GmlT ------------------------------------------
|
||||
instance (MonadBaseControl IO m) => MonadBase IO (GmlT m) where
|
||||
liftBase = GmlT . liftBase
|
||||
|
||||
instance (MonadBaseControl IO m) => MonadBaseControl IO (GmlT m) where
|
||||
type StM (GmlT m) a = StM (GmT m) a
|
||||
liftBaseWith = defaultLiftBaseWith
|
||||
restoreM = defaultRestoreM
|
||||
{-# INLINE liftBaseWith #-}
|
||||
{-# INLINE restoreM #-}
|
||||
|
||||
instance MonadTransControl GmlT where
|
||||
type StT GmlT a = StT GmT a
|
||||
liftWith f = GmlT $
|
||||
liftWith $ \runGm ->
|
||||
liftWith $ \runEnv ->
|
||||
f $ \ma -> runEnv $ runGm $ unGmlT ma
|
||||
restoreT = GmlT . restoreT . restoreT
|
||||
|
||||
|
||||
-- GmT ------------------------------------------
|
||||
|
||||
instance (MonadBaseControl IO m) => MonadBase IO (GmT m) where
|
||||
liftBase = GmT . liftBase
|
||||
|
||||
instance (MonadBaseControl IO m) => MonadBaseControl IO (GmT m) where
|
||||
type StM (GmT m) a =
|
||||
StM (StateT GhcModState
|
||||
(ErrorT GhcModError
|
||||
(JournalT GhcModLog
|
||||
(ReaderT GhcModEnv m) ) ) ) a
|
||||
liftBaseWith f = GmT (liftBaseWith $ \runInBase ->
|
||||
f $ runInBase . unGmT)
|
||||
restoreM = GmT . restoreM
|
||||
{-# INLINE liftBaseWith #-}
|
||||
{-# INLINE restoreM #-}
|
||||
|
||||
instance MonadTransControl GmT where
|
||||
type StT GmT a = (Either GhcModError (a, GhcModState), GhcModLog)
|
||||
liftWith f = GmT $
|
||||
liftWith $ \runS ->
|
||||
liftWith $ \runE ->
|
||||
liftWith $ \runJ ->
|
||||
liftWith $ \runR ->
|
||||
f $ \ma -> runR $ runJ $ runE $ runS $ unGmT ma
|
||||
restoreT = GmT . restoreT . restoreT . restoreT . restoreT
|
||||
{-# INLINE liftWith #-}
|
||||
{-# INLINE restoreT #-}
|
||||
|
||||
gmLiftInner :: Monad m => m a -> GmT m a
|
||||
gmLiftInner = GmT . lift . lift . lift . lift
|
||||
|
||||
gmLiftWithInner :: (MonadTransControl t, Monad m, Monad (t m))
|
||||
=> (Run t -> m (StT t a)) -> t m a
|
||||
gmLiftWithInner f = liftWith f >>= restoreT . return
|
||||
|
||||
--------------------------------------------------
|
||||
-- GHC API instances -----------------------------
|
||||
|
||||
|
|
@ -463,16 +115,16 @@ instance (MonadIO m, MonadBaseControl IO m) => GhcMonad (GmlT m) where
|
|||
gmlGetSession :: (MonadIO m, MonadBaseControl IO m) => GmlT m HscEnv
|
||||
gmlGetSession = do
|
||||
ref <- gmgsSession . fromJust . gmGhcSession <$> gmsGet
|
||||
GHC.liftIO $ readIORef ref
|
||||
liftIO $ readIORef ref
|
||||
|
||||
gmlSetSession :: (MonadIO m, MonadBaseControl IO m) => HscEnv -> GmlT m ()
|
||||
gmlSetSession a = do
|
||||
ref <- gmgsSession . fromJust . gmGhcSession <$> gmsGet
|
||||
GHC.liftIO $ flip writeIORef a ref
|
||||
liftIO $ flip writeIORef a ref
|
||||
|
||||
instance GhcMonad LightGhc where
|
||||
getSession = (GHC.liftIO . readIORef) =<< LightGhc ask
|
||||
setSession a = (GHC.liftIO . flip writeIORef a) =<< LightGhc ask
|
||||
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
|
||||
|
|
|
|||
|
|
@ -131,6 +131,12 @@ Library
|
|||
Language.Haskell.GhcMod.Logging
|
||||
Language.Haskell.GhcMod.Modules
|
||||
Language.Haskell.GhcMod.Monad
|
||||
Language.Haskell.GhcMod.Monad.Env
|
||||
Language.Haskell.GhcMod.Monad.Log
|
||||
Language.Haskell.GhcMod.Monad.Newtypes
|
||||
Language.Haskell.GhcMod.Monad.Orphans
|
||||
Language.Haskell.GhcMod.Monad.Out
|
||||
Language.Haskell.GhcMod.Monad.State
|
||||
Language.Haskell.GhcMod.Monad.Types
|
||||
Language.Haskell.GhcMod.Output
|
||||
Language.Haskell.GhcMod.PathsAndFiles
|
||||
|
|
|
|||
Loading…
Reference in New Issue