Check session validity via equality on DynFlags

Language/Haskell/GhcMod/DynFlags.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP, TemplateHaskell #-}
 
 module Language.Haskell.GhcMod.DynFlags where
 
@@ -10,6 +10,7 @@ import GHC.Paths (libdir)
 import qualified Language.Haskell.GhcMod.Gap as Gap
 import Language.Haskell.GhcMod.Types
 import Language.Haskell.GhcMod.DebugLogger
+import Language.Haskell.GhcMod.DynFlagsTH
 import System.IO.Unsafe (unsafePerformIO)
 import Prelude
 
@@ -102,7 +103,14 @@ setNoMaxRelevantBindings df = df { maxRelevantBinds = Nothing }
 setNoMaxRelevantBindings = id
 #endif
 
-deferErrors :: DynFlags -> Ghc DynFlags
+deferErrors :: Monad m => DynFlags -> m DynFlags
 deferErrors df = return $
   Gap.setWarnTypedHoles $ Gap.setDeferTypedHoles $
   Gap.setDeferTypeErrors $ setNoWarningFlags df
+
+----------------------------------------------------------------
+
+deriveEqDynFlags [d|
+  eqDynFlags :: DynFlags -> DynFlags -> Bool
+  eqDynFlags = undefined
+ |]

Language/Haskell/GhcMod/DynFlagsTH.hs

@@ -0,0 +1,97 @@
+-- ghc-mod: Making Haskell development *more* fun
+-- Copyright (C) 2015  Daniel Gröber <dxld ÄT darkboxed DOT org>
+--
+-- This program is free software: you can redistribute it and/or modify
+-- it under the terms of the GNU Affero General Public License as published by
+-- the Free Software Foundation, either version 3 of the License, or
+-- (at your option) any later version.
+--
+-- This program is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of
+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+-- GNU Affero General Public License for more details.
+--
+-- You should have received a copy of the GNU Affero General Public License
+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+{-# LANGUAGE TemplateHaskell #-}
+module Language.Haskell.GhcMod.DynFlagsTH where
+
+import Language.Haskell.TH.Syntax
+import Data.Maybe
+import Data.Generics.Aliases
+import Data.Generics.Schemes
+import Packages
+import Hooks
+import DynFlags
+
+deriveEqDynFlags :: Q [Dec] -> Q [Dec]
+deriveEqDynFlags qds = do
+  ~(TyConI (DataD [] _ [] [ctor] _ )) <- reify ''DynFlags
+  let ~(RecC _ fs) = ctor
+
+  a <- newName "a"
+  b <- newName "b"
+
+  e <- AppE (VarE 'and) . ListE <$> sequence (catMaybes $ map (eq a b) fs)
+
+  tysig@(SigD n _) :_ <- qds
+
+  return $ [tysig, FunD n [Clause [VarP a, VarP b] (NormalB e) []]]
+
+ where
+   eq :: Name -> Name -> (Name, Strict, Type) -> Maybe (Q Exp)
+   eq a b (fn@(Name (OccName fon) _), _, ft)
+       | not isUneqable = Just expr
+       | otherwise = Nothing
+    where
+       isUneqable = everything (||) (mkQ False hasUnEqable) ft
+
+       hasUnEqable ArrowT = True
+       hasUnEqable (ConT n@(Name (OccName on) _))
+           | n == ''LogAction = True
+           | any (==n) ignoredTypeNames = True
+           | any (==on) ignoredTypeOccNames = True
+       hasUnEqable _ = False
+
+       ignoredTypeNames =
+           [ ''PackageState
+           , ''Hooks
+           , ''FlushOut
+           , ''FlushErr
+           , ''Settings -- I think these can't cange at runtime
+           ]
+       ignoredTypeOccNames = [ "OnOff" ]
+
+       fa = AppE (VarE fn) (VarE a)
+       fb = AppE (VarE fn) (VarE b)
+       expr =
+         case fon of
+           "language" -> do
+               eqfn <- [| let eqfn (Just Haskell98) (Just Haskell98) = True
+                              eqfn (Just Haskell2010) (Just Haskell2010) = True
+                              eqfn _ _ = False
+                          in eqfn
+                       |]
+               return $ AppE (AppE eqfn fa) fb
+           "rtsOptsEnabled" -> do
+               eqfn <- [| let eqfn RtsOptsNone RtsOptsNone = True
+                              eqfn RtsOptsSafeOnly RtsOptsSafeOnly = True
+                              eqfn RtsOptsAll RtsOptsAll = True
+                              eqfn _ _ = False
+                          in eqfn
+                       |]
+               return $ AppE (AppE eqfn fa) fb
+
+           "sigOf" -> do
+               eqfn <- [| let eqfn NotSigOf NotSigOf = True
+                              eqfn (SigOf a') (SigOf b') = a' == b'
+                              eqfn (SigOfMap a') (SigOfMap b') = a' == b'
+                              eqfn _ _ = False
+                          in eqfn
+                       |]
+               return $ AppE (AppE eqfn fa) fb
+
+
+           _ ->
+               return $ InfixE (Just fa) (VarE '(==)) (Just fb)

Language/Haskell/GhcMod/LightGhc.hs

@@ -42,3 +42,7 @@ runLightGhc :: HscEnv -> LightGhc a -> IO a
 runLightGhc env action = do
   renv <- newIORef env
   flip runReaderT renv $ unLightGhc action
+
+runLightGhc' :: IORef HscEnv -> LightGhc a -> IO a
+runLightGhc' renv action = do
+  flip runReaderT renv $ unLightGhc action

Language/Haskell/GhcMod/Logger.hs

@@ -169,6 +169,6 @@ checkErrorPrefix :: String
 checkErrorPrefix = "Dummy:0:0:Error:"
 
 warningAsErrorPrefixes :: [String]
-warningAsErrorPrefixes = ["Couldn't match expected type"
+warningAsErrorPrefixes = [ "Couldn't match expected type"
                          , "Couldn't match type"
                          , "No instance for"]

Language/Haskell/GhcMod/Target.hs

@@ -66,29 +66,41 @@ runGmPkgGhc action = do
     withLightHscEnv pkgOpts $ \env -> liftIO $ runLightGhc env action
 
 initSession :: IOish m
-            => [GHCOption] -> (DynFlags -> Ghc DynFlags) -> GhcModT m ()
+            => [GHCOption] -> (forall gm. GhcMonad gm => DynFlags -> gm DynFlags) -> GhcModT m ()
 initSession opts mdf = do
    s <- gmsGet
    case gmGhcSession s of
-     Just GmGhcSession {..} | gmgsOptions /= opts-> do
-         gmLog GmDebug "initSession" $ text "Flags changed, creating new session"
-         putNewSession s
-     Just _ -> return ()
      Nothing -> do
          gmLog GmDebug "initSession" $ text "Session not initialized, creating new one"
          putNewSession s
+     Just GmGhcSession {..} -> do
+         gmLog GmDebug "initSession" $ text "Flags changed, creating new session"
+         crdl <- cradle
+         changed <- liftIO $ runLightGhc' gmgsSession $ do
+           df <- getSessionDynFlags
+           ndf <- initDF crdl
+           return $ ndf `eqDynFlags` df
 
+         if changed
+            then putNewSession s
+            else return ()
  where
-   putNewSession s = do
+   initDF Cradle { cradleTempDir } = do
-     rghc <- (liftIO . newIORef =<< newSession =<< cradle)
-     gmsPut s { gmGhcSession = Just $ GmGhcSession opts rghc }
-
-   newSession Cradle { cradleTempDir } = liftIO $ do
-     runGhc (Just libdir) $ do
        let setDf df = setTmpDir cradleTempDir <$> (mdf =<< addCmdOpts opts df)
        _ <- setSessionDynFlags =<< setDf =<< getSessionDynFlags
+       getSessionDynFlags
+
+   putNewSession s = do
+     rghc <- (liftIO . newIORef =<< newSession)
+     gmsPut s { gmGhcSession = Just $ GmGhcSession opts rghc }
+
+   newSession = do
+     crdl <- cradle
+     liftIO $ runGhc (Just libdir) $ do
+       _ <- initDF crdl
        getSession
 
+
 -- | Drop the currently active GHC session, the next that requires a GHC session
 -- will initialize a new one.
 dropSession :: IOish m => GhcModT m ()
@@ -114,7 +126,7 @@ runGmlT fns action = runGmlT' fns return action
 -- of certain files or modules, with updated GHC flags
 runGmlT' :: IOish m
               => [Either FilePath ModuleName]
-              -> (DynFlags -> Ghc DynFlags)
+              -> (forall gm. GhcMonad gm => DynFlags -> gm DynFlags)
               -> GmlT m a
               -> GhcModT m a
 runGmlT' fns mdf action = runGmlTWith fns mdf id action
@@ -124,7 +136,7 @@ runGmlT' fns mdf action = runGmlTWith fns mdf id action
 -- transformation
 runGmlTWith :: IOish m
                  => [Either FilePath ModuleName]
-                 -> (DynFlags -> Ghc DynFlags)
+                 -> (forall gm. GhcMonad gm => DynFlags -> gm DynFlags)
                  -> (GmlT m a -> GmlT m b)
                  -> GmlT m a
                  -> GhcModT m b

ghc-mod.cabal

@@ -187,6 +187,8 @@ Library
                       , extra             == 1.4.*
                       , pipes             == 4.1.*
                       , safe              < 0.4 && >= 0.3.9
+                      , template-haskell
+                      , syb
   if impl(ghc < 7.8)
     Build-Depends:      convertible
   if impl(ghc < 7.5)