X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcHsSyn.lhs;h=ee6de3357b24cdcd30040e5cc9e9e9178a0c27e8;hp=380490383151af3e72d1b64d7ed7fc1ac21cbd45;hb=72462499b891d5779c19f3bda03f96e24f9554ae;hpb=e8f87c4aafd7de496c1bc9d8eecbe35fb2faf262 diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index 3804903..ee6de33 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -9,21 +9,13 @@ This module is an extension of @HsSyn@ syntax, for use in the type checker. \begin{code} -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - module TcHsSyn ( mkHsConApp, mkHsDictLet, mkHsApp, hsLitType, hsLPatType, hsPatType, mkHsAppTy, mkSimpleHsAlt, - nlHsIntLit, mkVanillaTuplePat, + nlHsIntLit, + shortCutLit, hsOverLitName, - mkArbitraryType, -- Put this elsewhere? - -- re-exported from TcMonad TcId, TcIdSet, TcDictBinds, @@ -40,24 +32,23 @@ import HsSyn -- oodles of it import Id import TcRnMonad -import Type +import PrelNames import TcType import TcMType import TysPrim import TysWiredIn -import TyCon +import DataCon import Name import Var import VarSet import VarEnv +import Literal import BasicTypes import Maybes -import Unique import SrcLoc import Util import Bag import Outputable -import FastString \end{code} \begin{code} @@ -85,45 +76,77 @@ mappM = mapM 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 (ViewPat expr pat ty) = ty -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 _ _) = overLitType lit -hsPatType (NPlusKPat id _ _ _) = idType (unLoc id) -hsPatType (CoPat _ _ ty) = ty +hsPatType :: Pat Id -> Type +hsPatType (ParPat pat) = hsLPatType pat +hsPatType (WildPat ty) = ty +hsPatType (VarPat var) = idType var +hsPatType (VarPatOut var _) = idType var +hsPatType (BangPat pat) = hsLPatType pat +hsPatType (LazyPat pat) = hsLPatType pat +hsPatType (LitPat lit) = hsLitType lit +hsPatType (AsPat var _) = idType (unLoc var) +hsPatType (ViewPat _ _ ty) = ty +hsPatType (ListPat _ ty) = mkListTy ty +hsPatType (PArrPat _ ty) = mkPArrTy ty +hsPatType (TuplePat _ _ ty) = ty +hsPatType (ConPatOut { pat_ty = ty }) = ty +hsPatType (SigPatOut _ ty) = ty +hsPatType (NPat lit _ _) = overLitType lit +hsPatType (NPlusKPat id _ _ _) = idType (unLoc id) +hsPatType (CoPat _ _ ty) = ty +hsPatType p = pprPanic "hsPatType" (ppr p) hsLitType :: HsLit -> TcType -hsLitType (HsChar 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 (fromInteger 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} %************************************************************************ %* * @@ -162,6 +185,7 @@ data ZonkEnv = ZonkEnv (TcType -> TcM Type) -- How to zonk a type -- Maps an Id to its zonked version; both have the same Name -- Is only consulted lazily; hence knot-tying +emptyZonkEnv :: ZonkEnv emptyZonkEnv = ZonkEnv zonkTypeZapping emptyVarEnv extendZonkEnv :: ZonkEnv -> [Id] -> ZonkEnv @@ -194,10 +218,11 @@ zonkIdOcc :: ZonkEnv -> TcId -> 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 @@ -214,11 +239,23 @@ zonkDictBndrs :: ZonkEnv -> [Var] -> TcM [Var] -- "Dictionary" binders can be coercion variables or dictionary variables zonkDictBndrs env ids = mappM (zonkDictBndr env) ids -zonkDictBndr env var | isTyVar var = return var +zonkDictBndr :: ZonkEnv -> Var -> TcM Var +zonkDictBndr env var | isTyVar var = zonkTyVarBndr env var | otherwise = zonkIdBndr env var zonkTopBndrs :: [TcId] -> TcM [Id] zonkTopBndrs ids = zonkIdBndrs emptyZonkEnv ids + +-- Zonk the kind of a non-TC tyvar in case it is a coercion variable (their +-- kind contains types). +-- +zonkTyVarBndr :: ZonkEnv -> TyVar -> TcM TyVar +zonkTyVarBndr env tv + | isCoVar tv + = do { kind <- zonkTcTypeToType env (tyVarKind tv) + ; return $ setTyVarKind tv kind + } + | otherwise = return tv \end{code} @@ -266,8 +303,8 @@ zonkLocalBinds env (HsIPBinds (IPBinds binds dict_binds)) --------------------------------------------- zonkValBinds :: ZonkEnv -> HsValBinds TcId -> TcM (ZonkEnv, HsValBinds Id) -zonkValBinds env bs@(ValBindsIn _ _) - = panic "zonkValBinds" -- Not in typechecker output +zonkValBinds _ (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) } @@ -296,10 +333,10 @@ zonk_bind env bind@(PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty}) ; 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 }) +zonk_bind env (VarBind { var_id = var, var_rhs = expr, var_inline = inl }) = zonkIdBndr env var `thenM` \ new_var -> zonkLExpr env expr `thenM` \ new_expr -> - returnM (VarBind { var_id = new_var, var_rhs = new_expr }) + returnM (VarBind { var_id = new_var, var_rhs = new_expr, var_inline = inl }) zonk_bind env bind@(FunBind { fun_id = var, fun_matches = ms, fun_co_fn = co_fn }) = wrapLocM (zonkIdBndr env) var `thenM` \ new_var -> @@ -328,11 +365,9 @@ zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_dicts = dicts, = zonkIdBndr env global `thenM` \ new_global -> mapM zonk_prag prags `thenM` \ new_prags -> returnM (tyvars, new_global, zonkIdOcc env local, new_prags) - zonk_prag prag@(L _ (InlinePrag {})) = return prag - zonk_prag (L loc (SpecPrag expr ty inl)) - = do { expr' <- zonkExpr env expr - ; ty' <- zonkTcTypeToType env ty - ; return (L loc (SpecPrag expr' ty' inl)) } + zonk_prag (L loc (SpecPrag co_fn inl)) + = do { (_, co_fn') <- zonkCoFn env co_fn + ; return (L loc (SpecPrag co_fn' inl)) } \end{code} %************************************************************************ @@ -393,7 +428,7 @@ zonkExpr env (HsLit (HsRat f ty)) = 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) @@ -416,7 +451,7 @@ zonkExpr env (HsBracketOut body bs) 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) @@ -444,6 +479,13 @@ zonkExpr env (SectionR op expr) zonkLExpr env expr `thenM` \ new_expr -> returnM (SectionR new_op new_expr) +zonkExpr env (ExplicitTuple tup_args boxed) + = do { new_tup_args <- mapM zonk_tup_arg tup_args + ; return (ExplicitTuple new_tup_args boxed) } + where + zonk_tup_arg (Present e) = do { e' <- zonkLExpr env e; return (Present e') } + zonk_tup_arg (Missing t) = do { t' <- zonkTcTypeToType env t; return (Missing t') } + zonkExpr env (HsCase expr ms) = zonkLExpr env expr `thenM` \ new_expr -> zonkMatchGroup env ms `thenM` \ new_ms -> @@ -477,10 +519,6 @@ zonkExpr env (ExplicitPArr ty exprs) zonkLExprs env exprs `thenM` \ new_exprs -> returnM (ExplicitPArr new_ty new_exprs) -zonkExpr env (ExplicitTuple exprs boxed) - = zonkLExprs env exprs `thenM` \ new_exprs -> - returnM (ExplicitTuple new_exprs boxed) - zonkExpr env (RecordCon data_con con_expr rbinds) = do { new_con_expr <- zonkExpr env con_expr ; new_rbinds <- zonkRecFields env rbinds @@ -497,7 +535,7 @@ 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 -> @@ -544,11 +582,12 @@ zonkExpr env (HsWrap co_fn 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 -> @@ -559,7 +598,6 @@ zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids) ------------------------------------------------------------------------- zonkCoFn :: ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper) zonkCoFn env WpHole = return (env, WpHole) -zonkCoFn env WpInline = return (env, WpInline) zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1 ; (env2, c2') <- zonkCoFn env1 c2 ; return (env2, WpCompose c1' c2') } @@ -569,8 +607,16 @@ zonkCoFn env (WpLam id) = do { id' <- zonkDictBndr env id ; let env1 = extendZonkEnv1 env id' ; return (env1, WpLam id') } zonkCoFn env (WpTyLam tv) = ASSERT( isImmutableTyVar tv ) - do { return (env, WpTyLam tv) } -zonkCoFn env (WpApp id) = do { return (env, WpApp (zonkIdOcc env id)) } + do { tv' <- zonkTyVarBndr env tv + ; return (env, WpTyLam tv') } +zonkCoFn env (WpApp v) + | isTcTyVar v = do { co <- zonkTcTyVar v + ; return (env, WpTyApp co) } + -- Yuk! A mutable coercion variable is a TcTyVar + -- not a CoVar, so don't use isCoVar! + -- Yuk! A WpApp can't hold the zonked type, + -- so we switch to WpTyApp + | otherwise = return (env, WpApp (zonkIdOcc env v)) zonkCoFn env (WpTyApp ty) = do { ty' <- zonkTcTypeToType env ty ; return (env, WpTyApp ty') } zonkCoFn env (WpLet bs) = do { (env1, bs') <- zonkRecMonoBinds env bs @@ -581,21 +627,14 @@ zonkCoFn env (WpLet bs) = do { (env1, bs') <- zonkRecMonoBinds env 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 +zonkDo _ do_or_lc = do_or_lc ------------------------------------------------------------------------- zonkOverLit :: ZonkEnv -> HsOverLit TcId -> TcM (HsOverLit Id) -zonkOverLit env ol = - let - zonkedStuff = do ty' <- zonkTcTypeToType env (overLitType ol) - e' <- zonkExpr env (overLitExpr ol) - return (e', ty') - ru f (x, y) = return (f x y) - in - case ol of - (HsIntegral i _ _) -> ru (HsIntegral i) =<< zonkedStuff - (HsFractional r _ _) -> ru (HsFractional r) =<< zonkedStuff - (HsIsString s _ _) -> ru (HsIsString s) =<< zonkedStuff +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) @@ -640,21 +679,26 @@ zonkStmt env (ParStmt stmts_w_bndrs) 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_dicts = binds }) + = do { new_rvs <- zonkIdBndrs env rvs + ; new_lvs <- zonkIdBndrs env lvs + ; new_ret_id <- zonkExpr env ret_id + ; new_mfix_id <- zonkExpr env mfix_id + ; new_bind_id <- zonkExpr env bind_id + ; let env1 = extendZonkEnv env new_rvs + ; (env2, new_segStmts) <- zonkStmts env1 segStmts -- 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) + ; new_rets <- mapM (zonkExpr env2) rets + ; let env3 = extendZonkEnv env new_lvs -- Only the lvs are needed + ; (env4, new_binds) <- zonkRecMonoBinds env3 binds + ; return (env4, + RecStmt { recS_stmts = new_segStmts, recS_later_ids = new_lvs + , recS_rec_ids = new_rvs, recS_ret_fn = new_ret_id + , recS_mfix_fn = new_mfix_id, recS_bind_fn = new_bind_id + , recS_rec_rets = new_rets, recS_dicts = new_binds }) } zonkStmt env (ExprStmt expr then_op ty) = zonkLExpr env expr `thenM` \ new_expr -> @@ -704,7 +748,8 @@ zonkStmt env (BindStmt pat expr bind_op fail_op) ; new_fail <- zonkExpr env fail_op ; return (env1, BindStmt new_pat new_expr new_bind new_fail) } -zonkMaybeLExpr env Nothing = return Nothing +zonkMaybeLExpr :: ZonkEnv -> Maybe (LHsExpr TcId) -> TcM (Maybe (LHsExpr Id)) +zonkMaybeLExpr _ Nothing = return Nothing zonkMaybeLExpr env (Just e) = (zonkLExpr env e) >>= (return . Just) @@ -715,9 +760,9 @@ zonkRecFields env (HsRecFields flds dd) ; return (HsRecFields flds' dd) } where zonk_rbind fld - = do { new_expr <- zonkLExpr env (hsRecFieldArg fld) - ; return (fld { hsRecFieldArg = new_expr }) } - -- Field selectors have declared types; hence no zonking + = do { new_id <- wrapLocM (zonkIdBndr env) (hsRecFieldId fld) + ; new_expr <- zonkLExpr env (hsRecFieldArg fld) + ; return (fld { hsRecFieldId = new_id, hsRecFieldArg = new_expr }) } ------------------------------------------------------------------------- mapIPNameTc :: (a -> TcM b) -> IPName a -> TcM (IPName b) @@ -738,6 +783,7 @@ zonkPat :: ZonkEnv -> OutPat TcId -> TcM (ZonkEnv, OutPat Id) -- 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') } @@ -771,7 +817,8 @@ zonk_pat env (AsPat (L loc v) pat) zonk_pat env (ViewPat expr pat ty) = do { expr' <- zonkLExpr env expr ; (env', pat') <- zonkPat env pat - ; return (env', ViewPat expr' pat' ty) } + ; ty' <- zonkTcTypeToType env ty + ; return (env', ViewPat expr' pat' ty') } zonk_pat env (ListPat pats ty) = do { ty' <- zonkTcTypeToType env ty @@ -827,9 +874,13 @@ zonk_pat env (CoPat co_fn pat ty) ; 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') } @@ -846,6 +897,7 @@ zonkConStuff 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 @@ -864,9 +916,9 @@ 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) = +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} @@ -918,6 +970,7 @@ zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs) | isId (unLoc v) = wrapLocM (zonkIdBndr env) v | otherwise = ASSERT( isImmutableTyVar (unLoc v) ) return v + zonk_bndr (RuleBndrSig {}) = panic "zonk_bndr RuleBndrSig" \end{code} @@ -957,76 +1010,7 @@ zonkTypeZapping ty -- 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 { ty <- mkArbitraryType warn tv + zonk_unbound_tyvar tv = do { let ty = anyTypeOfKind (tyVarKind tv) ; writeMetaTyVar tv ty ; return ty } - where - warn span msg = setSrcSpan span (addWarnTc msg) - - -{- Note [Strangely-kinded void TyCons] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - See Trac #959 for more examples - -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. - -Meanwhile I have now fixed GHC to emit a civilized warning. - -} - -mkArbitraryType :: (SrcSpan -> SDoc -> TcRnIf g l a) -- How to complain - -> TcTyVar - -> TcRnIf g l Type -- Used by desugarer too --- Make up an arbitrary type whose kind is the same as the tyvar. --- We'll use this to instantiate the (unbound) tyvar. --- --- Also used by the desugarer; hence the (tiresome) parameter --- to use when generating a warning -mkArbitraryType warn tv - | liftedTypeKind `isSubKind` kind -- The vastly common case - = return anyPrimTy - | eqKind kind (tyConKind anyPrimTyCon1) -- *->* - = return (mkTyConApp anyPrimTyCon1 []) -- No tuples this size - | all isLiftedTypeKind args -- *-> ... ->*->* - , isLiftedTypeKind res -- Horrible hack to make less use - = return (mkTyConApp tup_tc []) -- of mkAnyPrimTyCon - | otherwise - = do { warn (getSrcSpan tv) msg - ; return (mkTyConApp (mkAnyPrimTyCon (getUnique tv) kind) []) } - -- Same name as the tyvar, apart from making it start with a colon (sigh) - -- I dread to think what will happen if this gets out into an - -- interface file. Catastrophe likely. Major sigh. - where - kind = tyVarKind tv - (args,res) = splitKindFunTys kind - tup_tc = tupleTyCon Boxed (length args) - - msg = vcat [ hang (ptext (sLit "Inventing strangely-kinded Any TyCon")) - 2 (ptext (sLit "of kind") <+> quotes (ppr kind)) - , nest 2 (ptext (sLit "from an instantiation of type variable") <+> quotes (ppr tv)) - , ptext (sLit "This warning can be suppressed by a type signature fixing") <+> quotes (ppr tv) - , nest 2 (ptext (sLit "but is harmless without -O (and usually harmless anyway).")) - , ptext (sLit "See http://hackage.haskell.org/trac/ghc/ticket/959 for details") ] -\end{code} +\end{code} \ No newline at end of file