From c50b4f5a384caafae3f60413a405fb396a8b3a5e Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= <dxld@darkboxed.org>
Date: Sat, 3 May 2014 16:08:28 +0200
Subject: [PATCH] ghc-mod deserves it's own monad

Having to call `findCradle` and `initializeFlagsWithCradle` everywhere
we interact with ghc-mod's API doesn't seem very Haskell-like to me I
think we should provide a Monad that has a run function that already
does all those tedious tasks for us.

The `GhcMod` monad is basically a wrapper around `RWST r w s IO` with an
instance for `GhcMonad`

Having a `Reader` allows us to pass `Options` to runGhcMod and not have
to worry about passing it everywhere, `Cradle` is also stored in the
reader environment on initialization.

Writer and State are just there for future use.

I've included a `toGhcMod` function that turns a `Ghc a` into a `GhcMod
a` this will make it easy to transition everyting to using the `GhcMod`
monad instead of `Ghc` without breaking the build or test suite for
extended periods of time.

Conflicts:
	ghc-mod.cabal
---
 Language/Haskell/GhcMod/Monad.hs | 110 +++++++++++++++++++++++++++++++
 ghc-mod.cabal                    |   9 +++
 2 files changed, 119 insertions(+)
 create mode 100644 Language/Haskell/GhcMod/Monad.hs

diff --git a/Language/Haskell/GhcMod/Monad.hs b/Language/Haskell/GhcMod/Monad.hs
new file mode 100644
index 0000000..82c3806
--- /dev/null
+++ b/Language/Haskell/GhcMod/Monad.hs
@@ -0,0 +1,110 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses, RankNTypes, TypeFamilies #-}
+module Language.Haskell.GhcMod.Monad (
+   GhcMod
+ , GhcModEnv(..)
+ , GhcModWriter
+ , GhcModState(..)
+ , runGhcMod'
+ , runGhcMod
+ , toGhcMod
+ , module Control.Monad.Reader.Class
+ , module Control.Monad.Writer.Class
+ , module Control.Monad.State.Class
+ ) where
+
+import Language.Haskell.GhcMod.Types
+import Language.Haskell.GhcMod.Cradle
+import Language.Haskell.GhcMod.GHCApi
+
+import GHC
+import GHC.Paths (libdir)
+import GhcMonad
+import Exception
+import MonadUtils
+import DynFlags
+
+import Data.IORef (IORef, readIORef, writeIORef, newIORef)
+
+import Control.Monad (liftM)
+import Control.Monad.Base (MonadBase,liftBase)
+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.Writer.Class
+import Control.Monad.State.Class
+
+data GhcModEnv = GhcModEnv {
+      gmGhcSession :: !(IORef HscEnv)
+    , gmOptions    :: Options
+    , gmCradle     :: Cradle
+    }
+
+data GhcModState = GhcModState
+
+defaultState :: GhcModState
+defaultState = GhcModState
+
+type GhcModWriter = ()
+
+newtype GhcMod a = GhcMod {
+      unGhcMod :: RWST GhcModEnv GhcModWriter GhcModState IO a }
+    deriving (Functor,
+              Applicative,
+              Monad,
+              MonadIO,
+              MonadReader GhcModEnv,
+              MonadWriter GhcModWriter,
+              MonadState GhcModState)
+
+runGhcMod' :: GhcModEnv
+          -> GhcModState
+          -> GhcMod a
+          -> IO (a,(GhcModState, GhcModWriter))
+runGhcMod' r s a = do
+  (a', s',w) <- runRWST (unGhcMod $ initGhcMonad (Just libdir) >> a) r s
+  return (a',(s',w))
+
+runGhcMod :: Options -> GhcMod a -> IO a
+runGhcMod opt a = do
+    session <- newIORef (error "empty session")
+    cradle <- findCradle
+    let env = GhcModEnv { gmGhcSession = session
+                        , gmOptions = opt
+                        , gmCradle = cradle }
+    fst <$> runGhcMod' env defaultState (a' cradle)
+ where
+    a' cradle = (toGhcMod $ initializeFlagsWithCradle opt cradle) >> a
+
+toGhcMod :: Ghc a -> GhcMod a
+toGhcMod a = do
+    s <- gmGhcSession <$> ask
+    liftIO $ unGhc a $ Session s
+
+instance MonadBase IO GhcMod where
+    liftBase = GhcMod . liftBase
+
+instance MonadBaseControl IO GhcMod where
+    newtype StM GhcMod a = StGhcMod {
+          unStGhcMod :: StM (RWST GhcModEnv () GhcModState IO) a }
+
+    liftBaseWith f = GhcMod . liftBaseWith $ \runInBase ->
+        f $ liftM StGhcMod . runInBase . unGhcMod
+
+    restoreM = GhcMod . restoreM . unStGhcMod
+    {-# INLINE liftBaseWith #-}
+    {-# INLINE restoreM #-}
+
+instance GhcMonad GhcMod where
+    getSession = liftIO . readIORef . gmGhcSession =<< ask
+    setSession a = liftIO . flip writeIORef a . gmGhcSession =<< ask
+
+instance HasDynFlags GhcMod where
+    getDynFlags = getSessionDynFlags
+
+instance ExceptionMonad GhcMod where
+    gcatch act handler = control $ \run ->
+        run act `gcatch` (run . handler)
+
+    gmask = liftBaseOp gmask . liftRestore
+     where liftRestore f r = f $ liftBaseOp_ r
diff --git a/ghc-mod.cabal b/ghc-mod.cabal
index 7141c4b..509a088 100644
--- a/ghc-mod.cabal
+++ b/ghc-mod.cabal
@@ -74,12 +74,14 @@ Library
                         Language.Haskell.GhcMod.PkgDoc
                         Language.Haskell.GhcMod.Utils
                         Language.Haskell.GhcMod.Types
+                        Language.Haskell.GhcMod.Monad
   Build-Depends:        base >= 4.0 && < 5
                       , containers
                       , deepseq
                       , directory
                       , filepath
                       , ghc
+                      , ghc-paths
                       , ghc-syb-utils
                       , hlint >= 1.8.61
                       , io-choice
@@ -88,6 +90,9 @@ Library
                       , syb
                       , time
                       , transformers
+                      , transformers-base
+                      , mtl
+                      , monad-control
                       , split
   if impl(ghc < 7.7)
     Build-Depends:      convertible
@@ -151,6 +156,7 @@ Test-Suite spec
                       , directory
                       , filepath
                       , ghc
+                      , ghc-paths
                       , ghc-syb-utils
                       , hlint >= 1.7.1
                       , io-choice
@@ -159,6 +165,9 @@ Test-Suite spec
                       , syb
                       , time
                       , transformers
+                      , transformers-base
+                      , mtl
+                      , monad-control
                       , hspec >= 1.8.2
                       , split
   if impl(ghc < 7.7)