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

Merge branch 'eqdynflags-2' of https://github.com/alanz/ghc-mod

This commit is contained in:
Daniel Gröber 2017-07-24 23:02:42 +02:00
parent a75e9b09d0 36fbe25e07
commit 3d9a339869
3 changed files with 72 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
core/GhcMod/DynFlags.hs
View File

@ -103,6 +103,6 @@ deferErrors df = return $
---------------------------------------------------------------- ----------------------------------------------------------------
deriveEqDynFlags [d| deriveEqDynFlags [d|
eqDynFlags :: DynFlags -> DynFlags -> Bool eqDynFlags :: DynFlags -> DynFlags -> [[(Bool, String)]]
eqDynFlags = undefined eqDynFlags = undefined
|] |]

92
core/GhcMod/DynFlagsTH.hs
View File

@ -15,17 +15,22 @@
-- along with this program. If not, see <http://www.gnu.org/licenses/>. -- along with this program. If not, see <http://www.gnu.org/licenses/>.
{-# LANGUAGE CPP, TemplateHaskell #-} {-# LANGUAGE CPP, TemplateHaskell #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveDataTypeable #-}
module GhcMod.DynFlagsTH where module GhcMod.DynFlagsTH where
import Language.Haskell.TH import Language.Haskell.TH
import Language.Haskell.TH.Syntax import Language.Haskell.TH.Syntax
import Control.Applicative import Control.Applicative
import qualified Data.IntSet as IS
import Data.Maybe import Data.Maybe
import Data.Generics.Aliases import Data.Generics.Aliases
import Data.Generics.Schemes import Data.Generics.Schemes
import DynFlags import DynFlags
import Prelude import Prelude
-- -------------------------------------
deriveEqDynFlags :: Q [Dec] -> Q [Dec] deriveEqDynFlags :: Q [Dec] -> Q [Dec]
deriveEqDynFlags qds = do deriveEqDynFlags qds = do
#if __GLASGOW_HASKELL__ <= 710 #if __GLASGOW_HASKELL__ <= 710
@ -39,7 +44,7 @@ deriveEqDynFlags qds = do
a <- newName "a" a <- newName "a"
b <- newName "b" b <- newName "b"
e <- AppE (VarE 'and) . ListE <$> sequence (catMaybes $ map (eq a b) fs) e <- ListE <$> sequence (mapMaybe (eq a b) fs)
tysig@(SigD n _) :_ <- qds tysig@(SigD n _) :_ <- qds
@ -84,31 +89,40 @@ deriveEqDynFlags qds = do
expr = expr =
case fon of case fon of
"rtsOptsEnabled" -> do "rtsOptsEnabled" -> do
let eqfn = [| let fn RtsOptsNone RtsOptsNone = True let eqfn = [| let fn RtsOptsNone RtsOptsNone = [(True, "")]
fn RtsOptsSafeOnly RtsOptsSafeOnly = True fn RtsOptsSafeOnly RtsOptsSafeOnly = [(True, "")]
fn RtsOptsAll RtsOptsAll = True fn RtsOptsAll RtsOptsAll = [(True, "")]
fn _ _ = False fn _ _ = [(False, "rtsOptsEnabled changed")]
in fn in fn
|] |]
[e| $(eqfn) $(return fa) $(return fb) |] [e| $(eqfn) $(return fa) $(return fb) |]
"extraPkgConfs" -> do "extraPkgConfs" -> do
let eqfn = [| let fn a' b' = and (zipWith eqpr (a' []) (b' [])) let eqfn = [| let fn a' b' = cond a' b'
&& length (a' []) == length (b' [])
eqpr GlobalPkgConf GlobalPkgConf = True cond a' b' = zz ++ ll
eqpr UserPkgConf UserPkgConf = True where
eqpr (PkgConfFile pa) (PkgConfFile pb) = pa == pb zz :: [(Bool,String)]
eqpr _ _ = False 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 in fn
|] |]
[e| $(eqfn) $(return fa) $(return fb) |] [e| $(eqfn) $(return fa) $(return fb) |]
#if __GLASGOW_HASKELL__ >= 710 && __GLASGOW_HASKELL__ < 800 #if __GLASGOW_HASKELL__ >= 710 && __GLASGOW_HASKELL__ < 800
"sigOf" -> do "sigOf" -> do
let eqfn = [| let fn NotSigOf NotSigOf = True let eqfn = [| let fn NotSigOf NotSigOf = [(True, "")]
fn (SigOf a') (SigOf b') = a' == b' fn (SigOf a') (SigOf b') = [(a' == b', if a' == b' then "" else "sigOf changed")]
fn (SigOfMap a') (SigOfMap b') = a' == b' fn (SigOfMap a') (SigOfMap b') = [(a' == b', if a' == b' then "" else "sigOfMap changed")]
fn _ _ = False fn _ _ = [(False, "sigOf changed")]
in fn in fn
|] |]
[e| $(eqfn) $(return fa) $(return fb) |] [e| $(eqfn) $(return fa) $(return fb) |]
@ -116,12 +130,12 @@ deriveEqDynFlags qds = do
#if __GLASGOW_HASKELL <= 706 #if __GLASGOW_HASKELL <= 706
"profAuto" -> do "profAuto" -> do
let eqfn = [| let fn NoProfAuto NoProfAuto = True let eqfn = [| let fn NoProfAuto NoProfAuto = [(True, "")]
fn ProfAutoAll ProfAutoAll = True fn ProfAutoAll ProfAutoAll = [(True, "")]
fn ProfAutoTop ProfAutoTop = True fn ProfAutoTop ProfAutoTop = [(True, "")]
fn ProfAutoExports ProfAutoExports = True fn ProfAutoExports ProfAutoExports = [(True, "")]
fn ProfAutoCalls ProfAutoCalls = True fn ProfAutoCalls ProfAutoCalls = [(True, "")]
fn _ _ = False fn _ _ = [(False, "profAuto changed")]
in fn in fn
|] |]
[e| $(eqfn) $(return fa) $(return fb) |] [e| $(eqfn) $(return fa) $(return fb) |]
@ -129,16 +143,38 @@ deriveEqDynFlags qds = do
#if __GLASGOW_HASKELL__ >= 706 #if __GLASGOW_HASKELL__ >= 706
"language" -> do "language" -> do
let eqfn = [| let fn (Just Haskell98) (Just Haskell98) = True let eqfn = [| let fn (Just Haskell98) (Just Haskell98) = [(True, "")]
fn (Just Haskell2010) (Just Haskell2010) = True fn (Just Haskell2010) (Just Haskell2010) = [(True, "")]
fn Nothing Nothing = True fn Nothing Nothing = [(True, "")]
fn _ _ = False fn _ _ = [(False, "language changed")]
in fn in fn
|] |]
[e| $(eqfn) $(return fa) $(return fb) |] [e| $(eqfn) $(return fa) $(return fb) |]
#endif #endif
_ -> "outputFile" -> do
[e| $(return fa) == $(return fb) |] 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) |]
-- expr' = [e| trace (if $(expr) == True then "" else show ($(litE $ StringL fon), $(expr))) $(expr) |] "generalFlags" -> checkIntSet "generalFlags"
"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
r = if delta == IS.empty
then [(True, "")]
else [(False, fieldName ++ ":delta=" ++ (show delta) )]
in fn
|]
[e| $(eqfn) $(return fa) $(return fb) |]

9
core/GhcMod/Target.hs
View File

@ -85,8 +85,13 @@ initSession opts mdf = do
df <- liftIO $ hsc_dflags <$> readIORef hsc_env_ref df <- liftIO $ hsc_dflags <$> readIORef hsc_env_ref
changed <- changed <-
withLightHscEnv' (initDF crdl) $ \hsc_env -> withLightHscEnv' (initDF crdl) $ \hsc_env -> do
return $ not $ hsc_dflags hsc_env `eqDynFlags` df 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)
let eq = and $ map fst dfEq
-- return $ not $ hsc_dflags hsc_env `eqDynFlags` df
return $ not eq
if changed if changed
then do then do