mkHsTyApp, mkHsDictApp, mkHsConApp,
mkHsTyLam, mkHsDictLam, mkHsDictLet, mkHsApp,
hsLitType, hsPatType, mkHsAppTy, mkSimpleHsAlt,
- nlHsIntLit,
+ nlHsIntLit, mkVanillaTuplePat,
- -- Coercions
- Coercion, ExprCoFn, PatCoFn,
- (<$>), (<.>), mkCoercion,
- idCoercion, isIdCoercion,
-
-- re-exported from TcMonad
TcId, TcIdSet, TcDictBinds,
import TcRnMonad
import Type ( Type )
-import TcType ( TcType, TcTyVar, mkTyVarTy, mkTyConApp, isImmutableTyVar, tcGetTyVar )
+import TcType ( TcType, TcTyVar, mkTyVarTy, mkTyConApp, isImmutableTyVar )
import Kind ( isLiftedTypeKind, liftedTypeKind, isSubKind )
import qualified Type
-import TcMType ( zonkQuantifiedTyVar, zonkType, zonkTcType, zonkTcTyVars, putMetaTyVar )
+import TcMType ( zonkQuantifiedTyVar, zonkType, zonkTcType, writeMetaTyVar )
import TysPrim ( charPrimTy, intPrimTy, floatPrimTy,
doublePrimTy, addrPrimTy
)
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 )
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)
+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) = mkTupleTy box (length pats) (map hsPatType pats)
+pat_type (TuplePat pats box ty) = ty
pat_type (ConPatOut _ _ _ _ _ ty) = ty
pat_type (SigPatOut pat ty) = ty
pat_type (NPat lit _ _ ty) = ty
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}
-
%************************************************************************
%* *
zonkMonoBinds env binds = mapBagM (wrapLocM (zonk_bind env)) binds
zonk_bind :: ZonkEnv -> HsBind TcId -> TcM (HsBind Id)
-zonk_bind env (PatBind pat grhss ty fvs)
+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 (PatBind new_pat new_grhss new_ty fvs) }
+ ; 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 fvs)
+zonk_bind env bind@(FunBind { fun_id = var, fun_matches = ms, fun_co_fn = co_fn })
= wrapLocM (zonkIdBndr env) var `thenM` \ new_var ->
- zonkMatchGroup env ms `thenM` \ new_ms ->
- returnM (FunBind new_var inf new_ms fvs)
+ 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 tyvars dicts exports val_binds)
+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, _) ->
mappM (zonkExport env2) exports `thenM` \ new_exports ->
returnM (new_val_binds, new_exports)
) `thenM` \ (new_val_bind, new_exports) ->
- returnM (AbsBinds tyvars new_dicts new_exports 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, prags)
- = 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 ->
- mapM zonk_prag prags `thenM` \ new_prags ->
- returnM (new_tyvars, new_global, zonkIdOcc env local, new_prags)
- zonk_prag prag@(InlinePrag _ _) = return prag
- zonk_prag (SpecPrag expr ty ds) = do { expr' <- zonkExpr env expr
- ; ty' <- zonkTcTypeToType env ty
- ; let ds' = zonkIdOccs env ds
- ; return (SpecPrag expr' ty' ds') }
+ = 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}
%************************************************************************
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)
returnM (HsCmdTop new_cmd new_stack_tys new_ty new_ids)
-------------------------------------------------------------------------
+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)
= do { (env', pat') <- zonkPat env pat
; return (env', LazyPat pat') }
+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
; (env', pats') <- zonkPats env pats
; return (env', PArrPat pats' ty') }
-zonk_pat env (TuplePat pats boxed)
- = do { (env', pats') <- zonkPats env pats
- ; return (env', TuplePat pats' boxed) }
+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 )
zonkTypeCollecting :: TcRef TyVarSet -> TcType -> TcM Type
-- This variant collects unbound type variables in a mutable variable
zonkTypeCollecting unbound_tv_set
- = zonkType zonk_unbound_tyvar True
+ = zonkType zonk_unbound_tyvar
where
zonk_unbound_tyvar tv
= zonkQuantifiedTyVar tv `thenM` \ 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 True 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 = do { putMetaTyVar tv ty; return ty }
+ zonk_unbound_tyvar tv = do { writeMetaTyVar tv ty; return ty }
where
ty = mkArbitraryType tv
projects / ghc-hetmet.git / blobdiff