module GHC.SYB.Utils where
import Data.Generics
import PprTyThing()
import DynFlags
import GHC hiding (moduleName)
import Outputable hiding (space)
import SrcLoc()
import qualified OccName(occNameString)
import Bag(Bag,bagToList)
import Var(Var)
import FastString(FastString)
#if __GLASGOW_HASKELL__ >= 800
import NameSet(NameSet,nameSetElemsStable)
#elif __GLASGOW_HASKELL__ >= 709
import NameSet(NameSet,nameSetElems)
#else
import NameSet(NameSet,nameSetToList)
#endif
#if __GLASGOW_HASKELL__ < 700
import GHC.SYB.Instances
#endif
import Control.Monad
import Data.List
#if __GLASGOW_HASKELL__ >= 800
nameSetElems :: NameSet -> [Name]
nameSetElems = nameSetElemsStable
#elif __GLASGOW_HASKELL__ < 709
nameSetElems :: NameSet -> [Name]
nameSetElems = nameSetToList
#endif
showSDoc_ :: SDoc -> String
#if __GLASGOW_HASKELL__ >= 707
showSDoc_ = showSDoc unsafeGlobalDynFlags
#elif __GLASGOW_HASKELL__ < 706
showSDoc_ = showSDoc
#else
showSDoc_ = showSDoc tracingDynFlags
#endif
data Stage = Parser | Renamer | TypeChecker deriving (Eq,Ord,Show)
showData :: Data a => Stage -> Int -> a -> String
showData stage n =
generic `ext1Q` list `extQ` string `extQ` fastString `extQ` srcSpan
`extQ` name `extQ` occName `extQ` moduleName `extQ` var `extQ` dataCon
`extQ` overLit
`extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet
#if __GLASGOW_HASKELL__ <= 708
`extQ` postTcType
#endif
`extQ` fixity
where generic :: Data a => a -> String
generic t = indent n ++ "(" ++ showConstr (toConstr t)
++ space (concat (intersperse " " (gmapQ (showData stage (n+1)) t))) ++ ")"
space "" = ""
space s = ' ':s
indent i = "\n" ++ replicate i ' '
string = show :: String -> String
fastString = ("{FastString: "++) . (++"}") . show :: FastString -> String
list l = indent n ++ "["
++ concat (intersperse "," (map (showData stage (n+1)) l)) ++ "]"
name = ("{Name: "++) . (++"}") . showSDoc_ . ppr :: Name -> String
occName = ("{OccName: "++) . (++"}") . OccName.occNameString
moduleName = ("{ModuleName: "++) . (++"}") . showSDoc_ . ppr :: ModuleName -> String
srcSpan = ("{"++) . (++"}") . showSDoc_ . ppr :: SrcSpan -> String
var = ("{Var: "++) . (++"}") . showSDoc_ . ppr :: Var -> String
dataCon = ("{DataCon: "++) . (++"}") . showSDoc_ . ppr :: DataCon -> String
overLit :: (HsOverLit RdrName) -> String
overLit = ("{HsOverLit:"++) . (++"}") . showSDoc_ . ppr
bagRdrName:: Bag (Located (HsBind RdrName)) -> String
bagRdrName = ("{Bag(Located (HsBind RdrName)): "++) . (++"}") . list . bagToList
bagName :: Bag (Located (HsBind Name)) -> String
bagName = ("{Bag(Located (HsBind Name)): "++) . (++"}") . list . bagToList
bagVar :: Bag (Located (HsBind Var)) -> String
bagVar = ("{Bag(Located (HsBind Var)): "++) . (++"}") . list . bagToList
nameSet | stage `elem` [Parser,TypeChecker]
= const ("{!NameSet placeholder here!}") :: NameSet -> String
| otherwise
= ("{NameSet: "++) . (++"}") . list . nameSetElems
#if __GLASGOW_HASKELL__ <= 708
postTcType | stage<TypeChecker = const "{!type placeholder here?!}" :: PostTcType -> String
| otherwise = showSDoc_ . ppr :: Type -> String
#endif
fixity | stage<Renamer = const "{!fixity placeholder here?!}" :: GHC.Fixity -> String
| otherwise = ("{Fixity: "++) . (++"}") . showSDoc_ . ppr :: GHC.Fixity -> String
everythingStaged :: Stage -> (r -> r -> r) -> r -> GenericQ r -> GenericQ r
everythingStaged stage k z f x
| (const False
#if __GLASGOW_HASKELL__ <= 708
`extQ` postTcType
#endif
`extQ` fixity `extQ` nameSet) x = z
| otherwise = foldl k (f x) (gmapQ (everythingStaged stage k z f) x)
where nameSet = const (stage `elem` [Parser,TypeChecker]) :: NameSet -> Bool
#if __GLASGOW_HASKELL__ <= 708
postTcType = const (stage<TypeChecker) :: PostTcType -> Bool
#endif
fixity = const (stage<Renamer) :: GHC.Fixity -> Bool
everythingButStaged :: Stage -> (r -> r -> r) -> r -> GenericQ (r,Bool) -> GenericQ r
everythingButStaged stage k z f x
| (const False
#if __GLASGOW_HASKELL__ <= 708
`extQ` postTcType
#endif
`extQ` fixity `extQ` nameSet) x = z
| stop == True = v
| otherwise = foldl k v (gmapQ (everythingButStaged stage k z f) x)
where (v, stop) = f x
nameSet = const (stage `elem` [Parser,TypeChecker]) :: NameSet -> Bool
#if __GLASGOW_HASKELL__ <= 708
postTcType = const (stage<TypeChecker) :: PostTcType -> Bool
#endif
fixity = const (stage<Renamer) :: GHC.Fixity -> Bool
somethingStaged :: Stage -> (Maybe u) -> GenericQ (Maybe u) -> GenericQ (Maybe u)
somethingStaged stage z = everythingStaged stage orElse z
somewhereStaged :: MonadPlus m => Stage -> GenericM m -> GenericM m
somewhereStaged stage f x
| (const False
#if __GLASGOW_HASKELL__ <= 708
`extQ` postTcType
#endif
`extQ` fixity `extQ` nameSet) x = mzero
| otherwise = f x `mplus` gmapMp (somewhereStaged stage f) x
where nameSet = const (stage `elem` [Parser,TypeChecker]) :: NameSet -> Bool
#if __GLASGOW_HASKELL__ <= 708
postTcType = const (stage<TypeChecker) :: PostTcType -> Bool
#endif
fixity = const (stage<Renamer) :: GHC.Fixity -> Bool
everywhereMStaged :: Monad m => Stage -> GenericM m -> GenericM m
everywhereMStaged stage f x
| (const False
#if __GLASGOW_HASKELL__ <= 708
`extQ` postTcType
#endif
`extQ` fixity `extQ` nameSet) x = return x
| otherwise = do x' <- gmapM (everywhereMStaged stage f) x
f x'
where nameSet = const (stage `elem` [Parser,TypeChecker]) :: NameSet -> Bool
#if __GLASGOW_HASKELL__ <= 708
postTcType = const (stage<TypeChecker) :: PostTcType -> Bool
#endif
fixity = const (stage<Renamer) :: GHC.Fixity -> Bool