diff --git a/core/GhcMod/DynFlags.hs b/core/GhcMod/DynFlags.hs index 77f213d..4bb1f24 100644 --- a/core/GhcMod/DynFlags.hs +++ b/core/GhcMod/DynFlags.hs @@ -103,6 +103,7 @@ deferErrors df = return $ ---------------------------------------------------------------- deriveEqDynFlags [d| - eqDynFlags :: DynFlags -> DynFlags -> Bool + eqDynFlags :: DynFlags -> DynFlags -> [[(Bool, String)]] + -- eqDynFlags :: DynFlags -> DynFlags -> ([Bool], [String]) eqDynFlags = undefined |] diff --git a/core/GhcMod/DynFlagsTH.hs b/core/GhcMod/DynFlagsTH.hs index 9085707..cac1f3c 100644 --- a/core/GhcMod/DynFlagsTH.hs +++ b/core/GhcMod/DynFlagsTH.hs @@ -14,18 +14,53 @@ -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . +{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE CPP, TemplateHaskell #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} module GhcMod.DynFlagsTH where import Language.Haskell.TH import Language.Haskell.TH.Syntax import Control.Applicative +import Data.Data import Data.Maybe import Data.Generics.Aliases import Data.Generics.Schemes +import BasicTypes import DynFlags import Prelude +deriving instance Data GhcMode +deriving instance Data GhcLink +deriving instance Data HscTarget +deriving instance Data Way +deriving instance Data DynLibLoader +deriving instance Data Option +deriving instance Data IgnorePackageFlag +deriving instance Data PackageFlag +deriving instance Data ModRenaming +deriving instance Data PackageArg +deriving instance Data TrustFlag +deriving instance Data SafeHaskellMode +-- deriving instance Data SseVersion + +-- ------------------------------------- + +-- instance Data SseVersion where +-- toConstr _ = toConstr SseVersionD + +-- data SseVersionData = SseVersionD deriving Data + +-- ------------------------------------- + +instance Data IntWithInf where + toConstr _ = toConstr IntWithInfD + +data IntWithInfData = IntWithInfD deriving Data + +-- ------------------------------------- + deriveEqDynFlags :: Q [Dec] -> Q [Dec] deriveEqDynFlags qds = do #if __GLASGOW_HASKELL__ <= 710 @@ -39,7 +74,11 @@ deriveEqDynFlags qds = do a <- newName "a" b <- newName "b" - e <- AppE (VarE 'and) . ListE <$> sequence (catMaybes $ map (eq a b) fs) + -- let combFunc = [| \(bs,ss) -> (and bs, unwords ss) |] + + -- e <- AppE (VarE 'and) . ListE <$> sequence (mapMaybe (eq a b) fs) + -- e <- AppE (combFunc) . ListE <$> sequence $ combFunc (catMaybes $ map (eq a b) fs) + e <- ListE <$> sequence (mapMaybe (eq a b) fs) tysig@(SigD n _) :_ <- qds @@ -68,6 +107,7 @@ deriveEqDynFlags qds = do #if __GLASGOW_HASKELL__ <= 706 , "ways" -- 'Ways' is not exported :/ #endif + , "sseVersion" ] ignoredTypeNames = [ "LogAction" @@ -84,31 +124,42 @@ deriveEqDynFlags qds = do expr = case fon of "rtsOptsEnabled" -> do - let eqfn = [| let fn RtsOptsNone RtsOptsNone = True - fn RtsOptsSafeOnly RtsOptsSafeOnly = True - fn RtsOptsAll RtsOptsAll = True - fn _ _ = False + let eqfn = [| let fn RtsOptsNone RtsOptsNone = [(True, "")] + fn RtsOptsSafeOnly RtsOptsSafeOnly = [(True, "")] + fn RtsOptsAll RtsOptsAll = [(True, "")] + fn _ _ = [(False, "rtsOptsEnabled changed")] in fn |] [e| $(eqfn) $(return fa) $(return fb) |] "extraPkgConfs" -> do - let eqfn = [| let fn a' b' = and (zipWith eqpr (a' []) (b' [])) - && length (a' []) == length (b' []) - eqpr GlobalPkgConf GlobalPkgConf = True - eqpr UserPkgConf UserPkgConf = True - eqpr (PkgConfFile pa) (PkgConfFile pb) = pa == pb - eqpr _ _ = False + -- let eqfn = [| let fn a' b' = and (zipWith eqpr (a' []) (b' [])) + -- && length (a' []) == length (b' []) + let eqfn = [| let fn a' b' = cond a' b' + + cond a' b' = zz ++ ll + where + zz :: [(Bool,String)] + zz = (zipWith eqpr (a' []) (b' [])) + + ll :: [(Bool,String)] + ll = [( length (a' []) == length (b' []) + , if length (a' []) == length (b' []) then "" else "extraPkgConfs length mismatch")] + + eqpr GlobalPkgConf GlobalPkgConf = (True, "") + eqpr UserPkgConf UserPkgConf = (True, "") + eqpr (PkgConfFile pa) (PkgConfFile pb) = (pa == pb,if pa == pb then "" else "extraPkgConfs changed") + eqpr _ _ = (False, "extraPkgConfs changed") in fn |] [e| $(eqfn) $(return fa) $(return fb) |] #if __GLASGOW_HASKELL__ >= 710 && __GLASGOW_HASKELL__ < 800 "sigOf" -> do - let eqfn = [| let fn NotSigOf NotSigOf = True - fn (SigOf a') (SigOf b') = a' == b' - fn (SigOfMap a') (SigOfMap b') = a' == b' - fn _ _ = False + let eqfn = [| let fn NotSigOf NotSigOf = [(True, "")] + fn (SigOf a') (SigOf b') = [(a' == b', if a' == b' then "" else "sigOf changed")] + fn (SigOfMap a') (SigOfMap b') = [(a' == b', if a' == b' then "" else "sigOfMap changed")] + fn _ _ = [(False, "sigOf changed")] in fn |] [e| $(eqfn) $(return fa) $(return fb) |] @@ -116,12 +167,12 @@ deriveEqDynFlags qds = do #if __GLASGOW_HASKELL <= 706 "profAuto" -> do - let eqfn = [| let fn NoProfAuto NoProfAuto = True - fn ProfAutoAll ProfAutoAll = True - fn ProfAutoTop ProfAutoTop = True - fn ProfAutoExports ProfAutoExports = True - fn ProfAutoCalls ProfAutoCalls = True - fn _ _ = False + let eqfn = [| let fn NoProfAuto NoProfAuto = [(True, "")] + fn ProfAutoAll ProfAutoAll = [(True, "")] + fn ProfAutoTop ProfAutoTop = [(True, "")] + fn ProfAutoExports ProfAutoExports = [(True, "")] + fn ProfAutoCalls ProfAutoCalls = [(True, "")] + fn _ _ = [(False, "profAuto changed")] in fn |] [e| $(eqfn) $(return fa) $(return fb) |] @@ -129,16 +180,18 @@ deriveEqDynFlags qds = do #if __GLASGOW_HASKELL__ >= 706 "language" -> do - let eqfn = [| let fn (Just Haskell98) (Just Haskell98) = True - fn (Just Haskell2010) (Just Haskell2010) = True - fn Nothing Nothing = True - fn _ _ = False + let eqfn = [| let fn (Just Haskell98) (Just Haskell98) = [(True, "")] + fn (Just Haskell2010) (Just Haskell2010) = [(True, "")] + fn Nothing Nothing = [(True, "")] + fn _ _ = [(False, "language changed")] in fn |] [e| $(eqfn) $(return fa) $(return fb) |] #endif _ -> - [e| $(return fa) == $(return fb) |] + -- [e| $(return fa) == $(return fb) |] + -- [e| [($(return fa) == $(return fb), if $(return fa) == $(return fb) then "" else "default changed")] |] + [e| [($(return fa) == $(return fb), if $(return fa) == $(return fb) then "" else ("default changed:" ++ fon ++ ":" ++ (show $ toConstr $(return fa)) ++ " /= " ++ (show $ toConstr $(return fa)) ) )] |] -- expr' = [e| trace (if $(expr) == True then "" else show ($(litE $ StringL fon), $(expr))) $(expr) |] diff --git a/core/GhcMod/Target.hs b/core/GhcMod/Target.hs index 1b61f9e..6d0d318 100644 --- a/core/GhcMod/Target.hs +++ b/core/GhcMod/Target.hs @@ -85,8 +85,13 @@ initSession opts mdf = do df <- liftIO $ hsc_dflags <$> readIORef hsc_env_ref changed <- - withLightHscEnv' (initDF crdl) $ \hsc_env -> - return $ not $ hsc_dflags hsc_env `eqDynFlags` df + withLightHscEnv' (initDF crdl) $ \hsc_env -> do + let dfEq = concat $ hsc_dflags hsc_env `eqDynFlags` df + gmLog GmDebug "initSession" $ text $ "dfEq=" ++ (show $ filter (\t -> not (fst t)) dfEq) + -- gmLog GmDebug "initSession" $ text $ "dfEq=" ++ (show dfEq) + let eq = and $ map fst dfEq + -- return $ not $ hsc_dflags hsc_env `eqDynFlags` df + return $ not eq if changed then do