X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcHsSyn.lhs;h=c2355a04aaf346f0e82db881e8ed8e2fe8c5ea38;hb=3c245de9199f522f75ace92219256badbd928bd6;hp=8968e49f42c590554f5276018cd1c38aadf65d76;hpb=550421384b8364cdaf3135f7859c9f7d7ee1fff1;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index 8968e49..c2355a0 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -8,20 +8,14 @@ checker. \begin{code} module TcHsSyn ( - TcDictBinds, mkHsTyApp, mkHsDictApp, mkHsConApp, - mkHsTyLam, mkHsDictLam, mkHsLet, mkHsApp, + mkHsTyLam, mkHsDictLam, mkHsDictLet, mkHsApp, hsLitType, hsPatType, mkHsAppTy, mkSimpleHsAlt, - nlHsIntLit, glueBindsOnGRHSs, + nlHsIntLit, mkVanillaTuplePat, - -- Coercions - Coercion, ExprCoFn, PatCoFn, - (<$>), (<.>), mkCoercion, - idCoercion, isIdCoercion, - -- re-exported from TcMonad - TcId, TcIdSet, + TcId, TcIdSet, TcDictBinds, zonkTopDecls, zonkTopExpr, zonkTopLExpr, zonkId, zonkTopBndrs @@ -37,38 +31,32 @@ import Id ( idType, setIdType, Id ) import TcRnMonad import Type ( Type ) -import TcType ( TcType, TcTyVar, eqKind, isTypeKind, mkTyVarTy, - tcGetTyVar, isAnyTypeKind, mkTyConApp ) +import TcType ( TcType, TcTyVar, mkTyVarTy, mkTyConApp, isImmutableTyVar ) +import Kind ( isLiftedTypeKind, liftedTypeKind, isSubKind ) import qualified Type -import TcMType ( zonkTcTyVarToTyVar, zonkType, zonkTcType, zonkTcTyVars, - putTcTyVar ) +import TcMType ( zonkQuantifiedTyVar, zonkType, zonkTcType, writeMetaTyVar ) import TysPrim ( charPrimTy, intPrimTy, floatPrimTy, doublePrimTy, addrPrimTy ) import TysWiredIn ( charTy, stringTy, intTy, mkListTy, mkPArrTy, mkTupleTy, unitTy, voidTy, listTyCon, tupleTyCon ) -import TyCon ( mkPrimTyCon, tyConKind ) -import PrimRep ( PrimRep(VoidRep) ) -import Name ( getOccName, mkInternalName, mkDerivedTyConOcc ) +import TyCon ( mkPrimTyCon, tyConKind, PrimRep(..) ) +import Kind ( splitKindFunTys ) +import Name ( Name, getOccName, mkInternalName, mkDerivedTyConOcc ) import Var ( Var, isId, isLocalVar, tyVarKind ) import VarSet import VarEnv import BasicTypes ( Boxity(..), IPName(..), ipNameName, mapIPName ) import Maybes ( orElse ) -import Maybe ( isNothing ) import Unique ( Uniquable(..) ) import SrcLoc ( noSrcLoc, noLoc, Located(..), unLoc ) +import Util ( mapSnd ) import Bag import Outputable \end{code} -\begin{code} -type TcDictBinds = LHsBinds TcId -- Bag of dictionary bindings -\end{code} - - %************************************************************************ %* * \subsection[mkFailurePair]{Code for pattern-matching and other failures} @@ -78,23 +66,30 @@ type TcDictBinds = LHsBinds TcId -- Bag of dictionary bindings Note: If @hsPatType@ doesn't bear a strong resemblance to @exprType@, then something is wrong. \begin{code} +mkVanillaTuplePat :: [OutPat Id] -> Boxity -> Pat Id +-- A vanilla tuple pattern simply gets its type from its sub-patterns +mkVanillaTuplePat pats box + = TuplePat pats box (mkTupleTy box (length pats) (map hsPatType pats)) + hsPatType :: OutPat Id -> Type -hsPatType pat = pat_type (unLoc pat) - -pat_type (ParPat pat) = hsPatType pat -pat_type (WildPat ty) = ty -pat_type (VarPat var) = idType var -pat_type (LazyPat pat) = hsPatType pat -pat_type (LitPat lit) = hsLitType lit -pat_type (AsPat var pat) = idType (unLoc var) -pat_type (ListPat _ ty) = mkListTy ty -pat_type (PArrPat _ ty) = mkPArrTy ty -pat_type (TuplePat pats box) = mkTupleTy box (length pats) (map hsPatType pats) -pat_type (ConPatOut _ _ ty _ _) = ty -pat_type (SigPatOut _ ty _) = ty -pat_type (NPatOut lit ty _) = ty -pat_type (NPlusKPatOut id _ _ _) = idType (unLoc id) -pat_type (DictPat ds ms) = case (ds ++ ms) of +hsPatType (L _ pat) = pat_type pat + +pat_type (ParPat pat) = hsPatType pat +pat_type (WildPat ty) = ty +pat_type (VarPat var) = idType var +pat_type (VarPatOut var _) = idType var +pat_type (BangPat pat) = hsPatType pat +pat_type (LazyPat pat) = hsPatType pat +pat_type (LitPat lit) = hsLitType lit +pat_type (AsPat var pat) = idType (unLoc var) +pat_type (ListPat _ ty) = mkListTy ty +pat_type (PArrPat _ ty) = mkPArrTy ty +pat_type (TuplePat pats box ty) = ty +pat_type (ConPatOut _ _ _ _ _ ty) = ty +pat_type (SigPatOut pat ty) = ty +pat_type (NPat lit _ _ ty) = ty +pat_type (NPlusKPat id _ _ _) = idType (unLoc id) +pat_type (DictPat ds ms) = case (ds ++ ms) of [] -> unitTy [d] -> idType d ds -> mkTupleTy Boxed (length ds) (map idType ds) @@ -113,39 +108,6 @@ hsLitType (HsFloatPrim f) = floatPrimTy hsLitType (HsDoublePrim d) = doublePrimTy \end{code} -%************************************************************************ -%* * -\subsection{Coercion functions} -%* * -%************************************************************************ - -\begin{code} -type Coercion a = Maybe (a -> a) - -- Nothing => identity fn - -type ExprCoFn = Coercion (HsExpr TcId) -type PatCoFn = Coercion (Pat TcId) - -(<.>) :: Coercion a -> Coercion a -> Coercion a -- Composition -Nothing <.> Nothing = Nothing -Nothing <.> Just f = Just f -Just f <.> Nothing = Just f -Just f1 <.> Just f2 = Just (f1 . f2) - -(<$>) :: Coercion a -> a -> a -Just f <$> e = f e -Nothing <$> e = e - -mkCoercion :: (a -> a) -> Coercion a -mkCoercion f = Just f - -idCoercion :: Coercion a -idCoercion = Nothing - -isIdCoercion :: Coercion a -> Bool -isIdCoercion = isNothing -\end{code} - %************************************************************************ %* * @@ -190,16 +152,22 @@ extendZonkEnv :: ZonkEnv -> [Id] -> ZonkEnv extendZonkEnv (ZonkEnv zonk_ty env) ids = ZonkEnv zonk_ty (extendVarEnvList env [(id,id) | id <- ids]) +extendZonkEnv1 :: ZonkEnv -> Id -> ZonkEnv +extendZonkEnv1 (ZonkEnv zonk_ty env) id + = ZonkEnv zonk_ty (extendVarEnv env id id) + setZonkType :: ZonkEnv -> (TcType -> TcM Type) -> ZonkEnv setZonkType (ZonkEnv _ env) zonk_ty = ZonkEnv zonk_ty env -mkZonkEnv :: [Id] -> ZonkEnv -mkZonkEnv ids = extendZonkEnv emptyZonkEnv ids +zonkEnvIds :: ZonkEnv -> [Id] +zonkEnvIds (ZonkEnv _ env) = varEnvElts env zonkIdOcc :: ZonkEnv -> TcId -> Id -- Ids defined in this module should be in the envt; -- ignore others. (Actually, data constructors are also -- not LocalVars, even when locally defined, but that is fine.) +-- (Also foreign-imported things aren't currently in the ZonkEnv; +-- that's ok because they don't need zonking.) -- -- Actually, Template Haskell works in 'chunks' of declarations, and -- an earlier chunk won't be in the 'env' that the zonking phase @@ -209,7 +177,7 @@ zonkIdOcc :: ZonkEnv -> TcId -> Id -- 'orElse' case in the LocalVar branch. -- -- Even without template splices, in module Main, the checking of --- 'main' is done as a separte chunk. +-- 'main' is done as a separate chunk. zonkIdOcc (ZonkEnv zonk_ty env) id | isLocalVar id = lookupVarEnv env id `orElse` id | otherwise = id @@ -238,99 +206,109 @@ zonkTopExpr e = zonkExpr emptyZonkEnv e zonkTopLExpr :: LHsExpr TcId -> TcM (LHsExpr Id) zonkTopLExpr e = zonkLExpr emptyZonkEnv e -zonkTopDecls :: Bag (LHsBind TcId) -> [LRuleDecl TcId] -> [LForeignDecl TcId] +zonkTopDecls :: LHsBinds TcId -> [LRuleDecl TcId] -> [LForeignDecl TcId] -> TcM ([Id], Bag (LHsBind Id), [LForeignDecl Id], [LRuleDecl Id]) -zonkTopDecls binds rules fords -- Top level is implicitly recursive - = fixM (\ ~(new_ids, _, _, _) -> - let - zonk_env = mkZonkEnv new_ids - in - zonkMonoBinds zonk_env binds `thenM` \ binds' -> - zonkRules zonk_env rules `thenM` \ rules' -> - zonkForeignExports zonk_env fords `thenM` \ fords' -> - - returnM (collectHsBindBinders binds', binds', fords', rules') - ) +zonkTopDecls binds rules fords + = do { (env, binds') <- zonkRecMonoBinds emptyZonkEnv binds + -- Top level is implicitly recursive + ; rules' <- zonkRules env rules + ; fords' <- zonkForeignExports env fords + ; return (zonkEnvIds env, binds', fords', rules') } --------------------------------------------- -zonkGroup :: ZonkEnv -> HsBindGroup TcId -> TcM (ZonkEnv, HsBindGroup Id) -zonkGroup env (HsBindGroup bs sigs is_rec) - = ASSERT( null sigs ) - do { (env1, bs') <- fixM (\ ~(_, new_binds) -> do - { let env1 = extendZonkEnv env (collectHsBindBinders new_binds) - ; bs' <- zonkMonoBinds env1 bs - ; return (env1, bs') }) - ; return (env1, HsBindGroup bs' [] is_rec) } - - -zonkGroup env (HsIPBinds binds) +zonkLocalBinds :: ZonkEnv -> HsLocalBinds TcId -> TcM (ZonkEnv, HsLocalBinds Id) +zonkLocalBinds env EmptyLocalBinds + = return (env, EmptyLocalBinds) + +zonkLocalBinds env (HsValBinds binds) + = do { (env1, new_binds) <- zonkValBinds env binds + ; return (env1, HsValBinds new_binds) } + +zonkLocalBinds env (HsIPBinds (IPBinds binds dict_binds)) = mappM (wrapLocM zonk_ip_bind) binds `thenM` \ new_binds -> let env1 = extendZonkEnv env [ipNameName n | L _ (IPBind n _) <- new_binds] in - returnM (env1, HsIPBinds new_binds) + zonkRecMonoBinds env1 dict_binds `thenM` \ (env2, new_dict_binds) -> + returnM (env2, HsIPBinds (IPBinds new_binds new_dict_binds)) where zonk_ip_bind (IPBind n e) = mapIPNameTc (zonkIdBndr env) n `thenM` \ n' -> zonkLExpr env e `thenM` \ e' -> returnM (IPBind n' e') + +--------------------------------------------- +zonkValBinds :: ZonkEnv -> HsValBinds TcId -> TcM (ZonkEnv, HsValBinds Id) +zonkValBinds env bs@(ValBindsIn _ _) + = panic "zonkValBinds" -- Not in typechecker output +zonkValBinds env (ValBindsOut binds sigs) + = do { (env1, new_binds) <- go env binds + ; return (env1, ValBindsOut new_binds sigs) } + where + go env [] = return (env, []) + go env ((r,b):bs) = do { (env1, b') <- zonkRecMonoBinds env b + ; (env2, bs') <- go env1 bs + ; return (env2, (r,b'):bs') } + --------------------------------------------- -zonkNestedBinds :: ZonkEnv -> [HsBindGroup TcId] -> TcM (ZonkEnv, [HsBindGroup Id]) -zonkNestedBinds env [] = return (env, []) -zonkNestedBinds env (b:bs) = do { (env1, b') <- zonkGroup env b - ; (env2, bs') <- zonkNestedBinds env1 bs - ; return (env2, b':bs') } +zonkRecMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (ZonkEnv, LHsBinds Id) +zonkRecMonoBinds env binds + = fixM (\ ~(_, new_binds) -> do + { let env1 = extendZonkEnv env (collectHsBindBinders new_binds) + ; binds' <- zonkMonoBinds env1 binds + ; return (env1, binds') }) --------------------------------------------- -zonkMonoBinds :: ZonkEnv -> Bag (LHsBind TcId) -> TcM (Bag (LHsBind Id)) +zonkMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (LHsBinds Id) zonkMonoBinds env binds = mapBagM (wrapLocM (zonk_bind env)) binds zonk_bind :: ZonkEnv -> HsBind TcId -> TcM (HsBind Id) -zonk_bind env (PatBind pat grhss) - = zonkPat env pat `thenM` \ (new_pat, _) -> - zonkGRHSs env grhss `thenM` \ new_grhss -> - returnM (PatBind new_pat new_grhss) +zonk_bind env bind@(PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty}) + = do { (_env, new_pat) <- zonkPat env pat -- Env already extended + ; new_grhss <- zonkGRHSs env grhss + ; new_ty <- zonkTcTypeToType env ty + ; return (bind { pat_lhs = new_pat, pat_rhs = new_grhss, pat_rhs_ty = new_ty }) } -zonk_bind env (VarBind var expr) +zonk_bind env (VarBind { var_id = var, var_rhs = expr }) = zonkIdBndr env var `thenM` \ new_var -> zonkLExpr env expr `thenM` \ new_expr -> - returnM (VarBind new_var new_expr) + returnM (VarBind { var_id = new_var, var_rhs = new_expr }) -zonk_bind env (FunBind var inf ms) +zonk_bind env bind@(FunBind { fun_id = var, fun_matches = ms, fun_co_fn = co_fn }) = wrapLocM (zonkIdBndr env) var `thenM` \ new_var -> - mappM (zonkMatch env) ms `thenM` \ new_ms -> - returnM (FunBind new_var inf new_ms) - -zonk_bind env (AbsBinds tyvars dicts exports inlines val_binds) - = mappM zonkTcTyVarToTyVar tyvars `thenM` \ new_tyvars -> - -- No need to extend tyvar env: the effects are - -- propagated through binding the tyvars themselves + zonkCoFn env co_fn `thenM` \ (env1, new_co_fn) -> + zonkMatchGroup env1 ms `thenM` \ new_ms -> + returnM (bind { fun_id = new_var, fun_matches = new_ms, fun_co_fn = new_co_fn }) +zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_dicts = dicts, + abs_exports = exports, abs_binds = val_binds }) + = ASSERT( all isImmutableTyVar tyvars ) zonkIdBndrs env dicts `thenM` \ new_dicts -> fixM (\ ~(new_val_binds, _) -> let - env1 = extendZonkEnv (extendZonkEnv env new_dicts) - (collectHsBindBinders new_val_binds) + env1 = extendZonkEnv env new_dicts + env2 = extendZonkEnv env1 (collectHsBindBinders new_val_binds) in - zonkMonoBinds env1 val_binds `thenM` \ new_val_binds -> - mappM (zonkExport env1) exports `thenM` \ new_exports -> + zonkMonoBinds env2 val_binds `thenM` \ new_val_binds -> + mappM (zonkExport env2) exports `thenM` \ new_exports -> returnM (new_val_binds, new_exports) ) `thenM` \ (new_val_bind, new_exports) -> - returnM (AbsBinds new_tyvars new_dicts new_exports inlines new_val_bind) + returnM (AbsBinds { abs_tvs = tyvars, abs_dicts = new_dicts, + abs_exports = new_exports, abs_binds = new_val_bind }) where - zonkExport env (tyvars, global, local) - = zonkTcTyVars tyvars `thenM` \ tys -> - let - new_tyvars = map (tcGetTyVar "zonkExport") tys - -- This isn't the binding occurrence of these tyvars - -- but they should *be* tyvars. Hence tcGetTyVar. - in - zonkIdBndr env global `thenM` \ new_global -> - returnM (new_tyvars, new_global, zonkIdOcc env local) + zonkExport env (tyvars, global, local, prags) + = zonkIdBndr env global `thenM` \ new_global -> + mapM zonk_prag prags `thenM` \ new_prags -> + returnM (tyvars, new_global, zonkIdOcc env local, new_prags) + zonk_prag prag@(InlinePrag {}) = return prag + zonk_prag (SpecPrag expr ty ds inl) = do { expr' <- zonkExpr env expr + ; ty' <- zonkTcTypeToType env ty + ; let ds' = zonkIdOccs env ds + ; return (SpecPrag expr' ty' ds' inl) } \end{code} %************************************************************************ @@ -340,26 +318,31 @@ zonk_bind env (AbsBinds tyvars dicts exports inlines val_binds) %************************************************************************ \begin{code} -zonkMatch :: ZonkEnv -> LMatch TcId-> TcM (LMatch Id) +zonkMatchGroup :: ZonkEnv -> MatchGroup TcId-> TcM (MatchGroup Id) +zonkMatchGroup env (MatchGroup ms ty) + = do { ms' <- mapM (zonkMatch env) ms + ; ty' <- zonkTcTypeToType env ty + ; return (MatchGroup ms' ty') } +zonkMatch :: ZonkEnv -> LMatch TcId-> TcM (LMatch Id) zonkMatch env (L loc (Match pats _ grhss)) - = zonkPats env pats `thenM` \ (new_pats, new_ids) -> - zonkGRHSs (extendZonkEnv env (bagToList new_ids)) grhss `thenM` \ new_grhss -> - returnM (L loc (Match new_pats Nothing new_grhss)) + = do { (env1, new_pats) <- zonkPats env pats + ; new_grhss <- zonkGRHSs env1 grhss + ; return (L loc (Match new_pats Nothing new_grhss)) } ------------------------------------------------------------------------- zonkGRHSs :: ZonkEnv -> GRHSs TcId -> TcM (GRHSs Id) -zonkGRHSs env (GRHSs grhss binds ty) - = zonkNestedBinds env binds `thenM` \ (new_env, new_binds) -> +zonkGRHSs env (GRHSs grhss binds) + = zonkLocalBinds env binds `thenM` \ (new_env, new_binds) -> let - zonk_grhs (GRHS guarded) - = zonkStmts new_env guarded `thenM` \ new_guarded -> - returnM (GRHS new_guarded) + zonk_grhs (GRHS guarded rhs) + = zonkStmts new_env guarded `thenM` \ (env2, new_guarded) -> + zonkLExpr env2 rhs `thenM` \ new_rhs -> + returnM (GRHS new_guarded new_rhs) in mappM (wrapLocM zonk_grhs) grhss `thenM` \ new_grhss -> - zonkTcTypeToType env ty `thenM` \ new_ty -> - returnM (GRHSs new_grhss new_binds new_ty) + returnM (GRHSs new_grhss new_binds) \end{code} %************************************************************************ @@ -389,11 +372,13 @@ zonkExpr env (HsLit (HsRat f ty)) zonkExpr env (HsLit lit) = returnM (HsLit lit) --- HsOverLit doesn't appear in typechecker output +zonkExpr env (HsOverLit lit) + = do { lit' <- zonkOverLit env lit + ; return (HsOverLit lit') } -zonkExpr env (HsLam match) - = zonkMatch env match `thenM` \ new_match -> - returnM (HsLam new_match) +zonkExpr env (HsLam matches) + = zonkMatchGroup env matches `thenM` \ new_matches -> + returnM (HsLam new_matches) zonkExpr env (HsApp e1 e2) = zonkLExpr env e1 `thenM` \ new_e1 -> @@ -407,8 +392,8 @@ zonkExpr env (HsBracketOut body bs) zonk_b (n,e) = zonkLExpr env e `thenM` \ e' -> returnM (n,e') -zonkExpr env (HsSplice n e) = WARN( True, ppr e ) -- Should not happen - returnM (HsSplice n e) +zonkExpr env (HsSpliceE s) = WARN( True, ppr s ) -- Should not happen + returnM (HsSpliceE s) zonkExpr env (OpApp e1 op fixity e2) = zonkLExpr env e1 `thenM` \ new_e1 -> @@ -416,7 +401,10 @@ zonkExpr env (OpApp e1 op fixity e2) zonkLExpr env e2 `thenM` \ new_e2 -> returnM (OpApp new_e1 new_op fixity new_e2) -zonkExpr env (NegApp _ _) = panic "zonkExpr env: NegApp" +zonkExpr env (NegApp expr op) + = zonkLExpr env expr `thenM` \ new_expr -> + zonkExpr env op `thenM` \ new_op -> + returnM (NegApp new_expr new_op) zonkExpr env (HsPar e) = zonkLExpr env e `thenM` \new_e -> @@ -434,7 +422,7 @@ zonkExpr env (SectionR op expr) zonkExpr env (HsCase expr ms) = zonkLExpr env expr `thenM` \ new_expr -> - mappM (zonkMatch env) ms `thenM` \ new_ms -> + zonkMatchGroup env ms `thenM` \ new_ms -> returnM (HsCase new_expr new_ms) zonkExpr env (HsIf e1 e2 e3) @@ -444,15 +432,16 @@ zonkExpr env (HsIf e1 e2 e3) returnM (HsIf new_e1 new_e2 new_e3) zonkExpr env (HsLet binds expr) - = zonkNestedBinds env binds `thenM` \ (new_env, new_binds) -> + = zonkLocalBinds env binds `thenM` \ (new_env, new_binds) -> zonkLExpr new_env expr `thenM` \ new_expr -> returnM (HsLet new_binds new_expr) -zonkExpr env (HsDo do_or_lc stmts ids ty) - = zonkStmts env stmts `thenM` \ new_stmts -> +zonkExpr env (HsDo do_or_lc stmts body ty) + = zonkStmts env stmts `thenM` \ (new_env, new_stmts) -> + zonkLExpr new_env body `thenM` \ new_body -> zonkTcTypeToType env ty `thenM` \ new_ty -> - zonkReboundNames env ids `thenM` \ new_ids -> - returnM (HsDo do_or_lc new_stmts new_ids new_ty) + returnM (HsDo (zonkDo env do_or_lc) + new_stmts new_body new_ty) zonkExpr env (ExplicitList ty exprs) = zonkTcTypeToType env ty `thenM` \ new_ty -> @@ -468,33 +457,33 @@ zonkExpr env (ExplicitTuple exprs boxed) = zonkLExprs env exprs `thenM` \ new_exprs -> returnM (ExplicitTuple new_exprs boxed) -zonkExpr env (RecordConOut data_con con_expr rbinds) - = zonkLExpr env con_expr `thenM` \ new_con_expr -> +zonkExpr env (RecordCon data_con con_expr rbinds) + = zonkExpr env con_expr `thenM` \ new_con_expr -> zonkRbinds env rbinds `thenM` \ new_rbinds -> - returnM (RecordConOut data_con new_con_expr new_rbinds) + returnM (RecordCon data_con new_con_expr new_rbinds) -zonkExpr env (RecordUpd _ _) = panic "zonkExpr env:RecordUpd" - -zonkExpr env (RecordUpdOut expr in_ty out_ty rbinds) +zonkExpr env (RecordUpd expr rbinds in_ty out_ty) = zonkLExpr env expr `thenM` \ new_expr -> zonkTcTypeToType env in_ty `thenM` \ new_in_ty -> zonkTcTypeToType env out_ty `thenM` \ new_out_ty -> zonkRbinds env rbinds `thenM` \ new_rbinds -> - returnM (RecordUpdOut new_expr new_in_ty new_out_ty new_rbinds) + returnM (RecordUpd new_expr new_rbinds new_in_ty new_out_ty) + +zonkExpr env (ExprWithTySigOut e ty) + = do { e' <- zonkLExpr env e + ; return (ExprWithTySigOut e' ty) } zonkExpr env (ExprWithTySig _ _) = panic "zonkExpr env:ExprWithTySig" -zonkExpr env (ArithSeqIn _) = panic "zonkExpr env:ArithSeqIn" -zonkExpr env (PArrSeqIn _) = panic "zonkExpr env:PArrSeqIn" -zonkExpr env (ArithSeqOut expr info) - = zonkLExpr env expr `thenM` \ new_expr -> +zonkExpr env (ArithSeq expr info) + = zonkExpr env expr `thenM` \ new_expr -> zonkArithSeq env info `thenM` \ new_info -> - returnM (ArithSeqOut new_expr new_info) + returnM (ArithSeq new_expr new_info) -zonkExpr env (PArrSeqOut expr info) - = zonkLExpr env expr `thenM` \ new_expr -> +zonkExpr env (PArrSeq expr info) + = zonkExpr env expr `thenM` \ new_expr -> zonkArithSeq env info `thenM` \ new_info -> - returnM (PArrSeqOut new_expr new_info) + returnM (PArrSeq new_expr new_info) zonkExpr env (HsSCC lbl expr) = zonkLExpr env expr `thenM` \ new_expr -> @@ -506,15 +495,13 @@ zonkExpr env (HsCoreAnn lbl expr) returnM (HsCoreAnn lbl new_expr) zonkExpr env (TyLam tyvars expr) - = mappM zonkTcTyVarToTyVar tyvars `thenM` \ new_tyvars -> - -- No need to extend tyvar env; see AbsBinds - + = ASSERT( all isImmutableTyVar tyvars ) zonkLExpr env expr `thenM` \ new_expr -> - returnM (TyLam new_tyvars new_expr) + returnM (TyLam tyvars new_expr) zonkExpr env (TyApp expr tys) - = zonkLExpr env expr `thenM` \ new_expr -> - mappM (zonkTcTypeToType env) tys `thenM` \ new_tys -> + = zonkLExpr env expr `thenM` \ new_expr -> + zonkTcTypeToTypes env tys `thenM` \ new_tys -> returnM (TyApp new_expr new_tys) zonkExpr env (DictLam dicts expr) @@ -531,12 +518,9 @@ zonkExpr env (DictApp expr dicts) -- arrow notation extensions zonkExpr env (HsProc pat body) - = zonkPat env pat `thenM` \ (new_pat, new_ids) -> - let - env1 = extendZonkEnv env (bagToList new_ids) - in - zonkCmdTop env1 body `thenM` \ new_body -> - returnM (HsProc new_pat new_body) + = do { (env1, new_pat) <- zonkPat env pat + ; new_body <- zonkCmdTop env1 body + ; return (HsProc new_pat new_body) } zonkExpr env (HsArrApp e1 e2 ty ho rl) = zonkLExpr env e1 `thenM` \ new_e1 -> @@ -549,27 +533,60 @@ zonkExpr env (HsArrForm op fixity args) mappM (zonkCmdTop env) args `thenM` \ new_args -> returnM (HsArrForm new_op fixity new_args) +zonkExpr env (HsCoerce co_fn expr) + = zonkCoFn env co_fn `thenM` \ (env1, new_co_fn) -> + zonkExpr env1 expr `thenM` \ new_expr -> + return (HsCoerce new_co_fn new_expr) + +zonkExpr env other = pprPanic "zonkExpr" (ppr other) + zonkCmdTop :: ZonkEnv -> LHsCmdTop TcId -> TcM (LHsCmdTop Id) zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids) - = zonkLExpr env cmd `thenM` \ new_cmd -> - mappM (zonkTcTypeToType env) stack_tys - `thenM` \ new_stack_tys -> + = zonkLExpr env cmd `thenM` \ new_cmd -> + zonkTcTypeToTypes env stack_tys `thenM` \ new_stack_tys -> zonkTcTypeToType env ty `thenM` \ new_ty -> - zonkReboundNames env ids `thenM` \ new_ids -> + mapSndM (zonkExpr env) ids `thenM` \ new_ids -> returnM (HsCmdTop new_cmd new_stack_tys new_ty new_ids) ------------------------------------------------------------------------- -zonkReboundNames :: ZonkEnv -> ReboundNames Id -> TcM (ReboundNames Id) -zonkReboundNames env prs - = mapM zonk prs - where - zonk (n, e) = zonkLExpr env e `thenM` \ new_e -> - returnM (n, new_e) +zonkCoFn :: ZonkEnv -> ExprCoFn -> TcM (ZonkEnv, ExprCoFn) +zonkCoFn env CoHole = return (env, CoHole) +zonkCoFn env (CoCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1 + ; (env2, c2') <- zonkCoFn env1 c2 + ; return (env2, CoCompose c1' c2') } +zonkCoFn env (CoLams ids c) = do { ids' <- zonkIdBndrs env ids + ; let env1 = extendZonkEnv env ids' + ; (env2, c') <- zonkCoFn env1 c + ; return (env2, CoLams ids' c') } +zonkCoFn env (CoTyLams tvs c) = ASSERT( all isImmutableTyVar tvs ) + do { (env1, c') <- zonkCoFn env c + ; return (env1, CoTyLams tvs c') } +zonkCoFn env (CoApps c ids) = do { (env1, c') <- zonkCoFn env c + ; return (env1, CoApps c' (zonkIdOccs env ids)) } +zonkCoFn env (CoTyApps c tys) = do { tys' <- zonkTcTypeToTypes env tys + ; (env1, c') <- zonkCoFn env c + ; return (env1, CoTyApps c' tys') } +zonkCoFn env (CoLet bs c) = do { (env1, bs') <- zonkRecMonoBinds env bs + ; (env2, c') <- zonkCoFn env1 c + ; return (env2, CoLet bs' c') } ------------------------------------------------------------------------- +zonkDo :: ZonkEnv -> HsStmtContext Name -> HsStmtContext Name +-- Only used for 'do', so the only Ids are in a MDoExpr table +zonkDo env (MDoExpr tbl) = MDoExpr (mapSnd (zonkIdOcc env) tbl) +zonkDo env do_or_lc = do_or_lc + +------------------------------------------------------------------------- +zonkOverLit :: ZonkEnv -> HsOverLit TcId -> TcM (HsOverLit Id) +zonkOverLit env (HsIntegral i e) + = do { e' <- zonkExpr env e; return (HsIntegral i e') } +zonkOverLit env (HsFractional r e) + = do { e' <- zonkExpr env e; return (HsFractional r e') } + +------------------------------------------------------------------------- zonkArithSeq :: ZonkEnv -> ArithSeqInfo TcId -> TcM (ArithSeqInfo Id) zonkArithSeq env (From e) @@ -594,16 +611,11 @@ zonkArithSeq env (FromThenTo e1 e2 e3) ------------------------------------------------------------------------- -zonkStmts :: ZonkEnv -> [LStmt TcId] -> TcM [LStmt Id] - -zonkStmts env stmts = zonk_stmts env stmts `thenM` \ (_, stmts) -> - returnM stmts - -zonk_stmts :: ZonkEnv -> [LStmt TcId] -> TcM (ZonkEnv, [LStmt Id]) -zonk_stmts env [] = return (env, []) -zonk_stmts env (s:ss) = do { (env1, s') <- wrapLocSndM (zonkStmt env) s - ; (env2, ss') <- zonk_stmts env1 ss - ; return (env2, s' : ss') } +zonkStmts :: ZonkEnv -> [LStmt TcId] -> TcM (ZonkEnv, [LStmt Id]) +zonkStmts env [] = return (env, []) +zonkStmts env (s:ss) = do { (env1, s') <- wrapLocSndM (zonkStmt env) s + ; (env2, ss') <- zonkStmts env1 ss + ; return (env2, s' : ss') } zonkStmt :: ZonkEnv -> Stmt TcId -> TcM (ZonkEnv, Stmt Id) zonkStmt env (ParStmt stmts_w_bndrs) @@ -614,45 +626,41 @@ zonkStmt env (ParStmt stmts_w_bndrs) in return (env1, ParStmt new_stmts_w_bndrs) where - zonk_branch (stmts, bndrs) = zonk_stmts env stmts `thenM` \ (env1, new_stmts) -> + zonk_branch (stmts, bndrs) = zonkStmts env stmts `thenM` \ (env1, new_stmts) -> returnM (new_stmts, zonkIdOccs env1 bndrs) -zonkStmt env (RecStmt segStmts lvs rvs rets) +zonkStmt env (RecStmt segStmts lvs rvs rets binds) = zonkIdBndrs env rvs `thenM` \ new_rvs -> let env1 = extendZonkEnv env new_rvs in - zonk_stmts env1 segStmts `thenM` \ (env2, new_segStmts) -> + zonkStmts env1 segStmts `thenM` \ (env2, new_segStmts) -> -- Zonk the ret-expressions in an envt that -- has the polymorphic bindings in the envt - zonkLExprs env2 rets `thenM` \ new_rets -> + mapM (zonkExpr env2) rets `thenM` \ new_rets -> let new_lvs = zonkIdOccs env2 lvs env3 = extendZonkEnv env new_lvs -- Only the lvs are needed in - returnM (env3, RecStmt new_segStmts new_lvs new_rvs new_rets) - -zonkStmt env (ResultStmt expr) - = zonkLExpr env expr `thenM` \ new_expr -> - returnM (env, ResultStmt new_expr) + zonkRecMonoBinds env3 binds `thenM` \ (env4, new_binds) -> + returnM (env4, RecStmt new_segStmts new_lvs new_rvs new_rets new_binds) -zonkStmt env (ExprStmt expr ty) +zonkStmt env (ExprStmt expr then_op ty) = zonkLExpr env expr `thenM` \ new_expr -> + zonkExpr env then_op `thenM` \ new_then -> zonkTcTypeToType env ty `thenM` \ new_ty -> - returnM (env, ExprStmt new_expr new_ty) + returnM (env, ExprStmt new_expr new_then new_ty) zonkStmt env (LetStmt binds) - = zonkNestedBinds env binds `thenM` \ (env1, new_binds) -> + = zonkLocalBinds env binds `thenM` \ (env1, new_binds) -> returnM (env1, LetStmt new_binds) -zonkStmt env (BindStmt pat expr) - = zonkLExpr env expr `thenM` \ new_expr -> - zonkPat env pat `thenM` \ (new_pat, new_ids) -> - let - env1 = extendZonkEnv env (bagToList new_ids) - in - returnM (env1, BindStmt new_pat new_expr) - +zonkStmt env (BindStmt pat expr bind_op fail_op) + = do { new_expr <- zonkLExpr env expr + ; (env1, new_pat) <- zonkPat env pat + ; new_bind <- zonkExpr env bind_op + ; new_fail <- zonkExpr env fail_op + ; return (env1, BindStmt new_pat new_expr new_bind new_fail) } ------------------------------------------------------------------------- @@ -679,106 +687,116 @@ mapIPNameTc f (Linear n) = f n `thenM` \ r -> returnM (Linear r) %************************************************************************ \begin{code} -zonkPat :: ZonkEnv -> OutPat TcId -> TcM (OutPat Id, Bag Id) -zonkPat env pat = wrapLocFstM (zonk_pat env) pat +zonkPat :: ZonkEnv -> OutPat TcId -> TcM (ZonkEnv, OutPat Id) +-- Extend the environment as we go, because it's possible for one +-- pattern to bind something that is used in another (inside or +-- to the right) +zonkPat env pat = wrapLocSndM (zonk_pat env) pat zonk_pat env (ParPat p) - = zonkPat env p `thenM` \ (new_p, ids) -> - returnM (ParPat new_p, ids) + = do { (env', p') <- zonkPat env p + ; return (env', ParPat p') } zonk_pat env (WildPat ty) - = zonkTcTypeToType env ty `thenM` \ new_ty -> - returnM (WildPat new_ty, emptyBag) + = do { ty' <- zonkTcTypeToType env ty + ; return (env, WildPat ty') } zonk_pat env (VarPat v) - = zonkIdBndr env v `thenM` \ new_v -> - returnM (VarPat new_v, unitBag new_v) + = do { v' <- zonkIdBndr env v + ; return (extendZonkEnv1 env v', VarPat v') } + +zonk_pat env (VarPatOut v binds) + = do { v' <- zonkIdBndr env v + ; (env', binds') <- zonkRecMonoBinds (extendZonkEnv1 env v') binds + ; returnM (env', VarPatOut v' binds') } zonk_pat env (LazyPat pat) - = zonkPat env pat `thenM` \ (new_pat, ids) -> - returnM (LazyPat new_pat, ids) + = do { (env', pat') <- zonkPat env pat + ; return (env', LazyPat pat') } -zonk_pat env (AsPat n pat) - = wrapLocM (zonkIdBndr env) n `thenM` \ new_n -> - zonkPat env pat `thenM` \ (new_pat, ids) -> - returnM (AsPat new_n new_pat, unLoc new_n `consBag` ids) +zonk_pat env (BangPat pat) + = do { (env', pat') <- zonkPat env pat + ; return (env', BangPat pat') } + +zonk_pat env (AsPat (L loc v) pat) + = do { v' <- zonkIdBndr env v + ; (env', pat') <- zonkPat (extendZonkEnv1 env v') pat + ; return (env', AsPat (L loc v') pat') } zonk_pat env (ListPat pats ty) - = zonkTcTypeToType env ty `thenM` \ new_ty -> - zonkPats env pats `thenM` \ (new_pats, ids) -> - returnM (ListPat new_pats new_ty, ids) + = do { ty' <- zonkTcTypeToType env ty + ; (env', pats') <- zonkPats env pats + ; return (env', ListPat pats' ty') } zonk_pat env (PArrPat pats ty) - = zonkTcTypeToType env ty `thenM` \ new_ty -> - zonkPats env pats `thenM` \ (new_pats, ids) -> - returnM (PArrPat new_pats new_ty, ids) - -zonk_pat env (TuplePat pats boxed) - = zonkPats env pats `thenM` \ (new_pats, ids) -> - returnM (TuplePat new_pats boxed, ids) - -zonk_pat env (ConPatOut n stuff ty tvs dicts) - = zonkTcTypeToType env ty `thenM` \ new_ty -> - mappM zonkTcTyVarToTyVar tvs `thenM` \ new_tvs -> - zonkIdBndrs env dicts `thenM` \ new_dicts -> - let - env1 = extendZonkEnv env new_dicts - in - zonkConStuff env1 stuff `thenM` \ (new_stuff, ids) -> - returnM (ConPatOut n new_stuff new_ty new_tvs new_dicts, - listToBag new_dicts `unionBags` ids) - -zonk_pat env (LitPat lit) = returnM (LitPat lit, emptyBag) - -zonk_pat env (SigPatOut pat ty expr) - = zonkPat env pat `thenM` \ (new_pat, ids) -> - zonkTcTypeToType env ty `thenM` \ new_ty -> - zonkExpr env expr `thenM` \ new_expr -> - returnM (SigPatOut new_pat new_ty new_expr, ids) - -zonk_pat env (NPatOut lit ty expr) - = zonkTcTypeToType env ty `thenM` \ new_ty -> - zonkExpr env expr `thenM` \ new_expr -> - returnM (NPatOut lit new_ty new_expr, emptyBag) - -zonk_pat env (NPlusKPatOut n k e1 e2) - = wrapLocM (zonkIdBndr env) n `thenM` \ new_n -> - zonkExpr env e1 `thenM` \ new_e1 -> - zonkExpr env e2 `thenM` \ new_e2 -> - returnM (NPlusKPatOut new_n k new_e1 new_e2, unitBag (unLoc new_n)) + = do { ty' <- zonkTcTypeToType env ty + ; (env', pats') <- zonkPats env pats + ; return (env', PArrPat pats' ty') } + +zonk_pat env (TuplePat pats boxed ty) + = do { ty' <- zonkTcTypeToType env ty + ; (env', pats') <- zonkPats env pats + ; return (env', TuplePat pats' boxed ty') } + +zonk_pat env (ConPatOut n tvs dicts binds stuff ty) + = ASSERT( all isImmutableTyVar tvs ) + do { new_ty <- zonkTcTypeToType env ty + ; new_dicts <- zonkIdBndrs env dicts + ; let env1 = extendZonkEnv env new_dicts + ; (env2, new_binds) <- zonkRecMonoBinds env1 binds + ; (env', new_stuff) <- zonkConStuff env2 stuff + ; returnM (env', ConPatOut n tvs new_dicts new_binds new_stuff new_ty) } + +zonk_pat env (LitPat lit) = return (env, LitPat lit) + +zonk_pat env (SigPatOut pat ty) + = do { ty' <- zonkTcTypeToType env ty + ; (env', pat') <- zonkPat env pat + ; return (env', SigPatOut pat' ty') } + +zonk_pat env (NPat lit mb_neg eq_expr ty) + = do { lit' <- zonkOverLit env lit + ; mb_neg' <- case mb_neg of + Nothing -> return Nothing + Just neg -> do { neg' <- zonkExpr env neg + ; return (Just neg') } + ; eq_expr' <- zonkExpr env eq_expr + ; ty' <- zonkTcTypeToType env ty + ; return (env, NPat lit' mb_neg' eq_expr' ty') } + +zonk_pat env (NPlusKPat (L loc n) lit e1 e2) + = do { n' <- zonkIdBndr env n + ; lit' <- zonkOverLit env lit + ; e1' <- zonkExpr env e1 + ; e2' <- zonkExpr env e2 + ; return (extendZonkEnv1 env n', NPlusKPat (L loc n') lit' e1' e2') } zonk_pat env (DictPat ds ms) - = zonkIdBndrs env ds `thenM` \ new_ds -> - zonkIdBndrs env ms `thenM` \ new_ms -> - returnM (DictPat new_ds new_ms, - listToBag new_ds `unionBags` listToBag new_ms) + = do { ds' <- zonkIdBndrs env ds + ; ms' <- zonkIdBndrs env ms + ; return (extendZonkEnv env (ds' ++ ms'), DictPat ds' ms') } --------------------------- zonkConStuff env (PrefixCon pats) - = zonkPats env pats `thenM` \ (new_pats, ids) -> - returnM (PrefixCon new_pats, ids) + = do { (env', pats') <- zonkPats env pats + ; return (env', PrefixCon pats') } zonkConStuff env (InfixCon p1 p2) - = zonkPat env p1 `thenM` \ (new_p1, ids1) -> - zonkPat env p2 `thenM` \ (new_p2, ids2) -> - returnM (InfixCon new_p1 new_p2, ids1 `unionBags` ids2) + = do { (env1, p1') <- zonkPat env p1 + ; (env', p2') <- zonkPat env1 p2 + ; return (env', InfixCon p1' p2') } zonkConStuff env (RecCon rpats) - = mapAndUnzipM zonk_rpat rpats `thenM` \ (new_rpats, ids_s) -> - returnM (RecCon new_rpats, unionManyBags ids_s) + = do { (env', pats') <- zonkPats env pats + ; returnM (env', RecCon (fields `zip` pats')) } where - zonk_rpat (f, pat) - = zonkPat env pat `thenM` \ (new_pat, ids) -> - returnM ((f, new_pat), ids) + (fields, pats) = unzip rpats --------------------------- -zonkPats env [] - = returnM ([], emptyBag) - -zonkPats env (pat:pats) - = zonkPat env pat `thenM` \ (pat', ids1) -> - zonkPats env pats `thenM` \ (pats', ids2) -> - returnM (pat':pats', ids1 `unionBags` ids2) +zonkPats env [] = return (env, []) +zonkPats env (pat:pats) = do { (env1, pat') <- zonkPat env pat + ; (env', pats') <- zonkPats env1 pats + ; return (env', pat':pats') } \end{code} %************************************************************************ @@ -845,7 +863,8 @@ zonkRule env (HsRule name act (vars::[RuleBndr TcId]) lhs rhs) where zonk_bndr (RuleBndr v) | isId (unLoc v) = wrapLocM (zonkIdBndr env) v - | otherwise = wrapLocM zonkTcTyVarToTyVar v + | otherwise = ASSERT( isImmutableTyVar (unLoc v) ) + return v \end{code} @@ -859,13 +878,16 @@ zonkRule env (HsRule name act (vars::[RuleBndr TcId]) lhs rhs) zonkTcTypeToType :: ZonkEnv -> TcType -> TcM Type zonkTcTypeToType (ZonkEnv zonk_ty _) ty = zonk_ty ty +zonkTcTypeToTypes :: ZonkEnv -> [TcType] -> TcM [Type] +zonkTcTypeToTypes env tys = mapM (zonkTcTypeToType env) tys + zonkTypeCollecting :: TcRef TyVarSet -> TcType -> TcM Type -- This variant collects unbound type variables in a mutable variable zonkTypeCollecting unbound_tv_set = zonkType zonk_unbound_tyvar where zonk_unbound_tyvar tv - = zonkTcTyVarToTyVar tv `thenM` \ tv' -> + = zonkQuantifiedTyVar tv `thenM` \ tv' -> readMutVar unbound_tv_set `thenM` \ tv_set -> writeMutVar unbound_tv_set (extendVarSet tv_set tv') `thenM_` return (mkTyVarTy tv') @@ -874,7 +896,7 @@ zonkTypeZapping :: TcType -> TcM Type -- This variant is used for everything except the LHS of rules -- It zaps unbound type variables to (), or some other arbitrary type zonkTypeZapping ty - = zonkType zonk_unbound_tyvar ty + = zonkType zonk_unbound_tyvar ty where -- Zonk a mutable but unbound type variable to an arbitrary type -- We know it's unbound even though we don't carry an environment, @@ -882,7 +904,9 @@ zonkTypeZapping ty -- mutable tyvar to a fresh immutable one. So the mutable store -- plays the role of an environment. If we come across a mutable -- type variable that isn't so bound, it must be completely free. - zonk_unbound_tyvar tv = putTcTyVar tv (mkArbitraryType tv) + zonk_unbound_tyvar tv = do { writeMetaTyVar tv ty; return ty } + where + ty = mkArbitraryType tv -- When the type checker finds a type variable with no binding, @@ -914,17 +938,17 @@ mkArbitraryType :: TcTyVar -> Type -- Make up an arbitrary type whose kind is the same as the tyvar. -- We'll use this to instantiate the (unbound) tyvar. mkArbitraryType tv - | isAnyTypeKind kind = voidTy -- The vastly common case - | otherwise = mkTyConApp tycon [] + | liftedTypeKind `isSubKind` kind = voidTy -- The vastly common case + | otherwise = mkTyConApp tycon [] where kind = tyVarKind tv - (args,res) = Type.splitFunTys kind -- Kinds are simple; use Type.splitFunTys + (args,res) = splitKindFunTys kind - tycon | kind `eqKind` tyConKind listTyCon -- *->* + tycon | kind == tyConKind listTyCon -- *->* = listTyCon -- No tuples this size - | all isTypeKind args && isTypeKind res - = tupleTyCon Boxed (length args) -- *-> ... ->*->* + | all isLiftedTypeKind args && isLiftedTypeKind res + = tupleTyCon Boxed (length args) -- *-> ... ->*->* | otherwise = pprTrace "Urk! Inventing strangely-kinded void TyCon:" (ppr tc_name $$ ppr kind) $