module HERMIT.GHC
(
module GhcPlugins
, ppIdInfo
, zapVarOccInfo
, thRdrNameGuesses
, varNameNS
, isQualified
, cmpString2Name
, cmpString2Var
, qualifiedName
, unqualifiedName
, alphaTyVars
, Type(..)
, TyLit(..)
, GhcException(..)
, throwGhcException
, throwCmdLineErrorS
, exprArity
, occurAnalyseExpr_NoBinderSwap
, isKind
, isLiftedTypeKindCon
, notElemVarSet
, varSetToStrings
, showVarSet
, Pair(..)
, bndrRuleAndUnfoldingVars
, coAxiomName
, CoAxiom.BranchIndex
, CoAxiom.CoAxiom
, CoAxiom.Branched
, Bag.foldBag
, eqExprX
, loadSysInterface
, lookupRdrNameInModule
, injectDependency
, reportAllUnsolved
, zEncodeString
#ifdef mingw32_HOST_OS
, initStaticOpts
#endif
, module Class
, module DsBinds
, module DsMonad
, module DynamicLoading
, module ErrUtils
, module PrelNames
, module TcEnv
#if __GLASGOW_HASKELL__ < 710
, module TcMType
#else
, module TcSMonad
#endif
, module TcRnMonad
, module TcRnTypes
, module TcSimplify
, module TcType
, module Unify
, getHscEnvCoreM
) where
import qualified Bag
import Class (classTyCon)
import qualified CoAxiom
import Convert (thRdrNameGuesses)
import CoreArity
import qualified CoreMonad
import DsBinds (dsEvBinds)
import DsMonad (DsM, initDsTc)
import DynamicLoading (forceLoadTyCon, getValueSafely, lookupRdrNameInModuleForPlugins)
import Encoding (zEncodeString)
import ErrUtils (pprErrMsgBag)
import Finder (findImportedModule, cannotFindModule)
import GhcPlugins hiding (exprSomeFreeVars, exprFreeVars, exprFreeIds, bindFreeVars, getHscEnv, RuleName)
import Kind (isKind,isLiftedTypeKindCon)
import LoadIface (loadSysInterface)
import qualified OccName
import OccurAnal (occurAnalyseExpr_NoBinderSwap)
import Pair (Pair(..))
import Panic (throwGhcException, throwGhcExceptionIO, GhcException(..))
import PrelNames (typeableClassName)
#ifdef mingw32_HOST_OS
import StaticFlags
#endif
import TcEnv (tcLookupClass)
import TcErrors (reportAllUnsolved)
#if __GLASGOW_HASKELL__ < 710
import TcMType (newWantedEvVar)
#else
import TcSMonad (newWantedEvVar)
#endif
import TcRnMonad (getCtLoc, initIfaceTcRn)
#if __GLASGOW_HASKELL__ < 710
import TcRnTypes (TcM, mkNonCanonical, mkFlatWC, CtEvidence(..), SkolemInfo(..), CtOrigin(..))
#else
import TcRnTypes (TcM, mkNonCanonical, mkSimpleWC, CtEvidence(..), SkolemInfo(..), CtOrigin(..))
#endif
import TcSimplify (solveWantedsTcM)
import TcType (mkPhiTy, mkSigmaTy)
import TypeRep (Type(..),TyLit(..))
import TysPrim (alphaTyVars)
import Unify (tcUnifyTys, BindFlag(..))
import Data.List (intercalate)
import HERMIT.GHC.Typechecker
varNameNS :: NameSpace
varNameNS = OccName.varName
getHscEnvCoreM :: CoreM HscEnv
getHscEnvCoreM = CoreMonad.getHscEnv
varSetToStrings :: VarSet -> [String]
varSetToStrings = map unqualifiedName . varSetElems
showVarSet :: VarSet -> String
showVarSet = intercalate ", " . varSetToStrings
coAxiomName :: CoAxiom.CoAxiom br -> Name
coAxiomName = CoAxiom.coAxiomName
unqualifiedName :: NamedThing nm => nm -> String
unqualifiedName = getOccString
qualifiedName :: Name -> String
qualifiedName nm = modStr ++ unqualifiedName nm
where modStr = maybe "" (\m -> moduleNameString (moduleName m) ++ ".") (nameModule_maybe nm)
cmpString2Name :: String -> Name -> Bool
cmpString2Name str nm | isQualified str = str == qualifiedName nm
| otherwise = str == unqualifiedName nm
isQualified :: String -> Bool
isQualified [] = False
isQualified xs = '.' `elem` init xs
cmpString2Var :: String -> Var -> Bool
cmpString2Var str = cmpString2Name str . varName
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 = True
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)
bndrRuleAndUnfoldingVars :: Var -> VarSet
bndrRuleAndUnfoldingVars v | isTyVar v = emptyVarSet
| otherwise = idRuleAndUnfoldingVars v
eqExprX :: IdUnfoldingFun -> RnEnv2 -> CoreExpr -> CoreExpr -> Bool
eqExprX id_unfolding_fun env e1 e2
= go env e1 e2
where
go env (Var v1) (Var v2)
| rnOccL env v1 == rnOccR env v2
= True
go env (Var v1) e2
| not (locallyBoundL env v1)
, Just e1' <- expandUnfolding_maybe (id_unfolding_fun (lookupRnInScope env v1))
= go (nukeRnEnvL env) e1' e2
go env e1 (Var v2)
| not (locallyBoundR env v2)
, Just e2' <- expandUnfolding_maybe (id_unfolding_fun (lookupRnInScope env v2))
= go (nukeRnEnvR env) e1 e2'
go _ (Lit lit1) (Lit lit2) = lit1 == lit2
go env (Type t1) (Type t2) = eqTypeX env t1 t2
go env (Coercion co1) (Coercion co2) = coreEqCoercion2 env co1 co2
go env (Cast e1 co1) (Cast e2 co2) = coreEqCoercion2 env co1 co2 && go env e1 e2
go env (App f1 a1) (App f2 a2) = go env f1 f2 && go env a1 a2
go env (Tick n1 e1) (Tick n2 e2) = go_tickish n1 n2 && go env e1 e2
go env (Lam b1 e1) (Lam b2 e2)
= eqTypeX env (varType b1) (varType b2)
&& go (rnBndr2 env b1 b2) e1 e2
go env (Let (NonRec v1 r1) e1) (Let (NonRec v2 r2) e2)
= go env r1 r2
&& go (rnBndr2 env v1 v2) e1 e2
go env (Let (Rec ps1) e1) (Let (Rec ps2) e2)
= all2 (go env') rs1 rs2 && go env' e1 e2
where
(bs1,rs1) = unzip ps1
(bs2,rs2) = unzip ps2
env' = rnBndrs2 env bs1 bs2
go env (Case e1 b1 t1 a1) (Case e2 b2 t2 a2)
| null a1
= null a2 && go env e1 e2 && eqTypeX env t1 t2
| otherwise
= go env e1 e2 && all2 (go_alt (rnBndr2 env b1 b2)) a1 a2
go _ _ _ = False
go_alt env (c1, bs1, e1) (c2, bs2, e2)
= c1 == c2 && go (rnBndrs2 env bs1 bs2) e1 e2
go_tickish (Breakpoint lid lids) (Breakpoint rid rids)
= lid == rid && map (rnOccL env) lids == map (rnOccR env) rids
go_tickish l r = l == r
locallyBoundL, locallyBoundR :: RnEnv2 -> Var -> Bool
locallyBoundL rn_env v = inRnEnvL rn_env v
locallyBoundR rn_env v = inRnEnvR rn_env v
lookupRdrNameInModule :: HscEnv -> ModGuts -> ModuleName -> RdrName -> IO (Maybe Name)
lookupRdrNameInModule hsc_env guts mod_name rdr_name = do
found_module <- findImportedModule hsc_env mod_name Nothing
case found_module of
Found _ mod -> do
(_, mb_iface) <- initTcFromModGuts hsc_env guts HsSrcFile False $
initIfaceTcRn $
loadSysInterface doc mod
case mb_iface of
Just iface -> do
let decl_spec = ImpDeclSpec { is_mod = mod_name, is_as = mod_name
, is_qual = False, is_dloc = noSrcSpan }
provenance = Imported [ImpSpec decl_spec ImpAll]
env = mkGlobalRdrEnv (gresFromAvails provenance (mi_exports iface))
case lookupGRE_RdrName rdr_name env of
[gre] -> return (Just (gre_name gre))
[] -> return Nothing
_ -> panic "lookupRdrNameInModule"
Nothing -> throwCmdLineErrorS dflags $ hsep [ptext (sLit "Could not determine the exports of the module"), ppr mod_name]
err -> throwCmdLineErrorS dflags $ cannotFindModule dflags mod_name err
where
dflags = hsc_dflags hsc_env
doc = ptext (sLit "contains a name used in an invocation of lookupRdrNameInModule")
throwCmdLineErrorS :: DynFlags -> SDoc -> IO a
throwCmdLineErrorS dflags = throwCmdLineError . showSDoc dflags
throwCmdLineError :: String -> IO a
throwCmdLineError = throwGhcExceptionIO . CmdLineError
injectDependency :: HscEnv -> ModGuts -> ModuleName -> IO ()
injectDependency hsc_env guts mod_name = do
found_module <- findImportedModule hsc_env mod_name Nothing
case found_module of
Found _ mod -> do
_ <- initTcFromModGuts hsc_env guts HsSrcFile False $
initIfaceTcRn $
loadSysInterface doc mod
return ()
err -> throwCmdLineErrorS dflags $ cannotFindModule dflags mod_name err
where
dflags = hsc_dflags hsc_env
doc = ptext (sLit "dependency injection requested by HERMIT")