From 7f860712713c1622a924ca18c18ecc68f70dfc8e Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Wed, 3 May 2017 11:56:51 +0200 Subject: [PATCH 1/4] Horrible hack to identify changed DynFlags --- core/GhcMod/DynFlags.hs | 3 +- core/GhcMod/DynFlagsTH.hs | 105 ++++++++++++++++++++++++++++---------- core/GhcMod/Target.hs | 9 +++- 3 files changed, 88 insertions(+), 29 deletions(-) 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 From 57ff5a03de99156bbe2849d1ea09e44a0649f610 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Wed, 3 May 2017 13:33:52 +0200 Subject: [PATCH 2/4] Clean up and show detailed changes for generalFlags and warningFlags As IntSet members currently, hits a stage restriction to call fromEnum, and my TH fu is not strong enough to work around it. --- core/GhcMod/DynFlagsTH.hs | 57 +++++++++++++++------------------------ 1 file changed, 21 insertions(+), 36 deletions(-) diff --git a/core/GhcMod/DynFlagsTH.hs b/core/GhcMod/DynFlagsTH.hs index cac1f3c..206a75e 100644 --- a/core/GhcMod/DynFlagsTH.hs +++ b/core/GhcMod/DynFlagsTH.hs @@ -23,42 +23,13 @@ module GhcMod.DynFlagsTH where import Language.Haskell.TH import Language.Haskell.TH.Syntax import Control.Applicative -import Data.Data +import qualified Data.IntSet as IS 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] @@ -107,7 +78,6 @@ deriveEqDynFlags qds = do #if __GLASGOW_HASKELL__ <= 706 , "ways" -- 'Ways' is not exported :/ #endif - , "sseVersion" ] ignoredTypeNames = [ "LogAction" @@ -189,9 +159,24 @@ deriveEqDynFlags qds = do [e| $(eqfn) $(return fa) $(return fb) |] #endif - _ -> - -- [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)) ) )] |] + "generalFlags" -> checkIntSet "generalFlags" --- expr' = [e| trace (if $(expr) == True then "" else show ($(litE $ StringL fon), $(expr))) $(expr) |] + "warningFlags" -> checkIntSet "warningFlags" + + _ -> + [e| [($(return fa) == $(return fb), if $(return fa) == $(return fb) then "" else ("default changed:" ++ fon) )] |] + + checkIntSet fieldName = do + let eqfn = [| let fn aa bb = r + where + uni = IS.union aa bb + dif = IS.intersection aa bb + delta = IS.difference uni dif + -- deltaStr = show $ map toEnum $( (IS.toList delta) :: [GeneralFlag] ) + r = if delta == IS.empty + then [(True, "")] + -- else [(False, "generalFlags:delta=" ++ deltaStr )] + else [(False, fieldName ++ ":delta=" ++ (show delta) )] + in fn + |] + [e| $(eqfn) $(return fa) $(return fb) |] From 597ffd02ea29eb611cff2a19da4d7d0703846849 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Wed, 3 May 2017 14:20:13 +0200 Subject: [PATCH 3/4] Add custom matcher for "outputFile" field --- core/GhcMod/DynFlags.hs | 1 - core/GhcMod/DynFlagsTH.hs | 14 +++++++------- core/GhcMod/Target.hs | 2 +- 3 files changed, 8 insertions(+), 9 deletions(-) diff --git a/core/GhcMod/DynFlags.hs b/core/GhcMod/DynFlags.hs index 4bb1f24..5caa072 100644 --- a/core/GhcMod/DynFlags.hs +++ b/core/GhcMod/DynFlags.hs @@ -104,6 +104,5 @@ deferErrors df = return $ deriveEqDynFlags [d| 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 206a75e..fbcee1f 100644 --- a/core/GhcMod/DynFlagsTH.hs +++ b/core/GhcMod/DynFlagsTH.hs @@ -14,7 +14,6 @@ -- 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 #-} @@ -45,10 +44,6 @@ deriveEqDynFlags qds = do a <- newName "a" b <- newName "b" - -- 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 @@ -103,8 +98,6 @@ deriveEqDynFlags qds = do [e| $(eqfn) $(return fa) $(return fb) |] "extraPkgConfs" -> do - -- 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 @@ -159,6 +152,13 @@ deriveEqDynFlags qds = do [e| $(eqfn) $(return fa) $(return fb) |] #endif + "outputFile" -> do + let eqfn = [| let fn (Just f1) (Just f2) = [(f1 == f2, if f1 == f2 then "" else "outputFile changed")] + fn _ _ = [(True, "")] -- anything with a Nothing is fine. + in fn + |] + [e| $(eqfn) $(return fa) $(return fb) |] + "generalFlags" -> checkIntSet "generalFlags" "warningFlags" -> checkIntSet "warningFlags" diff --git a/core/GhcMod/Target.hs b/core/GhcMod/Target.hs index 6d0d318..0523fc6 100644 --- a/core/GhcMod/Target.hs +++ b/core/GhcMod/Target.hs @@ -86,9 +86,9 @@ initSession opts mdf = do df <- liftIO $ hsc_dflags <$> readIORef hsc_env_ref changed <- withLightHscEnv' (initDF crdl) $ \hsc_env -> do + gmLog GmDebug "initSession" $ text $ "outputFiles:" ++ show (outputFile $ hsc_dflags hsc_env, outputFile df) 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 From 36fbe25e07c34ba81fbba735d4046a98ae75db3a Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Wed, 3 May 2017 15:26:51 +0200 Subject: [PATCH 4/4] Minor cleanup --- core/GhcMod/DynFlagsTH.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/core/GhcMod/DynFlagsTH.hs b/core/GhcMod/DynFlagsTH.hs index fbcee1f..1b03851 100644 --- a/core/GhcMod/DynFlagsTH.hs +++ b/core/GhcMod/DynFlagsTH.hs @@ -172,10 +172,8 @@ deriveEqDynFlags qds = do uni = IS.union aa bb dif = IS.intersection aa bb delta = IS.difference uni dif - -- deltaStr = show $ map toEnum $( (IS.toList delta) :: [GeneralFlag] ) r = if delta == IS.empty then [(True, "")] - -- else [(False, "generalFlags:delta=" ++ deltaStr )] else [(False, fieldName ++ ":delta=" ++ (show delta) )] in fn |]