module DsMonad (
DsM, mapM, mapAndUnzipM,
initDs, initDsTc, initTcDsForSolver, initDsWithModGuts, fixDs,
foldlM, foldrM, whenGOptM, unsetGOptM, unsetWOptM, xoptM,
Applicative(..),(<$>),
duplicateLocalDs, newSysLocalDsNoLP, newSysLocalDs,
newSysLocalsDsNoLP, newSysLocalsDs, newUniqueId,
newFailLocalDs, newPredVarDs,
getSrcSpanDs, putSrcSpanDs,
mkPrintUnqualifiedDs,
newUnique,
UniqSupply, newUniqueSupply,
getGhcModeDs, dsGetFamInstEnvs,
dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon,
dsLookupDataCon, dsLookupConLike,
DsMetaEnv, DsMetaVal(..), dsGetMetaEnv, dsLookupMetaEnv, dsExtendMetaEnv,
getPmDelta, updPmDelta,
dsGetCompleteMatches,
DsWarning, warnDs, warnIfSetDs, errDs, errDsCoreExpr,
failWithDs, failDs, discardWarningsDs,
askNoErrsDs,
DsMatchContext(..),
EquationInfo(..), MatchResult(..), DsWrapper, idDsWrapper,
CanItFail(..), orFail,
dsNoLevPoly, dsNoLevPolyExpr, dsWhenNoErrs,
pprRuntimeTrace
) where
import GhcPrelude
import TcRnMonad
import FamInstEnv
import CoreSyn
import MkCore ( unitExpr )
import CoreUtils ( exprType, isExprLevPoly )
import GHC.Hs
import TcIface
import TcMType ( checkForLevPolyX, formatLevPolyErr )
import PrelNames
import RdrName
import HscTypes
import Bag
import BasicTypes ( Origin )
import DataCon
import ConLike
import TyCon
import GHC.HsToCore.PmCheck.Types
import Id
import Module
import Outputable
import SrcLoc
import Type
import UniqSupply
import Name
import NameEnv
import DynFlags
import ErrUtils
import FastString
import UniqFM ( lookupWithDefaultUFM )
import Literal ( mkLitString )
import CostCentreState
import Data.IORef
data DsMatchContext
= DsMatchContext (HsMatchContext Name) SrcSpan
deriving ()
instance Outputable DsMatchContext where
ppr (DsMatchContext hs_match ss) = ppr ss <+> pprMatchContext hs_match
data EquationInfo
= EqnInfo { eqn_pats :: [Pat GhcTc]
, eqn_orig :: Origin
, eqn_rhs :: MatchResult
}
instance Outputable EquationInfo where
ppr (EqnInfo pats _ _) = ppr pats
type DsWrapper = CoreExpr -> CoreExpr
idDsWrapper :: DsWrapper
idDsWrapper e = e
data MatchResult
= MatchResult
CanItFail
(CoreExpr -> DsM CoreExpr)
data CanItFail = CanFail | CantFail
orFail :: CanItFail -> CanItFail -> CanItFail
orFail CantFail CantFail = CantFail
orFail _ _ = CanFail
fixDs :: (a -> DsM a) -> DsM a
fixDs = fixM
type DsWarning = (SrcSpan, SDoc)
initDsTc :: DsM a -> TcM a
initDsTc thing_inside
= do { tcg_env <- getGblEnv
; msg_var <- getErrsVar
; hsc_env <- getTopEnv
; envs <- mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
; setEnvs envs thing_inside
}
initDs :: HscEnv -> TcGblEnv -> DsM a -> IO (Messages, Maybe a)
initDs hsc_env tcg_env thing_inside
= do { msg_var <- newIORef emptyMessages
; envs <- mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
; runDs hsc_env envs thing_inside
}
mkDsEnvsFromTcGbl :: MonadIO m
=> HscEnv -> IORef Messages -> TcGblEnv
-> m (DsGblEnv, DsLclEnv)
mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
= do { cc_st_var <- liftIO $ newIORef newCostCentreState
; let dflags = hsc_dflags hsc_env
this_mod = tcg_mod tcg_env
type_env = tcg_type_env tcg_env
rdr_env = tcg_rdr_env tcg_env
fam_inst_env = tcg_fam_inst_env tcg_env
complete_matches = hptCompleteSigs hsc_env
++ tcg_complete_matches tcg_env
; return $ mkDsEnvs dflags this_mod rdr_env type_env fam_inst_env
msg_var cc_st_var complete_matches
}
runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages, Maybe a)
runDs hsc_env (ds_gbl, ds_lcl) thing_inside
= do { res <- initTcRnIf 'd' hsc_env ds_gbl ds_lcl
(tryM thing_inside)
; msgs <- readIORef (ds_msgs ds_gbl)
; let final_res
| errorsFound dflags msgs = Nothing
| Right r <- res = Just r
| otherwise = panic "initDs"
; return (msgs, final_res)
}
where dflags = hsc_dflags hsc_env
initDsWithModGuts :: HscEnv -> ModGuts -> DsM a -> IO (Messages, Maybe a)
initDsWithModGuts hsc_env guts thing_inside
= do { cc_st_var <- newIORef newCostCentreState
; msg_var <- newIORef emptyMessages
; let dflags = hsc_dflags hsc_env
type_env = typeEnvFromEntities ids (mg_tcs guts) (mg_fam_insts guts)
rdr_env = mg_rdr_env guts
fam_inst_env = mg_fam_inst_env guts
this_mod = mg_module guts
complete_matches = hptCompleteSigs hsc_env
++ mg_complete_sigs guts
bindsToIds (NonRec v _) = [v]
bindsToIds (Rec binds) = map fst binds
ids = concatMap bindsToIds (mg_binds guts)
envs = mkDsEnvs dflags this_mod rdr_env type_env
fam_inst_env msg_var cc_st_var
complete_matches
; runDs hsc_env envs thing_inside
}
initTcDsForSolver :: TcM a -> DsM (Messages, Maybe a)
initTcDsForSolver thing_inside
= do { (gbl, lcl) <- getEnvs
; hsc_env <- getTopEnv
; let DsGblEnv { ds_mod = mod
, ds_fam_inst_env = fam_inst_env } = gbl
DsLclEnv { dsl_loc = loc } = lcl
; liftIO $ initTc hsc_env HsSrcFile False mod loc $
updGblEnv (\tc_gbl -> tc_gbl { tcg_fam_inst_env = fam_inst_env }) $
thing_inside }
mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
-> IORef Messages -> IORef CostCentreState -> [CompleteMatch]
-> (DsGblEnv, DsLclEnv)
mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var cc_st_var
complete_matches
= let if_genv = IfGblEnv { if_doc = text "mkDsEnvs",
if_rec_types = Just (mod, return type_env) }
if_lenv = mkIfLclEnv mod (text "GHC error in desugarer lookup in" <+> ppr mod)
False
real_span = realSrcLocSpan (mkRealSrcLoc (moduleNameFS (moduleName mod)) 1 1)
completeMatchMap = mkCompleteMatchMap complete_matches
gbl_env = DsGblEnv { ds_mod = mod
, ds_fam_inst_env = fam_inst_env
, ds_if_env = (if_genv, if_lenv)
, ds_unqual = mkPrintUnqualified dflags rdr_env
, ds_msgs = msg_var
, ds_complete_matches = completeMatchMap
, ds_cc_st = cc_st_var
}
lcl_env = DsLclEnv { dsl_meta = emptyNameEnv
, dsl_loc = real_span
, dsl_delta = initDelta
}
in (gbl_env, lcl_env)
newUniqueId :: Id -> Type -> DsM Id
newUniqueId id = mk_local (occNameFS (nameOccName (idName id)))
duplicateLocalDs :: Id -> DsM Id
duplicateLocalDs old_local
= do { uniq <- newUnique
; return (setIdUnique old_local uniq) }
newPredVarDs :: PredType -> DsM Var
newPredVarDs pred
= newSysLocalDs pred
newSysLocalDsNoLP, newSysLocalDs, newFailLocalDs :: Type -> DsM Id
newSysLocalDsNoLP = mk_local (fsLit "ds")
newSysLocalDs = mkSysLocalOrCoVarM (fsLit "ds")
newFailLocalDs = mkSysLocalOrCoVarM (fsLit "fail")
newSysLocalsDsNoLP, newSysLocalsDs :: [Type] -> DsM [Id]
newSysLocalsDsNoLP = mapM newSysLocalDsNoLP
newSysLocalsDs = mapM newSysLocalDs
mk_local :: FastString -> Type -> DsM Id
mk_local fs ty = do { dsNoLevPoly ty (text "When trying to create a variable of type:" <+>
ppr ty)
; mkSysLocalOrCoVarM fs ty }
getGhcModeDs :: DsM GhcMode
getGhcModeDs = getDynFlags >>= return . ghcMode
getPmDelta :: DsM Delta
getPmDelta = do { env <- getLclEnv; return (dsl_delta env) }
updPmDelta :: Delta -> DsM a -> DsM a
updPmDelta delta = updLclEnv (\env -> env { dsl_delta = delta })
getSrcSpanDs :: DsM SrcSpan
getSrcSpanDs = do { env <- getLclEnv
; return (RealSrcSpan (dsl_loc env)) }
putSrcSpanDs :: SrcSpan -> DsM a -> DsM a
putSrcSpanDs (UnhelpfulSpan {}) thing_inside
= thing_inside
putSrcSpanDs (RealSrcSpan real_span) thing_inside
= updLclEnv (\ env -> env {dsl_loc = real_span}) thing_inside
warnDs :: WarnReason -> SDoc -> DsM ()
warnDs reason warn
= do { env <- getGblEnv
; loc <- getSrcSpanDs
; dflags <- getDynFlags
; let msg = makeIntoWarning reason $
mkWarnMsg dflags loc (ds_unqual env) warn
; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) }
warnIfSetDs :: WarningFlag -> SDoc -> DsM ()
warnIfSetDs flag warn
= whenWOptM flag $
warnDs (Reason flag) warn
errDs :: SDoc -> DsM ()
errDs err
= do { env <- getGblEnv
; loc <- getSrcSpanDs
; dflags <- getDynFlags
; let msg = mkErrMsg dflags loc (ds_unqual env) err
; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg)) }
errDsCoreExpr :: SDoc -> DsM CoreExpr
errDsCoreExpr err
= do { errDs err
; return unitExpr }
failWithDs :: SDoc -> DsM a
failWithDs err
= do { errDs err
; failM }
failDs :: DsM a
failDs = failM
askNoErrsDs :: DsM a -> DsM (a, Bool)
askNoErrsDs thing_inside
= do { errs_var <- newMutVar emptyMessages
; env <- getGblEnv
; mb_res <- tryM $
setGblEnv (env { ds_msgs = errs_var }) $
thing_inside
; msgs@(warns, errs) <- readMutVar errs_var
; updMutVar (ds_msgs env) (\ (w,e) -> (w `unionBags` warns, e `unionBags` errs))
; case mb_res of
Left _ -> failM
Right res -> do { dflags <- getDynFlags
; let errs_found = errorsFound dflags msgs
; return (res, not errs_found) } }
mkPrintUnqualifiedDs :: DsM PrintUnqualified
mkPrintUnqualifiedDs = ds_unqual <$> getGblEnv
instance MonadThings (IOEnv (Env DsGblEnv DsLclEnv)) where
lookupThing = dsLookupGlobal
dsLookupGlobal :: Name -> DsM TyThing
dsLookupGlobal name
= do { env <- getGblEnv
; setEnvs (ds_if_env env)
(tcIfaceGlobal name) }
dsLookupGlobalId :: Name -> DsM Id
dsLookupGlobalId name
= tyThingId <$> dsLookupGlobal name
dsLookupTyCon :: Name -> DsM TyCon
dsLookupTyCon name
= tyThingTyCon <$> dsLookupGlobal name
dsLookupDataCon :: Name -> DsM DataCon
dsLookupDataCon name
= tyThingDataCon <$> dsLookupGlobal name
dsLookupConLike :: Name -> DsM ConLike
dsLookupConLike name
= tyThingConLike <$> dsLookupGlobal name
dsGetFamInstEnvs :: DsM FamInstEnvs
dsGetFamInstEnvs
= do { eps <- getEps; env <- getGblEnv
; return (eps_fam_inst_env eps, ds_fam_inst_env env) }
dsGetMetaEnv :: DsM (NameEnv DsMetaVal)
dsGetMetaEnv = do { env <- getLclEnv; return (dsl_meta env) }
dsGetCompleteMatches :: TyCon -> DsM [CompleteMatch]
dsGetCompleteMatches tc = do
eps <- getEps
env <- getGblEnv
let lookup_completes ufm = lookupWithDefaultUFM ufm [] tc
eps_matches_list = lookup_completes $ eps_complete_matches eps
env_matches_list = lookup_completes $ ds_complete_matches env
return $ eps_matches_list ++ env_matches_list
dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (dsl_meta env) name) }
dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
dsExtendMetaEnv menv thing_inside
= updLclEnv (\env -> env { dsl_meta = dsl_meta env `plusNameEnv` menv }) thing_inside
discardWarningsDs :: DsM a -> DsM a
discardWarningsDs thing_inside
= do { env <- getGblEnv
; old_msgs <- readTcRef (ds_msgs env)
; result <- thing_inside
; writeTcRef (ds_msgs env) old_msgs
; return result }
dsNoLevPoly :: Type -> SDoc -> DsM ()
dsNoLevPoly ty doc = checkForLevPolyX errDs doc ty
dsNoLevPolyExpr :: CoreExpr -> SDoc -> DsM ()
dsNoLevPolyExpr e doc
| isExprLevPoly e = errDs (formatLevPolyErr (exprType e) $$ doc)
| otherwise = return ()
dsWhenNoErrs :: DsM a -> (a -> CoreExpr) -> DsM CoreExpr
dsWhenNoErrs thing_inside mk_expr
= do { (result, no_errs) <- askNoErrsDs thing_inside
; return $ if no_errs
then mk_expr result
else unitExpr }
pprRuntimeTrace :: String
-> SDoc
-> CoreExpr
-> DsM CoreExpr
pprRuntimeTrace str doc expr = do
traceId <- dsLookupGlobalId traceName
unpackCStringId <- dsLookupGlobalId unpackCStringName
dflags <- getDynFlags
let message :: CoreExpr
message = App (Var unpackCStringId) $
Lit $ mkLitString $ showSDoc dflags (hang (text str) 4 doc)
return $ mkApps (Var traceId) [Type (exprType expr), message, expr]