X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcHsSyn.lhs;h=d691ab4f642c8661aa7b6683f3c47e09f2a40449;hb=1f315e01fbdde2911dddb3b0789418906febc51c;hp=58480b1ffe7d6ae4ae9d9cf2565bbe6e8cac3ae9;hpb=e0d750bedbd33f7a133c8c82c35fd8db537ab649;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index 58480b1..d691ab4 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -25,8 +25,9 @@ module TcHsSyn ( mkHsTyApp, mkHsDictApp, mkHsConApp, mkHsTyLam, mkHsDictLam, mkHsLet, + simpleHsLitTy, - collectTypedPatBinders, outPatType, + collectTypedPatBinders, outPatType, -- re-exported from TcEnv TcId, @@ -47,10 +48,16 @@ import TcEnv ( tcLookupGlobal_maybe, tcExtendGlobalValEnv, TcEnv, TcId ) import TcMonad import Type ( Type ) +import TcType ( TcType ) import TcMType ( zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcType, zonkTcSigTyVars ) -import TysWiredIn ( mkListTy, mkTupleTy, unitTy ) +import TysPrim ( charPrimTy, intPrimTy, floatPrimTy, + doublePrimTy, addrPrimTy + ) +import TysWiredIn ( charTy, stringTy, intTy, integerTy, + mkListTy, mkPArrTy, mkTupleTy, unitTy ) import CoreSyn ( Expr ) -import BasicTypes ( RecFlag(..), Boxity(..) ) +import Var ( isId ) +import BasicTypes ( RecFlag(..), Boxity(..), IPName(..), ipNameName ) import Bag import Outputable import HscTypes ( TyThing(..) ) @@ -122,6 +129,21 @@ mkHsConApp data_con tys args = foldl HsApp (HsVar (dataConWrapId data_con) `mkHs \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} @@ -139,8 +161,10 @@ 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 @@ -164,8 +188,10 @@ 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) @@ -343,11 +369,11 @@ zonkMonoBinds (AbsBinds tyvars dicts exports inlines val_bind) \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 @@ -380,7 +406,7 @@ zonkExpr (HsVar id) 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)) @@ -443,15 +469,15 @@ zonkExpr (HsLet binds expr) zonkExpr (HsWith expr binds) = 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) where zonkIPBinds = mapNF_Tc zonkIPBind - zonkIPBind (n, e) = - zonkIdBndr n `thenNF_Tc` \ n' -> - zonkExpr e `thenNF_Tc` \ e' -> - returnNF_Tc (n', e') + zonkIPBind (n, e) + = mapIPNameTc zonkIdBndr n `thenNF_Tc` \ n' -> + zonkExpr e `thenNF_Tc` \ e' -> + returnNF_Tc (n', e') zonkExpr (HsDo _ _ _) = panic "zonkExpr:HsDo" @@ -469,6 +495,11 @@ zonkExpr (ExplicitList ty exprs) mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs -> returnNF_Tc (ExplicitList new_ty new_exprs) +zonkExpr (ExplicitPArr ty exprs) + = zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> + mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs -> + returnNF_Tc (ExplicitPArr new_ty new_exprs) + zonkExpr (ExplicitTuple exprs boxed) = mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs -> returnNF_Tc (ExplicitTuple new_exprs boxed) @@ -490,12 +521,18 @@ zonkExpr (RecordUpdOut expr in_ty out_ty dicts 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 -> @@ -604,8 +641,14 @@ zonkRbinds rbinds = 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} @@ -637,12 +680,17 @@ zonkPat (ListPat ty pats) 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 $ @@ -667,6 +715,12 @@ zonkPat (LitPat lit 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 -> @@ -707,23 +761,28 @@ zonkForeignExports :: [TcForeignExportDecl] -> NF_TcM [TypecheckedForeignDecl] zonkForeignExports ls = mapNF_Tc zonkForeignExport ls zonkForeignExport :: TcForeignExportDecl -> NF_TcM (TypecheckedForeignDecl) -zonkForeignExport (ForeignExport i hs_ty spec src_loc) = +zonkForeignExport (ForeignExport i hs_ty spec isDeprec src_loc) = zonkIdOcc i `thenNF_Tc` \ i' -> - returnNF_Tc (ForeignExport i' undefined spec 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 act 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 act 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' ->