TcMonoBinds, TcHsBinds, TcPat,
TcExpr, TcGRHSs, TcGRHS, TcMatch,
TcStmt, TcArithSeqInfo, TcRecordBinds,
- TcHsModule, TcCoreExpr, TcDictBinds,
+ TcHsModule, TcDictBinds,
TcForeignExportDecl,
TypecheckedHsBinds, TypecheckedRuleDecl,
TypecheckedMatch, TypecheckedHsModule,
TypecheckedGRHSs, TypecheckedGRHS,
TypecheckedRecordBinds, TypecheckedDictBinds,
+ TypecheckedMatchContext, TypecheckedCoreBind,
mkHsTyApp, mkHsDictApp, mkHsConApp,
mkHsTyLam, mkHsDictLam, mkHsLet,
+ simpleHsLitTy,
+
+ collectTypedPatBinders, outPatType,
-- re-exported from TcEnv
TcId,
- zonkTopBinds, zonkId, zonkIdOcc, zonkExpr,
+ zonkTopBinds, zonkId, zonkIdBndr, zonkIdOcc, zonkExpr,
zonkForeignExports, zonkRules
) where
import HsSyn -- oodles of it
-- others:
-import Id ( idName, idType, isLocalId, setIdType, isIP, Id )
+import Id ( idName, idType, setIdType, Id )
import DataCon ( dataConWrapId )
-import TcEnv ( tcLookupGlobal_maybe, tcExtendGlobalValEnv,
- TcEnv, TcId
- )
+import TcEnv ( tcLookupGlobal_maybe, tcExtendGlobalValEnv, TcEnv, TcId )
import TcMonad
-import TcType ( zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcType, zonkTcSigTyVars
- )
-import CoreSyn ( Expr )
-import BasicTypes ( RecFlag(..) )
+import Type ( Type )
+import TcType ( TcType, tcGetTyVar )
+import TcMType ( zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcType, zonkTcTyVars )
+import TysPrim ( charPrimTy, intPrimTy, floatPrimTy,
+ doublePrimTy, addrPrimTy
+ )
+import TysWiredIn ( charTy, stringTy, intTy, integerTy,
+ mkListTy, mkPArrTy, mkTupleTy, unitTy )
+import CoreSyn ( Expr(..), CoreExpr, CoreBind, Bind(..), CoreAlt, Note(..) )
+import Var ( isId )
+import BasicTypes ( RecFlag(..), Boxity(..), IPName(..), ipNameName )
import Bag
import Outputable
import HscTypes ( TyThing(..) )
type TcRecordBinds = HsRecordBinds TcId TcPat
type TcHsModule = HsModule TcId TcPat
-type TcCoreExpr = Expr TcId
type TcForeignExportDecl = ForeignDecl TcId
type TcRuleDecl = RuleDecl TcId TcPat
type TypecheckedArithSeqInfo = ArithSeqInfo Id TypecheckedPat
type TypecheckedStmt = Stmt Id TypecheckedPat
type TypecheckedMatch = Match Id TypecheckedPat
+type TypecheckedMatchContext = HsMatchContext Id
type TypecheckedGRHSs = GRHSs Id TypecheckedPat
type TypecheckedGRHS = GRHS Id TypecheckedPat
type TypecheckedRecordBinds = HsRecordBinds Id TypecheckedPat
type TypecheckedHsModule = HsModule Id TypecheckedPat
type TypecheckedForeignDecl = ForeignDecl Id
type TypecheckedRuleDecl = RuleDecl Id TypecheckedPat
+type TypecheckedCoreBind = (Id, CoreExpr)
\end{code}
\begin{code}
mkHsConApp data_con tys args = foldl HsApp (HsVar (dataConWrapId data_con) `mkHsTyApp` tys) args
\end{code}
+
+------------------------------------------------------
+\begin{code}
+simpleHsLitTy :: HsLit -> TcType
+simpleHsLitTy (HsCharPrim c) = charPrimTy
+simpleHsLitTy (HsStringPrim s) = addrPrimTy
+simpleHsLitTy (HsInt i) = intTy
+simpleHsLitTy (HsInteger i) = integerTy
+simpleHsLitTy (HsIntPrim i) = intPrimTy
+simpleHsLitTy (HsFloatPrim f) = floatPrimTy
+simpleHsLitTy (HsDoublePrim d) = doublePrimTy
+simpleHsLitTy (HsChar c) = charTy
+simpleHsLitTy (HsString str) = stringTy
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection[mkFailurePair]{Code for pattern-matching and other failures}
+%* *
+%************************************************************************
+
+Note: If @outPatType@ doesn't bear a strong resemblance to @exprType@,
+then something is wrong.
+\begin{code}
+outPatType :: TypecheckedPat -> Type
+
+outPatType (WildPat ty) = ty
+outPatType (VarPat var) = idType var
+outPatType (LazyPat pat) = outPatType pat
+outPatType (AsPat var pat) = idType var
+outPatType (ConPat _ ty _ _ _) = ty
+outPatType (ListPat ty _) = mkListTy ty
+outPatType (PArrPat ty _) = mkPArrTy ty
+outPatType (TuplePat pats box) = mkTupleTy box (length pats) (map outPatType pats)
+outPatType (RecPat _ ty _ _ _) = ty
+outPatType (SigPat _ ty _) = ty
+outPatType (LitPat lit ty) = ty
+outPatType (NPat lit ty _) = ty
+outPatType (NPlusKPat _ _ ty _ _) = ty
+outPatType (DictPat ds ms) = case (length ds_ms) of
+ 0 -> unitTy
+ 1 -> idType (head ds_ms)
+ n -> mkTupleTy Boxed n (map idType ds_ms)
+ where
+ ds_ms = ds ++ ms
+\end{code}
+
+
+Nota bene: @DsBinds@ relies on the fact that at least for simple
+tuple patterns @collectTypedPatBinders@ returns the binders in
+the same order as they appear in the tuple.
+
+@collectTypedBinders@ and @collectedTypedPatBinders@ are the exportees.
+
+\begin{code}
+collectTypedPatBinders :: TypecheckedPat -> [Id]
+collectTypedPatBinders (VarPat var) = [var]
+collectTypedPatBinders (LazyPat pat) = collectTypedPatBinders pat
+collectTypedPatBinders (AsPat a pat) = a : collectTypedPatBinders pat
+collectTypedPatBinders (SigPat pat _ _) = collectTypedPatBinders pat
+collectTypedPatBinders (ConPat _ _ _ _ pats) = concat (map collectTypedPatBinders pats)
+collectTypedPatBinders (ListPat t pats) = concat (map collectTypedPatBinders pats)
+collectTypedPatBinders (PArrPat t pats) = concat (map collectTypedPatBinders pats)
+collectTypedPatBinders (TuplePat pats _) = concat (map collectTypedPatBinders pats)
+collectTypedPatBinders (RecPat _ _ _ _ fields) = concat (map (\ (f,pat,_) -> collectTypedPatBinders pat)
+ fields)
+collectTypedPatBinders (DictPat ds ms) = ds ++ ms
+collectTypedPatBinders (NPlusKPat var _ _ _ _) = [var]
+collectTypedPatBinders any_other_pat = [ {-no binders-} ]
+\end{code}
+
+
%************************************************************************
%* *
\subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
zonkIdOcc :: TcId -> NF_TcM Id
zonkIdOcc id
- | not (isLocalId id) || isIP id
- -- We're avoiding looking up superclass selectors
- -- and constructors; zonking them is a no-op anyway, and the
- -- superclass selectors aren't in the environment anyway.
- = returnNF_Tc id
- | otherwise
= tcLookupGlobal_maybe (idName id) `thenNF_Tc` \ maybe_id' ->
+ -- We're even look up up superclass selectors and constructors;
+ -- even though zonking them is a no-op anyway, and the
+ -- superclass selectors aren't in the environment anyway.
+ -- But we don't want to call isLocalId to find out whether
+ -- it's a superclass selector (for example) because that looks
+ -- at the IdInfo field, which in turn be in a knot because of
+ -- the big knot in typecheckModule
let
new_id = case maybe_id' of
Just (AnId id') -> id'
- other -> pprTrace "zonkIdOcc:" (ppr id) id
+ other -> id -- WARN( isLocalId id, ppr id ) id
+ -- Oops: the warning can give a black hole
+ -- because it looks at the idinfo
in
returnNF_Tc new_id
\end{code}
new_globals)
where
zonkExport (tyvars, global, local)
- = zonkTcSigTyVars tyvars `thenNF_Tc` \ new_tyvars ->
+ = zonkTcTyVars tyvars `thenNF_Tc` \ tys ->
+ let
+ new_tyvars = map (tcGetTyVar "zonkExport") tys
-- This isn't the binding occurrence of these tyvars
- -- but they should *be* tyvars. Hence zonkTcSigTyVars.
+ -- but they should *be* tyvars. Hence tcGetTyVar.
+ in
zonkIdBndr global `thenNF_Tc` \ new_global ->
zonkIdOcc local `thenNF_Tc` \ new_local ->
returnNF_Tc (new_tyvars, new_global, new_local)
\begin{code}
zonkMatch :: TcMatch -> NF_TcM TypecheckedMatch
-zonkMatch (Match _ pats _ grhss)
+zonkMatch (Match pats _ grhss)
= zonkPats pats `thenNF_Tc` \ (new_pats, new_ids) ->
tcExtendGlobalValEnv (bagToList new_ids) $
zonkGRHSs grhss `thenNF_Tc` \ new_grhss ->
- returnNF_Tc (Match [] new_pats Nothing new_grhss)
+ returnNF_Tc (Match new_pats Nothing new_grhss)
-------------------------------------------------------------------------
zonkGRHSs :: TcGRHSs
-> NF_TcM TypecheckedGRHSs
-zonkGRHSs (GRHSs grhss binds (Just ty))
+zonkGRHSs (GRHSs grhss binds ty)
= zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) ->
tcSetEnv new_env $
let
in
mapNF_Tc zonk_grhs grhss `thenNF_Tc` \ new_grhss ->
zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
- returnNF_Tc (GRHSs new_grhss new_binds (Just new_ty))
+ returnNF_Tc (GRHSs new_grhss new_binds new_ty)
\end{code}
%************************************************************************
returnNF_Tc (HsVar id')
zonkExpr (HsIPVar id)
- = zonkIdOcc id `thenNF_Tc` \ id' ->
+ = mapIPNameTc zonkIdOcc id `thenNF_Tc` \ id' ->
returnNF_Tc (HsIPVar id')
zonkExpr (HsLit (HsRat f ty))
zonkExpr expr `thenNF_Tc` \ new_expr ->
returnNF_Tc (HsLet new_binds new_expr)
-zonkExpr (HsWith expr binds)
+zonkExpr (HsWith expr binds is_with)
= zonkIPBinds binds `thenNF_Tc` \ new_binds ->
- tcExtendGlobalValEnv (map fst new_binds) $
+ tcExtendGlobalValEnv (map (ipNameName . fst) new_binds) $
zonkExpr expr `thenNF_Tc` \ new_expr ->
- returnNF_Tc (HsWith new_expr new_binds)
+ returnNF_Tc (HsWith new_expr new_binds is_with)
where
zonkIPBinds = mapNF_Tc zonkIPBind
- zonkIPBind (n, e) =
- zonkIdBndr n `thenNF_Tc` \ n' ->
- zonkExpr e `thenNF_Tc` \ e' ->
- returnNF_Tc (n', e')
-
-zonkExpr (HsDo _ _ _) = panic "zonkExpr:HsDo"
+ zonkIPBind (n, e)
+ = mapIPNameTc zonkIdBndr n `thenNF_Tc` \ n' ->
+ zonkExpr e `thenNF_Tc` \ e' ->
+ returnNF_Tc (n', e')
-zonkExpr (HsDoOut do_or_lc stmts return_id then_id zero_id ty src_loc)
+zonkExpr (HsDo do_or_lc stmts ids ty src_loc)
= zonkStmts stmts `thenNF_Tc` \ new_stmts ->
- zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
- zonkIdOcc return_id `thenNF_Tc` \ new_return_id ->
- zonkIdOcc then_id `thenNF_Tc` \ new_then_id ->
- zonkIdOcc zero_id `thenNF_Tc` \ new_zero_id ->
- returnNF_Tc (HsDoOut do_or_lc new_stmts new_return_id new_then_id new_zero_id
- new_ty src_loc)
+ zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
+ mapNF_Tc zonkIdOcc ids `thenNF_Tc` \ new_ids ->
+ returnNF_Tc (HsDo do_or_lc new_stmts new_ids new_ty src_loc)
-zonkExpr (ExplicitList _) = panic "zonkExpr:ExplicitList"
+zonkExpr (ExplicitList ty exprs)
+ = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
+ mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs ->
+ returnNF_Tc (ExplicitList new_ty new_exprs)
-zonkExpr (ExplicitListOut ty exprs)
+zonkExpr (ExplicitPArr ty exprs)
= zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs ->
- returnNF_Tc (ExplicitListOut new_ty new_exprs)
+ returnNF_Tc (ExplicitPArr new_ty new_exprs)
zonkExpr (ExplicitTuple exprs boxed)
= mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs ->
zonkExpr (RecordUpd _ _) = panic "zonkExpr:RecordUpd"
-zonkExpr (RecordUpdOut expr ty dicts rbinds)
+zonkExpr (RecordUpdOut expr in_ty out_ty rbinds)
= zonkExpr expr `thenNF_Tc` \ new_expr ->
- zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
- mapNF_Tc zonkIdOcc dicts `thenNF_Tc` \ new_dicts ->
+ zonkTcTypeToType in_ty `thenNF_Tc` \ new_in_ty ->
+ zonkTcTypeToType out_ty `thenNF_Tc` \ new_out_ty ->
zonkRbinds rbinds `thenNF_Tc` \ new_rbinds ->
- returnNF_Tc (RecordUpdOut new_expr new_ty new_dicts new_rbinds)
+ returnNF_Tc (RecordUpdOut new_expr new_in_ty new_out_ty new_rbinds)
zonkExpr (ExprWithTySig _ _) = panic "zonkExpr:ExprWithTySig"
zonkExpr (ArithSeqIn _) = panic "zonkExpr:ArithSeqIn"
+zonkExpr (PArrSeqIn _) = panic "zonkExpr:PArrSeqIn"
zonkExpr (ArithSeqOut expr info)
= zonkExpr expr `thenNF_Tc` \ new_expr ->
zonkArithSeq info `thenNF_Tc` \ new_info ->
returnNF_Tc (ArithSeqOut new_expr new_info)
+zonkExpr (PArrSeqOut expr info)
+ = zonkExpr expr `thenNF_Tc` \ new_expr ->
+ zonkArithSeq info `thenNF_Tc` \ new_info ->
+ returnNF_Tc (PArrSeqOut new_expr new_info)
+
zonkExpr (HsCCall fun args may_gc is_casm result_ty)
= mapNF_Tc zonkExpr args `thenNF_Tc` \ new_args ->
zonkTcTypeToType result_ty `thenNF_Tc` \ new_result_ty ->
returnNF_Tc (ParStmtOut (zip new_bndrss new_stmtss) : new_stmts)
where (bndrss, stmtss) = unzip bndrstmtss
-zonkStmts [ReturnStmt expr]
- = zonkExpr expr `thenNF_Tc` \ new_expr ->
- returnNF_Tc [ReturnStmt new_expr]
-
-zonkStmts (ExprStmt expr locn : stmts)
+zonkStmts (ResultStmt expr locn : stmts)
= zonkExpr expr `thenNF_Tc` \ new_expr ->
zonkStmts stmts `thenNF_Tc` \ new_stmts ->
- returnNF_Tc (ExprStmt new_expr locn : new_stmts)
+ returnNF_Tc (ResultStmt new_expr locn : new_stmts)
-zonkStmts (GuardStmt expr locn : stmts)
+zonkStmts (ExprStmt expr ty locn : stmts)
= zonkExpr expr `thenNF_Tc` \ new_expr ->
+ zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
zonkStmts stmts `thenNF_Tc` \ new_stmts ->
- returnNF_Tc (GuardStmt new_expr locn : new_stmts)
+ returnNF_Tc (ExprStmt new_expr new_ty locn : new_stmts)
zonkStmts (LetStmt binds : stmts)
= zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) ->
= zonkExpr expr `thenNF_Tc` \ new_expr ->
zonkIdOcc field `thenNF_Tc` \ new_field ->
returnNF_Tc (new_field, new_expr, pun)
+
+-------------------------------------------------------------------------
+mapIPNameTc :: (a -> NF_TcM b) -> IPName a -> NF_TcM (IPName b)
+mapIPNameTc f (Dupable n) = f n `thenNF_Tc` \ r -> returnNF_Tc (Dupable r)
+mapIPNameTc f (Linear n) = f n `thenNF_Tc` \ r -> returnNF_Tc (Linear r)
\end{code}
+
%************************************************************************
%* *
\subsection[BackSubst-Pats]{Patterns}
zonkPats pats `thenNF_Tc` \ (new_pats, ids) ->
returnNF_Tc (ListPat new_ty new_pats, ids)
+zonkPat (PArrPat ty pats)
+ = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
+ zonkPats pats `thenNF_Tc` \ (new_pats, ids) ->
+ returnNF_Tc (PArrPat new_ty new_pats, ids)
+
zonkPat (TuplePat pats boxed)
= zonkPats pats `thenNF_Tc` \ (new_pats, ids) ->
returnNF_Tc (TuplePat new_pats boxed, ids)
zonkPat (ConPat n ty tvs dicts pats)
- = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
+ = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
mapNF_Tc zonkTcTyVarToTyVar tvs `thenNF_Tc` \ new_tvs ->
mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts ->
tcExtendGlobalValEnv new_dicts $
returnNF_Tc ((f, new_pat, pun), ids)
zonkPat (LitPat lit ty)
- = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
+ = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
returnNF_Tc (LitPat lit new_ty, emptyBag)
+zonkPat (SigPat pat ty expr)
+ = zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
+ zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
+ zonkExpr expr `thenNF_Tc` \ new_expr ->
+ returnNF_Tc (SigPat new_pat new_ty new_expr, ids)
+
zonkPat (NPat lit ty expr)
= zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
zonkExpr expr `thenNF_Tc` \ new_expr ->
returnNF_Tc (NPat lit new_ty new_expr, emptyBag)
zonkPat (NPlusKPat n k ty e1 e2)
- = zonkIdBndr n `thenNF_Tc` \ new_n ->
- zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
- zonkExpr e1 `thenNF_Tc` \ new_e1 ->
- zonkExpr e2 `thenNF_Tc` \ new_e2 ->
+ = zonkIdBndr n `thenNF_Tc` \ new_n ->
+ zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
+ zonkExpr e1 `thenNF_Tc` \ new_e1 ->
+ zonkExpr e2 `thenNF_Tc` \ new_e2 ->
returnNF_Tc (NPlusKPat new_n k new_ty new_e1 new_e2, unitBag new_n)
zonkPat (DictPat ds ms)
- = mapNF_Tc zonkIdBndr ds `thenNF_Tc` \ new_ds ->
- mapNF_Tc zonkIdBndr ms `thenNF_Tc` \ new_ms ->
+ = mapNF_Tc zonkIdBndr ds `thenNF_Tc` \ new_ds ->
+ mapNF_Tc zonkIdBndr ms `thenNF_Tc` \ new_ms ->
returnNF_Tc (DictPat new_ds new_ms,
listToBag new_ds `unionBags` listToBag new_ms)
zonkForeignExports ls = mapNF_Tc zonkForeignExport ls
zonkForeignExport :: TcForeignExportDecl -> NF_TcM (TypecheckedForeignDecl)
-zonkForeignExport (ForeignDecl i imp_exp hs_ty ext_nm cconv src_loc) =
+zonkForeignExport (ForeignExport i hs_ty spec isDeprec src_loc) =
zonkIdOcc i `thenNF_Tc` \ i' ->
- returnNF_Tc (ForeignDecl i' imp_exp undefined ext_nm cconv src_loc)
+ returnNF_Tc (ForeignExport i' undefined spec isDeprec src_loc)
\end{code}
\begin{code}
zonkRules :: [TcRuleDecl] -> NF_TcM [TypecheckedRuleDecl]
zonkRules rs = mapNF_Tc zonkRule rs
-zonkRule (HsRule name tyvars vars lhs rhs loc)
- = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
- mapNF_Tc zonkIdBndr [v | RuleBndr v <- vars] `thenNF_Tc` \ new_bndrs ->
- tcExtendGlobalValEnv new_bndrs $
+zonkRule (HsRule name act vars lhs rhs loc)
+ = mapNF_Tc zonk_bndr vars `thenNF_Tc` \ new_bndrs ->
+ tcExtendGlobalValEnv (filter isId new_bndrs) $
+ -- Type variables don't need an envt
+ -- They are bound through the mutable mechanism
zonkExpr lhs `thenNF_Tc` \ new_lhs ->
zonkExpr rhs `thenNF_Tc` \ new_rhs ->
- returnNF_Tc (HsRule name new_tyvars (map RuleBndr new_bndrs) new_lhs new_rhs loc)
+ returnNF_Tc (HsRule name act (map RuleBndr new_bndrs) new_lhs new_rhs loc)
-- I hate this map RuleBndr stuff
+ where
+ zonk_bndr (RuleBndr v)
+ | isId v = zonkIdBndr v
+ | otherwise = zonkTcTyVarToTyVar v
zonkRule (IfaceRuleOut fun rule)
= zonkIdOcc fun `thenNF_Tc` \ fun' ->
returnNF_Tc (IfaceRuleOut fun' rule)
\end{code}
+
projects / ghc-hetmet.git / blobdiff