X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcHsSyn.lhs;h=59dfa9c4a0ceb7405a620ead10985a1ea2a81cd3;hb=8e67f5502e2e316245806ee3735a2f41a844b611;hp=8c23d8a86d0cff03bf20f0867fc6c37ff7e46cd3;hpb=9003a18c4efa4548ae80709aef9963f7b544ded3;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index 8c23d8a..59dfa9c 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -8,32 +8,22 @@ checker. \begin{code} module TcHsSyn ( - TcMonoBinds, TcHsBinds, TcPat, - TcExpr, TcGRHSs, TcGRHS, TcMatch, - TcStmt, TcArithSeqInfo, TcRecordBinds, - TcHsModule, TcDictBinds, - TcForeignExportDecl, - - TypecheckedHsBinds, TypecheckedRuleDecl, - TypecheckedMonoBinds, TypecheckedPat, - TypecheckedHsExpr, TypecheckedArithSeqInfo, - TypecheckedStmt, TypecheckedForeignDecl, - TypecheckedMatch, TypecheckedHsModule, - TypecheckedGRHSs, TypecheckedGRHS, - TypecheckedRecordBinds, TypecheckedDictBinds, - TypecheckedMatchContext, TypecheckedCoreBind, - mkHsTyApp, mkHsDictApp, mkHsConApp, - mkHsTyLam, mkHsDictLam, mkHsLet, - simpleHsLitTy, + mkHsTyLam, mkHsDictLam, mkHsLet, mkHsApp, + hsLitType, hsPatType, mkHsAppTy, mkSimpleHsAlt, + nlHsIntLit, glueBindsOnGRHSs, + - collectTypedPatBinders, outPatType, + -- Coercions + Coercion, ExprCoFn, PatCoFn, + (<$>), (<.>), mkCoercion, + idCoercion, isIdCoercion, - -- re-exported from TcEnv - TcId, + -- re-exported from TcMonad + TcId, TcIdSet, TcDictBinds, - zonkTopBinds, zonkId, zonkIdBndr, zonkIdOcc, zonkExpr, - zonkForeignExports, zonkRules, zonkCoreExpr, zonkCoreBinds + zonkTopDecls, zonkTopExpr, zonkTopLExpr, + zonkId, zonkTopBndrs ) where #include "HsVersions.h" @@ -42,162 +32,112 @@ module TcHsSyn ( import HsSyn -- oodles of it -- others: -import Id ( idName, idType, setIdType, Id ) -import DataCon ( dataConWrapId ) -import TcEnv ( tcLookupGlobal_maybe, tcExtendGlobalValEnv, TcEnv, TcId ) +import Id ( idType, setIdType, Id ) -import TcMonad +import TcRnMonad import Type ( Type ) -import TcType ( TcType, tcGetTyVar ) -import TcMType ( zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcType, zonkTcTyVars ) +import TcType ( TcType, TcTyVar, mkTyVarTy, mkTyConApp, isImmutableTyVar, tcGetTyVar ) +import Kind ( isLiftedTypeKind, liftedTypeKind, isSubKind ) +import qualified Type +import TcMType ( zonkQuantifiedTyVar, zonkType, zonkTcType, zonkTcTyVars, putMetaTyVar ) import TysPrim ( charPrimTy, intPrimTy, floatPrimTy, doublePrimTy, addrPrimTy ) -import TysWiredIn ( charTy, stringTy, intTy, integerTy, - mkListTy, mkPArrTy, mkTupleTy, unitTy ) -import CoreSyn ( Expr(..), CoreExpr, CoreBind, Bind(..), CoreAlt, Note(..) ) -import Var ( isId ) -import BasicTypes ( RecFlag(..), Boxity(..), IPName(..), ipNameName ) +import TysWiredIn ( charTy, stringTy, intTy, + mkListTy, mkPArrTy, mkTupleTy, unitTy, + voidTy, listTyCon, tupleTyCon ) +import TyCon ( mkPrimTyCon, tyConKind, PrimRep(..) ) +import Kind ( splitKindFunTys ) +import Name ( getOccName, mkInternalName, mkDerivedTyConOcc ) +import Var ( Var, isId, isLocalVar, tyVarKind ) +import VarSet +import VarEnv +import BasicTypes ( Boxity(..), IPName(..), ipNameName, mapIPName ) +import Maybes ( orElse ) +import Maybe ( isNothing ) +import Unique ( Uniquable(..) ) +import SrcLoc ( noSrcLoc, noLoc, Located(..), unLoc ) import Bag import Outputable -import HscTypes ( TyThing(..) ) \end{code} -Type definitions -~~~~~~~~~~~~~~~~ - -The @Tc...@ datatypes are the ones that apply {\em during} type checking. -All the types in @Tc...@ things have mutable type-variables in them for -unification. - -At the end of type checking we zonk everything to @Typechecked...@ datatypes, -which have immutable type variables in them. - -\begin{code} -type TcHsBinds = HsBinds TcId TcPat -type TcMonoBinds = MonoBinds TcId TcPat -type TcDictBinds = TcMonoBinds -type TcPat = OutPat TcId -type TcExpr = HsExpr TcId TcPat -type TcGRHSs = GRHSs TcId TcPat -type TcGRHS = GRHS TcId TcPat -type TcMatch = Match TcId TcPat -type TcStmt = Stmt TcId TcPat -type TcArithSeqInfo = ArithSeqInfo TcId TcPat -type TcRecordBinds = HsRecordBinds TcId TcPat -type TcHsModule = HsModule TcId TcPat - -type TcForeignExportDecl = ForeignDecl TcId -type TcRuleDecl = RuleDecl TcId TcPat - -type TypecheckedPat = OutPat Id -type TypecheckedMonoBinds = MonoBinds Id TypecheckedPat -type TypecheckedDictBinds = TypecheckedMonoBinds -type TypecheckedHsBinds = HsBinds Id TypecheckedPat -type TypecheckedHsExpr = HsExpr Id TypecheckedPat -type TypecheckedArithSeqInfo = ArithSeqInfo Id TypecheckedPat -type TypecheckedStmt = Stmt Id TypecheckedPat -type TypecheckedMatch = Match Id TypecheckedPat -type TypecheckedMatchContext = HsMatchContext Id -type TypecheckedGRHSs = GRHSs Id TypecheckedPat -type TypecheckedGRHS = GRHS Id TypecheckedPat -type TypecheckedRecordBinds = HsRecordBinds Id TypecheckedPat -type TypecheckedHsModule = HsModule Id TypecheckedPat -type TypecheckedForeignDecl = ForeignDecl Id -type TypecheckedRuleDecl = RuleDecl Id TypecheckedPat -type TypecheckedCoreBind = (Id, CoreExpr) -\end{code} - -\begin{code} -mkHsTyApp expr [] = expr -mkHsTyApp expr tys = TyApp expr tys - -mkHsDictApp expr [] = expr -mkHsDictApp expr dict_vars = DictApp expr dict_vars - -mkHsTyLam [] expr = expr -mkHsTyLam tyvars expr = TyLam tyvars expr - -mkHsDictLam [] expr = expr -mkHsDictLam dicts expr = DictLam dicts expr - -mkHsLet EmptyMonoBinds expr = expr -mkHsLet mbinds expr = HsLet (MonoBind mbinds [] Recursive) expr - -mkHsConApp data_con tys args = foldl HsApp (HsVar (dataConWrapId data_con) `mkHsTyApp` tys) args -\end{code} - +%************************************************************************ +%* * +\subsection[mkFailurePair]{Code for pattern-matching and other failures} +%* * +%************************************************************************ ------------------------------------------------------- +Note: If @hsPatType@ doesn't bear a strong resemblance to @exprType@, +then something is wrong. \begin{code} -simpleHsLitTy :: HsLit -> TcType -simpleHsLitTy (HsCharPrim c) = charPrimTy -simpleHsLitTy (HsStringPrim s) = addrPrimTy -simpleHsLitTy (HsInt i) = intTy -simpleHsLitTy (HsInteger i) = integerTy -simpleHsLitTy (HsIntPrim i) = intPrimTy -simpleHsLitTy (HsFloatPrim f) = floatPrimTy -simpleHsLitTy (HsDoublePrim d) = doublePrimTy -simpleHsLitTy (HsChar c) = charTy -simpleHsLitTy (HsString str) = stringTy +hsPatType :: OutPat Id -> Type +hsPatType pat = pat_type (unLoc 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 (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 (ConPatOut _ _ _ _ _ ty) = ty +pat_type (SigPatOut pat ty) = ty +pat_type (NPatOut lit ty _) = ty +pat_type (NPlusKPatOut id _ _ _) = idType (unLoc id) +pat_type (DictPat ds ms) = case (ds ++ ms) of + [] -> unitTy + [d] -> idType d + ds -> mkTupleTy Boxed (length ds) (map idType ds) + + +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 \end{code} - %************************************************************************ %* * -\subsection[mkFailurePair]{Code for pattern-matching and other failures} +\subsection{Coercion functions} %* * %************************************************************************ -Note: If @outPatType@ doesn't bear a strong resemblance to @exprType@, -then something is wrong. \begin{code} -outPatType :: TypecheckedPat -> Type - -outPatType (WildPat ty) = ty -outPatType (VarPat var) = idType var -outPatType (LazyPat pat) = outPatType pat -outPatType (AsPat var pat) = idType var -outPatType (ConPat _ ty _ _ _) = ty -outPatType (ListPat ty _) = mkListTy ty -outPatType (PArrPat ty _) = mkPArrTy ty -outPatType (TuplePat pats box) = mkTupleTy box (length pats) (map outPatType pats) -outPatType (RecPat _ ty _ _ _) = ty -outPatType (SigPat _ ty _) = ty -outPatType (LitPat lit ty) = ty -outPatType (NPat lit ty _) = ty -outPatType (NPlusKPat _ _ ty _ _) = ty -outPatType (DictPat ds ms) = case (length ds_ms) of - 0 -> unitTy - 1 -> idType (head ds_ms) - n -> mkTupleTy Boxed n (map idType ds_ms) - where - ds_ms = ds ++ ms -\end{code} +type Coercion a = Maybe (a -> a) + -- Nothing => identity fn +type ExprCoFn = Coercion (HsExpr TcId) +type PatCoFn = Coercion (Pat TcId) -Nota bene: @DsBinds@ relies on the fact that at least for simple -tuple patterns @collectTypedPatBinders@ returns the binders in -the same order as they appear in the tuple. +(<.>) :: 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) -@collectTypedBinders@ and @collectedTypedPatBinders@ are the exportees. +(<$>) :: Coercion a -> a -> a +Just f <$> e = f e +Nothing <$> e = e -\begin{code} -collectTypedPatBinders :: TypecheckedPat -> [Id] -collectTypedPatBinders (VarPat var) = [var] -collectTypedPatBinders (LazyPat pat) = collectTypedPatBinders pat -collectTypedPatBinders (AsPat a pat) = a : collectTypedPatBinders pat -collectTypedPatBinders (SigPat pat _ _) = collectTypedPatBinders pat -collectTypedPatBinders (ConPat _ _ _ _ pats) = concat (map collectTypedPatBinders pats) -collectTypedPatBinders (ListPat t pats) = concat (map collectTypedPatBinders pats) -collectTypedPatBinders (PArrPat t pats) = concat (map collectTypedPatBinders pats) -collectTypedPatBinders (TuplePat pats _) = concat (map collectTypedPatBinders pats) -collectTypedPatBinders (RecPat _ _ _ _ fields) = concat (map (\ (f,pat,_) -> collectTypedPatBinders pat) - fields) -collectTypedPatBinders (DictPat ds ms) = ds ++ ms -collectTypedPatBinders (NPlusKPat var _ _ _ _) = [var] -collectTypedPatBinders any_other_pat = [ {-no binders-} ] +mkCoercion :: (a -> a) -> Coercion a +mkCoercion f = Just f + +idCoercion :: Coercion a +idCoercion = Nothing + +isIdCoercion :: Coercion a -> Bool +isIdCoercion = isNothing \end{code} @@ -207,7 +147,16 @@ collectTypedPatBinders any_other_pat = [ {-no binders-} ] %* * %************************************************************************ -This zonking pass runs over the bindings +\begin{code} +-- zonkId is used *during* typechecking just to zonk the Id's type +zonkId :: TcId -> TcM TcId +zonkId id + = zonkTcType (idType id) `thenM` \ ty' -> + returnM (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 @@ -224,143 +173,158 @@ It's all pretty boring stuff, because HsSyn is such a large type, and the environment manipulation is tiresome. \begin{code} --- zonkId is used *during* typechecking just to zonk the Id's type -zonkId :: TcId -> NF_TcM TcId -zonkId id - = zonkTcType (idType id) `thenNF_Tc` \ ty' -> - returnNF_Tc (setIdType id ty') +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 + -- Is only consulted lazily; hence knot-tying + +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 +-- Ids defined in this module should be in the envt; +-- ignore others. (Actually, data constructors are also +-- not LocalVars, even when locally defined, but that is fine.) +-- +-- Actually, Template Haskell works in 'chunks' of declarations, and +-- an earlier chunk won't be in the 'env' that the zonking phase +-- carries around. Instead it'll be in the tcg_gbl_env, already fully +-- zonked. There's no point in looking it up there (except for error +-- checking), and it's not conveniently to hand; hence the simple +-- 'orElse' case in the LocalVar branch. +-- +-- Even without template splices, in module Main, the checking of +-- 'main' is done as a separte chunk. +zonkIdOcc (ZonkEnv zonk_ty env) id + | isLocalVar id = lookupVarEnv env id `orElse` id + | otherwise = id + +zonkIdOccs env ids = map (zonkIdOcc env) ids -- zonkIdBndr is used *after* typechecking to get the Id's type -- to its final form. The TyVarEnv give -zonkIdBndr :: TcId -> NF_TcM Id -zonkIdBndr id - = zonkTcTypeToType (idType id) `thenNF_Tc` \ ty' -> - returnNF_Tc (setIdType id ty') - -zonkIdOcc :: TcId -> NF_TcM Id -zonkIdOcc id - = tcLookupGlobal_maybe (idName id) `thenNF_Tc` \ maybe_id' -> - -- We're even look up up superclass selectors and constructors; - -- even though zonking them is a no-op anyway, and the - -- superclass selectors aren't in the environment anyway. - -- But we don't want to call isLocalId to find out whether - -- it's a superclass selector (for example) because that looks - -- at the IdInfo field, which in turn be in a knot because of - -- the big knot in typecheckModule - let - new_id = case maybe_id' of - Just (AnId id') -> id' - other -> id -- WARN( isLocalId id, ppr id ) id - -- Oops: the warning can give a black hole - -- because it looks at the idinfo - in - returnNF_Tc new_id -\end{code} +zonkIdBndr :: ZonkEnv -> TcId -> TcM Id +zonkIdBndr env id + = zonkTcTypeToType env (idType id) `thenM` \ ty' -> + returnM (setIdType id ty') +zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id] +zonkIdBndrs env ids = mappM (zonkIdBndr env) ids -\begin{code} -zonkTopBinds :: TcMonoBinds -> NF_TcM (TypecheckedMonoBinds, TcEnv) -zonkTopBinds binds -- Top level is implicitly recursive - = fixNF_Tc (\ ~(_, new_ids) -> - tcExtendGlobalValEnv (bagToList new_ids) $ - zonkMonoBinds binds `thenNF_Tc` \ (binds', new_ids) -> - tcGetEnv `thenNF_Tc` \ env -> - returnNF_Tc ((binds', env), new_ids) - ) `thenNF_Tc` \ (stuff, _) -> - returnNF_Tc stuff - -zonkBinds :: TcHsBinds -> NF_TcM (TypecheckedHsBinds, TcEnv) - -zonkBinds binds - = go binds (\ binds' -> tcGetEnv `thenNF_Tc` \ env -> - returnNF_Tc (binds', env)) - where - -- go :: TcHsBinds - -- -> (TypecheckedHsBinds - -- -> NF_TcM (TypecheckedHsBinds, TcEnv) - -- ) - -- -> NF_TcM (TypecheckedHsBinds, TcEnv) - - go (ThenBinds b1 b2) thing_inside = go b1 $ \ b1' -> - go b2 $ \ b2' -> - thing_inside (b1' `ThenBinds` b2') - - go EmptyBinds thing_inside = thing_inside EmptyBinds - - go (MonoBind bind sigs is_rec) thing_inside - = ASSERT( null sigs ) - fixNF_Tc (\ ~(_, new_ids) -> - tcExtendGlobalValEnv (bagToList new_ids) $ - zonkMonoBinds bind `thenNF_Tc` \ (new_bind, new_ids) -> - thing_inside (mkMonoBind new_bind [] is_rec) `thenNF_Tc` \ stuff -> - returnNF_Tc (stuff, new_ids) - ) `thenNF_Tc` \ (stuff, _) -> - returnNF_Tc stuff +zonkTopBndrs :: [TcId] -> TcM [Id] +zonkTopBndrs ids = zonkIdBndrs emptyZonkEnv ids \end{code} + \begin{code} -------------------------------------------------------------------------- -zonkMonoBinds :: TcMonoBinds - -> NF_TcM (TypecheckedMonoBinds, Bag Id) - -zonkMonoBinds EmptyMonoBinds = returnNF_Tc (EmptyMonoBinds, emptyBag) - -zonkMonoBinds (AndMonoBinds mbinds1 mbinds2) - = zonkMonoBinds mbinds1 `thenNF_Tc` \ (b1', ids1) -> - zonkMonoBinds mbinds2 `thenNF_Tc` \ (b2', ids2) -> - returnNF_Tc (b1' `AndMonoBinds` b2', - ids1 `unionBags` ids2) - -zonkMonoBinds (PatMonoBind pat grhss locn) - = zonkPat pat `thenNF_Tc` \ (new_pat, ids) -> - zonkGRHSs grhss `thenNF_Tc` \ new_grhss -> - returnNF_Tc (PatMonoBind new_pat new_grhss locn, ids) - -zonkMonoBinds (VarMonoBind var expr) - = zonkIdBndr var `thenNF_Tc` \ new_var -> - zonkExpr expr `thenNF_Tc` \ new_expr -> - returnNF_Tc (VarMonoBind new_var new_expr, unitBag new_var) - -zonkMonoBinds (CoreMonoBind var core_expr) - = zonkIdBndr var `thenNF_Tc` \ new_var -> - returnNF_Tc (CoreMonoBind new_var core_expr, unitBag new_var) - -zonkMonoBinds (FunMonoBind var inf ms locn) - = zonkIdBndr var `thenNF_Tc` \ new_var -> - mapNF_Tc zonkMatch ms `thenNF_Tc` \ new_ms -> - returnNF_Tc (FunMonoBind new_var inf new_ms locn, unitBag new_var) - - -zonkMonoBinds (AbsBinds tyvars dicts exports inlines val_bind) - = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars -> - -- No need to extend tyvar env: the effects are - -- propagated through binding the tyvars themselves - - mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts -> - tcExtendGlobalValEnv new_dicts $ - - fixNF_Tc (\ ~(_, _, val_bind_ids) -> - tcExtendGlobalValEnv (bagToList val_bind_ids) $ - zonkMonoBinds val_bind `thenNF_Tc` \ (new_val_bind, val_bind_ids) -> - mapNF_Tc zonkExport exports `thenNF_Tc` \ new_exports -> - returnNF_Tc (new_val_bind, new_exports, val_bind_ids) - ) `thenNF_Tc ` \ (new_val_bind, new_exports, _) -> +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 + -- Top level is implicitly recursive + ; rules' <- zonkRules env rules + ; fords' <- zonkForeignExports env fords + ; return (zonkEnvIds env, binds', fords', rules') } + +--------------------------------------------- +zonkGroup :: ZonkEnv -> HsBindGroup TcId -> TcM (ZonkEnv, HsBindGroup Id) +zonkGroup env (HsBindGroup bs sigs is_rec) + = ASSERT( null sigs ) + do { (env1, bs') <- zonkRecMonoBinds env bs + ; return (env1, HsBindGroup bs' [] is_rec) } + +zonkGroup env (HsIPBinds binds) + = mappM (wrapLocM zonk_ip_bind) binds `thenM` \ new_binds -> let - new_globals = listToBag [global | (_, global, local) <- new_exports] + env1 = extendZonkEnv env [ipNameName n | L _ (IPBind n _) <- new_binds] in - returnNF_Tc (AbsBinds new_tyvars new_dicts new_exports inlines new_val_bind, - new_globals) + returnM (env1, HsIPBinds new_binds) where - zonkExport (tyvars, global, local) - = zonkTcTyVars tyvars `thenNF_Tc` \ tys -> + zonk_ip_bind (IPBind n e) + = mapIPNameTc (zonkIdBndr env) n `thenM` \ n' -> + zonkLExpr env e `thenM` \ e' -> + returnM (IPBind n' e') + +--------------------------------------------- +zonkNestedBinds :: ZonkEnv -> [HsBindGroup TcId] -> TcM (ZonkEnv, [HsBindGroup Id]) +zonkNestedBinds env [] = return (env, []) +zonkNestedBinds env (b:bs) = do { (env1, b') <- zonkGroup env b + ; (env2, bs') <- zonkNestedBinds env1 bs + ; return (env2, 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 (PatBind pat grhss 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) } + +zonk_bind env (VarBind var expr) + = zonkIdBndr env var `thenM` \ new_var -> + zonkLExpr env expr `thenM` \ new_expr -> + returnM (VarBind new_var new_expr) + +zonk_bind env (FunBind var inf ms) + = wrapLocM (zonkIdBndr env) var `thenM` \ new_var -> + zonkMatchGroup env ms `thenM` \ new_ms -> + returnM (FunBind new_var inf new_ms) + +zonk_bind env (AbsBinds tyvars dicts exports inlines val_binds) + = ASSERT( all isImmutableTyVar tyvars ) + zonkIdBndrs env dicts `thenM` \ new_dicts -> + fixM (\ ~(new_val_binds, _) -> + let + env1 = extendZonkEnv (extendZonkEnv env new_dicts) + (collectHsBindBinders new_val_binds) + in + zonkMonoBinds env1 val_binds `thenM` \ new_val_binds -> + mappM (zonkExport env1) exports `thenM` \ new_exports -> + returnM (new_val_binds, new_exports) + ) `thenM` \ (new_val_bind, new_exports) -> + returnM (AbsBinds tyvars new_dicts new_exports inlines new_val_bind) + where + zonkExport env (tyvars, global, local) + = 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 global `thenNF_Tc` \ new_global -> - zonkIdOcc local `thenNF_Tc` \ new_local -> - returnNF_Tc (new_tyvars, new_global, new_local) + zonkIdBndr env global `thenM` \ new_global -> + returnM (new_tyvars, new_global, zonkIdOcc env local) \end{code} %************************************************************************ @@ -370,29 +334,30 @@ zonkMonoBinds (AbsBinds tyvars dicts exports inlines val_bind) %************************************************************************ \begin{code} -zonkMatch :: TcMatch -> NF_TcM TypecheckedMatch - -zonkMatch (Match pats _ grhss) - = zonkPats pats `thenNF_Tc` \ (new_pats, new_ids) -> - tcExtendGlobalValEnv (bagToList new_ids) $ - zonkGRHSs grhss `thenNF_Tc` \ new_grhss -> - returnNF_Tc (Match new_pats Nothing new_grhss) +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 :: TcGRHSs - -> NF_TcM TypecheckedGRHSs +zonkGRHSs :: ZonkEnv -> GRHSs TcId -> TcM (GRHSs Id) -zonkGRHSs (GRHSs grhss binds ty) - = zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) -> - tcSetEnv new_env $ +zonkGRHSs env (GRHSs grhss binds) + = zonkNestedBinds env binds `thenM` \ (new_env, new_binds) -> let - zonk_grhs (GRHS guarded locn) - = zonkStmts guarded `thenNF_Tc` \ new_guarded -> - returnNF_Tc (GRHS new_guarded locn) + zonk_grhs (GRHS guarded) + = zonkStmts new_env guarded `thenM` \ new_guarded -> + returnM (GRHS new_guarded) in - mapNF_Tc zonk_grhs grhss `thenNF_Tc` \ new_grhss -> - zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> - returnNF_Tc (GRHSs new_grhss new_binds new_ty) + mappM (wrapLocM zonk_grhs) grhss `thenM` \ new_grhss -> + returnM (GRHSs new_grhss new_binds) \end{code} %************************************************************************ @@ -402,252 +367,301 @@ zonkGRHSs (GRHSs grhss binds ty) %************************************************************************ \begin{code} -zonkExpr :: TcExpr -> NF_TcM TypecheckedHsExpr - -zonkExpr (HsVar id) - = zonkIdOcc id `thenNF_Tc` \ id' -> - returnNF_Tc (HsVar id') +zonkLExprs :: ZonkEnv -> [LHsExpr TcId] -> TcM [LHsExpr Id] +zonkLExpr :: ZonkEnv -> LHsExpr TcId -> TcM (LHsExpr Id) +zonkExpr :: ZonkEnv -> HsExpr TcId -> TcM (HsExpr Id) -zonkExpr (HsIPVar id) - = mapIPNameTc zonkIdOcc id `thenNF_Tc` \ id' -> - returnNF_Tc (HsIPVar id') +zonkLExprs env exprs = mappM (zonkLExpr env) exprs +zonkLExpr env expr = wrapLocM (zonkExpr env) expr -zonkExpr (HsLit (HsRat f ty)) - = zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> - returnNF_Tc (HsLit (HsRat f new_ty)) +zonkExpr env (HsVar id) + = returnM (HsVar (zonkIdOcc env id)) -zonkExpr (HsLit (HsLitLit lit ty)) - = zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> - returnNF_Tc (HsLit (HsLitLit lit new_ty)) +zonkExpr env (HsIPVar id) + = returnM (HsIPVar (mapIPName (zonkIdOcc env) id)) -zonkExpr (HsLit lit) - = returnNF_Tc (HsLit lit) +zonkExpr env (HsLit (HsRat f ty)) + = zonkTcTypeToType env ty `thenM` \ new_ty -> + returnM (HsLit (HsRat f new_ty)) +zonkExpr env (HsLit lit) + = returnM (HsLit lit) -- HsOverLit doesn't appear in typechecker output -zonkExpr (HsLam match) - = zonkMatch match `thenNF_Tc` \ new_match -> - returnNF_Tc (HsLam new_match) - -zonkExpr (HsApp e1 e2) - = zonkExpr e1 `thenNF_Tc` \ new_e1 -> - zonkExpr e2 `thenNF_Tc` \ new_e2 -> - returnNF_Tc (HsApp new_e1 new_e2) - -zonkExpr (OpApp e1 op fixity e2) - = zonkExpr e1 `thenNF_Tc` \ new_e1 -> - zonkExpr op `thenNF_Tc` \ new_op -> - zonkExpr e2 `thenNF_Tc` \ new_e2 -> - returnNF_Tc (OpApp new_e1 new_op fixity new_e2) - -zonkExpr (NegApp _ _) = panic "zonkExpr: NegApp" -zonkExpr (HsPar _) = panic "zonkExpr: HsPar" - -zonkExpr (SectionL expr op) - = zonkExpr expr `thenNF_Tc` \ new_expr -> - zonkExpr op `thenNF_Tc` \ new_op -> - returnNF_Tc (SectionL new_expr new_op) - -zonkExpr (SectionR op expr) - = zonkExpr op `thenNF_Tc` \ new_op -> - zonkExpr expr `thenNF_Tc` \ new_expr -> - returnNF_Tc (SectionR new_op new_expr) - -zonkExpr (HsCase expr ms src_loc) - = zonkExpr expr `thenNF_Tc` \ new_expr -> - mapNF_Tc zonkMatch ms `thenNF_Tc` \ new_ms -> - returnNF_Tc (HsCase new_expr new_ms src_loc) - -zonkExpr (HsIf e1 e2 e3 src_loc) - = zonkExpr e1 `thenNF_Tc` \ new_e1 -> - zonkExpr e2 `thenNF_Tc` \ new_e2 -> - zonkExpr e3 `thenNF_Tc` \ new_e3 -> - returnNF_Tc (HsIf new_e1 new_e2 new_e3 src_loc) - -zonkExpr (HsLet binds expr) - = zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) -> - tcSetEnv new_env $ - zonkExpr expr `thenNF_Tc` \ new_expr -> - returnNF_Tc (HsLet new_binds new_expr) - -zonkExpr (HsWith expr binds) - = zonkIPBinds binds `thenNF_Tc` \ new_binds -> - tcExtendGlobalValEnv (map (ipNameName . fst) new_binds) $ - zonkExpr expr `thenNF_Tc` \ new_expr -> - returnNF_Tc (HsWith new_expr new_binds) - where - zonkIPBinds = mapNF_Tc zonkIPBind - zonkIPBind (n, e) - = mapIPNameTc zonkIdBndr n `thenNF_Tc` \ n' -> - zonkExpr e `thenNF_Tc` \ e' -> - returnNF_Tc (n', e') - -zonkExpr (HsDo _ _ _) = panic "zonkExpr:HsDo" - -zonkExpr (HsDoOut do_or_lc stmts return_id then_id zero_id ty src_loc) - = zonkStmts stmts `thenNF_Tc` \ new_stmts -> - zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> - zonkIdOcc return_id `thenNF_Tc` \ new_return_id -> - zonkIdOcc then_id `thenNF_Tc` \ new_then_id -> - zonkIdOcc zero_id `thenNF_Tc` \ new_zero_id -> - returnNF_Tc (HsDoOut do_or_lc new_stmts new_return_id new_then_id new_zero_id - new_ty src_loc) - -zonkExpr (ExplicitList ty exprs) - = zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> - mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs -> - returnNF_Tc (ExplicitList new_ty new_exprs) - -zonkExpr (ExplicitPArr ty exprs) - = zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> - mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs -> - returnNF_Tc (ExplicitPArr new_ty new_exprs) - -zonkExpr (ExplicitTuple exprs boxed) - = mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs -> - returnNF_Tc (ExplicitTuple new_exprs boxed) - -zonkExpr (RecordConOut data_con con_expr rbinds) - = zonkExpr con_expr `thenNF_Tc` \ new_con_expr -> - zonkRbinds rbinds `thenNF_Tc` \ new_rbinds -> - returnNF_Tc (RecordConOut data_con new_con_expr new_rbinds) - -zonkExpr (RecordUpd _ _) = panic "zonkExpr:RecordUpd" - -zonkExpr (RecordUpdOut expr in_ty out_ty rbinds) - = zonkExpr expr `thenNF_Tc` \ new_expr -> - zonkTcTypeToType in_ty `thenNF_Tc` \ new_in_ty -> - zonkTcTypeToType out_ty `thenNF_Tc` \ new_out_ty -> - zonkRbinds rbinds `thenNF_Tc` \ new_rbinds -> - returnNF_Tc (RecordUpdOut new_expr new_in_ty new_out_ty new_rbinds) - -zonkExpr (ExprWithTySig _ _) = panic "zonkExpr:ExprWithTySig" -zonkExpr (ArithSeqIn _) = panic "zonkExpr:ArithSeqIn" -zonkExpr (PArrSeqIn _) = panic "zonkExpr:PArrSeqIn" - -zonkExpr (ArithSeqOut expr info) - = zonkExpr expr `thenNF_Tc` \ new_expr -> - zonkArithSeq info `thenNF_Tc` \ new_info -> - returnNF_Tc (ArithSeqOut new_expr new_info) - -zonkExpr (PArrSeqOut expr info) - = zonkExpr expr `thenNF_Tc` \ new_expr -> - zonkArithSeq info `thenNF_Tc` \ new_info -> - returnNF_Tc (PArrSeqOut new_expr new_info) - -zonkExpr (HsCCall fun args may_gc is_casm result_ty) - = mapNF_Tc zonkExpr args `thenNF_Tc` \ new_args -> - zonkTcTypeToType result_ty `thenNF_Tc` \ new_result_ty -> - returnNF_Tc (HsCCall fun new_args may_gc is_casm new_result_ty) - -zonkExpr (HsSCC lbl expr) - = zonkExpr expr `thenNF_Tc` \ new_expr -> - returnNF_Tc (HsSCC lbl new_expr) - -zonkExpr (TyLam tyvars expr) - = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars -> - -- No need to extend tyvar env; see AbsBinds - - zonkExpr expr `thenNF_Tc` \ new_expr -> - returnNF_Tc (TyLam new_tyvars new_expr) - -zonkExpr (TyApp expr tys) - = zonkExpr expr `thenNF_Tc` \ new_expr -> - mapNF_Tc zonkTcTypeToType tys `thenNF_Tc` \ new_tys -> - returnNF_Tc (TyApp new_expr new_tys) - -zonkExpr (DictLam dicts expr) - = mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts -> - tcExtendGlobalValEnv new_dicts $ - zonkExpr expr `thenNF_Tc` \ new_expr -> - returnNF_Tc (DictLam new_dicts new_expr) - -zonkExpr (DictApp expr dicts) - = zonkExpr expr `thenNF_Tc` \ new_expr -> - mapNF_Tc zonkIdOcc dicts `thenNF_Tc` \ new_dicts -> - returnNF_Tc (DictApp new_expr new_dicts) +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 env (HsSpliceE s) = WARN( True, ppr s ) -- Should not happen + 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 _ _) = panic "zonkExpr env: NegApp" + +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) + +-- gaw 2004 +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) + = zonkNestedBinds 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 ids ty) + = zonkStmts env stmts `thenM` \ new_stmts -> + zonkTcTypeToType env ty `thenM` \ new_ty -> + zonkReboundNames env ids `thenM` \ new_ids -> + returnM (HsDo do_or_lc new_stmts new_ids 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 (ExplicitTuple exprs boxed) + = zonkLExprs env exprs `thenM` \ new_exprs -> + returnM (ExplicitTuple new_exprs boxed) + +zonkExpr env (RecordConOut data_con con_expr rbinds) + = zonkLExpr env con_expr `thenM` \ new_con_expr -> + zonkRbinds env rbinds `thenM` \ new_rbinds -> + returnM (RecordConOut data_con new_con_expr new_rbinds) + +zonkExpr env (RecordUpd _ _) = panic "zonkExpr env:RecordUpd" + +zonkExpr env (RecordUpdOut expr in_ty out_ty rbinds) + = zonkLExpr env expr `thenM` \ new_expr -> + zonkTcTypeToType env in_ty `thenM` \ new_in_ty -> + zonkTcTypeToType env out_ty `thenM` \ new_out_ty -> + zonkRbinds env rbinds `thenM` \ new_rbinds -> + returnM (RecordUpdOut new_expr new_in_ty new_out_ty new_rbinds) + +zonkExpr env (ExprWithTySigOut e ty) + = do { e' <- zonkLExpr env e + ; return (ExprWithTySigOut e' ty) } + +zonkExpr env (ExprWithTySig _ _) = panic "zonkExpr env:ExprWithTySig" +zonkExpr env (ArithSeqIn _) = panic "zonkExpr env:ArithSeqIn" +zonkExpr env (PArrSeqIn _) = panic "zonkExpr env:PArrSeqIn" + +zonkExpr env (ArithSeqOut expr info) + = zonkLExpr env expr `thenM` \ new_expr -> + zonkArithSeq env info `thenM` \ new_info -> + returnM (ArithSeqOut new_expr new_info) + +zonkExpr env (PArrSeqOut expr info) + = zonkLExpr env expr `thenM` \ new_expr -> + zonkArithSeq env info `thenM` \ new_info -> + returnM (PArrSeqOut new_expr new_info) + +zonkExpr env (HsSCC lbl expr) + = zonkLExpr env expr `thenM` \ new_expr -> + returnM (HsSCC lbl new_expr) + +-- hdaume: core annotations +zonkExpr env (HsCoreAnn lbl expr) + = zonkLExpr env expr `thenM` \ new_expr -> + returnM (HsCoreAnn lbl new_expr) + +zonkExpr env (TyLam tyvars expr) + = ASSERT( all isImmutableTyVar tyvars ) + zonkLExpr env expr `thenM` \ new_expr -> + returnM (TyLam tyvars new_expr) + +zonkExpr env (TyApp expr tys) + = zonkLExpr env expr `thenM` \ new_expr -> + mappM (zonkTcTypeToType env) tys `thenM` \ new_tys -> + returnM (TyApp new_expr new_tys) + +zonkExpr env (DictLam dicts expr) + = zonkIdBndrs env dicts `thenM` \ new_dicts -> + let + env1 = extendZonkEnv env new_dicts + in + zonkLExpr env1 expr `thenM` \ new_expr -> + returnM (DictLam new_dicts new_expr) + +zonkExpr env (DictApp expr dicts) + = zonkLExpr env expr `thenM` \ new_expr -> + returnM (DictApp new_expr (zonkIdOccs env dicts)) + +-- arrow notation extensions +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) + +zonkCmdTop :: ZonkEnv -> LHsCmdTop TcId -> TcM (LHsCmdTop Id) +zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd + +zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids) + = zonkLExpr env cmd `thenM` \ new_cmd -> + mappM (zonkTcTypeToType env) stack_tys + `thenM` \ new_stack_tys -> + zonkTcTypeToType env ty `thenM` \ new_ty -> + zonkReboundNames env ids `thenM` \ new_ids -> + returnM (HsCmdTop new_cmd new_stack_tys new_ty new_ids) ------------------------------------------------------------------------- -zonkArithSeq :: TcArithSeqInfo -> NF_TcM TypecheckedArithSeqInfo +zonkReboundNames :: ZonkEnv -> ReboundNames Id -> TcM (ReboundNames Id) +zonkReboundNames env prs + = mapM zonk prs + where + zonk (n, e) = zonkExpr env e `thenM` \ new_e -> + returnM (n, new_e) + + +------------------------------------------------------------------------- +zonkArithSeq :: ZonkEnv -> ArithSeqInfo TcId -> TcM (ArithSeqInfo Id) + +zonkArithSeq env (From e) + = zonkLExpr env e `thenM` \ new_e -> + returnM (From new_e) -zonkArithSeq (From e) - = zonkExpr e `thenNF_Tc` \ new_e -> - returnNF_Tc (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 (FromThen e1 e2) - = zonkExpr e1 `thenNF_Tc` \ new_e1 -> - zonkExpr e2 `thenNF_Tc` \ new_e2 -> - returnNF_Tc (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 (FromTo e1 e2) - = zonkExpr e1 `thenNF_Tc` \ new_e1 -> - zonkExpr e2 `thenNF_Tc` \ new_e2 -> - returnNF_Tc (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) -zonkArithSeq (FromThenTo e1 e2 e3) - = zonkExpr e1 `thenNF_Tc` \ new_e1 -> - zonkExpr e2 `thenNF_Tc` \ new_e2 -> - zonkExpr e3 `thenNF_Tc` \ new_e3 -> - returnNF_Tc (FromThenTo new_e1 new_e2 new_e3) ------------------------------------------------------------------------- -zonkStmts :: [TcStmt] - -> NF_TcM [TypecheckedStmt] - -zonkStmts [] = returnNF_Tc [] - -zonkStmts (ParStmtOut bndrstmtss : stmts) - = mapNF_Tc (mapNF_Tc zonkId) bndrss `thenNF_Tc` \ new_bndrss -> - let new_binders = concat new_bndrss in - mapNF_Tc zonkStmts stmtss `thenNF_Tc` \ new_stmtss -> - tcExtendGlobalValEnv new_binders $ - zonkStmts stmts `thenNF_Tc` \ new_stmts -> - returnNF_Tc (ParStmtOut (zip new_bndrss new_stmtss) : new_stmts) - where (bndrss, stmtss) = unzip bndrstmtss - -zonkStmts (ResultStmt expr locn : stmts) - = zonkExpr expr `thenNF_Tc` \ new_expr -> - zonkStmts stmts `thenNF_Tc` \ new_stmts -> - returnNF_Tc (ResultStmt new_expr locn : new_stmts) - -zonkStmts (ExprStmt expr ty locn : stmts) - = zonkExpr expr `thenNF_Tc` \ new_expr -> - zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> - zonkStmts stmts `thenNF_Tc` \ new_stmts -> - returnNF_Tc (ExprStmt new_expr new_ty locn : new_stmts) - -zonkStmts (LetStmt binds : stmts) - = zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) -> - tcSetEnv new_env $ - zonkStmts stmts `thenNF_Tc` \ new_stmts -> - returnNF_Tc (LetStmt new_binds : new_stmts) - -zonkStmts (BindStmt pat expr locn : stmts) - = zonkExpr expr `thenNF_Tc` \ new_expr -> - zonkPat pat `thenNF_Tc` \ (new_pat, new_ids) -> - tcExtendGlobalValEnv (bagToList new_ids) $ - zonkStmts stmts `thenNF_Tc` \ new_stmts -> - returnNF_Tc (BindStmt new_pat new_expr locn : new_stmts) +zonkStmts :: ZonkEnv -> [LStmt TcId] -> TcM [LStmt Id] + +zonkStmts env stmts = zonk_stmts env stmts `thenM` \ (_, stmts) -> + returnM stmts + +zonk_stmts :: ZonkEnv -> [LStmt TcId] -> TcM (ZonkEnv, [LStmt Id]) +zonk_stmts env [] = return (env, []) +zonk_stmts env (s:ss) = do { (env1, s') <- wrapLocSndM (zonkStmt env) s + ; (env2, ss') <- zonk_stmts 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) = zonk_stmts env stmts `thenM` \ (env1, new_stmts) -> + returnM (new_stmts, zonkIdOccs env1 bndrs) +zonkStmt env (RecStmt segStmts lvs rvs rets) + = zonkIdBndrs env rvs `thenM` \ new_rvs -> + let + env1 = extendZonkEnv env new_rvs + in + zonk_stmts env1 segStmts `thenM` \ (env2, new_segStmts) -> + -- Zonk the ret-expressions in an envt that + -- has the polymorphic bindings in the envt + zonkLExprs env2 rets `thenM` \ new_rets -> + let + new_lvs = zonkIdOccs env2 lvs + env3 = extendZonkEnv env new_lvs -- Only the lvs are needed + in + returnM (env3, RecStmt new_segStmts new_lvs new_rvs new_rets) + +zonkStmt env (ResultStmt expr) + = zonkLExpr env expr `thenM` \ new_expr -> + returnM (env, ResultStmt new_expr) + +zonkStmt env (ExprStmt expr ty) + = zonkLExpr env expr `thenM` \ new_expr -> + zonkTcTypeToType env ty `thenM` \ new_ty -> + returnM (env, ExprStmt new_expr new_ty) + +zonkStmt env (LetStmt binds) + = zonkNestedBinds env binds `thenM` \ (env1, new_binds) -> + returnM (env1, LetStmt new_binds) + +zonkStmt env (BindStmt pat expr) + = do { new_expr <- zonkLExpr env expr + ; (env1, new_pat) <- zonkPat env pat + ; return (env1, BindStmt new_pat new_expr) } ------------------------------------------------------------------------- -zonkRbinds :: TcRecordBinds -> NF_TcM TypecheckedRecordBinds +zonkRbinds :: ZonkEnv -> HsRecordBinds TcId -> TcM (HsRecordBinds Id) -zonkRbinds rbinds - = mapNF_Tc zonk_rbind rbinds +zonkRbinds env rbinds + = mappM zonk_rbind rbinds where - zonk_rbind (field, expr, pun) - = zonkExpr expr `thenNF_Tc` \ new_expr -> - zonkIdOcc field `thenNF_Tc` \ new_field -> - returnNF_Tc (new_field, new_expr, pun) + zonk_rbind (field, expr) + = zonkLExpr env expr `thenM` \ new_expr -> + returnM (fmap (zonkIdOcc env) field, new_expr) ------------------------------------------------------------------------- -mapIPNameTc :: (a -> NF_TcM b) -> IPName a -> NF_TcM (IPName b) -mapIPNameTc f (Dupable n) = f n `thenNF_Tc` \ r -> returnNF_Tc (Dupable r) -mapIPNameTc f (Linear n) = f n `thenNF_Tc` \ r -> returnNF_Tc (Linear r) +mapIPNameTc :: (a -> TcM b) -> IPName a -> TcM (IPName b) +mapIPNameTc f (Dupable n) = f n `thenM` \ r -> returnM (Dupable r) +mapIPNameTc f (Linear n) = f n `thenM` \ r -> returnM (Linear r) \end{code} @@ -658,97 +672,105 @@ mapIPNameTc f (Linear n) = f n `thenNF_Tc` \ r -> returnNF_Tc (Linear r) %************************************************************************ \begin{code} -zonkPat :: TcPat -> NF_TcM (TypecheckedPat, Bag Id) - -zonkPat (WildPat ty) - = zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> - returnNF_Tc (WildPat new_ty, emptyBag) - -zonkPat (VarPat v) - = zonkIdBndr v `thenNF_Tc` \ new_v -> - returnNF_Tc (VarPat new_v, unitBag new_v) - -zonkPat (LazyPat pat) - = zonkPat pat `thenNF_Tc` \ (new_pat, ids) -> - returnNF_Tc (LazyPat new_pat, ids) - -zonkPat (AsPat n pat) - = zonkIdBndr n `thenNF_Tc` \ new_n -> - zonkPat pat `thenNF_Tc` \ (new_pat, ids) -> - returnNF_Tc (AsPat new_n new_pat, new_n `consBag` ids) - -zonkPat (ListPat ty pats) - = zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> - zonkPats pats `thenNF_Tc` \ (new_pats, ids) -> - returnNF_Tc (ListPat new_ty new_pats, ids) - -zonkPat (PArrPat ty pats) - = zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> - zonkPats pats `thenNF_Tc` \ (new_pats, ids) -> - returnNF_Tc (PArrPat new_ty new_pats, ids) - -zonkPat (TuplePat pats boxed) - = zonkPats pats `thenNF_Tc` \ (new_pats, ids) -> - returnNF_Tc (TuplePat new_pats boxed, ids) - -zonkPat (ConPat n ty tvs dicts pats) - = zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> - mapNF_Tc zonkTcTyVarToTyVar tvs `thenNF_Tc` \ new_tvs -> - mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts -> - tcExtendGlobalValEnv new_dicts $ - zonkPats pats `thenNF_Tc` \ (new_pats, ids) -> - returnNF_Tc (ConPat n new_ty new_tvs new_dicts new_pats, - listToBag new_dicts `unionBags` ids) - -zonkPat (RecPat n ty tvs dicts rpats) - = zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> - mapNF_Tc zonkTcTyVarToTyVar tvs `thenNF_Tc` \ new_tvs -> - mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts -> - tcExtendGlobalValEnv new_dicts $ - mapAndUnzipNF_Tc zonk_rpat rpats `thenNF_Tc` \ (new_rpats, ids_s) -> - returnNF_Tc (RecPat n new_ty new_tvs new_dicts new_rpats, - listToBag new_dicts `unionBags` unionManyBags ids_s) +zonkPat :: ZonkEnv -> OutPat TcId -> TcM (ZonkEnv, OutPat Id) +-- Extend the environment as we go, because it's possible for one +-- pattern to bind something that is used in another (inside or +-- to the right) +zonkPat env pat = wrapLocSndM (zonk_pat env) pat + +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 (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 (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) + = do { (env', pats') <- zonkPats env pats + ; return (env', TuplePat pats' boxed) } + +zonk_pat env (ConPatOut n tvs dicts binds stuff ty) + = ASSERT( all isImmutableTyVar tvs ) + do { new_ty <- zonkTcTypeToType env ty + ; new_dicts <- zonkIdBndrs env dicts + ; let env1 = extendZonkEnv env new_dicts + ; (env2, new_binds) <- zonkRecMonoBinds env1 binds + ; (env', new_stuff) <- zonkConStuff env2 stuff + ; returnM (env', ConPatOut n tvs new_dicts new_binds new_stuff new_ty) } + +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 (NPatOut lit ty expr) + = do { ty' <- zonkTcTypeToType env ty + ; expr' <- zonkExpr env expr + ; return (env, NPatOut lit ty' expr') } + +zonk_pat env (NPlusKPatOut (L loc n) k e1 e2) + = do { n' <- zonkIdBndr env n + ; e1' <- zonkExpr env e1 + ; e2' <- zonkExpr env e2 + ; return (extendZonkEnv1 env n', NPlusKPatOut (L loc n') k 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') } + +--------------------------- +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 rpats) + = do { (env', pats') <- zonkPats env pats + ; returnM (env', RecCon (fields `zip` pats')) } where - zonk_rpat (f, pat, pun) - = zonkPat pat `thenNF_Tc` \ (new_pat, ids) -> - returnNF_Tc ((f, new_pat, pun), ids) - -zonkPat (LitPat lit ty) - = zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> - returnNF_Tc (LitPat lit new_ty, emptyBag) - -zonkPat (SigPat pat ty expr) - = zonkPat pat `thenNF_Tc` \ (new_pat, ids) -> - zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> - zonkExpr expr `thenNF_Tc` \ new_expr -> - returnNF_Tc (SigPat new_pat new_ty new_expr, ids) - -zonkPat (NPat lit ty expr) - = zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> - zonkExpr expr `thenNF_Tc` \ new_expr -> - returnNF_Tc (NPat lit new_ty new_expr, emptyBag) - -zonkPat (NPlusKPat n k ty e1 e2) - = zonkIdBndr n `thenNF_Tc` \ new_n -> - zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> - zonkExpr e1 `thenNF_Tc` \ new_e1 -> - zonkExpr e2 `thenNF_Tc` \ new_e2 -> - returnNF_Tc (NPlusKPat new_n k new_ty new_e1 new_e2, unitBag new_n) - -zonkPat (DictPat ds ms) - = mapNF_Tc zonkIdBndr ds `thenNF_Tc` \ new_ds -> - mapNF_Tc zonkIdBndr ms `thenNF_Tc` \ new_ms -> - returnNF_Tc (DictPat new_ds new_ms, - listToBag new_ds `unionBags` listToBag new_ms) - - -zonkPats [] - = returnNF_Tc ([], emptyBag) - -zonkPats (pat:pats) - = zonkPat pat `thenNF_Tc` \ (pat', ids1) -> - zonkPats pats `thenNF_Tc` \ (pats', ids2) -> - returnNF_Tc (pat':pats', ids1 `unionBags` ids2) + (fields, pats) = unzip rpats + +--------------------------- +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} %************************************************************************ @@ -759,108 +781,152 @@ zonkPats (pat:pats) \begin{code} -zonkForeignExports :: [TcForeignExportDecl] -> NF_TcM [TypecheckedForeignDecl] -zonkForeignExports ls = mapNF_Tc zonkForeignExport ls - -zonkForeignExport :: TcForeignExportDecl -> NF_TcM (TypecheckedForeignDecl) -zonkForeignExport (ForeignExport i hs_ty spec isDeprec src_loc) = - zonkIdOcc i `thenNF_Tc` \ i' -> - returnNF_Tc (ForeignExport i' undefined spec isDeprec src_loc) +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 isDeprec) = + returnM (ForeignExport (fmap (zonkIdOcc env) i) undefined spec isDeprec) +zonkForeignExport env for_imp + = returnM for_imp -- Foreign imports don't need zonking \end{code} \begin{code} -zonkRules :: [TcRuleDecl] -> NF_TcM [TypecheckedRuleDecl] -zonkRules rs = mapNF_Tc zonkRule rs +zonkRules :: ZonkEnv -> [LRuleDecl TcId] -> TcM [LRuleDecl Id] +zonkRules env rs = mappM (wrapLocM (zonkRule env)) rs -zonkRule (HsRule name act vars lhs rhs loc) - = mapNF_Tc zonk_bndr vars `thenNF_Tc` \ new_bndrs -> - tcExtendGlobalValEnv (filter isId new_bndrs) $ +zonkRule :: ZonkEnv -> RuleDecl TcId -> TcM (RuleDecl Id) +zonkRule env (HsRule name act (vars::[RuleBndr TcId]) lhs 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 - zonkExpr lhs `thenNF_Tc` \ new_lhs -> - zonkExpr rhs `thenNF_Tc` \ new_rhs -> - returnNF_Tc (HsRule name act (map RuleBndr new_bndrs) new_lhs new_rhs loc) - -- I hate this map RuleBndr stuff + + 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 + -- + -- foo :: T a -> Int + -- foo C = 1 + -- + -- {-# RULES "myrule" foo C = 1 #-} + -- + -- After type checking the LHS becomes (foo a (C a)) + -- and we do not want to zap the unbound tyvar 'a' to (), because + -- that limits the applicability of the rule. Instead, we + -- want to quantify over it! + -- + -- It's easiest to find the free tyvars here. Attempts to do so earlier + -- 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 new_rhs) + -- I hate this map RuleBndr stuff where zonk_bndr (RuleBndr v) - | isId v = zonkIdBndr v - | otherwise = zonkTcTyVarToTyVar v - -zonkRule (IfaceRuleOut fun rule) - = zonkIdOcc fun `thenNF_Tc` \ fun' -> - returnNF_Tc (IfaceRuleOut fun' rule) + | isId (unLoc v) = wrapLocM (zonkIdBndr env) v + | otherwise = ASSERT( isImmutableTyVar (unLoc v) ) + return v \end{code} + +%************************************************************************ +%* * +\subsection[BackSubst-Foreign]{Foreign exports} +%* * +%************************************************************************ + \begin{code} -zonkCoreBinds :: [(Id, Type, CoreExpr)] -> NF_TcM [(Id, CoreExpr)] -zonkCoreBinds ls = mapNF_Tc zonkOne ls - where - zonkOne (i, t, e) = - zonkIdOcc i `thenNF_Tc` \ i' -> - zonkCoreExpr e `thenNF_Tc` \ e' -> - returnNF_Tc (i',e') - --- needed? -zonkCoreExpr :: CoreExpr -> NF_TcM CoreExpr -zonkCoreExpr e = - case e of - Var i -> - zonkIdOcc i `thenNF_Tc` \ i' -> - returnNF_Tc (Var i') - Lit l -> returnNF_Tc (Lit l) - App f arg -> - zonkCoreExpr f `thenNF_Tc` \ f' -> - zonkCoreExpr arg `thenNF_Tc` \ arg' -> - returnNF_Tc (App f' arg') - Lam b e -> - zonkIdOcc b `thenNF_Tc` \ b' -> - zonkCoreExpr e `thenNF_Tc` \ e' -> - returnNF_Tc (Lam b' e') - Case scrut n alts -> - zonkCoreExpr scrut `thenNF_Tc` \ scrut' -> - zonkIdOcc n `thenNF_Tc` \ n' -> - mapNF_Tc zonkCoreAlt alts `thenNF_Tc` \ alts' -> - returnNF_Tc (Case scrut' n' alts') - Let b rhs -> - zonkCoreBind b `thenNF_Tc` \ b' -> - zonkCoreExpr rhs `thenNF_Tc` \ rhs' -> - returnNF_Tc (Let b' rhs') - Note note e -> - zonkNote note `thenNF_Tc` \ note' -> - zonkCoreExpr e `thenNF_Tc` \ e' -> - returnNF_Tc (Note note' e') - Type t -> - zonkTcTypeToType t `thenNF_Tc` \ t' -> - returnNF_Tc (Type t') - -zonkCoreBind :: CoreBind -> NF_TcM CoreBind -zonkCoreBind (NonRec b e) = - zonkIdOcc b `thenNF_Tc` \ b' -> - zonkCoreExpr e `thenNF_Tc` \ e' -> - returnNF_Tc (NonRec b' e') -zonkCoreBind (Rec bs) = - mapNF_Tc zonkIt bs `thenNF_Tc` \ bs' -> - returnNF_Tc (Rec bs') - where - zonkIt (b,e) = - zonkIdOcc b `thenNF_Tc` \ b' -> - zonkCoreExpr e `thenNF_Tc` \ e' -> - returnNF_Tc (b',e') - - -zonkCoreAlt :: CoreAlt -> NF_TcM CoreAlt -zonkCoreAlt (ac, bs, rhs) = - mapNF_Tc zonkIdOcc bs `thenNF_Tc` \ bs' -> - zonkCoreExpr rhs `thenNF_Tc` \ rhs' -> - returnNF_Tc (ac, bs', rhs') - -zonkNote :: Note -> NF_TcM Note -zonkNote n = - case n of - Coerce t f -> - zonkTcTypeToType t `thenNF_Tc` \ t' -> - zonkTcTypeToType f `thenNF_Tc` \ f' -> - returnNF_Tc (Coerce t' f') - _ -> returnNF_Tc n +zonkTcTypeToType :: ZonkEnv -> TcType -> TcM Type +zonkTcTypeToType (ZonkEnv zonk_ty _) ty = zonk_ty ty + +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 + 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 +-- 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 + 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, + -- because at the binding site for a type variable we bind the + -- 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 } + 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 = voidTy -- The vastly common case + | otherwise = mkTyConApp tycon [] + where + kind = tyVarKind tv + (args,res) = splitKindFunTys kind + + tycon | kind == tyConKind listTyCon -- *->* + = listTyCon -- No tuples this size + + | all isLiftedTypeKind args && isLiftedTypeKind res + = tupleTyCon Boxed (length args) -- *-> ... ->*->* + + | otherwise + = pprTrace "Urk! Inventing strangely-kinded void TyCon:" (ppr tc_name $$ ppr kind) $ + mkPrimTyCon tc_name kind 0 [] VoidRep + -- 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. + tc_name = mkInternalName (getUnique tv) (mkDerivedTyConOcc (getOccName tv)) noSrcLoc \end{code}