Merge pull request #317 from DanielG/dev

Workaround for #273 + more release-prep

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 -> do
-  withLogger (setAllWaringFlags . setNoMaxRelevantBindings) $
+  withLogger (setAllWaringFlags . setNoMaxRelevantBindings) $ do
+    _ <- G.setSessionDynFlags =<< addCmdOpts ghcOpts =<< G.getSessionDynFlags
     setTargetFiles fileNames
 
 ----------------------------------------------------------------

Language/Haskell/GhcMod/Debug.hs

@@ -30,10 +30,10 @@ debugInfo = cradle >>= \c -> convert' =<< do
       ]
   where
     simpleCompilerOption = options >>= \op ->
-        return $ CompilerOptions (ghcOpts op) [] []
+        return $ CompilerOptions (ghcUserOptions op) [] []
     fromCabalFile c = options >>= \opts -> do
         pkgDesc <- parseCabalFile $ fromJust $ cradleCabalFile c
-        liftIO $ 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/Find.hs

@@ -61,6 +61,7 @@ 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.

Language/Haskell/GhcMod/Logger.hs

@@ -64,7 +64,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

Language/Haskell/GhcMod/Monad.hs

@@ -30,7 +30,10 @@ module Language.Haskell.GhcMod.Monad (
   , getCompilerMode
   , setCompilerMode
   , withOptions
-  -- ** Exporting convenient modules
+  , withTempSession
+  , overrideGhcUserOptions
+  -- ** Re-exporting convenient stuff
+  , liftIO
   , module Control.Monad.Reader.Class
   , module Control.Monad.Journal.Class
   ) where
@@ -57,7 +60,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
@@ -201,7 +204,7 @@ initializeFlagsWithCradle opt c
   where
     mCradleFile = cradleCabalFile c
     cabal = isJust mCradleFile
-    ghcopts = ghcOpts opt
+    ghcopts = ghcUserOptions opt
     withCabal = do
         pkgDesc <- parseCabalFile $ fromJust mCradleFile
         compOpts <- liftIO $ getCompilerOptions ghcopts c pkgDesc
@@ -282,6 +285,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

Language/Haskell/GhcMod/Types.hs

@@ -28,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.
@@ -44,7 +45,7 @@ defaultOptions :: Options
 defaultOptions = Options {
     outputStyle   = PlainStyle
   , hlintOpts     = []
-  , ghcOpts       = []
+  , ghcUserOptions= []
   , operators     = False
   , detailed      = False
   , qualified     = False

src/GHCMod.hs

@@ -63,7 +63,7 @@ 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 "o" ["operators"]
             (NoArg (\opts -> opts { operators = True }))
@@ -138,7 +138,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

@@ -58,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