mkHsConApp, mkHsDictLet, mkHsApp,
hsLitType, hsLPatType, hsPatType,
mkHsAppTy, mkSimpleHsAlt,
- nlHsIntLit, mkVanillaTuplePat,
+ nlHsIntLit,
shortCutLit, hsOverLitName,
mkArbitraryType, -- Put this elsewhere?
import TcRnMonad
import PrelNames
-import Type
import TcType
import TcMType
import TysPrim
import Literal
import BasicTypes
import Maybes
-import Unique
import SrcLoc
import Util
import Bag
Note: If @hsLPatType@ 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 hsLPatType pats))
-
hsLPatType :: OutPat Id -> Type
hsLPatType (L _ pat) = hsPatType pat
zonkDictBndrs env ids = mappM (zonkDictBndr env) ids
zonkDictBndr :: ZonkEnv -> Var -> TcM Var
-zonkDictBndr env var | isTyVar var = return var
+zonkDictBndr env var | isTyVar var = zonkTyVarBndr env var
| otherwise = zonkIdBndr env var
zonkTopBndrs :: [TcId] -> TcM [Id]
zonkTopBndrs ids = zonkIdBndrs emptyZonkEnv ids
+
+-- Zonk the kind of a non-TC tyvar in case it is a coercion variable (their
+-- kind contains types).
+--
+zonkTyVarBndr :: ZonkEnv -> TyVar -> TcM TyVar
+zonkTyVarBndr env tv
+ | isCoVar tv
+ = do { kind <- zonkTcTypeToType env (tyVarKind tv)
+ ; return $ setTyVarKind tv kind
+ }
+ | otherwise = return tv
\end{code}
zonkLExpr env expr `thenM` \ new_expr ->
returnM (SectionR new_op new_expr)
+zonkExpr env (ExplicitTuple tup_args boxed)
+ = do { new_tup_args <- mapM zonk_tup_arg tup_args
+ ; return (ExplicitTuple new_tup_args boxed) }
+ where
+ zonk_tup_arg (Present e) = do { e' <- zonkLExpr env e; return (Present e') }
+ zonk_tup_arg (Missing t) = do { t' <- zonkTcTypeToType env t; return (Missing t') }
+
zonkExpr env (HsCase expr ms)
= zonkLExpr env expr `thenM` \ new_expr ->
zonkMatchGroup env ms `thenM` \ new_ms ->
zonkLExprs env exprs `thenM` \ new_exprs ->
returnM (ExplicitPArr new_ty new_exprs)
-zonkExpr env (ExplicitTuple exprs boxed)
- = zonkLExprs env exprs `thenM` \ new_exprs ->
- returnM (ExplicitTuple new_exprs boxed)
-
zonkExpr env (RecordCon data_con con_expr rbinds)
= do { new_con_expr <- zonkExpr env con_expr
; new_rbinds <- zonkRecFields env rbinds
; let env1 = extendZonkEnv1 env id'
; return (env1, WpLam id') }
zonkCoFn env (WpTyLam tv) = ASSERT( isImmutableTyVar tv )
- return (env, WpTyLam tv)
+ do { tv' <- zonkTyVarBndr env tv
+ ; return (env, WpTyLam tv') }
zonkCoFn env (WpApp v)
| isTcTyVar v = do { co <- zonkTcTyVar v
; return (env, WpTyApp co) }
; return (HsRecFields flds' dd) }
where
zonk_rbind fld
- = do { new_expr <- zonkLExpr env (hsRecFieldArg fld)
- ; return (fld { hsRecFieldArg = new_expr }) }
- -- Field selectors have declared types; hence no zonking
+ = do { new_id <- wrapLocM (zonkIdBndr env) (hsRecFieldId fld)
+ ; new_expr <- zonkLExpr env (hsRecFieldArg fld)
+ ; return (fld { hsRecFieldId = new_id, hsRecFieldArg = new_expr }) }
-------------------------------------------------------------------------
mapIPNameTc :: (a -> TcM b) -> IPName a -> TcM (IPName b)
zonk_pat env (ViewPat expr pat ty)
= do { expr' <- zonkLExpr env expr
; (env', pat') <- zonkPat env pat
- ; return (env', ViewPat expr' pat' ty) }
+ ; ty' <- zonkTcTypeToType env ty
+ ; return (env', ViewPat expr' pat' ty') }
zonk_pat env (ListPat pats ty)
= do { ty' <- zonkTcTypeToType env ty
, isLiftedTypeKind res -- Horrible hack to make less use
= return (mkTyConApp tup_tc []) -- of mkAnyPrimTyCon
| otherwise
- = do { warn (getSrcSpan tv) msg
+ = do { _ <- warn (getSrcSpan tv) msg
; return (mkTyConApp (mkAnyPrimTyCon (getUnique tv) kind) []) }
-- Same name as the tyvar, apart from making it start with a colon (sigh)
-- I dread to think what will happen if this gets out into an