module HERMIT.GHC
(
module GhcPlugins
, ppIdInfo
, zapVarOccInfo
, var2String
, thRdrNameGuesses
, name2THName
, var2THName
, cmpTHName2Name
, cmpString2Name
, cmpTHName2Var
, cmpString2Var
, fqName
, uqName
, findNamesFromString
, findNamesFromTH
, alphaTyVars
, Type(..)
, TyLit(..)
, GhcException(..)
, throwGhcException
, exprArity
, occurAnalyseExpr
, isKind
, isLiftedTypeKindCon
#if __GLASGOW_HASKELL__ > 706
, coAxiomName
, CoAxiom.BranchIndex
, CoAxiom.CoAxiom
, CoAxiom.Branched
#endif
, notElemVarSet
, varSetToStrings
, showVarSet
, Pair(..)
#if __GLASGOW_HASKELL__ <= 706
, Control.Monad.IO.Class.liftIO
#endif
) where
#if __GLASGOW_HASKELL__ <= 706
import qualified Control.Monad.IO.Class
import qualified MonadUtils (MonadIO,liftIO)
import GhcPlugins hiding (exprFreeVars, exprFreeIds, bindFreeVars, liftIO)
#else
import GhcPlugins hiding (exprFreeVars, exprFreeIds, bindFreeVars)
#endif
import Convert (thRdrNameGuesses)
import TysPrim (alphaTyVars)
import TypeRep (Type(..),TyLit(..))
import Panic (GhcException(ProgramError), throwGhcException)
import CoreArity
import Kind (isKind,isLiftedTypeKindCon)
import OccurAnal (occurAnalyseExpr)
import Pair (Pair(..))
#if __GLASGOW_HASKELL__ <= 706
import Data.Maybe (isJust)
#else
import qualified CoAxiom
#endif
import Data.List (intercalate)
import Data.Monoid hiding ((<>))
import qualified Language.Haskell.TH as TH
varSetToStrings :: VarSet -> [String]
varSetToStrings = map var2String . varSetElems
showVarSet :: VarSet -> String
showVarSet = intercalate ", " . varSetToStrings
#if __GLASGOW_HASKELL__ <= 706
#else
coAxiomName :: CoAxiom.CoAxiom br -> Name
coAxiomName = CoAxiom.coAxiomName
#endif
uqName :: NamedThing nm => nm -> String
uqName = getOccString
fqName :: Name -> String
fqName nm = modStr ++ uqName nm
where modStr = maybe "" (\m -> moduleNameString (moduleName m) ++ ".") (nameModule_maybe nm)
var2String :: Var -> String
var2String = uqName . varName
name2THName :: Name -> TH.Name
name2THName = TH.mkName . uqName
var2THName :: Var -> TH.Name
var2THName = name2THName . varName
cmpString2Name :: String -> Name -> Bool
cmpString2Name str nm | isQualified str = str == fqName nm
| otherwise = str == uqName nm
isQualified :: String -> Bool
isQualified [] = False
isQualified xs = '.' `elem` init xs
cmpString2Var :: String -> Var -> Bool
cmpString2Var str = cmpString2Name str . varName
cmpTHName2Name :: TH.Name -> Name -> Bool
cmpTHName2Name th_nm = cmpString2Name (show th_nm)
cmpTHName2Var :: TH.Name -> Var -> Bool
cmpTHName2Var nm = cmpTHName2Name nm . varName
findNamesFromString :: GlobalRdrEnv -> String -> [Name]
findNamesFromString rdrEnv str | isQualified str = take 1 res
| otherwise = res
where res = [ nm | elt <- globalRdrEnvElts rdrEnv, let nm = gre_name elt, cmpString2Name str nm ]
findNamesFromTH :: GlobalRdrEnv -> TH.Name -> [Name]
findNamesFromTH rdrEnv = findNamesFromString rdrEnv . show
ppIdInfo :: Id -> IdInfo -> SDoc
ppIdInfo v info
= showAttributes
[ (True, pp_scope <> ppr (idDetails v))
, (has_arity, ptext (sLit "Arity=") <> int arity)
, (has_caf_info, ptext (sLit "Caf=") <> ppr caf_info)
, (has_strictness, ptext (sLit "Str=") <> pprStrictness str_info)
, (has_unf, ptext (sLit "Unf=") <> ppr unf_info)
, (notNull rules, ptext (sLit "RULES:") <+> vcat (map ppr rules))
]
where
pp_scope | isGlobalId v = ptext (sLit "GblId")
| isExportedId v = ptext (sLit "LclIdX")
| otherwise = ptext (sLit "LclId")
arity = arityInfo info
has_arity = arity /= 0
caf_info = cafInfo info
has_caf_info = not (mayHaveCafRefs caf_info)
str_info = strictnessInfo info
has_strictness =
#if __GLASGOW_HASKELL__ > 706
True
#else
isJust str_info
#endif
unf_info = unfoldingInfo info
has_unf = hasSomeUnfolding unf_info
rules = specInfoRules (specInfo info)
showAttributes :: [(Bool,SDoc)] -> SDoc
showAttributes stuff
| null docs = empty
| otherwise = brackets (sep (punctuate comma docs))
where
docs = [d | (True,d) <- stuff]
zapVarOccInfo :: Var -> Var
zapVarOccInfo i = if isId i
then zapIdOccInfo i
else i
notElemVarSet :: Var -> VarSet -> Bool
notElemVarSet v vs = not (v `elemVarSet` vs)
instance Monoid VarSet where
mempty :: VarSet
mempty = emptyVarSet
mappend :: VarSet -> VarSet -> VarSet
mappend = unionVarSet
#if __GLASGOW_HASKELL__ <= 706
instance Control.Monad.IO.Class.MonadIO CoreM where
liftIO :: IO a -> CoreM a
liftIO = MonadUtils.liftIO
#endif