diff --git a/Language/Haskell/GhcMod/Gap.hs b/Language/Haskell/GhcMod/Gap.hs index 48337e0..d60b578 100644 --- a/Language/Haskell/GhcMod/Gap.hs +++ b/Language/Haskell/GhcMod/Gap.hs @@ -44,6 +44,7 @@ module Language.Haskell.GhcMod.Gap ( , Language.Haskell.GhcMod.Gap.isSynTyCon , parseModuleHeader , mkErrStyle' + , everythingStagedWithContext ) where import Control.Applicative hiding (empty) @@ -111,6 +112,8 @@ import Lexer as L import Parser import SrcLoc import Packages +import Data.Generics (GenericQ, extQ, gmapQ) +import GHC.SYB.Utils (Stage(..)) import Language.Haskell.GhcMod.Types (Expression(..)) import Prelude @@ -575,3 +578,20 @@ instance NFData ByteString where rnf Empty = () rnf (Chunk _ b) = rnf b #endif + +-- | Like 'everything', but avoid known potholes, based on the 'Stage' that +-- generated the Ast. +everythingStagedWithContext :: Stage -> s -> (r -> r -> r) -> r -> GenericQ (s -> (r, s)) -> GenericQ r +everythingStagedWithContext stage s0 f z q x + | (const False +#if __GLASGOW_HASKELL__ <= 708 + `extQ` postTcType +#endif + `extQ` fixity `extQ` nameSet) x = z + | otherwise = foldl f r (gmapQ (everythingStagedWithContext stage s' f z q) x) + where nameSet = const (stage `elem` [Parser,TypeChecker]) :: NameSet -> Bool +#if __GLASGOW_HASKELL__ <= 708 + postTcType = const (stage Bool +#endif + fixity = const (stage Bool + (r, s') = q x s0 diff --git a/Language/Haskell/GhcMod/SrcUtils.hs b/Language/Haskell/GhcMod/SrcUtils.hs index ba05a06..8bb988e 100644 --- a/Language/Haskell/GhcMod/SrcUtils.hs +++ b/Language/Haskell/GhcMod/SrcUtils.hs @@ -45,7 +45,8 @@ type CstGenQT = forall m. GhcMonad m => CstGenQS -> (m [(SrcSpan, Type)], CstGen collectSpansTypes :: (GhcMonad m) => G.TypecheckedModule -> (Int, Int) -> m [(SrcSpan, Type)] collectSpansTypes tcs lc = - everythingWithContext M.empty (liftM2 (++)) + everythingStagedWithContext TypeChecker M.empty (liftM2 (++)) + (return []) ((return [],) `mkQ` hsBind `extQ` hsExpr `extQ` hsPat) (G.tm_typechecked_source tcs) where