Horrible hack to identify changed DynFlags
This commit is contained in:
Alan Zimmerman
parent
35690941aa
commit
7f86071271
@ -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
|
||||
|]
|
||||
|
||||
@ -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) |]
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user