hasufell
/
ghc-mod
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Horrible hack to identify changed DynFlags

This commit is contained in:
Alan Zimmerman 2017-05-03 11:56:51 +02:00
parent 35690941aa
commit 7f86071271
3 changed files with 88 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
core/GhcMod/DynFlags.hs
View File

@ -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
|]

105
core/GhcMod/DynFlagsTH.hs
View File

@ -14,18 +14,53 @@
-- 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/>.
{-# 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) |]

9
core/GhcMod/Target.hs
View File

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