module Language.HERMIT.GHC
(
ppIdInfo
, var2String
, thRdrNameGuesses
, name2THName
, var2THName
, cmpTHName2Name
, cmpString2Name
, cmpTHName2Var
, cmpString2Var
, unqualifiedVarName
, findNameFromTH
, alphaTyVars
, Type(..)
, GhcException(..)
, throwGhcException
, exprArity
) where
import GhcPlugins
import Convert (thRdrNameGuesses)
import TysPrim (alphaTyVars)
import TypeRep (Type(..))
import Panic (GhcException(ProgramError), throwGhcException)
import CoreArity
#if __GLASGOW_HASKELL__ <= 706
import Data.Maybe (isJust)
#endif
import qualified Language.Haskell.TH as TH
var2String :: Var -> String
var2String = occNameString . nameOccName . varName
name2THName :: Name -> TH.Name
name2THName = TH.mkName . getOccString
var2THName :: Var -> TH.Name
var2THName = name2THName . varName
unqualifiedVarName :: Var -> String
unqualifiedVarName = TH.nameBase . var2THName
cmpTHName2Name :: TH.Name -> Name -> Bool
cmpTHName2Name th_nm = cmpString2Name (TH.nameBase th_nm)
cmpString2Name :: String -> Name -> Bool
cmpString2Name str nm = str == getOccString nm
cmpTHName2Var :: TH.Name -> Var -> Bool
cmpTHName2Var nm = cmpTHName2Name nm . varName
cmpString2Var :: String -> Var -> Bool
cmpString2Var str = cmpString2Name str . varName
findNameFromTH :: GlobalRdrEnv -> TH.Name -> [Name]
findNameFromTH rdrEnv nm =
[ gre_name elt
| elt <- concat $ occEnvElts rdrEnv
, cmpTHName2Name nm (gre_name elt)
]
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)
, (not (null 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]