-%
+1%
% (c) The University of Glasgow 2006
% (c) The AQUA Project, Glasgow University, 1996-1998
%
mkHsConApp, mkHsDictLet, mkHsApp,
hsLitType, hsLPatType, hsPatType,
mkHsAppTy, mkSimpleHsAlt,
- nlHsIntLit, mkVanillaTuplePat,
+ nlHsIntLit,
+ shortCutLit, hsOverLitName,
- mkArbitraryType, -- Put this elsewhere?
-
-- re-exported from TcMonad
- TcId, TcIdSet, TcDictBinds,
+ TcId, TcIdSet,
zonkTopDecls, zonkTopExpr, zonkTopLExpr,
zonkId, zonkTopBndrs
import Id
import TcRnMonad
-import Type
+import PrelNames
import TcType
import TcMType
+import Coercion
import TysPrim
import TysWiredIn
-import TyCon
+import DataCon
import Name
+import NameSet
import Var
import VarSet
import VarEnv
+import DynFlags( DynFlag(..) )
+import Literal
import BasicTypes
import Maybes
-import Unique
import SrcLoc
-import Util
import Bag
+import FastString
import Outputable
+-- import Data.Traversable( traverse )
+\end{code}
+
+\begin{code}
+-- XXX
+thenM :: Monad a => a b -> (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}
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
-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 pat) = idType (unLoc var)
-hsPatType (ListPat _ ty) = mkListTy ty
-hsPatType (PArrPat _ ty) = mkPArrTy ty
-hsPatType (TuplePat pats box ty) = ty
-hsPatType (ConPatOut{ pat_ty = ty })= ty
-hsPatType (SigPatOut pat ty) = ty
-hsPatType (NPat lit _ _ ty) = ty
-hsPatType (NPlusKPat id _ _ _) = idType (unLoc id)
-hsPatType (CoPat _ _ ty) = ty
-hsPatType (DictPat ds ms) = case (ds ++ ms) of
- [] -> unitTy
- [d] -> idType d
- ds -> mkTupleTy Boxed (length ds) (map idType ds)
-
+hsPatType :: Pat Id -> Type
+hsPatType (ParPat pat) = hsLPatType pat
+hsPatType (WildPat ty) = ty
+hsPatType (VarPat 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 c) = charTy
-hsLitType (HsCharPrim c) = charPrimTy
-hsLitType (HsString str) = stringTy
-hsLitType (HsStringPrim s) = addrPrimTy
-hsLitType (HsInt i) = intTy
-hsLitType (HsIntPrim i) = intPrimTy
-hsLitType (HsInteger i ty) = ty
-hsLitType (HsRat _ ty) = ty
-hsLitType (HsFloatPrim f) = floatPrimTy
-hsLitType (HsDoublePrim d) = doublePrimTy
+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 (integralFractionalLit i)) ty
+ -- The 'otherwise' case is important
+ -- Consider (3 :: Float). Syntactically it looks like an IntLit,
+ -- so we'll call shortCutIntLit, but of course it's a float
+ -- This can make a big difference for programs with a lot of
+ -- literals, compiled without -O
+
+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
+-- Get the canonical 'fromX' name for a particular OverLitVal
+hsOverLitName (HsIntegral {}) = fromIntegerName
+hsOverLitName (HsFractional {}) = fromRationalName
+hsOverLitName (HsIsString {}) = fromStringName
+\end{code}
%************************************************************************
%* *
\begin{code}
data ZonkEnv = ZonkEnv (TcType -> TcM Type) -- How to zonk a type
- (IdEnv Id) -- What variables are in scope
- -- Maps an Id to its zonked version; both have the same Name
+ (VarEnv Var) -- What variables are in scope
+ -- Maps an Id or EvVar to its zonked version; both have the same Name
+ -- Note that all evidence (coercion variables as well as dictionaries)
+ -- are kept in the ZonkEnv
+ -- Only *type* abstraction is done by side effect
-- Is only consulted lazily; hence knot-tying
+emptyZonkEnv :: ZonkEnv
emptyZonkEnv = ZonkEnv zonkTypeZapping emptyVarEnv
-extendZonkEnv :: ZonkEnv -> [Id] -> ZonkEnv
+extendZonkEnv :: ZonkEnv -> [Var] -> ZonkEnv
extendZonkEnv (ZonkEnv zonk_ty env) ids
= ZonkEnv zonk_ty (extendVarEnvList env [(id,id) | id <- ids])
-extendZonkEnv1 :: ZonkEnv -> Id -> ZonkEnv
+extendZonkEnv1 :: ZonkEnv -> Var -> ZonkEnv
extendZonkEnv1 (ZonkEnv zonk_ty env) id
= ZonkEnv zonk_ty (extendVarEnv env id id)
--
-- Even without template splices, in module Main, the checking of
-- 'main' is done as a separate chunk.
-zonkIdOcc (ZonkEnv zonk_ty env) 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 is used *after* typechecking to get the Id's type
zonkTopBndrs :: [TcId] -> TcM [Id]
zonkTopBndrs ids = zonkIdBndrs emptyZonkEnv ids
+
+zonkEvBndrsX :: ZonkEnv -> [EvVar] -> TcM (ZonkEnv, [Var])
+zonkEvBndrsX = mapAccumLM zonkEvBndrX
+
+zonkEvBndrX :: ZonkEnv -> EvVar -> TcM (ZonkEnv, EvVar)
+-- Works for dictionaries and coercions
+zonkEvBndrX env var
+ = do { var' <- zonkEvBndr env var
+ ; return (extendZonkEnv1 env var', var') }
+
+zonkEvBndr :: ZonkEnv -> EvVar -> TcM EvVar
+-- Works for dictionaries and coercions
+-- Does not extend the ZonkEnv
+zonkEvBndr env var
+ = do { ty' <- zonkTcTypeToType env (varType var)
+ ; return (setVarType var ty') }
+
+zonkEvVarOcc :: ZonkEnv -> EvVar -> EvVar
+zonkEvVarOcc env v = zonkIdOcc env v
\end{code}
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
- -- Top level is implicitly recursive
- ; rules' <- zonkRules env rules
- ; fords' <- zonkForeignExports env fords
- ; return (zonkEnvIds env, binds', fords', rules') }
+zonkTopDecls :: Bag EvBind
+ -> LHsBinds TcId -> NameSet
+ -> [LRuleDecl TcId] -> [LVectDecl TcId] -> [LTcSpecPrag] -> [LForeignDecl TcId]
+ -> TcM ([Id],
+ Bag EvBind,
+ Bag (LHsBind Id),
+ [LForeignDecl Id],
+ [LTcSpecPrag],
+ [LRuleDecl Id],
+ [LVectDecl Id])
+zonkTopDecls ev_binds binds sig_ns rules vects imp_specs fords
+ = do { (env1, ev_binds') <- zonkEvBinds emptyZonkEnv ev_binds
+
+ -- Warn about missing signatures
+ -- Do this only when we we have a type to offer
+ ; warn_missing_sigs <- doptM Opt_WarnMissingSigs
+ ; let sig_warn | warn_missing_sigs = topSigWarn sig_ns
+ | otherwise = noSigWarn
+
+ ; (env2, binds') <- zonkRecMonoBinds env1 sig_warn binds
+ -- Top level is implicitly recursive
+ ; rules' <- zonkRules env2 rules
+ ; vects' <- zonkVects env2 vects
+ ; specs' <- zonkLTcSpecPrags env2 imp_specs
+ ; fords' <- zonkForeignExports env2 fords
+ ; return (zonkEnvIds env2, ev_binds', binds', fords', specs', rules', vects') }
---------------------------------------------
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 _ (HsValBinds (ValBindsIn {}))
+ = panic "zonkLocalBinds" -- Not in typechecker output
+
+zonkLocalBinds env (HsValBinds vb@(ValBindsOut binds sigs))
+ = do { warn_missing_sigs <- doptM Opt_WarnMissingLocalSigs
+ ; let sig_warn | not warn_missing_sigs = noSigWarn
+ | otherwise = localSigWarn sig_ns
+ sig_ns = getTypeSigNames vb
+ ; (env1, new_binds) <- go env sig_warn binds
+ ; return (env1, HsValBinds (ValBindsOut new_binds sigs)) }
+ where
+ go env _ []
+ = return (env, [])
+ go env sig_warn ((r,b):bs)
+ = do { (env1, b') <- zonkRecMonoBinds env sig_warn b
+ ; (env2, bs') <- go env1 sig_warn bs
+ ; return (env2, (r,b'):bs') }
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) ->
+ zonkTcEvBinds env1 dict_binds `thenM` \ (env2, new_dict_binds) ->
returnM (env2, HsIPBinds (IPBinds new_binds new_dict_binds))
where
zonk_ip_bind (IPBind n e)
zonkLExpr env e `thenM` \ e' ->
returnM (IPBind n' e')
+---------------------------------------------
+zonkRecMonoBinds :: ZonkEnv -> SigWarn -> LHsBinds TcId -> TcM (ZonkEnv, LHsBinds Id)
+zonkRecMonoBinds env sig_warn binds
+ = fixM (\ ~(_, new_binds) -> do
+ { let env1 = extendZonkEnv env (collectHsBindsBinders new_binds)
+ ; binds' <- zonkMonoBinds env1 sig_warn binds
+ ; return (env1, binds') })
---------------------------------------------
-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) }
+type SigWarn = Bool -> [Id] -> TcM ()
+ -- Missing-signature warning
+ -- The Bool is True for an AbsBinds, False otherwise
+
+noSigWarn :: SigWarn
+noSigWarn _ _ = return ()
+
+topSigWarn :: NameSet -> SigWarn
+topSigWarn sig_ns _ ids = mapM_ (topSigWarnId sig_ns) ids
+
+topSigWarnId :: NameSet -> Id -> TcM ()
+-- The NameSet is the Ids that *lack* a signature
+-- We have to do it this way round because there are
+-- lots of top-level bindings that are generated by GHC
+-- and that don't have signatures
+topSigWarnId sig_ns id
+ | idName id `elemNameSet` sig_ns = warnMissingSig msg id
+ | otherwise = return ()
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') }
+ msg = ptext (sLit "Top-level binding with no type signature:")
+
+localSigWarn :: NameSet -> SigWarn
+localSigWarn sig_ns is_abs_bind ids
+ | not is_abs_bind = return ()
+ | otherwise = mapM_ (localSigWarnId sig_ns) ids
+
+localSigWarnId :: NameSet -> Id -> TcM ()
+-- NameSet are the Ids that *have* type signatures
+localSigWarnId sig_ns id
+ | not (isSigmaTy (idType id)) = return ()
+ | idName id `elemNameSet` sig_ns = return ()
+ | otherwise = warnMissingSig msg id
+ where
+ msg = ptext (sLit "Polymophic local binding with no type signature:")
----------------------------------------------
-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') })
+warnMissingSig :: SDoc -> Id -> TcM ()
+warnMissingSig msg id
+ = do { env0 <- tcInitTidyEnv
+ ; let (env1, tidy_ty) = tidyOpenType env0 (idType id)
+ ; addWarnTcM (env1, mk_msg tidy_ty) }
+ where
+ mk_msg ty = sep [ msg, nest 2 $ pprHsVar (idName id) <+> dcolon <+> ppr ty ]
---------------------------------------------
-zonkMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (LHsBinds Id)
-zonkMonoBinds env binds = mapBagM (wrapLocM (zonk_bind env)) binds
+zonkMonoBinds :: ZonkEnv -> SigWarn -> LHsBinds TcId -> TcM (LHsBinds Id)
+zonkMonoBinds env sig_warn binds = mapBagM (wrapLocM (zonk_bind env sig_warn)) binds
-zonk_bind :: ZonkEnv -> HsBind TcId -> TcM (HsBind Id)
-zonk_bind env bind@(PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty})
+zonk_bind :: ZonkEnv -> SigWarn -> HsBind TcId -> TcM (HsBind Id)
+zonk_bind env sig_warn bind@(PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty})
= do { (_env, new_pat) <- zonkPat env pat -- Env already extended
+ ; sig_warn False (collectPatBinders new_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 })
+zonk_bind env sig_warn (VarBind { var_id = var, var_rhs = expr, var_inline = inl })
+ = do { new_var <- zonkIdBndr env var
+ ; sig_warn False [new_var]
+ ; new_expr <- zonkLExpr env expr
+ ; return (VarBind { var_id = new_var, var_rhs = new_expr, var_inline = inl }) }
+
+zonk_bind env sig_warn bind@(FunBind { fun_id = L loc var, fun_matches = ms
+ , fun_co_fn = co_fn })
+ = do { new_var <- zonkIdBndr env var
+ ; sig_warn False [new_var]
+ ; (env1, new_co_fn) <- zonkCoFn env co_fn
+ ; new_ms <- zonkMatchGroup env1 ms
+ ; return (bind { fun_id = L loc new_var, fun_matches = new_ms
+ , fun_co_fn = new_co_fn }) }
+
+zonk_bind env sig_warn (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
+ , abs_ev_binds = ev_binds
+ , abs_exports = exports
+ , abs_binds = val_binds })
= ASSERT( all isImmutableTyVar tyvars )
- zonkIdBndrs 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 })
+ do { (env1, new_evs) <- zonkEvBndrsX env evs
+ ; (env2, new_ev_binds) <- zonkTcEvBinds env1 ev_binds
+ ; (new_val_bind, new_exports) <- fixM $ \ ~(new_val_binds, _) ->
+ do { let env3 = extendZonkEnv env2 (collectHsBindsBinders new_val_binds)
+ ; new_val_binds <- zonkMonoBinds env3 noSigWarn val_binds
+ ; new_exports <- mapM (zonkExport env3) exports
+ ; return (new_val_binds, new_exports) }
+ ; sig_warn True [b | (_,b,_,_) <- new_exports]
+ ; return (AbsBinds { abs_tvs = tyvars, abs_ev_vars = new_evs, abs_ev_binds = new_ev_binds
+ , abs_exports = new_exports, abs_binds = new_val_bind }) }
where
zonkExport env (tyvars, global, local, prags)
-- The tyvars are already zonked
= zonkIdBndr env global `thenM` \ new_global ->
- mapM zonk_prag prags `thenM` \ new_prags ->
+ zonkSpecPrags env 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 ds inl))
- = do { expr' <- zonkExpr env expr
- ; ty' <- zonkTcTypeToType env ty
- ; let ds' = zonkIdOccs env ds
- ; return (L loc (SpecPrag expr' ty' ds' inl)) }
+
+zonkSpecPrags :: ZonkEnv -> TcSpecPrags -> TcM TcSpecPrags
+zonkSpecPrags _ IsDefaultMethod = return IsDefaultMethod
+zonkSpecPrags env (SpecPrags ps) = do { ps' <- zonkLTcSpecPrags env ps
+ ; return (SpecPrags ps') }
+
+zonkLTcSpecPrags :: ZonkEnv -> [LTcSpecPrag] -> TcM [LTcSpecPrag]
+zonkLTcSpecPrags env ps
+ = mapM zonk_prag ps
+ where
+ zonk_prag (L loc (SpecPrag id co_fn inl))
+ = do { (_, co_fn') <- zonkCoFn env co_fn
+ ; return (L loc (SpecPrag (zonkIdOcc env id) co_fn' inl)) }
\end{code}
%************************************************************************
= zonkTcTypeToType env ty `thenM` \ new_ty ->
returnM (HsLit (HsRat f new_ty))
-zonkExpr env (HsLit lit)
+zonkExpr _ (HsLit lit)
= returnM (HsLit lit)
zonkExpr env (HsOverLit lit)
zonk_b (n,e) = zonkLExpr env e `thenM` \ e' ->
returnM (n,e')
-zonkExpr env (HsSpliceE s) = WARN( True, ppr s ) -- Should not happen
+zonkExpr _ (HsSpliceE s) = WARN( True, ppr s ) -- Should not happen
returnM (HsSpliceE s)
zonkExpr env (OpApp e1 op fixity e2)
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 (HsIf e0 e1 e2 e3)
+ = do { new_e0 <- fmapMaybeM (zonkExpr env) e0
+ ; new_e1 <- zonkLExpr env e1
+ ; new_e2 <- zonkLExpr env e2
+ ; new_e3 <- zonkLExpr env e3
+ ; returnM (HsIf new_e0 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 ->
+zonkExpr env (HsDo do_or_lc stmts ty)
+ = zonkStmts env stmts `thenM` \ (_, new_stmts) ->
zonkTcTypeToType env ty `thenM` \ new_ty ->
- returnM (HsDo (zonkDo env do_or_lc)
- new_stmts new_body new_ty)
+ returnM (HsDo do_or_lc new_stmts new_ty)
zonkExpr env (ExplicitList ty exprs)
= zonkTcTypeToType env ty `thenM` \ new_ty ->
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)
- = zonkExpr env con_expr `thenM` \ new_con_expr ->
- zonkRbinds env rbinds `thenM` \ new_rbinds ->
- returnM (RecordCon data_con new_con_expr new_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)
- = zonkLExpr env expr `thenM` \ new_expr ->
- mapM (zonkTcTypeToType env) in_tys `thenM` \ new_in_tys ->
- mapM (zonkTcTypeToType env) out_tys `thenM` \ new_out_tys ->
- zonkRbinds env rbinds `thenM` \ new_rbinds ->
- returnM (RecordUpd new_expr new_rbinds cons new_in_tys new_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 env (ExprWithTySig _ _) = panic "zonkExpr env:ExprWithTySig"
+zonkExpr _ (ExprWithTySig _ _) = panic "zonkExpr env:ExprWithTySig"
zonkExpr env (ArithSeq expr info)
= zonkExpr env expr `thenM` \ new_expr ->
zonkExpr env1 expr `thenM` \ new_expr ->
return (HsWrap new_co_fn new_expr)
-zonkExpr env other = pprPanic "zonkExpr" (ppr other)
+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 ->
-------------------------------------------------------------------------
zonkCoFn :: ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper)
-zonkCoFn env WpHole = return (env, WpHole)
+zonkCoFn env WpHole = return (env, WpHole)
zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1
; (env2, c2') <- zonkCoFn env1 c2
; return (env2, WpCompose c1' c2') }
-zonkCoFn env (WpCo co) = do { co' <- zonkTcTypeToType env co
- ; return (env, WpCo co') }
-zonkCoFn env (WpLam id) = do { id' <- zonkIdBndr env id
- ; let env1 = extendZonkEnv1 env id'
- ; return (env1, WpLam id') }
+zonkCoFn env (WpCast co) = do { co' <- zonkTcCoToCo env co
+ ; return (env, WpCast co') }
+zonkCoFn env (WpEvLam ev) = do { (env', ev') <- zonkEvBndrX env ev
+ ; return (env', WpEvLam ev') }
+zonkCoFn env (WpEvApp arg) = do { arg' <- zonkEvTerm env arg
+ ; return (env, WpEvApp arg') }
zonkCoFn env (WpTyLam tv) = ASSERT( isImmutableTyVar tv )
- do { return (env, WpTyLam tv) }
-zonkCoFn env (WpApp id) = do { return (env, WpApp (zonkIdOcc env id)) }
+ return (env, WpTyLam tv)
zonkCoFn env (WpTyApp ty) = do { ty' <- zonkTcTypeToType env ty
; return (env, WpTyApp ty') }
-zonkCoFn env (WpLet bs) = do { (env1, bs') <- zonkRecMonoBinds env bs
+zonkCoFn env (WpLet bs) = do { (env1, bs') <- zonkTcEvBinds env bs
; return (env1, WpLet bs') }
-
--------------------------------------------------------------------------
-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') }
-zonkOverLit env (HsIsString s e)
- = do { e' <- zonkExpr env e; return (HsIsString s e') }
+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)
; return (env2, s' : ss') }
zonkStmt :: ZonkEnv -> Stmt TcId -> TcM (ZonkEnv, Stmt Id)
-zonkStmt env (ParStmt stmts_w_bndrs)
+zonkStmt env (ParStmt stmts_w_bndrs mzip_op bind_op return_op)
= 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)
+ zonkExpr env1 mzip_op `thenM` \ new_mzip ->
+ zonkExpr env1 bind_op `thenM` \ new_bind ->
+ zonkExpr env1 return_op `thenM` \ new_return ->
+ return (env1, ParStmt new_stmts_w_bndrs new_mzip new_bind new_return)
where
zonk_branch (stmts, bndrs) = zonkStmts env stmts `thenM` \ (env1, new_stmts) ->
returnM (new_stmts, zonkIdOccs env1 bndrs)
-zonkStmt env (RecStmt segStmts lvs rvs rets binds)
- = zonkIdBndrs env rvs `thenM` \ new_rvs ->
- let
- env1 = extendZonkEnv env new_rvs
- in
- zonkStmts env1 segStmts `thenM` \ (env2, new_segStmts) ->
+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_ret_ty = ret_ty })
+ = do { new_rvs <- zonkIdBndrs env rvs
+ ; new_lvs <- zonkIdBndrs env lvs
+ ; new_ret_ty <- zonkTcTypeToType env ret_ty
+ ; 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
-- Zonk the ret-expressions in an envt that
-- has the polymorphic bindings in the envt
- mapM (zonkExpr env2) rets `thenM` \ new_rets ->
- let
- new_lvs = zonkIdOccs env2 lvs
- env3 = extendZonkEnv env new_lvs -- Only the lvs are needed
- in
- zonkRecMonoBinds env3 binds `thenM` \ (env4, new_binds) ->
- returnM (env4, RecStmt new_segStmts new_lvs new_rvs new_rets new_binds)
-
-zonkStmt env (ExprStmt expr then_op ty)
+ ; new_rets <- mapM (zonkExpr env2) rets
+ ; return (extendZonkEnv env new_lvs, -- Only the lvs are needed
+ 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_ret_ty = new_ret_ty }) }
+
+zonkStmt env (ExprStmt expr then_op guard_op ty)
= zonkLExpr env expr `thenM` \ new_expr ->
zonkExpr env then_op `thenM` \ new_then ->
+ zonkExpr env guard_op `thenM` \ new_guard ->
zonkTcTypeToType env ty `thenM` \ new_ty ->
- returnM (env, ExprStmt new_expr new_then new_ty)
+ returnM (env, ExprStmt new_expr new_then new_guard new_ty)
+
+zonkStmt env (LastStmt expr ret_op)
+ = zonkLExpr env expr `thenM` \ new_expr ->
+ zonkExpr env ret_op `thenM` \ new_ret ->
+ returnM (env, LastStmt new_expr new_ret)
+
+zonkStmt env (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap
+ , trS_by = by, trS_form = form, trS_using = using
+ , trS_ret = return_op, trS_bind = bind_op, trS_fmap = liftM_op })
+ = do { (env', stmts') <- zonkStmts env stmts
+ ; binderMap' <- mappM (zonkBinderMapEntry env') binderMap
+ ; by' <- fmapMaybeM (zonkLExpr env') by
+ ; using' <- zonkLExpr env using
+ ; return_op' <- zonkExpr env' return_op
+ ; bind_op' <- zonkExpr env' bind_op
+ ; liftM_op' <- zonkExpr env' liftM_op
+ ; let env'' = extendZonkEnv env' (map snd binderMap')
+ ; return (env'', TransStmt { trS_stmts = stmts', trS_bndrs = binderMap'
+ , trS_by = by', trS_form = form, trS_using = using'
+ , trS_ret = return_op', trS_bind = bind_op', trS_fmap = liftM_op' }) }
+ where
+ 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) ->
; new_fail <- zonkExpr env fail_op
; return (env1, BindStmt new_pat new_expr new_bind new_fail) }
-
-------------------------------------------------------------------------
-zonkRbinds :: ZonkEnv -> HsRecordBinds TcId -> TcM (HsRecordBinds Id)
-
-zonkRbinds env (HsRecordBinds rbinds)
- = mappM zonk_rbind rbinds >>= return . HsRecordBinds
+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 (field, expr)
- = zonkLExpr env expr `thenM` \ new_expr ->
- returnM (fmap (zonkIdOcc env) field, new_expr)
+ 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)
-- to the right)
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') }
= 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') }
; (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
; (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 })
+zonk_pat env p@(ConPatOut { pat_ty = ty, pat_dicts = evs, pat_binds = binds, pat_args = args })
= ASSERT( all isImmutableTyVar (pat_tvs p) )
do { new_ty <- zonkTcTypeToType env ty
- ; new_dicts <- zonkIdBndrs env dicts
- ; let env1 = extendZonkEnv env new_dicts
- ; (env2, new_binds) <- zonkRecMonoBinds env1 binds
+ ; (env1, new_evs) <- zonkEvBndrsX env evs
+ ; (env2, new_binds) <- zonkTcEvBinds env1 binds
; (env', new_args) <- zonkConStuff env2 args
- ; returnM (env', p { pat_ty = new_ty, pat_dicts = new_dicts,
+ ; returnM (env', p { pat_ty = new_ty, pat_dicts = new_evs,
pat_binds = new_binds, pat_args = new_args }) }
zonk_pat env (LitPat lit) = return (env, LitPat lit)
; (env', pat') <- zonkPat env pat
; return (env', SigPatOut pat' ty') }
-zonk_pat env (NPat lit mb_neg eq_expr 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') }
+ ; mb_neg' <- fmapMaybeM (zonkExpr env) mb_neg
; eq_expr' <- zonkExpr env eq_expr
- ; ty' <- zonkTcTypeToType env ty
- ; return (env, NPat lit' mb_neg' eq_expr' ty') }
+ ; return (env, NPat lit' mb_neg' eq_expr') }
zonk_pat env (NPlusKPat (L loc n) lit e1 e2)
= do { n' <- zonkIdBndr env n
; e2' <- zonkExpr env e2
; return (extendZonkEnv1 env n', NPlusKPat (L loc n') lit' e1' e2') }
-zonk_pat env (DictPat ds ms)
- = do { ds' <- zonkIdBndrs env ds
- ; ms' <- zonkIdBndrs env ms
- ; return (extendZonkEnv env (ds' ++ ms'), DictPat ds' ms') }
-
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 env pat = pprPanic "zonk_pat" (ppr pat)
+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') }
; (env', p2') <- zonkPat env1 p2
; return (env', InfixCon p1' p2') }
-zonkConStuff env (RecCon rpats)
- = do { let (fields, pats) = unzip [ (f, p) | HsRecField f p _ <- rpats ]
- ; (env', pats') <- zonkPats env pats
- ; let recCon = RecCon [ mkRecField f p | (f, p) <- zip fields pats' ]
- ; returnM (env', recCon) }
+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)) }
+ -- Field selectors have declared types; hence no zonking
---------------------------
+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
zonkForeignExports env ls = mappM (wrapLocM (zonkForeignExport env)) ls
zonkForeignExport :: ZonkEnv -> ForeignDecl TcId -> TcM (ForeignDecl Id)
-zonkForeignExport env (ForeignExport i hs_ty spec) =
+zonkForeignExport env (ForeignExport i _hs_ty spec) =
returnM (ForeignExport (fmap (zonkIdOcc env) i) undefined spec)
-zonkForeignExport env for_imp
+zonkForeignExport _ for_imp
= returnM for_imp -- Foreign imports don't need zonking
\end{code}
zonkRules env rs = mappM (wrapLocM (zonkRule env)) rs
zonkRule :: ZonkEnv -> RuleDecl TcId -> TcM (RuleDecl Id)
-zonkRule env (HsRule name act (vars::[RuleBndr TcId]) 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]
- -- Type variables don't need an envt
- -- They are bound through the mutable mechanism
+zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs)
+ = do { (env_rhs, new_bndrs) <- mapAccumLM zonk_bndr env vars
- env_lhs = setZonkType env_rhs (zonkTypeCollecting unbound_tv_set)
+ ; unbound_tv_set <- newMutVar emptyVarSet
+ ; let env_lhs = setZonkType env_rhs (zonkTypeCollecting unbound_tv_set)
-- We need to gather the type variables mentioned on the LHS so we can
-- quantify over them. Example:
-- data T a = C
-- are tiresome, because (a) the data type is big and (b) finding the
-- free type vars of an expression is necessarily monadic operation.
-- (consider /\a -> f @ b, where b is side-effected to a)
- 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)
- -- I hate this map RuleBndr stuff
+ ; new_lhs <- zonkLExpr env_lhs lhs
+ ; new_rhs <- zonkLExpr env_rhs rhs
+
+ ; unbound_tvs <- readMutVar unbound_tv_set
+ ; let final_bndrs :: [RuleBndr Var]
+ final_bndrs = map (RuleBndr . noLoc) (varSetElems unbound_tvs) ++ new_bndrs
+
+ ; return (HsRule name act 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 env (RuleBndr (L loc v))
+ = do { (env', v') <- zonk_it env v; return (env', RuleBndr (L loc v')) }
+ zonk_bndr _ (RuleBndrSig {}) = panic "zonk_bndr RuleBndrSig"
+
+ zonk_it env v
+ | isId v = do { v' <- zonkIdBndr env v; return (extendZonkEnv1 env v', v') }
+ | otherwise = ASSERT( isImmutableTyVar v) return (env, v)
\end{code}
+\begin{code}
+zonkVects :: ZonkEnv -> [LVectDecl TcId] -> TcM [LVectDecl Id]
+zonkVects env = mappM (wrapLocM (zonkVect env))
+
+zonkVect :: ZonkEnv -> VectDecl TcId -> TcM (VectDecl Id)
+zonkVect env (HsVect v Nothing)
+ = do { v' <- wrapLocM (zonkIdBndr env) v
+ ; return $ HsVect v' Nothing
+ }
+zonkVect env (HsVect v (Just e))
+ = do { v' <- wrapLocM (zonkIdBndr env) v
+ ; e' <- zonkLExpr env e
+ ; return $ HsVect v' (Just e')
+ }
+\end{code}
%************************************************************************
%* *
-\subsection[BackSubst-Foreign]{Foreign exports}
+ Constraints and evidence
+%* *
+%************************************************************************
+
+\begin{code}
+zonkEvTerm :: ZonkEnv -> EvTerm -> TcM EvTerm
+zonkEvTerm env (EvId v) = ASSERT2( isId v, ppr v )
+ return (EvId (zonkIdOcc env v))
+zonkEvTerm env (EvCoercion co) = do { co' <- zonkTcCoToCo env co
+ ; return (EvCoercion co') }
+zonkEvTerm env (EvCast v co) = ASSERT( isId v)
+ do { co' <- zonkTcCoToCo env co
+ ; return (EvCast (zonkIdOcc env v) co') }
+zonkEvTerm env (EvSuperClass d n) = return (EvSuperClass (zonkIdOcc env d) n)
+zonkEvTerm env (EvDFunApp df tys tms)
+ = do { tys' <- zonkTcTypeToTypes env tys
+ ; let tms' = map (zonkEvVarOcc env) tms
+ ; return (EvDFunApp (zonkIdOcc env df) tys' tms') }
+
+zonkTcEvBinds :: ZonkEnv -> TcEvBinds -> TcM (ZonkEnv, TcEvBinds)
+zonkTcEvBinds env (TcEvBinds var) = do { (env', bs') <- zonkEvBindsVar env var
+ ; return (env', EvBinds bs') }
+zonkTcEvBinds env (EvBinds bs) = do { (env', bs') <- zonkEvBinds env bs
+ ; return (env', EvBinds bs') }
+
+zonkEvBindsVar :: ZonkEnv -> EvBindsVar -> TcM (ZonkEnv, Bag EvBind)
+zonkEvBindsVar env (EvBindsVar ref _) = do { bs <- readMutVar ref
+ ; zonkEvBinds env (evBindMapBinds bs) }
+
+zonkEvBinds :: ZonkEnv -> Bag EvBind -> TcM (ZonkEnv, Bag EvBind)
+zonkEvBinds env binds
+ = fixM (\ ~( _, new_binds) -> do
+ { let env1 = extendZonkEnv env (collect_ev_bndrs new_binds)
+ ; binds' <- mapBagM (zonkEvBind env1) binds
+ ; return (env1, binds') })
+ where
+ collect_ev_bndrs :: Bag EvBind -> [EvVar]
+ collect_ev_bndrs = foldrBag add []
+ add (EvBind var _) vars = var : vars
+
+zonkEvBind :: ZonkEnv -> EvBind -> TcM EvBind
+zonkEvBind env (EvBind var term)
+ = do { var' <- zonkEvBndr env var
+ ; term' <- zonkEvTerm env term
+ ; return (EvBind var' term') }
+\end{code}
+
+%************************************************************************
+%* *
+ Zonking types
%* *
%************************************************************************
zonkTypeCollecting :: TcRef TyVarSet -> TcType -> TcM Type
-- This variant collects unbound type variables in a mutable variable
zonkTypeCollecting unbound_tv_set
- = zonkType zonk_unbound_tyvar
+ = zonkType (mkZonkTcTyVar 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')
+ = do { tv' <- zonkQuantifiedTyVar tv
+ ; tv_set <- readMutVar unbound_tv_set
+ ; writeMutVar unbound_tv_set (extendVarSet tv_set tv')
+ ; return (mkTyVarTy tv') }
zonkTypeZapping :: TcType -> TcM Type
-- 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 (mkZonkTcTyVar 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 { writeMetaTyVar tv ty; return ty }
- where
- ty = mkArbitraryType tv
-
-
--- When the type checker finds a type variable with no binding,
--- which means it can be instantiated with an arbitrary type, it
--- usually instantiates it to Void. Eg.
---
--- length []
--- ===>
--- length Void (Nil Void)
---
--- But in really obscure programs, the type variable might have
--- a kind other than *, so we need to invent a suitably-kinded type.
---
--- This commit uses
--- Void for kind *
--- List for kind *->*
--- Tuple for kind *->...*->*
---
--- which deals with most cases. (Previously, it only dealt with
--- kind *.)
---
--- In the other cases, it just makes up a TyCon with a suitable
--- kind. If this gets into an interface file, anyone reading that
--- file won't understand it. This is fixable (by making the client
--- of the interface file make up a TyCon too) but it is tiresome and
--- never happens, so I am leaving it
-
-mkArbitraryType :: TcTyVar -> Type
--- Make up an arbitrary type whose kind is the same as the tyvar.
--- We'll use this to instantiate the (unbound) tyvar.
-mkArbitraryType tv
- | liftedTypeKind `isSubKind` kind = anyPrimTy -- The vastly common case
- | otherwise = mkTyConApp tycon []
- where
- kind = tyVarKind tv
- (args,res) = splitKindFunTys kind
-
- tycon | eqKind kind (tyConKind anyPrimTyCon1) -- *->*
- = anyPrimTyCon1 -- No tuples this size
+ zonk_unbound_tyvar tv = do { let ty = anyTypeOfKind (tyVarKind tv)
+ ; writeMetaTyVar tv ty
+ ; return ty }
- | all isLiftedTypeKind args && isLiftedTypeKind res
- = tupleTyCon Boxed (length args) -- *-> ... ->*->*
- -- Horrible hack to make less use of mkAnyPrimTyCon
-
- | otherwise
- = 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
- -- interface file. Catastrophe likely. Major sigh.
+zonkTcCoToCo :: ZonkEnv -> Coercion -> TcM Coercion
+zonkTcCoToCo env co
+ = go co
+ where
+ go (CoVarCo cv) = return (CoVarCo (zonkEvVarOcc env cv))
+ go (Refl ty) = do { ty' <- zonkTcTypeToType env ty
+ ; return (Refl ty') }
+ go (TyConAppCo tc cos) = do { cos' <- mapM go cos; return (mkTyConAppCo tc cos') }
+ go (AxiomInstCo ax cos) = do { cos' <- mapM go cos; return (AxiomInstCo ax cos') }
+ go (AppCo co1 co2) = do { co1' <- go co1; co2' <- go co2
+ ; return (mkAppCo co1' co2') }
+ go (UnsafeCo t1 t2) = do { t1' <- zonkTcTypeToType env t1
+ ; t2' <- zonkTcTypeToType env t2
+ ; return (mkUnsafeCo t1' t2') }
+ go (SymCo co) = do { co' <- go co; return (mkSymCo co') }
+ go (NthCo n co) = do { co' <- go co; return (mkNthCo n co') }
+ go (TransCo co1 co2) = do { co1' <- go co1; co2' <- go co2
+ ; return (mkTransCo co1' co2') }
+ go (InstCo co ty) = do { co' <- go co; ty' <- zonkTcTypeToType env ty
+ ; return (mkInstCo co' ty') }
+ go (ForAllCo tv co) = ASSERT( isImmutableTyVar tv )
+ do { co' <- go co; return (mkForAllCo tv co') }
\end{code}
projects / ghc-hetmet.git / blobdiff