#if __GLASGOW_HASKELL__ > 706
#endif
module HERMIT.GHC
(
module GhcPlugins
, ppIdInfo
, zapVarOccInfo
, var2String
, thRdrNameGuesses
, varNameNS
, isQualified
, cmpString2Name
, cmpString2Var
, fqName
, uqName
, findNamesFromString
, 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(..)
, bndrRuleAndUnfoldingVars
#if __GLASGOW_HASKELL__ <= 706
, exprType
, Control.Monad.IO.Class.liftIO
#else
, runDsMtoCoreM
, runTcMtoCoreM
, buildTypeable
, buildDictionary
, eqExprX
, lookupRdrNameInModuleForPlugins
#endif
, mkPhiTy
, mkSigmaTy
, getHscEnvCoreM
) where
#if __GLASGOW_HASKELL__ <= 706
import qualified Control.Monad.IO.Class
import qualified MonadUtils (MonadIO,liftIO)
import GhcPlugins hiding (exprFreeVars, exprFreeIds, bindFreeVars, exprType, liftIO, PluginPass, getHscEnv)
import TysPrim (alphaTy, alphaTyVars)
import Panic (throwGhcException, GhcException(..))
import PprCore (pprCoreExpr)
import Data.Monoid hiding ((<>))
#else
import Finder (findImportedModule, cannotFindModule)
import GhcPlugins hiding (exprFreeVars, exprFreeIds, bindFreeVars, PluginPass, getHscEnv)
import LoadIface (loadPluginInterface)
import Panic (throwGhcException, throwGhcExceptionIO, GhcException(..))
import TcRnMonad (initIfaceTcRn)
import TysPrim (alphaTyVars)
#endif
import Convert (thRdrNameGuesses)
import CoreArity
import qualified CoreMonad
import Kind (isKind,isLiftedTypeKindCon)
import qualified OccName
import OccurAnal (occurAnalyseExpr)
import Pair (Pair(..))
import TcType (mkPhiTy, mkSigmaTy)
import TypeRep (Type(..),TyLit(..))
#if __GLASGOW_HASKELL__ <= 706
import Data.Maybe (isJust)
#else
import qualified Bag
import qualified CoAxiom
import DsBinds (dsEvBinds)
import DsMonad (DsM, initDsTc)
import PrelNames (typeableClassName)
import TcEnv (tcLookupClass)
import TcMType (newWantedEvVar)
import TcRnMonad (getCtLoc)
import TcRnTypes (TcM, mkNonCanonical, mkFlatWC, CtEvidence(..), SkolemInfo(..), CtOrigin(..))
import TcSimplify (solveWantedsTcM)
import HERMIT.GHC.Typechecker
#endif
import Data.List (intercalate)
varNameNS :: NameSpace
varNameNS = OccName.varName
getHscEnvCoreM :: CoreM HscEnv
getHscEnvCoreM = CoreMonad.getHscEnv
#if __GLASGOW_HASKELL__ <= 706
exprType :: CoreExpr -> Type
exprType (Var var) = idType var
exprType (Lit lit) = literalType lit
exprType (Coercion co) = coercionType co
exprType (Let bind body)
| NonRec tv rhs <- bind
, Type ty <- rhs = substTyWith [tv] [ty] (exprType body)
| otherwise = exprType body
exprType (Case _ _ ty _) = ty
exprType (Cast _ co) = pSnd (coercionKind co)
exprType (Tick _ e) = exprType e
exprType (Lam binder expr) = mkPiType binder (exprType expr)
exprType e@(App _ _)
= case collectArgs e of
(fun, args) -> applyTypeToArgs e (exprType fun) args
exprType other = pprTrace "exprType" (pprCoreExpr other) alphaTy
#endif
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
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
findNamesFromString :: GlobalRdrEnv -> String -> [Name]
findNamesFromString rdrEnv str | isQualified str = res
| otherwise = res
where res = [ nm | elt <- globalRdrEnvElts rdrEnv, let nm = gre_name elt, cmpString2Name str nm ]
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)
#if __GLASGOW_HASKELL__ <= 706
instance Monoid VarSet where
mempty :: VarSet
mempty = emptyVarSet
mappend :: VarSet -> VarSet -> VarSet
mappend = unionVarSet
instance Control.Monad.IO.Class.MonadIO CoreM where
liftIO :: IO a -> CoreM a
liftIO = MonadUtils.liftIO
#endif
bndrRuleAndUnfoldingVars :: Var -> VarSet
bndrRuleAndUnfoldingVars v | isTyVar v = emptyVarSet
| otherwise = idRuleAndUnfoldingVars v
#if __GLASGOW_HASKELL__ > 706
runTcMtoCoreM :: ModGuts -> TcM a -> CoreM a
runTcMtoCoreM guts m = do
env <- CoreMonad.getHscEnv
(msgs, mr) <- liftIO $ initTcFromModGuts env guts HsSrcFile False m
let dumpSDocs endMsg = Bag.foldBag (\ d r -> d ++ ('\n':r)) show endMsg
showMsgs (warns, errs) = "Errors:\n" ++ dumpSDocs ("Warnings:\n" ++ dumpSDocs "" warns) errs
maybe (fail $ showMsgs msgs) return mr
runDsMtoCoreM :: ModGuts -> DsM a -> CoreM a
runDsMtoCoreM guts = runTcMtoCoreM guts . initDsTc
buildTypeable :: ModGuts -> Type -> CoreM (Id, [CoreBind])
buildTypeable guts ty = do
evar <- runTcMtoCoreM guts $ do
cls <- tcLookupClass typeableClassName
let predTy = mkClassPred cls [typeKind ty, ty]
newWantedEvVar predTy
buildDictionary guts evar
buildDictionary :: ModGuts -> Id -> CoreM (Id, [CoreBind])
buildDictionary guts evar = do
(i, bs) <- runTcMtoCoreM guts $ do
loc <- getCtLoc $ GivenOrigin UnkSkol
let predTy = varType evar
nonC = mkNonCanonical $ CtWanted { ctev_pred = predTy, ctev_evar = evar, ctev_loc = loc }
wCs = mkFlatWC [nonC]
(_wCs', bnds) <- solveWantedsTcM wCs
return (evar, bnds)
bnds <- runDsMtoCoreM guts $ dsEvBinds bs
return (i,bnds)
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
lookupRdrNameInModuleForPlugins :: HscEnv -> ModGuts -> ModuleName -> RdrName -> IO (Maybe Name)
lookupRdrNameInModuleForPlugins 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 $
loadPluginInterface 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
#endif