Prepare for splitting off ghc-mod-core eventually
This commit is contained in:
Daniel Gröber
28
core/Language/Haskell/GhcMod/Monad/Compat.hs_h
Normal file
28
core/Language/Haskell/GhcMod/Monad/Compat.hs_h
Normal file
@@ -0,0 +1,28 @@
|
||||
-- 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
|
||||
68
core/Language/Haskell/GhcMod/Monad/Env.hs
Normal file
68
core/Language/Haskell/GhcMod/Monad/Env.hs
Normal file
@@ -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)
|
||||
71
core/Language/Haskell/GhcMod/Monad/Log.hs
Normal file
71
core/Language/Haskell/GhcMod/Monad/Log.hs
Normal file
@@ -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)
|
||||
176
core/Language/Haskell/GhcMod/Monad/Newtypes.hs
Normal file
176
core/Language/Haskell/GhcMod/Monad/Newtypes.hs
Normal file
@@ -0,0 +1,176 @@
|
||||
-- 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)
|
||||
|
||||
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
|
||||
)
|
||||
|
||||
newtype GmT m a = GmT {
|
||||
unGmT :: StateT GhcModState
|
||||
(ErrorT GhcModError
|
||||
(JournalT GhcModLog
|
||||
(ReaderT GhcModEnv m) ) ) a
|
||||
} deriving ( Functor
|
||||
, Applicative
|
||||
, Alternative
|
||||
, Monad
|
||||
, MonadPlus
|
||||
, MonadError GhcModError
|
||||
)
|
||||
|
||||
newtype GmlT m a = GmlT { unGmlT :: GhcModT m a }
|
||||
deriving ( Functor
|
||||
, Applicative
|
||||
, Alternative
|
||||
, Monad
|
||||
, MonadPlus
|
||||
, MonadError GhcModError
|
||||
)
|
||||
|
||||
newtype LightGhc a = LightGhc { unLightGhc :: ReaderT (IORef HscEnv) IO a }
|
||||
deriving ( Functor
|
||||
, Applicative
|
||||
, Monad
|
||||
)
|
||||
|
||||
-- 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 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
|
||||
83
core/Language/Haskell/GhcMod/Monad/Orphans.hs
Normal file
83
core/Language/Haskell/GhcMod/Monad/Orphans.hs
Normal file
@@ -0,0 +1,83 @@
|
||||
-- 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, UndecidableInstances, StandaloneDeriving #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
|
||||
{-# 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
|
||||
|
||||
#if DIFFERENT_MONADIO
|
||||
import qualified MonadUtils as GHC (MonadIO(..))
|
||||
#endif
|
||||
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
|
||||
deriving instance MTL.MonadIO m => GHC.MonadIO (GmOutT m)
|
||||
deriving instance MTL.MonadIO m => GHC.MonadIO (GmT m)
|
||||
deriving instance MTL.MonadIO m => GHC.MonadIO (GmlT m)
|
||||
deriving instance GHC.MonadIO LightGhc
|
||||
#endif
|
||||
|
||||
deriving instance MTL.MonadIO m => MTL.MonadIO (GmOutT m)
|
||||
deriving instance MTL.MonadIO m => MTL.MonadIO (GmT m)
|
||||
deriving instance MTL.MonadIO m => MTL.MonadIO (GmlT m)
|
||||
deriving instance MTL.MonadIO LightGhc
|
||||
|
||||
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
|
||||
52
core/Language/Haskell/GhcMod/Monad/Out.hs
Normal file
52
core/Language/Haskell/GhcMod/Monad/Out.hs
Normal file
@@ -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
|
||||
67
core/Language/Haskell/GhcMod/Monad/State.hs
Normal file
67
core/Language/Haskell/GhcMod/Monad/State.hs
Normal file
@@ -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)
|
||||
239
core/Language/Haskell/GhcMod/Monad/Types.hs
Normal file
239
core/Language/Haskell/GhcMod/Monad/Types.hs
Normal file
@@ -0,0 +1,239 @@
|
||||
-- ghc-mod: Making Haskell development *more* fun
|
||||
-- Copyright (C) 2015 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, FlexibleInstances #-}
|
||||
{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, RankNTypes #-}
|
||||
{-# LANGUAGE TypeFamilies, UndecidableInstances, BangPatterns #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Language.Haskell.GhcMod.Monad.Types (
|
||||
-- * Monad Types
|
||||
GhcModT
|
||||
, GmOutT(..)
|
||||
, GmT(..)
|
||||
, GmlT(..)
|
||||
, LightGhc(..)
|
||||
, GmGhc
|
||||
, IOish
|
||||
-- * Environment, state and logging
|
||||
, GhcModEnv(..)
|
||||
, GhcModState(..)
|
||||
, GhcModCaches(..)
|
||||
, defaultGhcModState
|
||||
, GmGhcSession(..)
|
||||
, GmComponent(..)
|
||||
-- * Accessing 'GhcModEnv', 'GhcModState' and 'GhcModLog'
|
||||
, GmLogLevel(..)
|
||||
, GhcModLog(..)
|
||||
, GhcModError(..)
|
||||
, Gm
|
||||
, GmEnv(..)
|
||||
, GmState(..)
|
||||
, GmLog(..)
|
||||
, GmOut(..)
|
||||
, cradle
|
||||
, options
|
||||
, outputOpts
|
||||
, withOptions
|
||||
, getMMappedFiles
|
||||
, setMMappedFiles
|
||||
, addMMappedFile
|
||||
, delMMappedFile
|
||||
, lookupMMappedFile
|
||||
, getMMappedFilePaths
|
||||
-- * Re-exporting convenient stuff
|
||||
, 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)
|
||||
|
||||
--------------------------------------------------
|
||||
-- GHC API instances -----------------------------
|
||||
|
||||
-- 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 in 'IOish' is causing this violation.
|
||||
|
||||
type GmGhc m = (IOish m, GhcMonad m)
|
||||
|
||||
instance (MonadIO m, MonadBaseControl IO m) => GhcMonad (GmlT m) where
|
||||
getSession = gmlGetSession
|
||||
setSession = gmlSetSession
|
||||
|
||||
-- | Get the underlying GHC session
|
||||
gmlGetSession :: (MonadIO m, MonadBaseControl IO m) => GmlT m HscEnv
|
||||
gmlGetSession = do
|
||||
ref <- gmgsSession . fromJustNote "gmlGetSession" . gmGhcSession <$> gmsGet
|
||||
liftIO $ readIORef ref
|
||||
|
||||
-- | Set the underlying GHC session
|
||||
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
|
||||
Reference in New Issue
Block a user