module GHC.SYB.Utils where
import Data.Generics
import PprTyThing()
import DynFlags
import GHC hiding (moduleName)
import Outputable hiding (space)
import SrcLoc()
import qualified Data.ByteString as BS
import qualified OccName(occNameString)
import Bag(Bag,bagToList)
import Var(Var)
import FastString(FastString)
#if __GLASGOW_HASKELL__ >= 802
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__ >= 802
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` byteString
`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
byteString = ("{ByteString: "++) . (++"}") . show :: BS.ByteString -> 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