diff --git a/Language/Haskell/GhcMod/DynFlags.hs b/Language/Haskell/GhcMod/DynFlags.hs index 4d54ae2..09975db 100644 --- a/Language/Haskell/GhcMod/DynFlags.hs +++ b/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 + |] diff --git a/Language/Haskell/GhcMod/DynFlagsTH.hs b/Language/Haskell/GhcMod/DynFlagsTH.hs new file mode 100644 index 0000000..13ac237 --- /dev/null +++ b/Language/Haskell/GhcMod/DynFlagsTH.hs @@ -0,0 +1,97 @@ +-- ghc-mod: Making Haskell development *more* fun +-- Copyright (C) 2015 Daniel Gröber +-- +-- 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 . + +{-# 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) diff --git a/Language/Haskell/GhcMod/LightGhc.hs b/Language/Haskell/GhcMod/LightGhc.hs index 18aac05..6c53716 100644 --- a/Language/Haskell/GhcMod/LightGhc.hs +++ b/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 diff --git a/Language/Haskell/GhcMod/Logger.hs b/Language/Haskell/GhcMod/Logger.hs index 10ebd5b..36d1995 100644 --- a/Language/Haskell/GhcMod/Logger.hs +++ b/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"] diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs index 7985d1a..2e2d1ae 100644 --- a/Language/Haskell/GhcMod/Target.hs +++ b/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 - rghc <- (liftIO . newIORef =<< newSession =<< cradle) - gmsPut s { gmGhcSession = Just $ GmGhcSession opts rghc } - - newSession Cradle { cradleTempDir } = liftIO $ do - runGhc (Just libdir) $ do + initDF Cradle { cradleTempDir } = 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 diff --git a/ghc-mod.cabal b/ghc-mod.cabal index afe8a52..0dc2789 100644 --- a/ghc-mod.cabal +++ 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)