Merge pull request #288 from DanielG/dev-pkgs

Make `GhcMod` be `GhcModT (ErrorT IO)`

Language/Haskell/GhcMod/Boot.hs

@@ -8,7 +8,7 @@ import Language.Haskell.GhcMod.List
 import Language.Haskell.GhcMod.Monad
 
 -- | Printing necessary information for front-end booting.
-boot :: GhcMod String
+boot :: IOish m => GhcModT m String
 boot =  concat <$> sequence [modules, languages, flags,
                              concat <$> mapM browse preBrowsedModules]
 

Language/Haskell/GhcMod/Browse.hs

@@ -28,8 +28,9 @@ import Type (dropForAlls, splitFunTy_maybe, mkFunTy, isPredTy)
 -- | Getting functions, classes, etc from a module.
 --   If 'detailed' is 'True', their types are also obtained.
 --   If 'operators' is 'True', operators are also returned.
-browse :: ModuleString -- ^ A module name. (e.g. \"Data.List\")
+browse :: IOish m
-       -> GhcMod String
+       => ModuleString -- ^ A module name. (e.g. \"Data.List\")
+       -> GhcModT m String
 browse pkgmdl = convert' . sort =<< (listExports =<< getModule)
   where
     (mpkg,mdl) = splitPkgMdl pkgmdl
@@ -61,7 +62,7 @@ splitPkgMdl pkgmdl = case break (==':') pkgmdl of
     (mdl,"")    -> (Nothing,mdl)
     (pkg,_:mdl) -> (Just pkg,mdl)
 
-processExports :: ModuleInfo -> GhcMod [String]
+processExports :: IOish m => ModuleInfo -> GhcModT m [String]
 processExports minfo = do
   opt <- options
   let
@@ -70,13 +71,13 @@ processExports minfo = do
       | otherwise = filter (isAlpha . head . getOccString)
   mapM (showExport opt minfo) $ removeOps $ G.modInfoExports minfo
 
-showExport :: Options -> ModuleInfo -> Name -> GhcMod String
+showExport :: IOish m => Options -> ModuleInfo -> Name -> GhcModT m String
 showExport opt minfo e = do
   mtype' <- mtype
   return $ concat $ catMaybes [mqualified, Just $ formatOp $ getOccString e, mtype']
   where
     mqualified = (G.moduleNameString (G.moduleName $ G.nameModule e) ++ ".") `justIf` qualified opt
-    mtype :: GhcMod (Maybe String)
+    mtype :: IOish m => GhcModT m (Maybe String)
     mtype
       | detailed opt = do
         tyInfo <- G.modInfoLookupName minfo e
@@ -91,7 +92,7 @@ showExport opt minfo e = do
       | isAlpha n = nm
       | otherwise = "(" ++ nm ++ ")"
     formatOp "" = error "formatOp"
-    inOtherModule :: Name -> GhcMod (Maybe TyThing)
+    inOtherModule :: IOish m => Name -> GhcModT m (Maybe TyThing)
     inOtherModule nm = G.getModuleInfo (G.nameModule nm) >> G.lookupGlobalName nm
     justIf :: a -> Bool -> Maybe a
     justIf x True = Just x
@@ -138,7 +139,7 @@ showOutputable dflag = unwords . lines . showPage dflag styleUnqualified . ppr
 ----------------------------------------------------------------
 
 -- | Browsing all functions in all system/user modules.
-browseAll :: DynFlags -> GhcMod [(String,String)]
+browseAll :: IOish m => DynFlags -> GhcModT m [(String,String)]
 browseAll dflag = do
     ms <- G.packageDbModules True
     is <- mapM G.getModuleInfo ms

Language/Haskell/GhcMod/CaseSplit.hs

@@ -33,10 +33,11 @@ data SplitToTextInfo = SplitToTextInfo { sVarName     :: String
                                        }
 
 -- | Splitting a variable in a equation.
-splits :: FilePath     -- ^ A target file.
+splits :: IOish m
+       => FilePath     -- ^ A target file.
        -> Int          -- ^ Line number.
        -> Int          -- ^ Column number.
-       -> GhcMod String
+       -> GhcModT m String
 splits file lineNo colNo = ghandle handler body
   where
     body = inModuleContext file $ \dflag style -> do

Language/Haskell/GhcMod/Check.hs

@@ -15,8 +15,9 @@ import Language.Haskell.GhcMod.Monad
 
 -- | Checking syntax of a target file using GHC.
 --   Warnings and errors are returned.
-checkSyntax :: [FilePath]  -- ^ The target files.
+checkSyntax :: IOish m
-            -> GhcMod String
+            => [FilePath]  -- ^ The target files.
+            -> GhcModT m String
 checkSyntax [] = return ""
 checkSyntax files = withErrorHandler sessionName $ do
     either id id <$> check files
@@ -29,8 +30,9 @@ checkSyntax files = withErrorHandler sessionName $ do
 
 -- | Checking syntax of a target file using GHC.
 --   Warnings and errors are returned.
-check :: [FilePath]  -- ^ The target files.
+check :: IOish m
-      -> GhcMod (Either String String)
+      => [FilePath]  -- ^ The target files.
+      -> GhcModT m (Either String String)
 check fileNames = do
   withLogger setAllWaringFlags $ do
     setTargetFiles fileNames
@@ -38,8 +40,9 @@ check fileNames = do
 ----------------------------------------------------------------
 
 -- | Expanding Haskell Template.
-expandTemplate :: [FilePath]  -- ^ The target files.
+expandTemplate :: IOish m
-               -> GhcMod String
+               => [FilePath]  -- ^ The target files.
+               -> GhcModT m String
 expandTemplate [] = return ""
 expandTemplate files = withErrorHandler sessionName $ do
     either id id <$> expand files
@@ -51,7 +54,8 @@ expandTemplate files = withErrorHandler sessionName $ do
 ----------------------------------------------------------------
 
 -- | Expanding Haskell Template.
-expand :: [FilePath]  -- ^ The target files.
+expand :: IOish m
-      -> GhcMod (Either String String)
+       => [FilePath]  -- ^ The target files.
+       -> GhcModT m (Either String String)
 expand fileNames = withLogger (Gap.setDumpSplices . setNoWaringFlags) $
     setTargetFiles fileNames

Language/Haskell/GhcMod/Convert.hs

@@ -23,7 +23,7 @@ inter :: Char -> [Builder] -> Builder
 inter _ [] = id
 inter c bs = foldr1 (\x y -> x . (c:) . y) bs
 
-convert' :: ToString a => a -> GhcMod String
+convert' :: (ToString a, IOish m) => a -> GhcModT m String
 convert' x = flip convert x <$> options
 
 convert :: ToString a => Options -> a -> String

Language/Haskell/GhcMod/Debug.hs

@@ -12,7 +12,7 @@ import Language.Haskell.GhcMod.Internal
 ----------------------------------------------------------------
 
 -- | Obtaining debug information.
-debugInfo :: GhcMod String
+debugInfo :: IOish m => GhcModT m String
 debugInfo = cradle >>= \c -> convert' =<< do
     CompilerOptions gopts incDir pkgs <-
         if isJust $ cradleCabalFile c then
@@ -38,5 +38,5 @@ debugInfo = cradle >>= \c -> convert' =<< do
 ----------------------------------------------------------------
 
 -- | Obtaining root information.
-rootInfo :: GhcMod String
+rootInfo :: IOish m => GhcModT m String
 rootInfo = convert' =<< cradleRootDir <$> cradle

Language/Haskell/GhcMod/FillSig.hs

@@ -38,10 +38,11 @@ data SigInfo = Signature SrcSpan [G.RdrName] (G.HsType G.RdrName)
 data HESigInfo = HESignature HE.SrcSpan [HE.Name HE.SrcSpanInfo] (HE.Type HE.SrcSpanInfo)
 
 -- | Create a initial body from a signature.
-sig :: FilePath     -- ^ A target file.
+sig :: IOish m
+    => FilePath     -- ^ A target file.
     -> Int          -- ^ Line number.
     -> Int          -- ^ Column number.
-    -> GhcMod String
+    -> GhcModT m String
 sig file lineNo colNo = ghandle handler body
   where
     body = inModuleContext file $ \dflag style -> do

Language/Haskell/GhcMod/Find.hs

@@ -31,11 +31,11 @@ type Symbol = String
 newtype SymMdlDb = SymMdlDb (Map Symbol [ModuleString])
 
 -- | Finding modules to which the symbol belong.
-findSymbol :: Symbol -> GhcMod String
+findSymbol :: IOish m => Symbol -> GhcModT m String
 findSymbol sym = convert' =<< lookupSym sym <$> getSymMdlDb
 
 -- | Creating 'SymMdlDb'.
-getSymMdlDb :: GhcMod SymMdlDb
+getSymMdlDb :: IOish m => GhcModT m SymMdlDb
 getSymMdlDb = do
     sm <- G.getSessionDynFlags >>= browseAll
 #if MIN_VERSION_containers(0,5,0)

Language/Haskell/GhcMod/Flag.hs

@@ -6,7 +6,7 @@ import Language.Haskell.GhcMod.Monad
 
 -- | Listing GHC flags. (e.g -fno-warn-orphans)
 
-flags :: GhcMod String
+flags :: IOish m => GhcModT m String
 flags = convert' [ "-f" ++ prefix ++ option
                  | option <- Gap.fOptions
                  , prefix <- ["","no-"]

Language/Haskell/GhcMod/Info.hs

@@ -21,9 +21,10 @@ import Language.Haskell.GhcMod.Convert
 ----------------------------------------------------------------
 
 -- | Obtaining information of a target expression. (GHCi's info:)
-info :: FilePath     -- ^ A target file.
+info :: IOish m
+     => FilePath     -- ^ A target file.
      -> Expression   -- ^ A Haskell expression.
-     -> GhcMod String
+     -> GhcModT m String
 info file expr = do
     opt <- options
     convert opt <$> ghandle handler body
@@ -36,10 +37,11 @@ info file expr = do
 ----------------------------------------------------------------
 
 -- | Obtaining type of a target expression. (GHCi's type:)
-types :: FilePath     -- ^ A target file.
+types :: IOish m
+      => FilePath     -- ^ A target file.
       -> Int          -- ^ Line number.
       -> Int          -- ^ Column number.
-      -> GhcMod String
+      -> GhcModT m String
 types file lineNo colNo = do
     opt <- options
     convert opt <$> ghandle handler body

Language/Haskell/GhcMod/Lang.hs

@@ -6,5 +6,5 @@ import Language.Haskell.GhcMod.Monad
 
 -- | Listing language extensions.
 
-languages :: GhcMod String
+languages :: IOish m => GhcModT m String
 languages = convert' supportedLanguagesAndExtensions

Language/Haskell/GhcMod/Lint.hs

@@ -11,8 +11,9 @@ import Language.Haskell.HLint (hlint)
 
 -- | Checking syntax of a target file using hlint.
 --   Warnings and errors are returned.
-lint :: FilePath  -- ^ A target file.
+lint :: IOish m
-     -> GhcMod String
+     => FilePath  -- ^ A target file.
+     -> GhcModT m String
 lint file = do
   opt <- options
   ghandle handler . pack =<< (liftIO $ hlint $ file : "--quiet" : hlintOpts opt)

Language/Haskell/GhcMod/List.hs

@@ -13,7 +13,7 @@ import UniqFM (eltsUFM)
 ----------------------------------------------------------------
 
 -- | Listing installed modules.
-modules :: GhcMod String
+modules :: IOish m => GhcModT m String
 modules = do
     opt <- options
     convert opt . (arrange opt) <$> (getModules `G.gcatch` handler)

Language/Haskell/GhcMod/Logger.hs

@@ -34,7 +34,7 @@ newtype LogRef = LogRef (IORef Builder)
 newLogRef :: IO LogRef
 newLogRef = LogRef <$> newIORef id
 
-readAndClearLogRef :: LogRef -> GhcMod String
+readAndClearLogRef :: IOish m => LogRef -> GhcModT m String
 readAndClearLogRef (LogRef ref) = do
     b <- liftIO $ readIORef ref
     liftIO $ writeIORef ref id
@@ -50,9 +50,10 @@ appendLogRef df (LogRef ref) _ sev src style msg = do
 -- | Set the session flag (e.g. "-Wall" or "-w:") then
 --   executes a body. Logged messages are returned as 'String'.
 --   Right is success and Left is failure.
-withLogger :: (DynFlags -> DynFlags)
+withLogger :: IOish m
-           -> GhcMod ()
+           => (DynFlags -> DynFlags)
-           -> GhcMod (Either String String)
+           -> GhcModT m ()
+           -> GhcModT m (Either String String)
 withLogger setDF body = ghandle sourceError $ do
     logref <- liftIO $ newLogRef
     wflags <- filter ("-fno-warn" `isPrefixOf`) . ghcOpts <$> options
@@ -65,7 +66,7 @@ withLogger setDF body = ghandle sourceError $ do
 ----------------------------------------------------------------
 
 -- | Converting 'SourceError' to 'String'.
-sourceError :: SourceError -> GhcMod (Either String String)
+sourceError :: IOish m => SourceError -> GhcModT m (Either String String)
 sourceError err = do
     dflags <- G.getSessionDynFlags
     style <- toGhcMod getStyle

Language/Haskell/GhcMod/Monad.hs

@@ -1,16 +1,18 @@
 {-# LANGUAGE CPP, GeneralizedNewtypeDeriving, FlexibleInstances #-}
 {-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, RankNTypes #-}
 {-# LANGUAGE TypeFamilies, UndecidableInstances, RecordWildCards #-}
+{-# LANGUAGE StandaloneDeriving #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Language.Haskell.GhcMod.Monad (
    GhcMod
+ , runGhcMod
+ , liftGhcMod
  , GhcModT
+ , IOish
  , GhcModEnv(..)
  , GhcModWriter
  , GhcModState(..)
- , runGhcMod'
- , runGhcMod
  , runGhcModT'
  , runGhcModT
  , newGhcModEnv
@@ -18,11 +20,23 @@ module Language.Haskell.GhcMod.Monad (
  , toGhcMod
  , options
  , cradle
+ , Options(..)
+ , defaultOptions
  , module Control.Monad.Reader.Class
  , module Control.Monad.Writer.Class
  , module Control.Monad.State.Class
  ) where
 
+#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
+
+
 import Language.Haskell.GhcMod.Types
 import Language.Haskell.GhcMod.Cradle
 import Language.Haskell.GhcMod.DynFlags
@@ -47,22 +61,26 @@ import HscTypes
 -- So, RWST automatically becomes an instance of MonadIO.
 import MonadUtils
 
-#if __GLASGOW_HASKELL__ < 708
+#if DIFFERENT_MONADIO
--- To make RWST an instance of MonadIO.
 import Control.Monad.Trans.Class (lift)
+import qualified Control.Monad.IO.Class
 import Data.Monoid (Monoid)
 #endif
 
 import Control.Applicative (Alternative)
 import Control.Monad (MonadPlus, liftM, void)
 import Control.Monad.Base (MonadBase, liftBase)
+import Control.Monad.Trans.RWS.Lazy (liftCatch)
 
 import Control.Monad.Reader.Class
 import Control.Monad.State.Class
 import Control.Monad.Trans.Class
-import Control.Monad.Trans.Control (MonadBaseControl(..), StM, liftBaseWith, control, liftBaseOp, liftBaseOp_)
+import Control.Monad.Trans.Maybe
+import Control.Monad.Trans.Control (MonadBaseControl(..), StM, liftBaseWith,
+  control, liftBaseOp, liftBaseOp_)
 import Control.Monad.Trans.RWS.Lazy (RWST(..), runRWST)
 import Control.Monad.Writer.Class
+import Control.Monad.Error (Error(..), ErrorT(..), MonadError)
 
 import Data.Maybe (fromJust, isJust)
 import Data.IORef (IORef, readIORef, writeIORef, newIORef)
@@ -78,16 +96,28 @@ data GhcModEnv = GhcModEnv {
     , gmCradle     :: Cradle
     }
 
-data GhcModState = GhcModState
+data GhcModState = GhcModState deriving (Eq,Show,Read)
 
 defaultState :: GhcModState
 defaultState = GhcModState
 
 type GhcModWriter = ()
 
+data GhcModError = GMENoMsg
+                 | GMEString String
+                 | GMECabal
+                 | GMEGhc
+                   deriving (Eq,Show,Read)
+
+instance Error GhcModError where
+    noMsg = GMENoMsg
+    strMsg = GMEString
+
 ----------------------------------------------------------------
 
-type GhcMod a = GhcModT IO a
+type IOish m = (Functor m, MonadIO m, MonadBaseControl IO m)
+
+type GhcMod a = GhcModT (ErrorT GhcModError IO) a
 
 newtype GhcModT m a = GhcModT {
       unGhcModT :: RWST GhcModEnv GhcModWriter GhcModState m a
@@ -97,16 +127,27 @@ newtype GhcModT m a = GhcModT {
                , Monad
                , MonadPlus
                , MonadIO
+#if DIFFERENT_MONADIO
+               , Control.Monad.IO.Class.MonadIO
+#endif
                , MonadReader GhcModEnv
                , MonadWriter GhcModWriter
                , MonadState GhcModState
                , MonadTrans
                )
 
-#if __GLASGOW_HASKELL__ < 708
+deriving instance MonadError GhcModError m => MonadError GhcModError (GhcModT m)
+
+#if MONADIO_INSTANCES
 instance (Monoid w, MonadIO m) => MonadIO (RWST r w s m) where
---  liftIO :: MonadIO m => IO a -> m a
     liftIO = lift . liftIO
+
+instance (Error e, MonadIO m) => MonadIO (ErrorT e m) where
+    liftIO = lift . liftIO
+
+instance (MonadIO m) => MonadIO (MaybeT m) where
+    liftIO = lift . liftIO
+
 #endif
 
 ----------------------------------------------------------------
@@ -155,15 +196,6 @@ initSession build Options {..} CompilerOptions {..} = do
 
 ----------------------------------------------------------------
 
-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")
@@ -174,7 +206,10 @@ newGhcModEnv opt dir = do
         , gmCradle = c
         }
 
-runGhcModT :: (MonadIO m, MonadBaseControl IO m) => Options -> GhcModT m a -> m a
+-- | Run a @GhcModT m@ computation, i.e. one with a custom underlying monad.
+--
+-- You probably don't want this, look at 'runGhcMod' instead.
+runGhcModT :: IOish m => Options -> GhcModT m a -> m a
 runGhcModT opt action = do
     env <- liftBase $ newGhcModEnv opt =<< getCurrentDirectory
     (a,(_,_)) <- runGhcModT' env defaultState $ do
@@ -184,46 +219,68 @@ runGhcModT opt action = do
             action
     return a
 
-runGhcMod' :: GhcModEnv
+-- | Run a computation inside @GhcModT@ providing the RWST environment and
+-- initial state. This is a low level function, use it only if you know what to
+-- do with 'GhcModEnv' and 'GhcModState'.
+--
+-- You should probably look at 'runGhcModT' instead.
+runGhcModT' :: IOish m
+           => GhcModEnv
            -> GhcModState
-           -> GhcModT IO a
+           -> GhcModT m a
-           -> IO (a,(GhcModState, GhcModWriter))
+           -> m (a,(GhcModState, GhcModWriter))
-runGhcMod' = runGhcModT'
+runGhcModT' r s a = do
+  (a',s',w) <- runRWST (unGhcModT $ initGhcMonad (Just libdir) >> a) r s
+  return (a',(s',w))
+
+-- | Run a 'GhcMod' computation. If you want an underlying monad other than
+-- 'ErrorT e IO' you should look at 'runGhcModT'
+runGhcMod :: Options
+          -> GhcMod a
+          -> IO (Either GhcModError a)
+runGhcMod o a =
+  runErrorT $ runGhcModT o a
+
+liftErrorT :: IOish m => GhcModT m a -> GhcModT (ErrorT GhcModError m) a
+liftErrorT action =
+    GhcModT $ RWST $ \e s -> ErrorT $ Right <$> (runRWST $ unGhcModT action) e s
+
+-- | Lift @(GhcModT IO)@ into @GhcMod@, which is an alias for @GhcModT (ErrorT
+-- GhcModError IO)@.
+liftGhcMod :: GhcModT IO a -> GhcMod a
+liftGhcMod = liftErrorT
 
-runGhcMod :: Options -> GhcMod a -> IO a
-runGhcMod = runGhcModT
 ----------------------------------------------------------------
 
-withErrorHandler :: String -> GhcMod a -> GhcMod a
+withErrorHandler :: IOish m => String -> GhcModT m a -> GhcModT m a
 withErrorHandler label = ghandle ignore
   where
-    ignore :: SomeException -> GhcMod a
+    ignore :: IOish m => SomeException -> GhcModT m 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 :: IOish m => Ghc a -> GhcModT m a
 toGhcMod a = do
     s <- gmGhcSession <$> ask
     liftIO $ unGhc a $ Session s
 
 ----------------------------------------------------------------
 
-options :: GhcMod Options
+options :: IOish m => GhcModT m Options
 options = gmOptions <$> ask
 
-cradle :: GhcMod Cradle
+cradle :: IOish m => GhcModT m 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 }
+          unStGhcMod :: StM (RWST GhcModEnv GhcModWriter GhcModState m) a }
 
     liftBaseWith f = GhcModT . liftBaseWith $ \runInBase ->
         f $ liftM StGhcMod . runInBase . unGhcModT

Language/Haskell/GhcMod/PkgDoc.hs

@@ -9,7 +9,7 @@ import Control.Applicative ((<$>))
 import System.Process (readProcess)
 
 -- | Obtaining the package name and the doc path of a module.
-pkgDoc :: String -> GhcMod String
+pkgDoc :: IOish m => String -> GhcModT m String
 pkgDoc mdl = cradle >>= \c -> liftIO $ do
     pkg <- trim <$> readProcess "ghc-pkg" (toModuleOpts c) []
     if pkg == "" then

ghc-mod.cabal

@@ -51,6 +51,7 @@ Extra-Source-Files:     ChangeLog
 Library
   Default-Language:     Haskell2010
   GHC-Options:          -Wall
+  Default-Extensions:   ConstraintKinds, FlexibleContexts
   Exposed-Modules:      Language.Haskell.GhcMod
                         Language.Haskell.GhcMod.Ghc
                         Language.Haskell.GhcMod.Monad
@@ -117,6 +118,7 @@ Executable ghc-mod
   Main-Is:              GHCMod.hs
   Other-Modules:        Paths_ghc_mod
   GHC-Options:          -Wall
+  Default-Extensions:   ConstraintKinds, FlexibleContexts
   HS-Source-Dirs:       src
   Build-Depends:        base >= 4.0 && < 5
                       , directory
@@ -130,6 +132,7 @@ Executable ghc-modi
   Main-Is:              GHCModi.hs
   Other-Modules:        Paths_ghc_mod
   GHC-Options:          -Wall
+  Default-Extensions:   ConstraintKinds, FlexibleContexts
   HS-Source-Dirs:       src
   Build-Depends:        base >= 4.0 && < 5
                       , containers
@@ -143,12 +146,14 @@ Test-Suite doctest
   Default-Language:     Haskell2010
   HS-Source-Dirs:       test
   Ghc-Options:          -threaded -Wall
+  Default-Extensions:   ConstraintKinds, FlexibleContexts
   Main-Is:              doctests.hs
   Build-Depends:        base
                       , doctest >= 0.9.3
 
 Test-Suite spec
   Default-Language:     Haskell2010
+  Default-Extensions:   ConstraintKinds, FlexibleContexts
   Main-Is:              Main.hs
   Hs-Source-Dirs:       test, .
   Type:                 exitcode-stdio-1.0

src/GHCMod.hs

@@ -111,7 +111,7 @@ main = flip E.catches handlers $ do
         nArgs n f = if length remainingArgs == n
                         then f
                         else E.throw (ArgumentsMismatch cmdArg0)
-    res <- runGhcMod opt $ case cmdArg0 of
+    res <- runGhcModT opt $ case cmdArg0 of
       "list"    -> modules
       "lang"    -> languages
       "flag"    -> flags
@@ -152,7 +152,7 @@ main = flip E.catches handlers $ do
         hPutStrLn stderr $ "\"" ++ file ++ "\" not found"
         printUsage
     printUsage = hPutStrLn stderr $ '\n' : O.usageInfo usage argspec
-    withFile :: (FilePath -> GhcMod a) -> FilePath -> GhcMod a
+    withFile :: IOish m => (FilePath -> GhcModT m a) -> FilePath -> GhcModT m a
     withFile cmd file = do
         exist <- liftIO $ doesFileExist file
         if exist

src/GHCModi.hs

@@ -101,8 +101,8 @@ main = E.handle cmdHandler $
 --            c = cradle0 { cradleCurrentDir = rootdir } TODO: ?????
         setCurrentDirectory rootdir
         mvar <- liftIO newEmptyMVar
-        void $ forkIO $ runGhcMod opt $ setupDB mvar
+        void $ forkIO $ runGhcModT opt $ setupDB mvar
-        runGhcMod opt $ loop S.empty mvar
+        runGhcModT opt $ loop S.empty mvar
       where
         -- this is just in case.
         -- If an error is caught here, it is a bug of GhcMod library.
@@ -116,7 +116,7 @@ replace (x:xs)    =  x  : replace xs
 
 ----------------------------------------------------------------
 
-setupDB :: MVar SymMdlDb -> GhcMod ()
+setupDB :: IOish m => MVar SymMdlDb -> GhcModT m ()
 setupDB mvar = ghandle handler $ do
     liftIO . putMVar mvar =<< getSymMdlDb
   where
@@ -124,7 +124,7 @@ setupDB mvar = ghandle handler $ do
 
 ----------------------------------------------------------------
 
-loop :: Set FilePath -> MVar SymMdlDb -> GhcMod ()
+loop :: IOish m => Set FilePath -> MVar SymMdlDb -> GhcModT m ()
 loop set mvar = do
     cmdArg <- liftIO getLine
     let (cmd,arg') = break (== ' ') cmdArg
@@ -152,9 +152,10 @@ loop set mvar = do
 
 ----------------------------------------------------------------
 
-checkStx :: Set FilePath
+checkStx :: IOish m
+         => Set FilePath
          -> FilePath
-         -> GhcMod (String, Bool, Set FilePath)
+         -> GhcModT m (String, Bool, Set FilePath)
 checkStx set file = do
     set' <- toGhcMod $ newFileSet set file
     let files = S.toList set'
@@ -191,17 +192,17 @@ isSameMainFile file (Just x)
 
 ----------------------------------------------------------------
 
-findSym :: Set FilePath -> String -> MVar SymMdlDb
+findSym :: IOish m => Set FilePath -> String -> MVar SymMdlDb
-        -> GhcMod (String, Bool, Set FilePath)
+        -> GhcModT m (String, Bool, Set FilePath)
 findSym set sym mvar = do
     db <- liftIO $ readMVar mvar
     opt <- options
     let ret = lookupSym' opt sym db
     return (ret, True, set)
 
-lintStx :: Set FilePath
+lintStx :: IOish m => Set FilePath
         -> FilePath
-        -> GhcMod (String, Bool, Set FilePath)
+        -> GhcModT m (String, Bool, Set FilePath)
 lintStx set optFile = do
     ret <- local env' $ lint file
     return (ret, True, set)
@@ -228,36 +229,40 @@ parseLintOptions optFile = case brk (== ']') (dropWhile (/= '[') optFile) of
 
 ----------------------------------------------------------------
 
-showInfo :: Set FilePath
+showInfo :: IOish m
+         => Set FilePath
          -> FilePath
-         -> GhcMod (String, Bool, Set FilePath)
+         -> GhcModT m (String, Bool, Set FilePath)
 showInfo set fileArg = do
     let [file, expr] = words fileArg
     set' <- newFileSet set file
     ret <- info file expr
     return (ret, True, set')
 
-showType :: Set FilePath
+showType :: IOish m
+         => Set FilePath
          -> FilePath
-         -> GhcMod (String, Bool, Set FilePath)
+         -> GhcModT m (String, Bool, Set FilePath)
 showType set fileArg  = do
     let [file, line, column] = words fileArg
     set' <- newFileSet set file
     ret <- types file (read line) (read column)
     return (ret, True, set')
 
-doSplit :: Set FilePath
+doSplit :: IOish m
+        => Set FilePath
         -> FilePath
-        -> GhcMod (String, Bool, Set FilePath)
+        -> GhcModT m (String, Bool, Set FilePath)
 doSplit set fileArg  = do
     let [file, line, column] = words fileArg
     set' <- newFileSet set file
     ret <- splits file (read line) (read column)
     return (ret, True, set')
 
-doSig :: Set FilePath
+doSig :: IOish m
+      => Set FilePath
       -> FilePath
-      -> GhcMod (String, Bool, Set FilePath)
+      -> GhcModT m (String, Bool, Set FilePath)
 doSig set fileArg  = do
     let [file, line, column] = words fileArg
     set' <- newFileSet set file
@@ -266,15 +271,17 @@ doSig set fileArg  = do
 
 ----------------------------------------------------------------
 
-bootIt :: Set FilePath
+bootIt :: IOish m
-       -> GhcMod (String, Bool, Set FilePath)
+       => Set FilePath
+       -> GhcModT m (String, Bool, Set FilePath)
 bootIt set = do
     ret <- boot
     return (ret, True, set)
 
-browseIt :: Set FilePath
+browseIt :: IOish m
+         => Set FilePath
          -> ModuleString
-         -> GhcMod (String, Bool, Set FilePath)
+         -> GhcModT m (String, Bool, Set FilePath)
 browseIt set mdl = do
     ret <- browse mdl
     return (ret, True, set)

test/TestUtils.hs

@@ -12,14 +12,14 @@ module TestUtils (
 import Language.Haskell.GhcMod.Monad
 import Language.Haskell.GhcMod.Types
 
-isolateCradle :: GhcMod a -> GhcMod a
+isolateCradle :: IOish m => GhcModT m a -> GhcModT m a
 isolateCradle action =
     local modifyEnv  $ action
  where
     modifyEnv e = e { gmCradle = (gmCradle e) { cradlePkgDbStack = [GlobalDb] } }
 
-runIsolatedGhcMod :: Options -> GhcMod a -> IO a
+runIsolatedGhcMod :: Options -> GhcModT IO a -> IO a
-runIsolatedGhcMod opt action = runGhcMod opt $ isolateCradle action
+runIsolatedGhcMod opt action = runGhcModT opt $ isolateCradle action
 
 -- | Run GhcMod in isolated cradle with default options
 runID = runIsolatedGhcMod defaultOptions
@@ -28,7 +28,9 @@ runID = runIsolatedGhcMod defaultOptions
 runI = runIsolatedGhcMod
 
 -- | Run GhcMod
-run = runGhcMod
+run :: Options -> GhcModT IO a -> IO a
+run = runGhcModT
 
 -- | Run GhcMod with default options
-runD = runGhcMod defaultOptions
+runD :: GhcModT IO a -> IO a
+runD = runGhcModT defaultOptions

test/doctests.hs

@@ -6,6 +6,7 @@ main :: IO ()
 main = doctest [
     "-package"
   , "ghc"
+  , "-XConstraintKinds", "-XFlexibleContexts"
   , "-idist/build/autogen/"
   , "-optP-include"
   , "-optPdist/build/autogen/cabal_macros.h"