X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcHsSyn.lhs;h=de572ba65bb215fb2370746c11f601f9bc1aae8d;hb=388e3356f71daffa62f1d4157e1e07e4c68f218a;hp=491ca275c389f922fdb65309b864a2549112efd4;hpb=0db3e625ff0717f36495b375e6008995d6ffb0a3;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index 491ca27..de572ba 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -13,11 +13,9 @@ 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, @@ -35,12 +33,10 @@ import Id import TcRnMonad import PrelNames -import Type import TcType import TcMType import TysPrim import TysWiredIn -import TyCon import DataCon import Name import Var @@ -49,12 +45,10 @@ import VarEnv import Literal import BasicTypes import Maybes -import Unique import SrcLoc import Util import Bag import Outputable -import FastString \end{code} \begin{code} @@ -82,11 +76,6 @@ 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 @@ -492,6 +481,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 -> @@ -525,10 +521,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 @@ -823,7 +815,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 @@ -1015,76 +1008,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