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

Fix deriveEqDynFlags

Browse Source 
- didn't ignore 'IORef's
- eqfn for 'laguage' was missing a case for Nothing
This commit is contained in:
Daniel Gröber 2016-07-16 03:32:26 +02:00
parent 9605d1da7f
commit 500166c819
1 changed files with 52 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

78
Language/Haskell/GhcMod/DynFlagsTH.hs
View File

@ -17,6 +17,7 @@
{-# LANGUAGE CPP, TemplateHaskell #-} {-# LANGUAGE CPP, TemplateHaskell #-}
module Language.Haskell.GhcMod.DynFlagsTH where module Language.Haskell.GhcMod.DynFlagsTH where
import Language.Haskell.TH
import Language.Haskell.TH.Syntax import Language.Haskell.TH.Syntax
import Control.Applicative import Control.Applicative
import Data.Maybe import Data.Maybe
@ -46,13 +47,14 @@ deriveEqDynFlags qds = do
where where
eq :: Name -> Name -> (Name, Strict, Type) -> Maybe (Q Exp) eq :: Name -> Name -> (Name, Strict, Type) -> Maybe (Q Exp)
eq a b (fn@(Name (OccName fon) _), _, ft) eq a b (fun@(Name (OccName fon) _), _, ft)
| not (isUneqable || isIgnored) = Just expr | not (isUneqable || isIgnored) = Just expr
| otherwise = Nothing | otherwise = Nothing
where where
isUneqable = everything (||) (mkQ False hasUnEqable) ft isUneqable = everything (||) (mkQ False hasUnEqable) ft
hasUnEqable ArrowT = True hasUnEqable (AppT (ConT (Name (OccName on) _)) _)
| any (==on) ignoredConstructorNames = True
hasUnEqable (ConT (Name (OccName on) _)) hasUnEqable (ConT (Name (OccName on) _))
| any (==on) ignoredTypeNames = True | any (==on) ignoredTypeNames = True
| any (==on) ignoredTypeOccNames = True | any (==on) ignoredTypeOccNames = True
@ -60,6 +62,8 @@ deriveEqDynFlags qds = do
isIgnored = fon `elem` ignoredNames isIgnored = fon `elem` ignoredNames
ignoredConstructorNames = [ "IORef" ]
ignoredNames = [ "pkgDatabase" -- 7.8 ignoredNames = [ "pkgDatabase" -- 7.8
#if __GLASGOW_HASKELL__ <= 706 #if __GLASGOW_HASKELL__ <= 706
, "ways" -- 'Ways' is not exported :/ , "ways" -- 'Ways' is not exported :/
@ -75,52 +79,66 @@ deriveEqDynFlags qds = do
] ]
ignoredTypeOccNames = [ "OnOff" ] ignoredTypeOccNames = [ "OnOff" ]
fa = AppE (VarE fn) (VarE a) fa = AppE (VarE fun) (VarE a)
fb = AppE (VarE fn) (VarE b) fb = AppE (VarE fun) (VarE b)
expr = expr =
case fon of case fon of
"rtsOptsEnabled" -> do "rtsOptsEnabled" -> do
eqfn <- [| let eqfn RtsOptsNone RtsOptsNone = True let eqfn = [| let fn RtsOptsNone RtsOptsNone = True
eqfn RtsOptsSafeOnly RtsOptsSafeOnly = True fn RtsOptsSafeOnly RtsOptsSafeOnly = True
eqfn RtsOptsAll RtsOptsAll = True fn RtsOptsAll RtsOptsAll = True
eqfn _ _ = False fn _ _ = False
in eqfn in fn
|] |]
return $ AppE (AppE eqfn fa) fb [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
in fn
|]
[e| $(eqfn) $(return fa) $(return fb) |]
#if __GLASGOW_HASKELL__ >= 710 && __GLASGOW_HASKELL__ < 800 #if __GLASGOW_HASKELL__ >= 710 && __GLASGOW_HASKELL__ < 800
"sigOf" -> do "sigOf" -> do
eqfn <- [| let eqfn NotSigOf NotSigOf = True let eqfn = [| let fn NotSigOf NotSigOf = True
eqfn (SigOf a') (SigOf b') = a' == b' fn (SigOf a') (SigOf b') = a' == b'
eqfn (SigOfMap a') (SigOfMap b') = a' == b' fn (SigOfMap a') (SigOfMap b') = a' == b'
eqfn _ _ = False fn _ _ = False
in eqfn in fn
|] |]
return $ AppE (AppE eqfn fa) fb [e| $(eqfn) $(return fa) $(return fb) |]
#endif #endif
#if __GLASGOW_HASKELL <= 706 #if __GLASGOW_HASKELL <= 706
"profAuto" -> do "profAuto" -> do
eqfn <- [| let eqfn NoProfAuto NoProfAuto = True let eqfn = [| let fn NoProfAuto NoProfAuto = True
eqfn ProfAutoAll ProfAutoAll = True fn ProfAutoAll ProfAutoAll = True
eqfn ProfAutoTop ProfAutoTop = True fn ProfAutoTop ProfAutoTop = True
eqfn ProfAutoExports ProfAutoExports = True fn ProfAutoExports ProfAutoExports = True
eqfn ProfAutoCalls ProfAutoCalls = True fn ProfAutoCalls ProfAutoCalls = True
eqfn _ _ = False fn _ _ = False
in eqfn in fn
|] |]
return $ AppE (AppE eqfn fa) fb [e| $(eqfn) $(return fa) $(return fb) |]
#endif #endif
#if __GLASGOW_HASKELL__ >= 706 #if __GLASGOW_HASKELL__ >= 706
"language" -> do "language" -> do
eqfn <- [| let eqfn (Just Haskell98) (Just Haskell98) = True let eqfn = [| let fn (Just Haskell98) (Just Haskell98) = True
eqfn (Just Haskell2010) (Just Haskell2010) = True fn (Just Haskell2010) (Just Haskell2010) = True
eqfn _ _ = False fn Nothing Nothing = True
in eqfn fn _ _ = False
in fn
|] |]
return $ AppE (AppE eqfn fa) fb [e| $(eqfn) $(return fa) $(return fb) |]
#endif #endif
_ -> _ ->
return $ InfixE (Just fa) (VarE '(==)) (Just fb) [e| $(return fa) == $(return fb) |]
-- expr' = [e| trace (if $(expr) == True then "" else show ($(litE $ StringL fon), $(expr))) $(expr) |]