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\")
-       -> GhcMod String
+browse :: IOish m
+       => 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.
-            -> GhcMod String
+checkSyntax :: IOish m
+            => [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.
-      -> GhcMod (Either String String)
+check :: IOish m
+      => [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.
-               -> GhcMod String
+expandTemplate :: IOish m
+               => [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.
-      -> GhcMod (Either String String)
+expand :: IOish m
+       => [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.
-     -> GhcMod String
+lint :: IOish m
+     => 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)
-           -> GhcMod ()
-           -> GhcMod (Either String String)
+withLogger :: IOish m
+           => (DynFlags -> DynFlags)
+           -> 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
--- To make RWST an instance of MonadIO.
+#if DIFFERENT_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
-           -> IO (a,(GhcModState, GhcModWriter))
-runGhcMod' = runGhcModT'
+           -> 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))
+
+-- | 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