Merge pull request #257 from DanielG/dev-monad

Migrate Browse and Check to GhcMod monad

Language/Haskell/GhcMod.hs

@@ -14,7 +14,7 @@ module Language.Haskell.GhcMod (
   , Expression
   -- * 'IO' utilities
   , bootInfo
-  , browseModule
+  , browse
   , checkSyntax
   , lintSyntax
   , expandTemplate

Language/Haskell/GhcMod/Boot.hs

@@ -2,27 +2,25 @@ module Language.Haskell.GhcMod.Boot where
 
 import Control.Applicative ((<$>))
 import CoreMonad (liftIO, liftIO)
-import GHC (Ghc)
 import Language.Haskell.GhcMod.Browse
 import Language.Haskell.GhcMod.Flag
-import Language.Haskell.GhcMod.GHCApi
 import Language.Haskell.GhcMod.Lang
 import Language.Haskell.GhcMod.List
+import Language.Haskell.GhcMod.Monad
 import Language.Haskell.GhcMod.Types
 
 -- | Printing necessary information for front-end booting.
-bootInfo :: Options -> Cradle -> IO String
-bootInfo opt cradle = withGHC' $ do
-    initializeFlagsWithCradle opt cradle
-    boot opt
+bootInfo :: Options -> IO String
+bootInfo opt = runGhcMod opt $ boot
 
 -- | Printing necessary information for front-end booting.
-boot :: Options -> Ghc String
-boot opt = do
-    mods  <- modules opt
+boot :: GhcMod String
+boot = do
+    opt   <- options
+    mods  <- modules
     langs <- liftIO $ listLanguages opt
     flags <- liftIO $ listFlags opt
-    pre   <- concat <$> mapM (browse opt) preBrowsedModules
+    pre   <- concat <$> mapM browse preBrowsedModules
     return $ mods ++ langs ++ flags ++ pre
 
 preBrowsedModules :: [String]

Language/Haskell/GhcMod/Browse.hs

@@ -1,6 +1,5 @@
 module Language.Haskell.GhcMod.Browse (
-    browseModule
-  , browse
+    browse
   , browseAll)
   where
 
@@ -11,11 +10,13 @@ import Data.List (sort)
 import Data.Maybe (catMaybes)
 import Exception (ghandle)
 import FastString (mkFastString)
-import GHC (Ghc, GhcException(CmdLineError), ModuleInfo, Name, TyThing, DynFlags, Type, TyCon, Module)
+import GHC (GhcException(CmdLineError), ModuleInfo, Name, TyThing, DynFlags, Type, TyCon, Module)
 import qualified GHC as G
 import Language.Haskell.GhcMod.Doc (showPage, showOneLine, styleUnqualified)
 import Language.Haskell.GhcMod.GHCApi
 import Language.Haskell.GhcMod.Gap
+import Language.Haskell.GhcMod.Monad
+import Language.Haskell.GhcMod.Convert
 import Language.Haskell.GhcMod.Types
 import Name (getOccString)
 import Outputable (ppr, Outputable)
@@ -27,28 +28,15 @@ 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.
-browseModule :: Options
-             -> Cradle
-             -> ModuleString -- ^ A module name. (e.g. \"Data.List\")
-             -> IO String
-browseModule opt cradle pkgmdl = withGHC' $ do
-    initializeFlagsWithCradle opt cradle
-    browse opt pkgmdl
-
--- | 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 :: Options
-       -> ModuleString -- ^ A module name. (e.g. \"Data.List\")
-       -> Ghc String
-browse opt pkgmdl = do
-    convert opt . sort <$> (getModule >>= listExports)
+browse :: ModuleString -- ^ A module name. (e.g. \"Data.List\")
+       -> GhcMod String
+browse pkgmdl = convert' . sort =<< (listExports =<< getModule)
   where
     (mpkg,mdl) = splitPkgMdl pkgmdl
     mdlname = G.mkModuleName mdl
     mpkgid = mkFastString <$> mpkg
     listExports Nothing       = return []
-    listExports (Just mdinfo) = processExports opt mdinfo
+    listExports (Just mdinfo) = processExports mdinfo
     -- findModule works only for package modules, moreover,
     -- you cannot load a package module. On the other hand,
     -- to browse a local module you need to load it first.
@@ -73,19 +61,22 @@ splitPkgMdl pkgmdl = case break (==':') pkgmdl of
     (mdl,"")    -> (Nothing,mdl)
     (pkg,_:mdl) -> (Just pkg,mdl)
 
-processExports :: Options -> ModuleInfo -> Ghc [String]
-processExports opt minfo = mapM (showExport opt minfo) $ removeOps $ G.modInfoExports minfo
-  where
+processExports :: ModuleInfo -> GhcMod [String]
+processExports minfo = do
+  opt <- options
+  let
     removeOps
       | operators opt = id
       | otherwise = filter (isAlpha . head . getOccString)
+  mapM (showExport opt minfo) $ removeOps $ G.modInfoExports minfo
 
-showExport :: Options -> ModuleInfo -> Name -> Ghc String
+showExport :: Options -> ModuleInfo -> Name -> GhcMod 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
       | detailed opt = do
         tyInfo <- G.modInfoLookupName minfo e
@@ -100,7 +91,7 @@ showExport opt minfo e = do
       | isAlpha n = nm
       | otherwise = "(" ++ nm ++ ")"
     formatOp "" = error "formatOp"
-    inOtherModule :: Name -> Ghc (Maybe TyThing)
+    inOtherModule :: Name -> GhcMod (Maybe TyThing)
     inOtherModule nm = G.getModuleInfo (G.nameModule nm) >> G.lookupGlobalName nm
     justIf :: a -> Bool -> Maybe a
     justIf x True = Just x
@@ -147,7 +138,7 @@ showOutputable dflag = unwords . lines . showPage dflag styleUnqualified . ppr
 ----------------------------------------------------------------
 
 -- | Browsing all functions in all system/user modules.
-browseAll :: DynFlags -> Ghc [(String,String)]
+browseAll :: DynFlags -> GhcMod [(String,String)]
 browseAll dflag = do
     ms <- G.packageDbModules True
     is <- mapM G.getModuleInfo ms

Language/Haskell/GhcMod/Check.hs

@@ -6,24 +6,20 @@ module Language.Haskell.GhcMod.Check (
   ) where
 
 import Control.Applicative ((<$>))
-import GHC (Ghc)
 import Language.Haskell.GhcMod.GHCApi
 import qualified Language.Haskell.GhcMod.Gap as Gap
 import Language.Haskell.GhcMod.Logger
-import Language.Haskell.GhcMod.Types
+import Language.Haskell.GhcMod.Monad
 
 ----------------------------------------------------------------
 
 -- | Checking syntax of a target file using GHC.
 --   Warnings and errors are returned.
-checkSyntax :: Options
-            -> Cradle
-            -> [FilePath]  -- ^ The target files.
-            -> IO String
-checkSyntax _   _      []    = return ""
-checkSyntax opt cradle files = withGHC sessionName $ do
-    initializeFlagsWithCradle opt cradle
-    either id id <$> check opt files
+checkSyntax :: [FilePath]  -- ^ The target files.
+            -> GhcMod String
+checkSyntax [] = return ""
+checkSyntax files = withErrorHandler sessionName $ do
+    either id id <$> check files
   where
     sessionName = case files of
       [file] -> file
@@ -33,23 +29,20 @@ checkSyntax opt cradle files = withGHC sessionName $ do
 
 -- | Checking syntax of a target file using GHC.
 --   Warnings and errors are returned.
-check :: Options
-      -> [FilePath]  -- ^ The target files.
-      -> Ghc (Either String String)
-check opt fileNames = withLogger opt setAllWaringFlags $
+check :: [FilePath]  -- ^ The target files.
+      -> GhcMod (Either String String)
+check fileNames = do
+  withLogger setAllWaringFlags $ do
     setTargetFiles fileNames
 
 ----------------------------------------------------------------
 
 -- | Expanding Haskell Template.
-expandTemplate :: Options
-               -> Cradle
-               -> [FilePath]  -- ^ The target files.
-               -> IO String
-expandTemplate _   _      []    = return ""
-expandTemplate opt cradle files = withGHC sessionName $ do
-    initializeFlagsWithCradle opt cradle
-    either id id <$> expand opt files
+expandTemplate :: [FilePath]  -- ^ The target files.
+               -> GhcMod String
+expandTemplate [] = return ""
+expandTemplate files = withErrorHandler sessionName $ do
+    either id id <$> expand files
   where
     sessionName = case files of
       [file] -> file
@@ -58,8 +51,7 @@ expandTemplate opt cradle files = withGHC sessionName $ do
 ----------------------------------------------------------------
 
 -- | Expanding Haskell Template.
-expand :: Options
-      -> [FilePath]  -- ^ The target files.
-      -> Ghc (Either String String)
-expand opt fileNames = withLogger opt (Gap.setDumpSplices . setNoWaringFlags) $
+expand :: [FilePath]  -- ^ The target files.
+      -> GhcMod (Either String String)
+expand fileNames = withLogger (Gap.setDumpSplices . setNoWaringFlags) $
     setTargetFiles fileNames

Language/Haskell/GhcMod/Convert.hs

@@ -0,0 +1,103 @@
+{-# LANGUAGE FlexibleInstances #-}
+
+module Language.Haskell.GhcMod.Convert (convert, convert') where
+
+import Language.Haskell.GhcMod.Monad
+import Language.Haskell.GhcMod.Types
+
+import Control.Applicative ((<$>))
+
+type Builder = String -> String
+
+-- |
+--
+-- >>> replace '"' "\\\"" "foo\"bar" ""
+-- "foo\\\"bar"
+replace :: Char -> String -> String -> Builder
+replace _ _  [] = id
+replace c cs (x:xs)
+  | x == c    = (cs ++) . replace c cs xs
+  | otherwise = (x :) . replace c cs xs
+
+inter :: Char -> [Builder] -> Builder
+inter _ [] = id
+inter c bs = foldr1 (\x y -> x . (c:) . y) bs
+
+convert' :: ToString a => a -> GhcMod String
+convert' x = flip convert x <$> options
+
+convert :: ToString a => Options -> a -> String
+convert opt@Options { outputStyle = LispStyle  } x = toLisp  opt x "\n"
+convert opt@Options { outputStyle = PlainStyle } x
+  | str == "\n" = ""
+  | otherwise   = str
+  where
+    str = toPlain opt x "\n"
+
+class ToString a where
+    toLisp  :: Options -> a -> Builder
+    toPlain :: Options -> a -> Builder
+
+lineSep :: Options -> String
+lineSep opt = lsep
+  where
+    LineSeparator lsep = lineSeparator opt
+
+-- |
+--
+-- >>> toLisp defaultOptions "fo\"o" ""
+-- "\"fo\\\"o\""
+-- >>> toPlain defaultOptions "foo" ""
+-- "foo"
+instance ToString String where
+    toLisp  opt = quote opt
+    toPlain opt = replace '\n' (lineSep opt)
+
+-- |
+--
+-- >>> toLisp defaultOptions ["foo", "bar", "ba\"z"] ""
+-- "(\"foo\" \"bar\" \"ba\\\"z\")"
+-- >>> toPlain defaultOptions ["foo", "bar", "baz"] ""
+-- "foo\nbar\nbaz"
+instance ToString [String] where
+    toLisp  opt = toSexp1 opt
+    toPlain opt = inter '\n' . map (toPlain opt)
+
+-- |
+--
+-- >>> let inp = [((1,2,3,4),"foo"),((5,6,7,8),"bar")] :: [((Int,Int,Int,Int),String)]
+-- >>> toLisp defaultOptions inp ""
+-- "((1 2 3 4 \"foo\") (5 6 7 8 \"bar\"))"
+-- >>> toPlain defaultOptions inp ""
+-- "1 2 3 4 \"foo\"\n5 6 7 8 \"bar\""
+instance ToString [((Int,Int,Int,Int),String)] where
+    toLisp  opt = toSexp2 . map toS
+      where
+        toS x = ('(' :) . tupToString opt x . (')' :)
+    toPlain opt = inter '\n' . map (tupToString opt)
+
+toSexp1 :: Options -> [String] -> Builder
+toSexp1 opt ss = ('(' :) . inter ' ' (map (quote opt) ss) . (')' :)
+
+toSexp2 :: [Builder] -> Builder
+toSexp2 ss = ('(' :) . (inter ' ' ss) . (')' :)
+
+tupToString :: Options -> ((Int,Int,Int,Int),String) -> Builder
+tupToString opt ((a,b,c,d),s) = (show a ++) . (' ' :)
+                              . (show b ++) . (' ' :)
+                              . (show c ++) . (' ' :)
+                              . (show d ++) . (' ' :)
+                              . quote opt s -- fixme: quote is not necessary
+
+quote :: Options -> String -> Builder
+quote opt str = ("\"" ++) .  (quote' str ++) . ("\"" ++)
+  where
+    lsep = lineSep opt
+    quote' [] = []
+    quote' (x:xs)
+      | x == '\n' = lsep   ++ quote' xs
+      | x == '\\' = "\\\\" ++ quote' xs
+      | x == '"'  = "\\\"" ++ quote' xs
+      | otherwise = x       : quote' xs
+
+----------------------------------------------------------------

Language/Haskell/GhcMod/Debug.hs

@@ -7,6 +7,7 @@ import Data.List (intercalate)
 import Data.Maybe (fromMaybe, isJust, fromJust)
 import Language.Haskell.GhcMod.CabalApi
 import Language.Haskell.GhcMod.GHCApi
+import Language.Haskell.GhcMod.Convert
 import Language.Haskell.GhcMod.Types
 
 ----------------------------------------------------------------

Language/Haskell/GhcMod/Find.hs

@@ -5,10 +5,10 @@ module Language.Haskell.GhcMod.Find where
 import Data.Function (on)
 import Data.List (groupBy, sort)
 import Data.Maybe (fromMaybe)
-import GHC (Ghc)
 import qualified GHC as G
 import Language.Haskell.GhcMod.Browse (browseAll)
-import Language.Haskell.GhcMod.GHCApi
+import Language.Haskell.GhcMod.Monad
+import Language.Haskell.GhcMod.Convert
 import Language.Haskell.GhcMod.Types
 
 #ifndef MIN_VERSION_containers
@@ -31,13 +31,11 @@ type Symbol = String
 newtype SymMdlDb = SymMdlDb (Map Symbol [ModuleString])
 
 -- | Finding modules to which the symbol belong.
-findSymbol :: Options -> Cradle -> Symbol -> IO String
-findSymbol opt cradle sym = withGHC' $ do
-    initializeFlagsWithCradle opt cradle
-    lookupSym opt sym <$> getSymMdlDb
+findSymbol :: Symbol -> GhcMod String
+findSymbol sym = convert' =<< lookupSym sym <$> getSymMdlDb
 
 -- | Creating 'SymMdlDb'.
-getSymMdlDb :: Ghc SymMdlDb
+getSymMdlDb :: GhcMod SymMdlDb
 getSymMdlDb = do
     sm <- G.getSessionDynFlags >>= browseAll
 #if MIN_VERSION_containers(0,5,0)
@@ -52,5 +50,8 @@ getSymMdlDb = do
     tieup x = (head (map fst x), map snd x)
 
 -- | Looking up 'SymMdlDb' with 'Symbol' to find modules.
-lookupSym :: Options -> Symbol -> SymMdlDb -> String
-lookupSym opt sym (SymMdlDb db) = convert opt $ fromMaybe [] (M.lookup sym db)
+lookupSym :: Symbol -> SymMdlDb -> [ModuleString]
+lookupSym sym (SymMdlDb db) = fromMaybe [] (M.lookup sym db)
+
+lookupSym' :: Options -> Symbol -> SymMdlDb -> String
+lookupSym' opt sym db = convert opt $ lookupSym sym db

Language/Haskell/GhcMod/Flag.hs

@@ -1,6 +1,7 @@
 module Language.Haskell.GhcMod.Flag where
 
 import qualified Language.Haskell.GhcMod.Gap as Gap
+import Language.Haskell.GhcMod.Convert
 import Language.Haskell.GhcMod.Types
 
 -- | Listing GHC flags. (e.g -fno-warn-orphans)

Language/Haskell/GhcMod/GHCApi.hs

@@ -164,22 +164,25 @@ getDynamicFlags = do
     mlibdir <- getSystemLibDir
     G.runGhc mlibdir G.getSessionDynFlags
 
-withDynFlags :: (DynFlags -> DynFlags) -> Ghc a -> Ghc a
-withDynFlags setFlag body = G.gbracket setup teardown (\_ -> body)
+withDynFlags :: GhcMonad m
+             => (DynFlags -> DynFlags)
+             -> m a
+             -> m a
+withDynFlags setFlags body = G.gbracket setup teardown (\_ -> body)
   where
     setup = do
-        dflag <- G.getSessionDynFlags
-        void $ G.setSessionDynFlags (setFlag dflag)
-        return dflag
+        dflags <- G.getSessionDynFlags
+        void $ G.setSessionDynFlags (setFlags dflags)
+        return dflags
     teardown = void . G.setSessionDynFlags
 
-withCmdFlags :: [GHCOption] -> Ghc a -> Ghc a
+withCmdFlags :: GhcMonad m => [GHCOption] -> m a -> m a
 withCmdFlags flags body = G.gbracket setup teardown (\_ -> body)
   where
     setup = do
-        dflag <- G.getSessionDynFlags >>= addCmdOpts flags
-        void $ G.setSessionDynFlags dflag
-        return dflag
+        dflags <- G.getSessionDynFlags >>= addCmdOpts flags
+        void $ G.setSessionDynFlags dflags
+        return dflags
     teardown = void . G.setSessionDynFlags
 
 ----------------------------------------------------------------

Language/Haskell/GhcMod/Gap.hs

@@ -45,7 +45,7 @@ import ErrUtils
 import FastString
 import HscTypes
 import Language.Haskell.GhcMod.GHCChoice
-import Language.Haskell.GhcMod.Types hiding (convert)
+import Language.Haskell.GhcMod.Types
 import NameSet
 import Outputable
 import PprTyThing

Language/Haskell/GhcMod/Ghc.hs

@@ -14,6 +14,7 @@ module Language.Haskell.GhcMod.Ghc (
   , SymMdlDb
   , getSymMdlDb
   , lookupSym
+  , lookupSym'
   ) where
 
 import Language.Haskell.GhcMod.Boot

Language/Haskell/GhcMod/Info.hs

@@ -25,6 +25,7 @@ import Language.Haskell.GhcMod.GHCApi
 import Language.Haskell.GhcMod.Gap (HasType(..), setDeferTypeErrors)
 import qualified Language.Haskell.GhcMod.Gap as Gap
 import Language.Haskell.GhcMod.Types
+import Language.Haskell.GhcMod.Convert
 import Outputable (PprStyle)
 import TcHsSyn (hsPatType)
 

Language/Haskell/GhcMod/Lang.hs

@@ -2,6 +2,7 @@ module Language.Haskell.GhcMod.Lang where
 
 import DynFlags (supportedLanguagesAndExtensions)
 import Language.Haskell.GhcMod.Types
+import Language.Haskell.GhcMod.Convert
 
 -- | Listing language extensions.
 

Language/Haskell/GhcMod/Lint.hs

@@ -3,6 +3,7 @@ module Language.Haskell.GhcMod.Lint where
 import Control.Applicative ((<$>))
 import Control.Exception (handle, SomeException(..))
 import Language.Haskell.GhcMod.Logger (checkErrorPrefix)
+import Language.Haskell.GhcMod.Convert
 import Language.Haskell.GhcMod.Types
 import Language.Haskell.HLint (hlint)
 

Language/Haskell/GhcMod/List.hs

@@ -3,9 +3,9 @@ module Language.Haskell.GhcMod.List (listModules, modules) where
 import Control.Applicative ((<$>))
 import Control.Exception (SomeException(..))
 import Data.List (nub, sort)
-import GHC (Ghc)
 import qualified GHC as G
-import Language.Haskell.GhcMod.GHCApi
+import Language.Haskell.GhcMod.Monad
+import Language.Haskell.GhcMod.Convert
 import Language.Haskell.GhcMod.Types
 import Packages (pkgIdMap, exposedModules, sourcePackageId, display)
 import UniqFM (eltsUFM)
@@ -14,13 +14,13 @@ import UniqFM (eltsUFM)
 
 -- | Listing installed modules.
 listModules :: Options -> Cradle -> IO String
-listModules opt cradle = withGHC' $ do
-    initializeFlagsWithCradle opt cradle
-    modules opt
+listModules opt _ = runGhcMod opt $ modules
 
 -- | Listing installed modules.
-modules :: Options -> Ghc String
-modules opt = convert opt . arrange <$> (getModules `G.gcatch` handler)
+modules :: GhcMod String
+modules = do
+    opt <- options
+    convert opt . (arrange opt) <$> (getModules `G.gcatch` handler)
   where
     getModules = getExposedModules <$> G.getSessionDynFlags
     getExposedModules = concatMap exposedModules'
@@ -29,8 +29,8 @@ modules opt = convert opt . arrange <$> (getModules `G.gcatch` handler)
         map G.moduleNameString (exposedModules p)
     	`zip`
         repeat (display $ sourcePackageId p)
-    arrange = nub . sort . map dropPkgs
-    dropPkgs (name, pkg)
+    arrange opt = nub . sort . map (dropPkgs opt)
+    dropPkgs opt (name, pkg)
       | detailed opt = name ++ " " ++ pkg
       | otherwise = name
     handler (SomeException _) = return []

Language/Haskell/GhcMod/Logger.hs

@@ -6,20 +6,22 @@ module Language.Haskell.GhcMod.Logger (
   ) where
 
 import Bag (Bag, bagToList)
-import Control.Applicative ((<$>))
+import Control.Applicative ((<$>),(*>))
 import CoreMonad (liftIO)
 import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef)
 import Data.List (isPrefixOf)
 import Data.Maybe (fromMaybe)
 import ErrUtils (ErrMsg, errMsgShortDoc, errMsgExtraInfo)
 import Exception (ghandle)
-import GHC (Ghc, DynFlags, SrcSpan, Severity(SevError))
+import GHC (DynFlags, SrcSpan, Severity(SevError))
 import qualified GHC as G
 import HscTypes (SourceError, srcErrorMessages)
 import Language.Haskell.GhcMod.Doc (showPage, getStyle)
 import Language.Haskell.GhcMod.GHCApi (withDynFlags, withCmdFlags)
 import qualified Language.Haskell.GhcMod.Gap as Gap
-import Language.Haskell.GhcMod.Types (Options(..), convert)
+import Language.Haskell.GhcMod.Convert (convert')
+import Language.Haskell.GhcMod.Monad
+import Language.Haskell.GhcMod.Types (Options(..))
 import Outputable (PprStyle, SDoc)
 import System.FilePath (normalise)
 
@@ -32,11 +34,11 @@ newtype LogRef = LogRef (IORef Builder)
 newLogRef :: IO LogRef
 newLogRef = LogRef <$> newIORef id
 
-readAndClearLogRef :: Options -> LogRef -> IO String
-readAndClearLogRef opt (LogRef ref) = do
-    b <- readIORef ref
-    writeIORef ref id
-    return $! convert opt (b [])
+readAndClearLogRef :: LogRef -> GhcMod String
+readAndClearLogRef (LogRef ref) = do
+    b <- liftIO $ readIORef ref
+    liftIO $ writeIORef ref id
+    convert' (b [])
 
 appendLogRef :: DynFlags -> LogRef -> DynFlags -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ()
 appendLogRef df (LogRef ref) _ sev src style msg = do
@@ -46,28 +48,29 @@ appendLogRef df (LogRef ref) _ sev src style msg = do
 ----------------------------------------------------------------
 
 -- | Set the session flag (e.g. "-Wall" or "-w:") then
---   executes a body. Log messages are returned as 'String'.
+--   executes a body. Logged messages are returned as 'String'.
 --   Right is success and Left is failure.
-withLogger :: Options -> (DynFlags -> DynFlags) -> Ghc () -> Ghc (Either String String)
-withLogger opt setDF body = ghandle (sourceError opt) $ do
+withLogger :: (DynFlags -> DynFlags)
+           -> GhcMod ()
+           -> GhcMod (Either String String)
+withLogger setDF body = ghandle sourceError $ do
     logref <- liftIO $ newLogRef
+    wflags <- filter ("-fno-warn" `isPrefixOf`) . ghcOpts <$> options
     withDynFlags (setLogger logref . setDF) $ do
-        withCmdFlags wflags $ do
-            body
-            liftIO $ Right <$> readAndClearLogRef opt logref
+        withCmdFlags wflags $ do body *> (Right <$> readAndClearLogRef logref)
   where
     setLogger logref df = Gap.setLogAction df $ appendLogRef df logref
-    wflags = filter ("-fno-warn" `isPrefixOf`) $ ghcOpts opt
+
 
 ----------------------------------------------------------------
 
 -- | Converting 'SourceError' to 'String'.
-sourceError :: Options -> SourceError -> Ghc (Either String String)
-sourceError opt err = do
-    dflag <- G.getSessionDynFlags
-    style <- getStyle
-    let ret = convert opt . errBagToStrList dflag style . srcErrorMessages $ err
-    return (Left ret)
+sourceError :: SourceError -> GhcMod (Either String String)
+sourceError err = do
+    dflags <- G.getSessionDynFlags
+    style <- toGhcMod getStyle
+    ret <- convert' $ (errBagToStrList dflags style . srcErrorMessages $ err)
+    return $ Left ret
 
 errBagToStrList :: DynFlags -> PprStyle -> Bag ErrMsg -> [String]
 errBagToStrList dflag style = map (ppErrMsg dflag style) . reverse . bagToList

Language/Haskell/GhcMod/Monad.hs

@@ -7,7 +7,9 @@ module Language.Haskell.GhcMod.Monad (
  , GhcModState(..)
  , runGhcMod'
  , runGhcMod
+ , withErrorHandler
  , toGhcMod
+ , options
  , module Control.Monad.Reader.Class
  , module Control.Monad.Writer.Class
  , module Control.Monad.State.Class
@@ -46,6 +48,10 @@ import Control.Monad.Reader.Class
 import Control.Monad.Writer.Class
 import Control.Monad.State.Class
 
+import System.IO (hPutStr, hPrint, stderr)
+import System.Exit (exitSuccess)
+
+
 data GhcModEnv = GhcModEnv {
       gmGhcSession :: !(IORef HscEnv)
     , gmOptions    :: Options
@@ -83,22 +89,38 @@ 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
+runGhcMod opt action = 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
+    (a,(_,_)) <- runGhcMod' env defaultState $ do
+        dflags <- getSessionDynFlags
+        defaultCleanupHandler dflags $ do
+            toGhcMod $ initializeFlagsWithCradle opt cradle
+            action
+    return a
+
+withErrorHandler :: String -> GhcMod a -> GhcMod a
+withErrorHandler label = ghandle ignore
+  where
+    ignore :: SomeException -> GhcMod a
+    ignore e = liftIO $ do
+        hPutStr stderr $ label ++ ":0:0:Error:"
+        hPrint stderr e
+        exitSuccess
 
 toGhcMod :: Ghc a -> GhcMod a
 toGhcMod a = do
     s <- gmGhcSession <$> ask
     liftIO $ unGhc a $ Session s
 
+options :: GhcMod Options
+options = gmOptions <$> ask
+
 instance MonadBase IO GhcMod where
     liftBase = GhcMod . liftBase
 

Language/Haskell/GhcMod/Types.hs

@@ -1,5 +1,3 @@
-{-# LANGUAGE FlexibleInstances #-}
-
 module Language.Haskell.GhcMod.Types where
 
 import Data.List (intercalate)
@@ -39,98 +37,6 @@ defaultOptions = Options {
 
 ----------------------------------------------------------------
 
-type Builder = String -> String
-
--- |
---
--- >>> replace '"' "\\\"" "foo\"bar" ""
--- "foo\\\"bar"
-replace :: Char -> String -> String -> Builder
-replace _ _  [] = id
-replace c cs (x:xs)
-  | x == c    = (cs ++) . replace c cs xs
-  | otherwise = (x :) . replace c cs xs
-
-inter :: Char -> [Builder] -> Builder
-inter _ [] = id
-inter c bs = foldr1 (\x y -> x . (c:) . y) bs
-
-convert :: ToString a => Options -> a -> String
-convert opt@Options { outputStyle = LispStyle  } x = toLisp  opt x "\n"
-convert opt@Options { outputStyle = PlainStyle } x
-  | str == "\n" = ""
-  | otherwise   = str
-  where
-    str = toPlain opt x "\n"
-
-class ToString a where
-    toLisp  :: Options -> a -> Builder
-    toPlain :: Options -> a -> Builder
-
-lineSep :: Options -> String
-lineSep opt = lsep
-  where
-    LineSeparator lsep = lineSeparator opt
-
--- |
---
--- >>> toLisp defaultOptions "fo\"o" ""
--- "\"fo\\\"o\""
--- >>> toPlain defaultOptions "foo" ""
--- "foo"
-instance ToString String where
-    toLisp  opt = quote opt
-    toPlain opt = replace '\n' (lineSep opt)
-
--- |
---
--- >>> toLisp defaultOptions ["foo", "bar", "ba\"z"] ""
--- "(\"foo\" \"bar\" \"ba\\\"z\")"
--- >>> toPlain defaultOptions ["foo", "bar", "baz"] ""
--- "foo\nbar\nbaz"
-instance ToString [String] where
-    toLisp  opt = toSexp1 opt
-    toPlain opt = inter '\n' . map (toPlain opt)
-
--- |
---
--- >>> let inp = [((1,2,3,4),"foo"),((5,6,7,8),"bar")] :: [((Int,Int,Int,Int),String)]
--- >>> toLisp defaultOptions inp ""
--- "((1 2 3 4 \"foo\") (5 6 7 8 \"bar\"))"
--- >>> toPlain defaultOptions inp ""
--- "1 2 3 4 \"foo\"\n5 6 7 8 \"bar\""
-instance ToString [((Int,Int,Int,Int),String)] where
-    toLisp  opt = toSexp2 . map toS
-      where
-        toS x = ('(' :) . tupToString opt x . (')' :)
-    toPlain opt = inter '\n' . map (tupToString opt)
-
-toSexp1 :: Options -> [String] -> Builder
-toSexp1 opt ss = ('(' :) . inter ' ' (map (quote opt) ss) . (')' :)
-
-toSexp2 :: [Builder] -> Builder
-toSexp2 ss = ('(' :) . (inter ' ' ss) . (')' :)
-
-tupToString :: Options -> ((Int,Int,Int,Int),String) -> Builder
-tupToString opt ((a,b,c,d),s) = (show a ++) . (' ' :)
-                              . (show b ++) . (' ' :)
-                              . (show c ++) . (' ' :)
-                              . (show d ++) . (' ' :)
-                              . quote opt s -- fixme: quote is not necessary
-
-quote :: Options -> String -> Builder
-quote opt str = ("\"" ++) .  (quote' str ++) . ("\"" ++)
-  where
-    lsep = lineSep opt
-    quote' [] = []
-    quote' (x:xs)
-      | x == '\n' = lsep   ++ quote' xs
-      | x == '\\' = "\\\\" ++ quote' xs
-      | x == '"'  = "\\\"" ++ quote' xs
-      | otherwise = x       : quote' xs
-
-----------------------------------------------------------------
-
 -- | The environment where this library is used.
 data Cradle = Cradle {
   -- | The directory where this library is executed.

ghc-mod.cabal

@@ -63,6 +63,7 @@ Library
                         Language.Haskell.GhcMod.Cabal18
                         Language.Haskell.GhcMod.Check
                         Language.Haskell.GhcMod.Cradle
+                        Language.Haskell.GhcMod.Convert
                         Language.Haskell.GhcMod.Debug
                         Language.Haskell.GhcMod.Doc
                         Language.Haskell.GhcMod.Find
@@ -155,6 +156,7 @@ Test-Suite spec
                         LintSpec
                         ListSpec
                         GhcPkgSpec
+                        TestUtils
   Build-Depends:        base >= 4.0 && < 5
                       , containers
                       , deepseq

src/GHCMod.hs

@@ -9,6 +9,7 @@ import qualified Control.Exception as E
 import Data.Typeable (Typeable)
 import Data.Version (showVersion)
 import Language.Haskell.GhcMod
+import Language.Haskell.GhcMod.Monad
 import Paths_ghc_mod
 import System.Console.GetOpt (OptDescr(..), ArgDescr(..), ArgOrder(..))
 import qualified System.Console.GetOpt as O
@@ -112,17 +113,17 @@ main = flip E.catches handlers $ do
       "list"    -> listModules opt cradle
       "lang"    -> listLanguages opt
       "flag"    -> listFlags opt
-      "browse"  -> concat <$> mapM (browseModule opt cradle) remainingArgs
-      "check"   -> checkSyntax opt cradle remainingArgs
-      "expand"  -> expandTemplate opt cradle remainingArgs
+      "browse"  -> runGhcMod opt $ concat <$> mapM browse remainingArgs
+      "check"   -> runGhcMod opt $ checkSyntax remainingArgs
+      "expand"  -> runGhcMod opt $ expandTemplate remainingArgs
       "debug"   -> debugInfo opt cradle
       "info"    -> nArgs 3 infoExpr opt cradle cmdArg1 cmdArg3
       "type"    -> nArgs 4 $ typeExpr opt cradle cmdArg1 (read cmdArg3) (read cmdArg4)
-      "find"    -> nArgs 1 $ findSymbol opt cradle cmdArg1
+      "find"    -> runGhcMod opt $ nArgs 1 $ findSymbol cmdArg1
       "lint"    -> nArgs 1 withFile (lintSyntax opt) cmdArg1
       "root"    -> rootInfo opt cradle
       "doc"     -> nArgs 1 $ packageDoc opt cradle cmdArg1
-      "boot"    -> bootInfo opt cradle
+      "boot"    -> bootInfo opt
       "version" -> return progVersion
       "help"    -> return $ O.usageInfo usage argspec
       cmd       -> E.throw (NoSuchCommand cmd)

src/GHCModi.hs

@@ -35,6 +35,7 @@ import GHC (Ghc)
 import qualified GHC as G
 import Language.Haskell.GhcMod
 import Language.Haskell.GhcMod.Ghc
+import Language.Haskell.GhcMod.Monad
 import Language.Haskell.GhcMod.Internal
 import Paths_ghc_mod
 import System.Console.GetOpt
@@ -116,9 +117,8 @@ replace (x:xs)    =  x  : replace xs
 
 ----------------------------------------------------------------
 
-run :: Cradle -> Maybe FilePath -> Options -> Ghc a -> IO a
-run cradle mlibdir opt body = G.runGhc mlibdir $ do
-    initializeFlagsWithCradle opt cradle
+run :: Cradle -> Maybe FilePath -> Options -> GhcMod a -> IO a
+run _ _ opt body = runGhcMod opt $ do
     dflags <- G.getSessionDynFlags
     G.defaultCleanupHandler dflags body
 
@@ -133,19 +133,19 @@ setupDB cradle mlibdir opt mvar = E.handle handler $ do
 
 ----------------------------------------------------------------
 
-loop :: Options -> Set FilePath -> MVar SymMdlDb -> Ghc ()
+loop :: Options -> Set FilePath -> MVar SymMdlDb -> GhcMod ()
 loop opt set mvar = do
     cmdArg <- liftIO getLine
     let (cmd,arg') = break (== ' ') cmdArg
         arg = dropWhile (== ' ') arg'
     (ret,ok,set') <- case cmd of
         "check"  -> checkStx opt set arg
-        "find"   -> findSym  opt set arg mvar
-        "lint"   -> lintStx  opt set arg
-        "info"   -> showInfo opt set arg
-        "type"   -> showType opt set arg
-        "boot"   -> bootIt   opt set
-        "browse" -> browseIt opt set arg
+        "find"   -> findSym set arg mvar
+        "lint"   -> toGhcMod $ lintStx  opt set arg
+        "info"   -> toGhcMod $ showInfo opt set arg
+        "type"   -> toGhcMod $ showType opt set arg
+        "boot"   -> bootIt set
+        "browse" -> browseIt set arg
         "quit"   -> return ("quit", False, set)
         ""       -> return ("quit", False, set)
         _        -> return ([], True, set)
@@ -162,11 +162,11 @@ loop opt set mvar = do
 checkStx :: Options
          -> Set FilePath
          -> FilePath
-         -> Ghc (String, Bool, Set FilePath)
-checkStx opt set file = do
-    set' <- newFileSet set file
+         -> GhcMod (String, Bool, Set FilePath)
+checkStx _ set file = do
+    set' <- toGhcMod $ newFileSet set file
     let files = S.toList set'
-    eret <- check opt files
+    eret <- check files
     case eret of
         Right ret -> return (ret, True, set')
         Left ret  -> return (ret, True, set) -- fxime: set
@@ -199,11 +199,12 @@ isSameMainFile file (Just x)
 
 ----------------------------------------------------------------
 
-findSym :: Options -> Set FilePath -> String -> MVar SymMdlDb
-        -> Ghc (String, Bool, Set FilePath)
-findSym opt set sym mvar = do
+findSym :: Set FilePath -> String -> MVar SymMdlDb
+        -> GhcMod (String, Bool, Set FilePath)
+findSym set sym mvar = do
     db <- liftIO $ readMVar mvar
-    let ret = lookupSym opt sym db
+    opt <- options
+    let ret = lookupSym' opt sym db
     return (ret, True, set)
 
 lintStx :: Options -> Set FilePath -> FilePath
@@ -255,17 +256,15 @@ showType opt set fileArg  = do
 
 ----------------------------------------------------------------
 
-bootIt :: Options
-       -> Set FilePath
-       -> Ghc (String, Bool, Set FilePath)
-bootIt opt set = do
-    ret <- boot opt
+bootIt :: Set FilePath
+       -> GhcMod (String, Bool, Set FilePath)
+bootIt set = do
+    ret <- boot
     return (ret, True, set)
 
-browseIt :: Options
-         -> Set FilePath
+browseIt :: Set FilePath
          -> ModuleString
-         -> Ghc (String, Bool, Set FilePath)
-browseIt opt set mdl = do
-    ret <- browse opt mdl
+         -> GhcMod (String, Bool, Set FilePath)
+browseIt set mdl = do
+    ret <- browse mdl
     return (ret, True, set)

test/BrowseSpec.hs

@@ -5,30 +5,30 @@ import Language.Haskell.GhcMod
 import Language.Haskell.GhcMod.Cradle
 import Test.Hspec
 
+import TestUtils
 import Dir
 
 spec :: Spec
 spec = do
-    describe "browseModule" $ do
+    describe "browse" $ do
         it "lists up symbols in the module" $ do
-            cradle <- findCradle
-            syms <- lines <$> browseModule defaultOptions cradle "Data.Map"
+            syms <- runD $ lines <$> browse "Data.Map"
             syms `shouldContain` ["differenceWithKey"]
 
-    describe "browseModule -d" $ do
+    describe "browse -d" $ do
         it "lists up symbols with type info in the module" $ do
-            cradle <- findCradle
-            syms <- lines <$> browseModule defaultOptions { detailed = True } cradle "Data.Either"
+            syms <- run defaultOptions { detailed = True }
+                    $ lines <$> browse "Data.Either"
             syms `shouldContain` ["either :: (a -> c) -> (b -> c) -> Either a b -> c"]
 
         it "lists up data constructors with type info in the module" $ do
             cradle <- findCradle
-            syms <- lines <$> browseModule defaultOptions { detailed = True} cradle "Data.Either"
+            syms <- run defaultOptions { detailed = True}
+                    $ lines <$> browse "Data.Either"
             syms `shouldContain` ["Left :: a -> Either a b"]
 
-    describe "browseModule local" $ do
+    describe "browse local" $ do
         it "lists symbols in a local module" $ do
             withDirectory_ "test/data" $ do
-                cradle <- findCradleWithoutSandbox
-                syms <- lines <$> browseModule defaultOptions cradle "Baz"
+                syms <- runID $ lines <$> browse "Baz"
                 syms `shouldContain` ["baz"]

test/CheckSpec.hs

@@ -6,6 +6,7 @@ import Language.Haskell.GhcMod.Cradle
 import System.FilePath
 import Test.Hspec
 
+import TestUtils
 import Dir
 
 spec :: Spec
@@ -13,31 +14,26 @@ spec = do
     describe "checkSyntax" $ do
         it "can check even if an executable depends on its library" $ do
             withDirectory_ "test/data/ghc-mod-check" $ do
-                cradle <- findCradleWithoutSandbox
-                res <- checkSyntax defaultOptions cradle ["main.hs"]
+                res <- runID $ checkSyntax ["main.hs"]
                 res `shouldBe` "main.hs:5:1:Warning: Top-level binding with no type signature: main :: IO ()\n"
 
         it "can check even if a test module imports another test module located at different directory" $ do
             withDirectory_ "test/data/check-test-subdir" $ do
-                cradle <- findCradleWithoutSandbox
-                res <- checkSyntax defaultOptions cradle ["test/Bar/Baz.hs"]
+                res <- runID $ checkSyntax ["test/Bar/Baz.hs"]
                 res `shouldSatisfy` (("test" </> "Foo.hs:3:1:Warning: Top-level binding with no type signature: foo :: [Char]\n") `isSuffixOf`)
 
         it "can detect mutually imported modules" $ do
             withDirectory_ "test/data" $ do
-                cradle <- findCradleWithoutSandbox
-                res <- checkSyntax defaultOptions cradle ["Mutual1.hs"]
+                res <- runID $ checkSyntax ["Mutual1.hs"]
                 res `shouldSatisfy` ("Module imports form a cycle" `isInfixOf`)
 
         it "can check a module using QuasiQuotes" $ do
             withDirectory_ "test/data" $ do
-                cradle <- findCradleWithoutSandbox
-                res <- checkSyntax defaultOptions cradle ["Baz.hs"]
+                res <- runID $ checkSyntax ["Baz.hs"]
                 res `shouldSatisfy` ("Baz.hs:5:1:Warning:" `isPrefixOf`)
 
         context "without errors" $ do
             it "doesn't output empty line" $ do
                 withDirectory_ "test/data/ghc-mod-check/Data" $ do
-                    cradle <- findCradleWithoutSandbox
-                    res <- checkSyntax defaultOptions cradle ["Foo.hs"]
+                    res <- runID $ checkSyntax ["Foo.hs"]
                     res `shouldBe` ""

test/TestUtils.hs

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