%
% (c) The University of Glasgow 2006
% (c) The AQUA Project, Glasgow University, 19961998
%
TcHsSyn: Specialisations of the @HsSyn@ syntax for the typechecker
This module is an extension of @HsSyn@ syntax, for use in the type
checker.
\begin{code}
module TcHsSyn (
mkHsConApp, mkHsDictLet, mkHsApp,
hsLitType, hsLPatType, hsPatType,
mkHsAppTy, mkSimpleHsAlt,
nlHsIntLit,
shortCutLit, hsOverLitName,
mkArbitraryType,
TcId, TcIdSet, TcDictBinds,
zonkTopDecls, zonkTopExpr, zonkTopLExpr,
zonkId, zonkTopBndrs
) where
#include "HsVersions.h"
import HsSyn
import Id
import TcRnMonad
import PrelNames
import TcType
import TcMType
import TysPrim
import TysWiredIn
import TyCon
import DataCon
import Name
import Var
import VarSet
import VarEnv
import Literal
import BasicTypes
import Maybes
import SrcLoc
import Util
import Bag
import Outputable
import FastString
\end{code}
\begin{code}
thenM :: Monad a => a b -> (b -> a c) -> a c
thenM = (>>=)
thenM_ :: Monad a => a b -> a c -> a c
thenM_ = (>>)
returnM :: Monad m => a -> m a
returnM = return
mappM :: (Monad m) => (a -> m b) -> [a] -> m [b]
mappM = mapM
\end{code}
%************************************************************************
%* *
\subsection[mkFailurePair]{Code for patternmatching and other failures}
%* *
%************************************************************************
Note: If @hsLPatType@ doesn't bear a strong resemblance to @exprType@,
then something is wrong.
\begin{code}
hsLPatType :: OutPat Id -> Type
hsLPatType (L _ pat) = hsPatType pat
hsPatType :: Pat Id -> Type
hsPatType (ParPat pat) = hsLPatType pat
hsPatType (WildPat ty) = ty
hsPatType (VarPat var) = idType var
hsPatType (VarPatOut var _) = idType var
hsPatType (BangPat pat) = hsLPatType pat
hsPatType (LazyPat pat) = hsLPatType pat
hsPatType (LitPat lit) = hsLitType lit
hsPatType (AsPat var _) = idType (unLoc var)
hsPatType (ViewPat _ _ ty) = ty
hsPatType (ListPat _ ty) = mkListTy ty
hsPatType (PArrPat _ ty) = mkPArrTy ty
hsPatType (TuplePat _ _ ty) = ty
hsPatType (ConPatOut { pat_ty = ty }) = ty
hsPatType (SigPatOut _ ty) = ty
hsPatType (NPat lit _ _) = overLitType lit
hsPatType (NPlusKPat id _ _ _) = idType (unLoc id)
hsPatType (CoPat _ _ ty) = ty
hsPatType p = pprPanic "hsPatType" (ppr p)
hsLitType :: HsLit -> TcType
hsLitType (HsChar _) = charTy
hsLitType (HsCharPrim _) = charPrimTy
hsLitType (HsString _) = stringTy
hsLitType (HsStringPrim _) = addrPrimTy
hsLitType (HsInt _) = intTy
hsLitType (HsIntPrim _) = intPrimTy
hsLitType (HsWordPrim _) = wordPrimTy
hsLitType (HsInteger _ ty) = ty
hsLitType (HsRat _ ty) = ty
hsLitType (HsFloatPrim _) = floatPrimTy
hsLitType (HsDoublePrim _) = doublePrimTy
\end{code}
Overloaded literals. Here mainly becuase it uses isIntTy etc
\begin{code}
shortCutLit :: OverLitVal -> TcType -> Maybe (HsExpr TcId)
shortCutLit (HsIntegral i) ty
| isIntTy ty && inIntRange i = Just (HsLit (HsInt i))
| isWordTy ty && inWordRange i = Just (mkLit wordDataCon (HsWordPrim i))
| isIntegerTy ty = Just (HsLit (HsInteger i ty))
| otherwise = shortCutLit (HsFractional (fromInteger i)) ty
shortCutLit (HsFractional f) ty
| isFloatTy ty = Just (mkLit floatDataCon (HsFloatPrim f))
| isDoubleTy ty = Just (mkLit doubleDataCon (HsDoublePrim f))
| otherwise = Nothing
shortCutLit (HsIsString s) ty
| isStringTy ty = Just (HsLit (HsString s))
| otherwise = Nothing
mkLit :: DataCon -> HsLit -> HsExpr Id
mkLit con lit = HsApp (nlHsVar (dataConWrapId con)) (nlHsLit lit)
hsOverLitName :: OverLitVal -> Name
hsOverLitName (HsIntegral {}) = fromIntegerName
hsOverLitName (HsFractional {}) = fromRationalName
hsOverLitName (HsIsString {}) = fromStringName
\end{code}
%************************************************************************
%* *
\subsection[BackSubstHsBinds]{Running a substitution over @HsBinds@}
%* *
%************************************************************************
\begin{code}
zonkId :: TcId -> TcM TcId
zonkId id
= zonkTcType (idType id) `thenM` \ ty' ->
returnM (Id.setIdType id ty')
\end{code}
The rest of the zonking is done *after* typechecking.
The main zonking pass runs over the bindings
a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc
b) convert unbound TcTyVar to Void
c) convert each TcId to an Id by zonking its type
The type variables are converted by binding mutable tyvars to immutable ones
and then zonking as normal.
The Ids are converted by binding them in the normal Tc envt; that
way we maintain sharing; eg an Id is zonked at its binding site and they
all occurrences of that Id point to the common zonked copy
It's all pretty boring stuff, because HsSyn is such a large type, and
the environment manipulation is tiresome.
\begin{code}
data ZonkEnv = ZonkEnv (TcType -> TcM Type)
(IdEnv Id)
emptyZonkEnv :: ZonkEnv
emptyZonkEnv = ZonkEnv zonkTypeZapping emptyVarEnv
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
zonkEnvIds :: ZonkEnv -> [Id]
zonkEnvIds (ZonkEnv _ env) = varEnvElts env
zonkIdOcc :: ZonkEnv -> TcId -> Id
zonkIdOcc (ZonkEnv _zonk_ty env) id
| isLocalVar id = lookupVarEnv env id `orElse` id
| otherwise = id
zonkIdOccs :: ZonkEnv -> [TcId] -> [Id]
zonkIdOccs env ids = map (zonkIdOcc env) ids
zonkIdBndr :: ZonkEnv -> TcId -> TcM Id
zonkIdBndr env id
= zonkTcTypeToType env (idType id) `thenM` \ ty' ->
returnM (Id.setIdType id ty')
zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id]
zonkIdBndrs env ids = mappM (zonkIdBndr env) ids
zonkDictBndrs :: ZonkEnv -> [Var] -> TcM [Var]
zonkDictBndrs env ids = mappM (zonkDictBndr env) ids
zonkDictBndr :: ZonkEnv -> Var -> TcM Var
zonkDictBndr env var | isTyVar var = zonkTyVarBndr env var
| otherwise = zonkIdBndr env var
zonkTopBndrs :: [TcId] -> TcM [Id]
zonkTopBndrs ids = zonkIdBndrs emptyZonkEnv ids
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}
\begin{code}
zonkTopExpr :: HsExpr TcId -> TcM (HsExpr Id)
zonkTopExpr e = zonkExpr emptyZonkEnv e
zonkTopLExpr :: LHsExpr TcId -> TcM (LHsExpr Id)
zonkTopLExpr e = zonkLExpr emptyZonkEnv e
zonkTopDecls :: LHsBinds TcId -> [LRuleDecl TcId] -> [LForeignDecl TcId]
-> TcM ([Id],
Bag (LHsBind Id),
[LForeignDecl Id],
[LRuleDecl Id])
zonkTopDecls binds rules fords
= do { (env, binds') <- zonkRecMonoBinds emptyZonkEnv binds
; rules' <- zonkRules env rules
; fords' <- zonkForeignExports env fords
; return (zonkEnvIds env, binds', fords', rules') }
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
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 _ (ValBindsIn _ _)
= panic "zonkValBinds"
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') }
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 bind@(PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty})
= do { (_env, new_pat) <- zonkPat env pat
; 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_id = var, var_rhs = expr })
= zonkIdBndr env var `thenM` \ new_var ->
zonkLExpr env expr `thenM` \ new_expr ->
returnM (VarBind { var_id = new_var, var_rhs = new_expr })
zonk_bind env bind@(FunBind { fun_id = var, fun_matches = ms, fun_co_fn = co_fn })
= wrapLocM (zonkIdBndr env) var `thenM` \ new_var ->
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 )
zonkDictBndrs env dicts `thenM` \ new_dicts ->
fixM (\ ~(new_val_binds, _) ->
let
env1 = extendZonkEnv env new_dicts
env2 = extendZonkEnv env1 (collectHsBindBinders new_val_binds)
in
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 { abs_tvs = tyvars, abs_dicts = new_dicts,
abs_exports = new_exports, abs_binds = new_val_bind })
where
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@(L _ (InlinePrag {})) = return prag
zonk_prag (L loc (SpecPrag expr ty inl))
= do { expr' <- zonkExpr env expr
; ty' <- zonkTcTypeToType env ty
; return (L loc (SpecPrag expr' ty' inl)) }
\end{code}
%************************************************************************
%* *
\subsection[BackSubstMatchGRHSs]{Match and GRHSs}
%* *
%************************************************************************
\begin{code}
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))
= 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)
= zonkLocalBinds env binds `thenM` \ (new_env, new_binds) ->
let
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 ->
returnM (GRHSs new_grhss new_binds)
\end{code}
%************************************************************************
%* *
\subsection[BackSubstHsExpr]{Running a zonkitution over a TypeCheckedExpr}
%* *
%************************************************************************
\begin{code}
zonkLExprs :: ZonkEnv -> [LHsExpr TcId] -> TcM [LHsExpr Id]
zonkLExpr :: ZonkEnv -> LHsExpr TcId -> TcM (LHsExpr Id)
zonkExpr :: ZonkEnv -> HsExpr TcId -> TcM (HsExpr Id)
zonkLExprs env exprs = mappM (zonkLExpr env) exprs
zonkLExpr env expr = wrapLocM (zonkExpr env) expr
zonkExpr env (HsVar id)
= returnM (HsVar (zonkIdOcc env id))
zonkExpr env (HsIPVar id)
= returnM (HsIPVar (mapIPName (zonkIdOcc env) id))
zonkExpr env (HsLit (HsRat f ty))
= zonkTcTypeToType env ty `thenM` \ new_ty ->
returnM (HsLit (HsRat f new_ty))
zonkExpr _ (HsLit lit)
= returnM (HsLit lit)
zonkExpr env (HsOverLit lit)
= do { lit' <- zonkOverLit env lit
; return (HsOverLit lit') }
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 ->
zonkLExpr env e2 `thenM` \ new_e2 ->
returnM (HsApp new_e1 new_e2)
zonkExpr env (HsBracketOut body bs)
= mappM zonk_b bs `thenM` \ bs' ->
returnM (HsBracketOut body bs')
where
zonk_b (n,e) = zonkLExpr env e `thenM` \ e' ->
returnM (n,e')
zonkExpr _ (HsSpliceE s) = WARN( True, ppr s )
returnM (HsSpliceE s)
zonkExpr env (OpApp e1 op fixity e2)
= zonkLExpr env e1 `thenM` \ new_e1 ->
zonkLExpr env op `thenM` \ new_op ->
zonkLExpr env e2 `thenM` \ new_e2 ->
returnM (OpApp new_e1 new_op fixity new_e2)
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 ->
returnM (HsPar new_e)
zonkExpr env (SectionL expr op)
= zonkLExpr env expr `thenM` \ new_expr ->
zonkLExpr env op `thenM` \ new_op ->
returnM (SectionL new_expr new_op)
zonkExpr env (SectionR op expr)
= zonkLExpr env op `thenM` \ new_op ->
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 ->
returnM (HsCase new_expr new_ms)
zonkExpr env (HsIf e1 e2 e3)
= zonkLExpr env e1 `thenM` \ new_e1 ->
zonkLExpr env e2 `thenM` \ new_e2 ->
zonkLExpr env e3 `thenM` \ new_e3 ->
returnM (HsIf new_e1 new_e2 new_e3)
zonkExpr env (HsLet binds expr)
= 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 body ty)
= zonkStmts env stmts `thenM` \ (new_env, new_stmts) ->
zonkLExpr new_env body `thenM` \ new_body ->
zonkTcTypeToType env ty `thenM` \ 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 (ExplicitList new_ty new_exprs)
zonkExpr env (ExplicitPArr ty exprs)
= zonkTcTypeToType env ty `thenM` \ new_ty ->
zonkLExprs env exprs `thenM` \ new_exprs ->
returnM (ExplicitPArr new_ty new_exprs)
zonkExpr env (RecordCon data_con con_expr rbinds)
= do { new_con_expr <- zonkExpr env con_expr
; new_rbinds <- zonkRecFields env rbinds
; return (RecordCon data_con new_con_expr new_rbinds) }
zonkExpr env (RecordUpd expr rbinds cons in_tys out_tys)
= do { new_expr <- zonkLExpr env expr
; new_in_tys <- mapM (zonkTcTypeToType env) in_tys
; new_out_tys <- mapM (zonkTcTypeToType env) out_tys
; new_rbinds <- zonkRecFields env rbinds
; return (RecordUpd new_expr new_rbinds cons new_in_tys new_out_tys) }
zonkExpr env (ExprWithTySigOut e ty)
= do { e' <- zonkLExpr env e
; return (ExprWithTySigOut e' ty) }
zonkExpr _ (ExprWithTySig _ _) = panic "zonkExpr env:ExprWithTySig"
zonkExpr env (ArithSeq expr info)
= zonkExpr env expr `thenM` \ new_expr ->
zonkArithSeq env info `thenM` \ new_info ->
returnM (ArithSeq new_expr new_info)
zonkExpr env (PArrSeq expr info)
= zonkExpr env expr `thenM` \ new_expr ->
zonkArithSeq env info `thenM` \ new_info ->
returnM (PArrSeq new_expr new_info)
zonkExpr env (HsSCC lbl expr)
= zonkLExpr env expr `thenM` \ new_expr ->
returnM (HsSCC lbl new_expr)
zonkExpr env (HsTickPragma info expr)
= zonkLExpr env expr `thenM` \ new_expr ->
returnM (HsTickPragma info new_expr)
zonkExpr env (HsCoreAnn lbl expr)
= zonkLExpr env expr `thenM` \ new_expr ->
returnM (HsCoreAnn lbl new_expr)
zonkExpr env (HsProc pat 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 ->
zonkLExpr env e2 `thenM` \ new_e2 ->
zonkTcTypeToType env ty `thenM` \ new_ty ->
returnM (HsArrApp new_e1 new_e2 new_ty ho rl)
zonkExpr env (HsArrForm op fixity args)
= zonkLExpr env op `thenM` \ new_op ->
mappM (zonkCmdTop env) args `thenM` \ new_args ->
returnM (HsArrForm new_op fixity new_args)
zonkExpr env (HsWrap co_fn expr)
= zonkCoFn env co_fn `thenM` \ (env1, new_co_fn) ->
zonkExpr env1 expr `thenM` \ new_expr ->
return (HsWrap new_co_fn new_expr)
zonkExpr _ expr = pprPanic "zonkExpr" (ppr expr)
zonkCmdTop :: ZonkEnv -> LHsCmdTop TcId -> TcM (LHsCmdTop Id)
zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd
zonk_cmd_top :: ZonkEnv -> HsCmdTop TcId -> TcM (HsCmdTop Id)
zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids)
= zonkLExpr env cmd `thenM` \ new_cmd ->
zonkTcTypeToTypes env stack_tys `thenM` \ new_stack_tys ->
zonkTcTypeToType env ty `thenM` \ new_ty ->
mapSndM (zonkExpr env) ids `thenM` \ new_ids ->
returnM (HsCmdTop new_cmd new_stack_tys new_ty new_ids)
zonkCoFn :: ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper)
zonkCoFn env WpHole = return (env, WpHole)
zonkCoFn env WpInline = return (env, WpInline)
zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1
; (env2, c2') <- zonkCoFn env1 c2
; return (env2, WpCompose c1' c2') }
zonkCoFn env (WpCast co) = do { co' <- zonkTcTypeToType env co
; return (env, WpCast co') }
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 )
do { tv' <- zonkTyVarBndr env tv
; return (env, WpTyLam tv') }
zonkCoFn env (WpApp v)
| isTcTyVar v = do { co <- zonkTcTyVar v
; return (env, WpTyApp co) }
| otherwise = return (env, WpApp (zonkIdOcc env v))
zonkCoFn env (WpTyApp ty) = do { ty' <- zonkTcTypeToType env ty
; return (env, WpTyApp ty') }
zonkCoFn env (WpLet bs) = do { (env1, bs') <- zonkRecMonoBinds env bs
; return (env1, WpLet bs') }
zonkDo :: ZonkEnv -> HsStmtContext Name -> HsStmtContext Name
zonkDo env (MDoExpr tbl) = MDoExpr (mapSnd (zonkIdOcc env) tbl)
zonkDo _ do_or_lc = do_or_lc
zonkOverLit :: ZonkEnv -> HsOverLit TcId -> TcM (HsOverLit Id)
zonkOverLit env lit@(OverLit { ol_witness = e, ol_type = ty })
= do { ty' <- zonkTcTypeToType env ty
; e' <- zonkExpr env e
; return (lit { ol_witness = e', ol_type = ty' }) }
zonkArithSeq :: ZonkEnv -> ArithSeqInfo TcId -> TcM (ArithSeqInfo Id)
zonkArithSeq env (From e)
= zonkLExpr env e `thenM` \ new_e ->
returnM (From new_e)
zonkArithSeq env (FromThen e1 e2)
= zonkLExpr env e1 `thenM` \ new_e1 ->
zonkLExpr env e2 `thenM` \ new_e2 ->
returnM (FromThen new_e1 new_e2)
zonkArithSeq env (FromTo e1 e2)
= zonkLExpr env e1 `thenM` \ new_e1 ->
zonkLExpr env e2 `thenM` \ new_e2 ->
returnM (FromTo new_e1 new_e2)
zonkArithSeq env (FromThenTo e1 e2 e3)
= zonkLExpr env e1 `thenM` \ new_e1 ->
zonkLExpr env e2 `thenM` \ new_e2 ->
zonkLExpr env e3 `thenM` \ new_e3 ->
returnM (FromThenTo new_e1 new_e2 new_e3)
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)
= mappM zonk_branch stmts_w_bndrs `thenM` \ new_stmts_w_bndrs ->
let
new_binders = concat (map snd new_stmts_w_bndrs)
env1 = extendZonkEnv env new_binders
in
return (env1, ParStmt new_stmts_w_bndrs)
where
zonk_branch (stmts, bndrs) = zonkStmts env stmts `thenM` \ (env1, new_stmts) ->
returnM (new_stmts, zonkIdOccs env1 bndrs)
zonkStmt env (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_ids = rvs
, recS_ret_fn = ret_id, recS_mfix_fn = mfix_id, recS_bind_fn = bind_id
, recS_rec_rets = rets, recS_dicts = binds })
= do { new_rvs <- zonkIdBndrs env rvs
; new_lvs <- zonkIdBndrs env lvs
; new_ret_id <- zonkExpr env ret_id
; new_mfix_id <- zonkExpr env mfix_id
; new_bind_id <- zonkExpr env bind_id
; let env1 = extendZonkEnv env new_rvs
; (env2, new_segStmts) <- zonkStmts env1 segStmts
; new_rets <- mapM (zonkExpr env2) rets
; let env3 = extendZonkEnv env new_lvs
; (env4, new_binds) <- zonkRecMonoBinds env3 binds
; return (env4,
RecStmt { recS_stmts = new_segStmts, recS_later_ids = new_lvs
, recS_rec_ids = new_rvs, recS_ret_fn = new_ret_id
, recS_mfix_fn = new_mfix_id, recS_bind_fn = new_bind_id
, recS_rec_rets = new_rets, recS_dicts = new_binds }) }
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_then new_ty)
zonkStmt env (TransformStmt (stmts, binders) usingExpr maybeByExpr)
= do { (env', stmts') <- zonkStmts env stmts
; let binders' = zonkIdOccs env' binders
; usingExpr' <- zonkLExpr env' usingExpr
; maybeByExpr' <- zonkMaybeLExpr env' maybeByExpr
; return (env', TransformStmt (stmts', binders') usingExpr' maybeByExpr') }
zonkStmt env (GroupStmt (stmts, binderMap) groupByClause)
= do { (env', stmts') <- zonkStmts env stmts
; binderMap' <- mappM (zonkBinderMapEntry env') binderMap
; groupByClause' <-
case groupByClause of
GroupByNothing usingExpr -> (zonkLExpr env' usingExpr) >>= (return . GroupByNothing)
GroupBySomething eitherUsingExpr byExpr -> do
eitherUsingExpr' <- mapEitherM (zonkLExpr env') (zonkExpr env') eitherUsingExpr
byExpr' <- zonkLExpr env' byExpr
return $ GroupBySomething eitherUsingExpr' byExpr'
; let env'' = extendZonkEnv env' (map snd binderMap')
; return (env'', GroupStmt (stmts', binderMap') groupByClause') }
where
mapEitherM f g x = do
case x of
Left a -> f a >>= (return . Left)
Right b -> g b >>= (return . Right)
zonkBinderMapEntry env (oldBinder, newBinder) = do
let oldBinder' = zonkIdOcc env oldBinder
newBinder' <- zonkIdBndr env newBinder
return (oldBinder', newBinder')
zonkStmt env (LetStmt binds)
= zonkLocalBinds env binds `thenM` \ (env1, new_binds) ->
returnM (env1, LetStmt new_binds)
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) }
zonkMaybeLExpr :: ZonkEnv -> Maybe (LHsExpr TcId) -> TcM (Maybe (LHsExpr Id))
zonkMaybeLExpr _ Nothing = return Nothing
zonkMaybeLExpr env (Just e) = (zonkLExpr env e) >>= (return . Just)
zonkRecFields :: ZonkEnv -> HsRecordBinds TcId -> TcM (HsRecordBinds TcId)
zonkRecFields env (HsRecFields flds dd)
= do { flds' <- mappM zonk_rbind flds
; return (HsRecFields flds' dd) }
where
zonk_rbind fld
= 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 f (IPName n) = f n `thenM` \ r -> returnM (IPName r)
\end{code}
%************************************************************************
%* *
\subsection[BackSubstPats]{Patterns}
%* *
%************************************************************************
\begin{code}
zonkPat :: ZonkEnv -> OutPat TcId -> TcM (ZonkEnv, OutPat Id)
zonkPat env pat = wrapLocSndM (zonk_pat env) pat
zonk_pat :: ZonkEnv -> Pat TcId -> TcM (ZonkEnv, Pat Id)
zonk_pat env (ParPat p)
= do { (env', p') <- zonkPat env p
; return (env', ParPat p') }
zonk_pat env (WildPat ty)
= do { ty' <- zonkTcTypeToType env ty
; return (env, WildPat ty') }
zonk_pat env (VarPat 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)
= 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
; return (env', AsPat (L loc v') pat') }
zonk_pat env (ViewPat expr pat ty)
= do { expr' <- zonkLExpr env expr
; (env', pat') <- zonkPat env pat
; ty' <- zonkTcTypeToType env ty
; return (env', ViewPat expr' pat' ty') }
zonk_pat env (ListPat pats ty)
= do { ty' <- zonkTcTypeToType env ty
; (env', pats') <- zonkPats env pats
; return (env', ListPat pats' ty') }
zonk_pat env (PArrPat pats ty)
= 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 p@(ConPatOut { pat_ty = ty, pat_dicts = dicts, pat_binds = binds, pat_args = args })
= ASSERT( all isImmutableTyVar (pat_tvs p) )
do { new_ty <- zonkTcTypeToType env ty
; new_dicts <- zonkDictBndrs env dicts
; let env1 = extendZonkEnv env new_dicts
; (env2, new_binds) <- zonkRecMonoBinds env1 binds
; (env', new_args) <- zonkConStuff env2 args
; returnM (env', p { pat_ty = new_ty, pat_dicts = new_dicts,
pat_binds = new_binds, pat_args = new_args }) }
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)
= 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
; return (env, NPat lit' mb_neg' eq_expr') }
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 (CoPat co_fn pat ty)
= do { (env', co_fn') <- zonkCoFn env co_fn
; (env'', pat') <- zonkPat env' (noLoc pat)
; ty' <- zonkTcTypeToType env'' ty
; return (env'', CoPat co_fn' (unLoc pat') ty') }
zonk_pat _ pat = pprPanic "zonk_pat" (ppr pat)
zonkConStuff :: ZonkEnv
-> HsConDetails (OutPat TcId) (HsRecFields id (OutPat TcId))
-> TcM (ZonkEnv,
HsConDetails (OutPat Id) (HsRecFields id (OutPat Id)))
zonkConStuff env (PrefixCon pats)
= do { (env', pats') <- zonkPats env pats
; return (env', PrefixCon pats') }
zonkConStuff env (InfixCon p1 p2)
= do { (env1, p1') <- zonkPat env p1
; (env', p2') <- zonkPat env1 p2
; return (env', InfixCon p1' p2') }
zonkConStuff env (RecCon (HsRecFields rpats dd))
= do { (env', pats') <- zonkPats env (map hsRecFieldArg rpats)
; let rpats' = zipWith (\rp p' -> rp { hsRecFieldArg = p' }) rpats pats'
; returnM (env', RecCon (HsRecFields rpats' dd)) }
zonkPats :: ZonkEnv -> [OutPat TcId] -> TcM (ZonkEnv, [OutPat Id])
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}
%************************************************************************
%* *
\subsection[BackSubstForeign]{Foreign exports}
%* *
%************************************************************************
\begin{code}
zonkForeignExports :: ZonkEnv -> [LForeignDecl TcId] -> TcM [LForeignDecl Id]
zonkForeignExports env ls = mappM (wrapLocM (zonkForeignExport env)) ls
zonkForeignExport :: ZonkEnv -> ForeignDecl TcId -> TcM (ForeignDecl Id)
zonkForeignExport env (ForeignExport i _hs_ty spec) =
returnM (ForeignExport (fmap (zonkIdOcc env) i) undefined spec)
zonkForeignExport _ for_imp
= returnM for_imp
\end{code}
\begin{code}
zonkRules :: ZonkEnv -> [LRuleDecl TcId] -> TcM [LRuleDecl Id]
zonkRules env rs = mappM (wrapLocM (zonkRule env)) rs
zonkRule :: ZonkEnv -> RuleDecl TcId -> TcM (RuleDecl Id)
zonkRule env (HsRule name act (vars) lhs fv_lhs rhs fv_rhs)
= mappM zonk_bndr vars `thenM` \ new_bndrs ->
newMutVar emptyVarSet `thenM` \ unbound_tv_set ->
let
env_rhs = extendZonkEnv env [id | b <- new_bndrs, let id = unLoc b, isId id]
env_lhs = setZonkType env_rhs (zonkTypeCollecting unbound_tv_set)
in
zonkLExpr env_lhs lhs `thenM` \ new_lhs ->
zonkLExpr env_rhs rhs `thenM` \ new_rhs ->
readMutVar unbound_tv_set `thenM` \ unbound_tvs ->
let
final_bndrs :: [Located Var]
final_bndrs = map noLoc (varSetElems unbound_tvs) ++ new_bndrs
in
returnM (HsRule name act (map RuleBndr final_bndrs) new_lhs fv_lhs new_rhs fv_rhs)
where
zonk_bndr (RuleBndr v)
| isId (unLoc v) = wrapLocM (zonkIdBndr env) v
| otherwise = ASSERT( isImmutableTyVar (unLoc v) )
return v
zonk_bndr (RuleBndrSig {}) = panic "zonk_bndr RuleBndrSig"
\end{code}
%************************************************************************
%* *
\subsection[BackSubstForeign]{Foreign exports}
%* *
%************************************************************************
\begin{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
zonkTypeCollecting unbound_tv_set
= zonkType zonk_unbound_tyvar
where
zonk_unbound_tyvar tv
= zonkQuantifiedTyVar tv `thenM` \ tv' ->
readMutVar unbound_tv_set `thenM` \ tv_set ->
writeMutVar unbound_tv_set (extendVarSet tv_set tv') `thenM_`
return (mkTyVarTy tv')
zonkTypeZapping :: TcType -> TcM Type
zonkTypeZapping ty
= zonkType zonk_unbound_tyvar ty
where
zonk_unbound_tyvar tv = do { ty <- mkArbitraryType warn tv
; writeMetaTyVar tv ty
; return ty }
where
warn span msg = setSrcSpan span (addWarnTc msg)
mkArbitraryType :: (SrcSpan -> SDoc -> TcRnIf g l a)
-> TcTyVar
-> TcRnIf g l Type
mkArbitraryType warn tv
| liftedTypeKind `isSubKind` kind
= return anyPrimTy
| eqKind kind (tyConKind anyPrimTyCon1)
= return (mkTyConApp anyPrimTyCon1 [])
| all isLiftedTypeKind args
, isLiftedTypeKind res
= return (mkTyConApp tup_tc [])
| otherwise
= do { _ <- warn (getSrcSpan tv) msg
; return (mkTyConApp (mkAnyPrimTyCon (getUnique tv) kind) []) }
where
kind = tyVarKind tv
(args,res) = splitKindFunTys kind
tup_tc = tupleTyCon Boxed (length args)
msg = vcat [ hang (ptext (sLit "Inventing strangely-kinded Any TyCon"))
2 (ptext (sLit "of kind") <+> quotes (ppr kind))
, nest 2 (ptext (sLit "from an instantiation of type variable") <+> quotes (ppr tv))
, ptext (sLit "This warning can be suppressed by a type signature fixing") <+> quotes (ppr tv)
, nest 2 (ptext (sLit "but is harmless without -O (and usually harmless anyway)."))
, ptext (sLit "See http://hackage.haskell.org/trac/ghc/ticket/959 for details") ]
\end{code}