module Language.HERMIT.GHC
(
ppIdInfo
, var2String
, thRdrNameGuesses
, name2THName
, var2THName
, cmpTHName2Name
, cmpString2Name
, cmpTHName2Var
, cmpString2Var
, fqName
, uqName
, findNamesFromString
, findNamesFromTH
, alphaTyVars
, Type(..)
, TyLit(..)
, GhcException(..)
, throwGhcException
, exprArity
, Language.HERMIT.GHC.coAxiomName
#if __GLASGOW_HASKELL__ > 706
, CoAxiom.BranchIndex
, CoAxiom.CoAxiom
, CoAxiom.Branched
#endif
) where
import GhcPlugins as GHC
import Convert (thRdrNameGuesses)
import TysPrim (alphaTyVars)
import TypeRep (Type(..),TyLit(..))
import Panic (GhcException(ProgramError), throwGhcException)
import CoreArity
#if __GLASGOW_HASKELL__ <= 706
import Data.Maybe (isJust)
#else
import qualified CoAxiom
#endif
import qualified Language.Haskell.TH as TH
import Language.Haskell.TH.Syntax (showName)
#if __GLASGOW_HASKELL__ <= 706
coAxiomName :: CoAxiom -> Name
coAxiomName = GHC.coAxiomName
#else
coAxiomName :: CoAxiom.CoAxiom br -> Name
coAxiomName = CoAxiom.coAxiomName
#endif
uqName :: Name -> 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 (showName 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 . showName
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]