projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Make updates to the external package state atomic.
[ghc-hetmet.git]
/
compiler
/
typecheck
/
TcHsSyn.lhs
diff --git
a/compiler/typecheck/TcHsSyn.lhs
b/compiler/typecheck/TcHsSyn.lhs
index
fe9c808
..
299d70f
100644
(file)
--- a/
compiler/typecheck/TcHsSyn.lhs
+++ b/
compiler/typecheck/TcHsSyn.lhs
@@
-13,7
+13,7
@@
module TcHsSyn (
mkHsConApp, mkHsDictLet, mkHsApp,
hsLitType, hsLPatType, hsPatType,
mkHsAppTy, mkSimpleHsAlt,
mkHsConApp, mkHsDictLet, mkHsApp,
hsLitType, hsLPatType, hsPatType,
mkHsAppTy, mkSimpleHsAlt,
- nlHsIntLit, mkVanillaTuplePat,
+ nlHsIntLit,
shortCutLit, hsOverLitName,
mkArbitraryType, -- Put this elsewhere?
shortCutLit, hsOverLitName,
mkArbitraryType, -- Put this elsewhere?
@@
-35,7
+35,6
@@
import Id
import TcRnMonad
import PrelNames
import TcRnMonad
import PrelNames
-import Type
import TcType
import TcMType
import TysPrim
import TcType
import TcMType
import TysPrim
@@
-49,7
+48,6
@@
import VarEnv
import Literal
import BasicTypes
import Maybes
import Literal
import BasicTypes
import Maybes
-import Unique
import SrcLoc
import Util
import Bag
import SrcLoc
import Util
import Bag
@@
-82,11
+80,6
@@
mappM = mapM
Note: If @hsLPatType@ doesn't bear a strong resemblance to @exprType@,
then something is wrong.
\begin{code}
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
hsLPatType :: OutPat Id -> Type
hsLPatType (L _ pat) = hsPatType pat
@@
-251,11
+244,22
@@
zonkDictBndrs :: ZonkEnv -> [Var] -> TcM [Var]
zonkDictBndrs env ids = mappM (zonkDictBndr env) ids
zonkDictBndr :: ZonkEnv -> Var -> TcM Var
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
| 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}
\end{code}
@@
-481,6
+485,13
@@
zonkExpr env (SectionR op expr)
zonkLExpr env expr `thenM` \ new_expr ->
returnM (SectionR new_op new_expr)
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 ->
zonkExpr env (HsCase expr ms)
= zonkLExpr env expr `thenM` \ new_expr ->
zonkMatchGroup env ms `thenM` \ new_ms ->
@@
-514,10
+525,6
@@
zonkExpr env (ExplicitPArr ty exprs)
zonkLExprs env exprs `thenM` \ new_exprs ->
returnM (ExplicitPArr new_ty new_exprs)
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
zonkExpr env (RecordCon data_con con_expr rbinds)
= do { new_con_expr <- zonkExpr env con_expr
; new_rbinds <- zonkRecFields env rbinds
@@
-607,7
+614,8
@@
zonkCoFn env (WpLam id) = do { id' <- zonkDictBndr env id
; let env1 = extendZonkEnv1 env id'
; return (env1, WpLam id') }
zonkCoFn env (WpTyLam tv) = ASSERT( isImmutableTyVar tv )
; 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) }
zonkCoFn env (WpApp v)
| isTcTyVar v = do { co <- zonkTcTyVar v
; return (env, WpTyApp co) }
@@
-754,9
+762,9
@@
zonkRecFields env (HsRecFields flds dd)
; return (HsRecFields flds' dd) }
where
zonk_rbind fld
; 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)
-------------------------------------------------------------------------
mapIPNameTc :: (a -> TcM b) -> IPName a -> TcM (IPName b)
@@
-811,7
+819,8
@@
zonk_pat env (AsPat (L loc v) pat)
zonk_pat env (ViewPat expr pat ty)
= do { expr' <- zonkLExpr env expr
; (env', pat') <- zonkPat env pat
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
zonk_pat env (ListPat pats ty)
= do { ty' <- zonkTcTypeToType env ty
@@
-1059,7
+1068,7
@@
mkArbitraryType warn tv
, isLiftedTypeKind res -- Horrible hack to make less use
= return (mkTyConApp tup_tc []) -- of mkAnyPrimTyCon
| otherwise
, 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
; 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