Fix merge conflict, dropdown-list no longer needed

Language/Haskell/GhcMod.hs

@@ -18,6 +18,7 @@ module Language.Haskell.GhcMod (
   -- * Monad Types
   , GhcModT
   , IOish
+  , GhcModError(..)
   -- * Monad utilities
   , runGhcModT
   , withOptions

Language/Haskell/GhcMod/CabalApi.hs

@@ -11,14 +11,16 @@ module Language.Haskell.GhcMod.CabalApi (
   ) where
 
 import Language.Haskell.GhcMod.CabalConfig
-import Language.Haskell.GhcMod.Gap (benchmarkBuildInfo, benchmarkTargets, toModuleString)
+import Language.Haskell.GhcMod.Gap (benchmarkBuildInfo, benchmarkTargets,
+                                    toModuleString)
 import Language.Haskell.GhcMod.GhcPkg
 import Language.Haskell.GhcMod.Types
 
+import MonadUtils (MonadIO, liftIO)
 import Control.Applicative ((<$>))
 import qualified Control.Exception as E
 import Control.Monad (filterM)
-import CoreMonad (liftIO)
+import Control.Monad.Error.Class (Error, MonadError(..))
 import Data.Maybe (maybeToList)
 import Data.Set (fromList, toList)
 import Distribution.Package (Dependency(Dependency)
@@ -69,19 +71,21 @@ includeDirectories cdir wdir dirs = uniqueAndSort (extdirs ++ [cdir,wdir])
 
 ----------------------------------------------------------------
 
--- | Parsing a cabal file and returns 'PackageDescription'.
+-- | Parse a cabal file and return a 'PackageDescription'.
---   'IOException' is thrown if parsing fails.
+parseCabalFile :: (MonadIO m, Error e,  MonadError e m)
-parseCabalFile :: FilePath -> IO PackageDescription
+               => FilePath
+               -> m PackageDescription
 parseCabalFile file = do
-    cid <- getGHCId
+    cid <- liftIO getGHCId
-    epgd <- readPackageDescription silent file
+    epgd <- liftIO $ readPackageDescription silent file
     case toPkgDesc cid epgd of
-        Left deps    -> E.throwIO $ userError $ show deps ++ " are not installed"
+        Left deps    -> fail $ show deps ++ " are not installed"
         Right (pd,_) -> if nullPkg pd
-                        then E.throwIO $ userError $ file ++ " is broken"
+                        then fail $ file ++ " is broken"
                         else return pd
   where
-    toPkgDesc cid = finalizePackageDescription [] (const True) buildPlatform cid []
+    toPkgDesc cid =
+        finalizePackageDescription [] (const True) buildPlatform cid []
     nullPkg pd = name == ""
       where
         PackageName name = C.pkgName (P.package pd)

Language/Haskell/GhcMod/CaseSplit.hs

@@ -4,7 +4,6 @@ module Language.Haskell.GhcMod.CaseSplit (
     splits
   ) where
 
-import CoreMonad (liftIO)
 import Data.List (find, intercalate)
 import Data.Maybe (isJust)
 import qualified Data.Text as T

Language/Haskell/GhcMod/Check.hs

@@ -8,8 +8,10 @@ module Language.Haskell.GhcMod.Check (
 import Control.Applicative ((<$>))
 import Language.Haskell.GhcMod.DynFlags
 import qualified Language.Haskell.GhcMod.Gap as Gap
+import qualified GHC as G
 import Language.Haskell.GhcMod.Logger
-import Language.Haskell.GhcMod.Monad (IOish, GhcModT, withErrorHandler)
+import Language.Haskell.GhcMod.Monad (IOish, GhcModT, withErrorHandler
+                                     , overrideGhcUserOptions)
 import Language.Haskell.GhcMod.Target (setTargetFiles)
 
 ----------------------------------------------------------------
@@ -34,8 +36,9 @@ checkSyntax files = withErrorHandler sessionName $
 check :: IOish m
       => [FilePath]  -- ^ The target files.
       -> GhcModT m (Either String String)
-check fileNames =
+check fileNames = overrideGhcUserOptions $ \ghcOpts ->
-  withLogger (setAllWaringFlags . setNoMaxRelevantBindings) $
+  withLogger (setAllWaringFlags . setNoMaxRelevantBindings . Gap.setWarnTypedHoles . Gap.setDeferTypeErrors) $ do
+    _ <- G.setSessionDynFlags =<< addCmdOpts ghcOpts =<< G.getSessionDynFlags
     setTargetFiles fileNames
 
 ----------------------------------------------------------------

Language/Haskell/GhcMod/Debug.hs

@@ -1,7 +1,6 @@
 module Language.Haskell.GhcMod.Debug (debugInfo, rootInfo) where
 
 import Control.Applicative ((<$>))
-import CoreMonad (liftIO)
 import Data.List (intercalate)
 import Data.Maybe (isJust, fromJust)
 import Language.Haskell.GhcMod.Convert
@@ -30,10 +29,10 @@ debugInfo = cradle >>= \c -> convert' =<< do
       ]
   where
     simpleCompilerOption = options >>= \op ->
-        return $ CompilerOptions (ghcOpts op) [] []
+        return $ CompilerOptions (ghcUserOptions op) [] []
-    fromCabalFile c = options >>= \opts -> liftIO $ do
+    fromCabalFile c = options >>= \opts -> do
         pkgDesc <- parseCabalFile $ fromJust $ cradleCabalFile c
-        getCompilerOptions (ghcOpts opts) c pkgDesc
+        liftIO $ getCompilerOptions (ghcUserOptions opts) c pkgDesc
 
 ----------------------------------------------------------------
 

Language/Haskell/GhcMod/DynFlags.hs

@@ -88,8 +88,8 @@ withCmdFlags :: GhcMonad m => [GHCOption] -> m a -> m a
 withCmdFlags flags body = G.gbracket setup teardown (\_ -> body)
   where
     setup = do
-        dflags <- G.getSessionDynFlags >>= addCmdOpts flags
+        dflags <- G.getSessionDynFlags
-        void $ G.setSessionDynFlags dflags
+        void $ G.setSessionDynFlags =<< addCmdOpts flags dflags
         return dflags
     teardown = void . G.setSessionDynFlags
 

Language/Haskell/GhcMod/FillSig.hs

@@ -20,7 +20,6 @@ import Language.Haskell.GhcMod.Convert
 import Language.Haskell.GhcMod.Monad
 import Language.Haskell.GhcMod.SrcUtils
 import Language.Haskell.GhcMod.Types
-import CoreMonad (liftIO)
 import Outputable (PprStyle)
 import qualified Type as Ty
 import qualified HsBinds as Ty
@@ -119,11 +118,11 @@ getSignature modSum lineNo colNo = do
                         G.DataFamily -> Data
 #endif
 #if __GLASGOW_HASKELL__ >= 706
-            getTyFamVarName = \x -> case x of
+            getTyFamVarName x = case x of
                 L _ (G.UserTyVar n)     -> n
                 L _ (G.KindedTyVar n _) -> n
 #else
-            getTyFamVarName = \x -> case x of  -- In GHC 7.4, HsTyVarBndr's have an extra arg
+            getTyFamVarName x = case x of  -- In GHC 7.4, HsTyVarBndr's have an extra arg
                 L _ (G.UserTyVar n _)     -> n
                 L _ (G.KindedTyVar n _ _) -> n
 #endif
@@ -170,7 +169,7 @@ initialBody' fname args = initialHead fname args ++ " = "
 
 initialFamBody :: FnArgsInfo ty name => DynFlags -> PprStyle -> name -> [name] -> String
 initialFamBody dflag style name args = initialHead (getFnName dflag style name)
-                                         (map (\arg -> FnExplicitName (getFnName dflag style arg)) args)
+                                         (map (FnExplicitName . getFnName dflag style) args)
                                          ++ " = ()"
 
 initialHead :: String -> [FnArg] -> String
@@ -299,7 +298,7 @@ findVar dflag style tcm tcs lineNo colNo =
               then let Just (s,t) = tyInfo
                        b = case others of  -- If inside an App, we need parenthesis
                              [] -> False
-                             (L _ (G.HsApp (L _ a1) (L _ a2))):_ ->
+                             L _ (G.HsApp (L _ a1) (L _ a2)):_ ->
                                isSearchedVar i a1 || isSearchedVar i a2
                              _  -> False
                     in return $ Just (s, name, t, b)
@@ -340,9 +339,9 @@ auto file lineNo colNo = ghandle handler body
           topLevel <- getEverythingInTopLevel minfo
           let (f,pats) = getPatsForVariable tcs (lineNo,colNo)
               -- Remove self function to prevent recursion, and id to trim cases
-              filterFn = (\(n,_) -> let funName = G.getOccString n
+              filterFn (n,_) = let funName = G.getOccString n
                                    recName = G.getOccString (G.getName f)
-                                     in not $ funName `elem` recName:notWantedFuns)
+                               in funName `notElem` recName:notWantedFuns
               -- Find without using other functions in top-level
               localBnds = M.unions $ map (\(L _ pat) -> getBindingsForPat pat) pats
               lbn = filter filterFn (M.toList localBnds)

Language/Haskell/GhcMod/Find.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, BangPatterns #-}
+{-# LANGUAGE CPP #-}
 
 module Language.Haskell.GhcMod.Find
 #ifndef SPEC
@@ -19,7 +19,6 @@ import Control.Applicative ((<$>))
 import Control.Exception (handle, SomeException(..))
 import Control.Monad (when, void)
 import Control.Monad.Error.Class
-import CoreMonad (liftIO)
 import Data.Function (on)
 import Data.List (groupBy, sort)
 import Data.List.Split (splitOn)
@@ -59,8 +58,14 @@ newtype SymbolDb = SymbolDb (Map Symbol [ModuleString])
 
 ----------------------------------------------------------------
 
+-- | When introducing incompatible changes to the 'symbolCache' file format
+-- increment this version number.
+symbolCacheVersion :: Integer
+symbolCacheVersion = 0
+
+-- | Filename of the symbol table cache file.
 symbolCache :: String
-symbolCache = "ghc-mod.cache"
+symbolCache = "ghc-mod-"++ show symbolCacheVersion ++".cache"
 
 packageCache :: String
 packageCache = "package.cache"
@@ -89,6 +94,8 @@ lookupSym sym (SymbolDb db) = fromMaybe [] $ M.lookup sym db
 loadSymbolDb :: IO SymbolDb
 loadSymbolDb = SymbolDb <$> readSymbolDb
 
+-- | Returns the path to the currently running ghc-mod executable. With ghc<7.6
+-- this is a guess but >=7.6 uses 'getExecutablePath'.
 ghcModExecutable :: IO FilePath
 #ifndef SPEC
 ghcModExecutable = do
@@ -130,7 +137,6 @@ getSymbolCachePath = do
 --   if the file does not exist or is invalid.
 --   The file name is printed.
 
--- TODO: Before releaseing add a version number to the name of the cache file
 dumpSymbol :: IOish m => GhcModT m String
 dumpSymbol = do
     dir <- getSymbolCachePath
@@ -144,7 +150,7 @@ dumpSymbol = do
 writeSymbolCache :: FilePath
                  -> [(Symbol,[ModuleString])]
                  -> IO ()
-writeSymbolCache cache sm = do
+writeSymbolCache cache sm =
   void . withFile cache WriteMode $ \hdl ->
       mapM (hPrint hdl) sm
 

Language/Haskell/GhcMod/GHCChoice.hs

@@ -21,10 +21,3 @@ goNext = liftIO . GE.throwIO $ userError "goNext"
 -- | Run any one 'Ghc' monad.
 runAnyOne :: GhcMonad m => [m a] -> m a
 runAnyOne = foldr (||>) goNext
-
-----------------------------------------------------------------
-
--- | Try the left 'GhcMonad' action. If 'IOException' occurs, try
---   the right 'GhcMonad' action.
-(|||>) :: GhcMonad m => m a -> m a -> m a
-x |||> y = x `GE.gcatch` (\(_ :: IOException) -> y)

Language/Haskell/GhcMod/Internal.hs

@@ -44,12 +44,10 @@ module Language.Haskell.GhcMod.Internal (
   , getCompilerMode
   , setCompilerMode
   , withOptions
-  -- * 'Ghc' Choice
+  -- * 'GhcMonad' Choice
   , (||>)
   , goNext
   , runAnyOne
-  -- * 'GhcMonad' Choice
-  , (|||>)
   ) where
 
 import GHC.Paths (libdir)

Language/Haskell/GhcMod/Lint.hs

@@ -2,7 +2,6 @@ module Language.Haskell.GhcMod.Lint where
 
 import Exception (ghandle)
 import Control.Exception (SomeException(..))
-import CoreMonad (liftIO)
 import Language.Haskell.GhcMod.Logger (checkErrorPrefix)
 import Language.Haskell.GhcMod.Convert
 import Language.Haskell.GhcMod.Monad

Language/Haskell/GhcMod/Logger.hs

@@ -7,7 +7,6 @@ module Language.Haskell.GhcMod.Logger (
 
 import Bag (Bag, bagToList)
 import Control.Applicative ((<$>))
-import CoreMonad (liftIO)
 import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef)
 import Data.List (isPrefixOf)
 import Data.Maybe (fromMaybe)
@@ -64,7 +63,7 @@ withLogger :: IOish m
            -> GhcModT m (Either String String)
 withLogger setDF body = ghandle sourceError $ do
     logref <- liftIO newLogRef
-    wflags <- filter ("-fno-warn" `isPrefixOf`) . ghcOpts <$> options
+    wflags <- filter ("-fno-warn" `isPrefixOf`) . ghcUserOptions <$> options
     withDynFlags (setLogger logref . setDF) $
         withCmdFlags wflags $ do
             body
@@ -106,7 +105,15 @@ ppMsg spn sev dflag style msg = prefix ++ cts
         (line,col,_,_) <- Gap.getSrcSpan spn
         file <- normalise <$> Gap.getSrcFile spn
         let severityCaption = Gap.showSeverityCaption sev
-        return $ file ++ ":" ++ show line ++ ":" ++ show col ++ ":" ++ severityCaption
+            pref0
+              | typeWarning1 `isPrefixOf` cts ||
+                typeWarning2 `isPrefixOf` cts = file ++ ":" ++ show line ++ ":" ++ show col ++ ":"
+              | otherwise                     = file ++ ":" ++ show line ++ ":" ++ show col ++ ":" ++ severityCaption
+        return pref0
+    -- DeferTypeErrors turns a type error to a warning.
+    -- So, let's turns it the error again.
+    typeWarning1 = "Couldn't match expected type"
+    typeWarning2 = "Couldn't match type"
 
 checkErrorPrefix :: String
 checkErrorPrefix = "Dummy:0:0:Error:"

Language/Haskell/GhcMod/Monad.hs

@@ -1,7 +1,6 @@
 {-# LANGUAGE CPP, GeneralizedNewtypeDeriving, FlexibleInstances #-}
 {-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, RankNTypes #-}
 {-# LANGUAGE TypeFamilies, UndecidableInstances, RecordWildCards #-}
-{-# LANGUAGE StandaloneDeriving #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Language.Haskell.GhcMod.Monad (
@@ -23,15 +22,18 @@ module Language.Haskell.GhcMod.Monad (
   -- ** Conversion
   , toGhcModT
   -- ** Accessing 'GhcModEnv' and 'GhcModState'
+  , gmsGet
+  , gmsPut
   , options
   , cradle
   , getCompilerMode
   , setCompilerMode
   , withOptions
-  -- ** Exporting convenient modules
+  , withTempSession
+  , overrideGhcUserOptions
+  -- ** Re-exporting convenient stuff
+  , liftIO
   , module Control.Monad.Reader.Class
-  , module Control.Monad.Writer.Class
-  , module Control.Monad.State.Class
   , module Control.Monad.Journal.Class
   ) where
 
@@ -57,7 +59,7 @@ import Exception
 import GHC
 import qualified GHC as G
 import GHC.Paths (libdir)
-import GhcMonad
+import GhcMonad hiding (withTempSession)
 #if __GLASGOW_HASKELL__ <= 702
 import HscTypes
 #endif
@@ -85,15 +87,16 @@ import Control.Monad.Trans.Control (MonadBaseControl(..), StM, liftBaseWith,
 
 import Control.Monad.Trans.Class
 import Control.Monad.Reader.Class
-import Control.Monad.Writer.Class
+import Control.Monad.Writer.Class (MonadWriter)
-import Control.Monad.State.Class
+import Control.Monad.State.Class (MonadState(..))
 
-import Control.Monad.Error (Error(..), MonadError, ErrorT, runErrorT)
+import Control.Monad.Error (MonadError, ErrorT, runErrorT)
 import Control.Monad.Reader (ReaderT, runReaderT)
 import Control.Monad.State.Strict (StateT, runStateT)
 import Control.Monad.Trans.Journal (JournalT, runJournalT)
 #ifdef MONADIO_INSTANCES
 import Control.Monad.Trans.Maybe (MaybeT)
+import Control.Monad.Error (Error(..))
 #endif
 import Control.Monad.Journal.Class
 
@@ -122,16 +125,6 @@ data CompilerMode = Simple | Intelligent deriving (Eq,Show,Read)
 defaultState :: GhcModState
 defaultState = GhcModState Simple
 
-data GhcModError = GMENoMsg
-                 | GMEString String
-                 | GMECabal
-                 | GMEGhc
-                   deriving (Eq,Show,Read)
-
-instance Error GhcModError where
-    noMsg = GMENoMsg
-    strMsg = GMEString
-
 ----------------------------------------------------------------
 
 -- | A constraint alias (-XConstraintKinds) to make functions dealing with
@@ -163,15 +156,21 @@ newtype GhcModT m a = GhcModT {
 #if DIFFERENT_MONADIO
                , Control.Monad.IO.Class.MonadIO
 #endif
-               , MonadReader GhcModEnv
+               , MonadReader GhcModEnv -- TODO: make MonadReader instance
+                                       -- pass-through like MonadState
                , MonadWriter w
-               , MonadState GhcModState
                , MonadError GhcModError
                )
 
 instance MonadTrans GhcModT where
     lift = GhcModT . lift . lift . lift . lift
 
+instance MonadState s m => MonadState s (GhcModT m) where
+    get = GhcModT $ lift $ lift $ lift get
+    put = GhcModT . lift . lift . lift . put
+    state = GhcModT . lift . lift . lift . state
+
+
 #if MONADIO_INSTANCES
 instance MonadIO m => MonadIO (StateT s m) where
     liftIO = lift . liftIO
@@ -194,7 +193,7 @@ instance MonadIO m => MonadIO (MaybeT m) where
 -- | Initialize the 'DynFlags' relating to the compilation of a single
 -- file or GHC session according to the 'Cradle' and 'Options'
 -- provided.
-initializeFlagsWithCradle :: GhcMonad m
+initializeFlagsWithCradle :: (GhcMonad m, MonadError GhcModError m)
         => Options
         -> Cradle
         -> m ()
@@ -204,9 +203,9 @@ initializeFlagsWithCradle opt c
   where
     mCradleFile = cradleCabalFile c
     cabal = isJust mCradleFile
-    ghcopts = ghcOpts opt
+    ghcopts = ghcUserOptions opt
     withCabal = do
-        pkgDesc <- liftIO $ parseCabalFile $ fromJust mCradleFile
+        pkgDesc <- parseCabalFile $ fromJust mCradleFile
         compOpts <- liftIO $ getCompilerOptions ghcopts c pkgDesc
         initSession CabalPkg opt compOpts
     withSandbox = initSession SingleFile opt compOpts
@@ -253,7 +252,7 @@ runGhcModT :: IOish m
            -> m (Either GhcModError a, GhcModLog)
 runGhcModT opt action = do
     env <- liftBase $ newGhcModEnv opt =<< getCurrentDirectory
-    first (fmap fst) <$> (runGhcModT' env defaultState $ do
+    first (fst <$>) <$> (runGhcModT' env defaultState $ do
         dflags <- getSessionDynFlags
         defaultCleanupHandler dflags $ do
             initializeFlagsWithCradle opt (gmCradle env)
@@ -271,9 +270,9 @@ runGhcModT' :: IOish m
            -> m (Either GhcModError (a, GhcModState), GhcModLog)
 runGhcModT' r s a = do
   (res, w') <-
-      flip runReaderT r $ runJournalT $ runErrorT $ flip runStateT s
+      flip runReaderT r $ runJournalT $ runErrorT $
-        $ (unGhcModT $ initGhcMonad (Just libdir) >> a)
+        runStateT (unGhcModT $ initGhcMonad (Just libdir) >> a) s
-  return $ (res, w')
+  return (res, w')
 ----------------------------------------------------------------
 
 withErrorHandler :: IOish m => String -> GhcModT m a -> GhcModT m a
@@ -285,6 +284,28 @@ withErrorHandler label = ghandle ignore
         hPrint stderr e
         exitSuccess
 
+-- | Make a copy of the 'gmGhcSession' IORef, run the action and restore the
+-- original 'HscEnv'.
+withTempSession :: IOish m => GhcModT m a -> GhcModT m a
+withTempSession action = do
+  session <- gmGhcSession <$> ask
+  savedHscEnv <- liftIO $ readIORef session
+  a <- action
+  liftIO $ writeIORef session savedHscEnv
+  return a
+
+-- | This is a very ugly workaround don't use it.
+overrideGhcUserOptions :: IOish m => ([GHCOption] -> GhcModT m b) -> GhcModT m b
+overrideGhcUserOptions action = withTempSession $ do
+  env <- ask
+  opt <- options
+  let ghcOpts = ghcUserOptions opt
+      opt' = opt { ghcUserOptions = [] }
+
+  initializeFlagsWithCradle opt' (gmCradle env)
+
+  action ghcOpts
+
 -- | This is only a transitional mechanism don't use it for new code.
 toGhcModT :: IOish m => Ghc a -> GhcModT m a
 toGhcModT a = do
@@ -293,17 +314,23 @@ toGhcModT a = do
 
 ----------------------------------------------------------------
 
+gmsGet :: IOish m => GhcModT m GhcModState
+gmsGet = GhcModT get
+
+gmsPut :: IOish m => GhcModState -> GhcModT m ()
+gmsPut = GhcModT . put
+
 options :: IOish m => GhcModT m Options
 options = gmOptions <$> ask
 
 cradle :: IOish m => GhcModT m Cradle
 cradle = gmCradle <$> ask
 
-getCompilerMode :: (Functor m, MonadState GhcModState m) => m CompilerMode
+getCompilerMode :: IOish m => GhcModT m CompilerMode
-getCompilerMode = gmCompilerMode <$> get
+getCompilerMode = gmCompilerMode <$> gmsGet
 
-setCompilerMode :: MonadState GhcModState m => CompilerMode -> m ()
+setCompilerMode :: IOish m => CompilerMode -> GhcModT m ()
-setCompilerMode mode = (\s -> put s { gmCompilerMode = mode } ) =<< get
+setCompilerMode mode = (\s -> gmsPut s { gmCompilerMode = mode } ) =<< gmsGet
 
 ----------------------------------------------------------------
 

Language/Haskell/GhcMod/PkgDoc.hs

@@ -1,6 +1,5 @@
 module Language.Haskell.GhcMod.PkgDoc (pkgDoc) where
 
-import CoreMonad (liftIO)
 import Language.Haskell.GhcMod.Types
 import Language.Haskell.GhcMod.GhcPkg
 import Language.Haskell.GhcMod.Monad

Language/Haskell/GhcMod/Target.hs

@@ -15,7 +15,7 @@ setTargetFiles :: IOish m => [FilePath] -> GhcModT m ()
 setTargetFiles files = do
     targets <- forM files $ \file -> G.guessTarget file Nothing
     G.setTargets targets
-    mode <- gmCompilerMode <$> get
+    mode <- getCompilerMode
     if mode == Intelligent then
         loadTargets Intelligent
       else do

Language/Haskell/GhcMod/Types.hs

@@ -2,9 +2,22 @@ module Language.Haskell.GhcMod.Types where
 
 import Data.List (intercalate)
 import qualified Data.Map as M
+import Control.Monad.Error (Error(..))
 
 import PackageConfig (PackageConfig)
 
+-- |
+data GhcModError = GMENoMsg
+                 -- ^ Unknown error
+                 | GMEString String
+                 -- ^ Some Error with a message. These are produced mostly by
+                 -- 'fail' calls on GhcModT.
+                   deriving (Eq,Show,Read)
+
+instance Error GhcModError where
+    noMsg = GMENoMsg
+    strMsg = GMEString
+
 -- | Output style.
 data OutputStyle = LispStyle  -- ^ S expression style.
                  | PlainStyle -- ^ Plain textstyle.
@@ -15,7 +28,8 @@ newtype LineSeparator = LineSeparator String
 data Options = Options {
     outputStyle   :: OutputStyle
   , hlintOpts     :: [String]
-  , ghcOpts       :: [GHCOption]
+    -- | GHC command line options set on the @ghc-mod@ command line
+  , ghcUserOptions:: [GHCOption]
   -- | If 'True', 'browse' also returns operators.
   , operators     :: Bool
   -- | If 'True', 'browse' also returns types.
@@ -31,7 +45,7 @@ defaultOptions :: Options
 defaultOptions = Options {
     outputStyle   = PlainStyle
   , hlintOpts     = []
-  , ghcOpts       = []
+  , ghcUserOptions= []
   , operators     = False
   , detailed      = False
   , qualified     = False

ghc-mod.cabal

@@ -133,6 +133,7 @@ Executable ghc-modi
   Default-Language:     Haskell2010
   Main-Is:              GHCModi.hs
   Other-Modules:        Paths_ghc_mod
+                        Utils
   GHC-Options:          -Wall -threaded
   Default-Extensions:   ConstraintKinds, FlexibleContexts
   HS-Source-Dirs:       src

src/GHCMod.hs

@@ -63,8 +63,11 @@ argspec = [ Option "l" ["tolisp"]
             (ReqArg (\h opts -> opts { hlintOpts = h : hlintOpts opts }) "hlintOpt")
             "hlint options"
           , Option "g" ["ghcOpt"]
-            (ReqArg (\g opts -> opts { ghcOpts = g : ghcOpts opts }) "ghcOpt")
+            (ReqArg (\g opts -> opts { ghcUserOptions = g : ghcUserOptions opts }) "ghcOpt")
             "GHC options"
+          , Option "v" ["verbose"]
+            (NoArg (\opts -> opts { ghcUserOptions = "-v" : ghcUserOptions opts }))
+            "verbose"
           , Option "o" ["operators"]
             (NoArg (\opts -> opts { operators = True }))
             "print operators, too"
@@ -138,7 +141,8 @@ main = flip E.catches handlers $ do
       cmd       -> E.throw (NoSuchCommand cmd)
     case res of
       Right s -> putStr s
-      Left e -> error $ show e
+      Left (GMENoMsg) -> hPutStrLn stderr "Unknown error"
+      Left (GMEString msg) -> hPutStrLn stderr msg
   where
     handlers = [Handler (handleThenExit handler1), Handler (handleThenExit handler2)]
     handleThenExit handler e = handler e >> exitFailure

src/GHCModi.hs

@@ -39,6 +39,8 @@ import System.Directory (setCurrentDirectory)
 import System.Environment (getArgs)
 import System.IO (hFlush,stdout)
 
+import Utils
+
 ----------------------------------------------------------------
 
 type Logger = IO String
@@ -56,7 +58,7 @@ argspec = [ Option "b" ["boundary"]
             (NoArg (\opts -> opts { outputStyle = LispStyle }))
             "print as a list of Lisp"
           , Option "g" []
-            (ReqArg (\s opts -> opts { ghcOpts = s : ghcOpts opts }) "flag") "specify a ghc flag"
+            (ReqArg (\s opts -> opts { ghcUserOptions = s : ghcUserOptions opts }) "flag") "specify a ghc flag"
           ]
 
 usage :: String
@@ -231,7 +233,7 @@ showInfo :: IOish m
          -> FilePath
          -> GhcModT m (String, Bool, Set FilePath)
 showInfo set fileArg = do
-    let [file, expr] = words fileArg
+    let [file, expr] = splitN 2 fileArg
     set' <- newFileSet set file
     ret <- info file expr
     return (ret, True, set')
@@ -241,7 +243,7 @@ showType :: IOish m
          -> FilePath
          -> GhcModT m (String, Bool, Set FilePath)
 showType set fileArg  = do
-    let [file, line, column] = words fileArg
+    let [file, line, column] = splitN 3 fileArg
     set' <- newFileSet set file
     ret <- types file (read line) (read column)
     return (ret, True, set')
@@ -251,7 +253,7 @@ doSplit :: IOish m
         -> FilePath
         -> GhcModT m (String, Bool, Set FilePath)
 doSplit set fileArg  = do
-    let [file, line, column] = words fileArg
+    let [file, line, column] = splitN 3 fileArg
     set' <- newFileSet set file
     ret <- splits file (read line) (read column)
     return (ret, True, set')
@@ -261,7 +263,7 @@ doSig :: IOish m
       -> FilePath
       -> GhcModT m (String, Bool, Set FilePath)
 doSig set fileArg  = do
-    let [file, line, column] = words fileArg
+    let [file, line, column] = splitN 3 fileArg
     set' <- newFileSet set file
     ret <- sig file (read line) (read column)
     return (ret, True, set')
@@ -271,7 +273,7 @@ doRefine :: IOish m
          -> FilePath
          -> GhcModT m (String, Bool, Set FilePath)
 doRefine set fileArg  = do
-    let [file, line, column, expr] = words fileArg
+    let [file, line, column, expr] = splitN 4 fileArg
     set' <- newFileSet set file
     ret <- refine file (read line) (read column) expr
     return (ret, True, set')
@@ -281,7 +283,7 @@ doAuto :: IOish m
        -> FilePath
        -> GhcModT m (String, Bool, Set FilePath)
 doAuto set fileArg  = do
-    let [file, line, column] = words fileArg
+    let [file, line, column] = splitN 3 fileArg
     set' <- newFileSet set file
     ret <- auto file (read line) (read column)
     return (ret, True, set')

src/Utils.hs

@@ -0,0 +1,27 @@
+module Utils where
+
+-- |
+--
+-- >>> split "foo bar baz"
+-- ["foo","bar baz"]
+-- >>> split "foo  bar  baz"
+-- ["foo","bar  baz"]
+split :: String -> [String]
+split xs = [ys, dropWhile isSpace zs]
+  where
+    isSpace = (== ' ')
+    (ys,zs) = break isSpace xs
+
+-- |
+--
+-- >>> splitN 0 "foo  bar  baz"
+-- ["foo","bar  baz"]
+-- >>> splitN 2 "foo  bar  baz"
+-- ["foo","bar  baz"]
+-- >>> splitN 3 "foo  bar  baz"
+-- ["foo","bar","baz"]
+splitN :: Int -> String -> [String]
+splitN n xs
+  | n <= 2    = split xs
+  | otherwise = let [ys,zs] = split xs
+                in ys : splitN (n - 1) zs

test/CabalApiSpec.hs

@@ -13,6 +13,7 @@ import System.Directory
 import System.FilePath
 
 import Dir
+import TestUtils
 
 import Config (cProjectVersionInt) -- ghc version
 
@@ -23,14 +24,16 @@ spec :: Spec
 spec = do
     describe "parseCabalFile" $ do
         it "throws an exception if the cabal file is broken" $ do
-            parseCabalFile "test/data/broken-cabal/broken.cabal" `shouldThrow` (\(_::IOException) -> True)
+            shouldReturnError $
+              runD' $ parseCabalFile "test/data/broken-cabal/broken.cabal"
+
 
     describe "getCompilerOptions" $ do
         it "gets necessary CompilerOptions" $ do
             cwd <- getCurrentDirectory
             withDirectory "test/data/subdir1/subdir2" $ \dir -> do
                 cradle <- findCradle
-                pkgDesc <- parseCabalFile $ fromJust $ cradleCabalFile cradle
+                pkgDesc <- runD $ parseCabalFile $ fromJust $ cradleCabalFile cradle
                 res <- getCompilerOptions [] cradle pkgDesc
                 let res' = res {
                         ghcOptions  = ghcOptions res
@@ -45,18 +48,18 @@ spec = do
 
     describe "cabalDependPackages" $ do
         it "extracts dependent packages" $ do
-            pkgs <- cabalDependPackages . cabalAllBuildInfo <$> parseCabalFile "test/data/cabalapi.cabal"
+            pkgs <- cabalDependPackages . cabalAllBuildInfo <$> runD (parseCabalFile "test/data/cabalapi.cabal")
             pkgs `shouldBe` ["Cabal","base","template-haskell"]
 
     describe "cabalSourceDirs" $ do
         it "extracts all hs-source-dirs" $ do
-            dirs <- cabalSourceDirs . cabalAllBuildInfo <$> parseCabalFile "test/data/check-test-subdir/check-test-subdir.cabal"
+            dirs <- cabalSourceDirs . cabalAllBuildInfo <$> runD (parseCabalFile "test/data/check-test-subdir/check-test-subdir.cabal")
             dirs `shouldBe` ["src", "test"]
         it "extracts all hs-source-dirs including \".\"" $ do
-            dirs <- cabalSourceDirs . cabalAllBuildInfo <$> parseCabalFile "test/data/cabalapi.cabal"
+            dirs <- cabalSourceDirs . cabalAllBuildInfo <$> runD (parseCabalFile "test/data/cabalapi.cabal")
             dirs `shouldBe` [".", "test"]
 
     describe "cabalAllBuildInfo" $ do
         it "extracts build info" $ do
-            info <- cabalAllBuildInfo <$> parseCabalFile "test/data/cabalapi.cabal"
+            info <- cabalAllBuildInfo <$> runD (parseCabalFile "test/data/cabalapi.cabal")
             show info `shouldBe` "[BuildInfo {buildable = True, buildTools = [], cppOptions = [], ccOptions = [], ldOptions = [], pkgconfigDepends = [], frameworks = [], cSources = [], hsSourceDirs = [\".\"], otherModules = [ModuleName [\"Browse\"],ModuleName [\"CabalApi\"],ModuleName [\"Cabal\"],ModuleName [\"CabalDev\"],ModuleName [\"Check\"],ModuleName [\"ErrMsg\"],ModuleName [\"Flag\"],ModuleName [\"GHCApi\"],ModuleName [\"GHCChoice\"],ModuleName [\"Gap\"],ModuleName [\"Info\"],ModuleName [\"Lang\"],ModuleName [\"Lint\"],ModuleName [\"List\"],ModuleName [\"Paths_ghc_mod\"],ModuleName [\"Types\"]], defaultLanguage = Nothing, otherLanguages = [], defaultExtensions = [], otherExtensions = [], oldExtensions = [], extraLibs = [], extraLibDirs = [], includeDirs = [], includes = [], installIncludes = [], options = [(GHC,[\"-Wall\"])], ghcProfOptions = [], ghcSharedOptions = [], customFieldsBI = [], targetBuildDepends = [Dependency (PackageName \"Cabal\") (UnionVersionRanges (ThisVersion (Version {versionBranch = [1,10], versionTags = []})) (LaterVersion (Version {versionBranch = [1,10], versionTags = []}))),Dependency (PackageName \"base\") (IntersectVersionRanges (UnionVersionRanges (ThisVersion (Version {versionBranch = [4,0], versionTags = []})) (LaterVersion (Version {versionBranch = [4,0], versionTags = []}))) (EarlierVersion (Version {versionBranch = [5], versionTags = []}))),Dependency (PackageName \"template-haskell\") AnyVersion]},BuildInfo {buildable = True, buildTools = [], cppOptions = [], ccOptions = [], ldOptions = [], pkgconfigDepends = [], frameworks = [], cSources = [], hsSourceDirs = [\"test\",\".\"], otherModules = [ModuleName [\"Expectation\"],ModuleName [\"BrowseSpec\"],ModuleName [\"CabalApiSpec\"],ModuleName [\"FlagSpec\"],ModuleName [\"LangSpec\"],ModuleName [\"LintSpec\"],ModuleName [\"ListSpec\"]], defaultLanguage = Nothing, otherLanguages = [], defaultExtensions = [], otherExtensions = [], oldExtensions = [], extraLibs = [], extraLibDirs = [], includeDirs = [], includes = [], installIncludes = [], options = [], ghcProfOptions = [], ghcSharedOptions = [], customFieldsBI = [], targetBuildDepends = [Dependency (PackageName \"Cabal\") (UnionVersionRanges (ThisVersion (Version {versionBranch = [1,10], versionTags = []})) (LaterVersion (Version {versionBranch = [1,10], versionTags = []}))),Dependency (PackageName \"base\") (IntersectVersionRanges (UnionVersionRanges (ThisVersion (Version {versionBranch = [4,0], versionTags = []})) (LaterVersion (Version {versionBranch = [4,0], versionTags = []}))) (EarlierVersion (Version {versionBranch = [5], versionTags = []})))]}]"

test/Main.hs

@@ -11,7 +11,9 @@ import TestUtils
 
 main = do
   let sandboxes = [ "test/data", "test/data/check-packageid"
-                  , "test/data/duplicate-pkgver/" ]
+                  , "test/data/duplicate-pkgver/"
+                  , "test/data/broken-cabal/"
+                  ]
       genSandboxCfg dir = withDirectory dir $ \cwd -> do
          system ("sed 's|@CWD@|" ++ cwd ++ "|g' cabal.sandbox.config.in > cabal.sandbox.config")
       pkgDirs =

test/MonadSpec.hs

@@ -3,6 +3,7 @@ module MonadSpec where
 
 import Test.Hspec
 import Dir
+import TestUtils
 import Control.Applicative
 import Control.Monad.Error.Class
 import Language.Haskell.GhcMod.Types
@@ -23,5 +24,9 @@ spec = do
 
     describe "runGhcModT" $
         it "complains if the cabal file fails to parse while a sandbox is present" $ withDirectory_ "test/data/broken-cabal" $ do
-          (a,_) <- runGhcModT defaultOptions (gmCradle <$> ask)
+          shouldReturnError $ runD' (gmCradle <$> ask)
-          a `shouldSatisfy` (\(Left _) -> True)
+
+    describe "gmsGet/Put" $
+        it "work" $ do
+          (runD $ gmsPut (GhcModState Intelligent) >> gmsGet)
+            `shouldReturn` (GhcModState Intelligent)

test/TestUtils.hs

@@ -1,10 +1,12 @@
 module TestUtils (
     run
   , runD
+  , runD'
   , runI
   , runID
   , runIsolatedGhcMod
   , isolateCradle
+  , shouldReturnError
   , module Language.Haskell.GhcMod.Monad
   , module Language.Haskell.GhcMod.Types
   ) where
@@ -12,6 +14,8 @@ module TestUtils (
 import Language.Haskell.GhcMod.Monad
 import Language.Haskell.GhcMod.Types
 
+import Test.Hspec
+
 isolateCradle :: IOish m => GhcModT m a -> GhcModT m a
 isolateCradle action =
     local modifyEnv  $ action
@@ -42,3 +46,16 @@ run opt a = extract $ runGhcModT opt a
 -- | Run GhcMod with default options
 runD :: GhcModT IO a -> IO a
 runD = extract . runGhcModT defaultOptions
+
+runD' :: GhcModT IO a -> IO (Either GhcModError a, GhcModLog)
+runD' = runGhcModT defaultOptions
+
+shouldReturnError :: Show a
+                  => IO (Either GhcModError a, GhcModLog)
+                  -> Expectation
+shouldReturnError action = do
+  (a,_) <- action
+  a `shouldSatisfy` isLeft
+ where
+   isLeft (Left _) = True
+   isLeft _ = False