\begin{code}
module TcHsSyn (
- TcDictBinds,
mkHsTyApp, mkHsDictApp, mkHsConApp,
- mkHsTyLam, mkHsDictLam, mkHsLet, mkHsApp,
+ mkHsTyLam, mkHsDictLam, mkHsDictLet, mkHsApp,
hsLitType, hsPatType, mkHsAppTy, mkSimpleHsAlt,
- nlHsIntLit, glueBindsOnGRHSs,
+ nlHsIntLit,
- -- Coercions
- Coercion, ExprCoFn, PatCoFn,
- (<$>), (<.>), mkCoercion,
- idCoercion, isIdCoercion,
-
-- re-exported from TcMonad
- TcId, TcIdSet,
+ TcId, TcIdSet, TcDictBinds,
zonkTopDecls, zonkTopExpr, zonkTopLExpr,
zonkId, zonkTopBndrs
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}
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
+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 (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 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)
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}
-
%************************************************************************
%* *
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
-- '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
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')
+
---------------------------------------------
-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') }
+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') }
---------------------------------------------
-zonkMonoBinds :: ZonkEnv -> Bag (LHsBind TcId) -> TcM (Bag (LHsBind Id))
+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 -> 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}
%************************************************************************
%************************************************************************
\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}
%************************************************************************
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 ->
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 ->
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 ->
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)
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 ->
= 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)
-
-zonkExpr env (RecordUpd _ _) = panic "zonkExpr env:RecordUpd"
+ returnM (RecordCon data_con new_con_expr new_rbinds)
-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 ->
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)
-- 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 ->
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)
-------------------------------------------------------------------------
-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)
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) }
-------------------------------------------------------------------------
%************************************************************************
\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 (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)
+ = do { ty' <- zonkTcTypeToType env ty
+ ; (env', pats') <- zonkPats env pats
+ ; return (env', PArrPat pats' ty') }
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 { (env', pats') <- zonkPats env pats
+ ; return (env', TuplePat pats' boxed) }
+
+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}
%************************************************************************
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}
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')
-- 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,
-- 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,
-- 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) $
projects / ghc-hetmet.git / blobdiff