Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : type-nats
http://hackage.haskell.org/trac/ghc/changeset/cfd89e12334e7dbcc8d9aaee898bcc38b77f549b >--------------------------------------------------------------- commit cfd89e12334e7dbcc8d9aaee898bcc38b77f549b Merge: 5851f84... 86ebfef... Author: Iavor S. Diatchki <[email protected]> Date: Sun Feb 12 13:29:29 2012 -0800 Merge remote-tracking branch 'origin/master' into type-nats Conflicts: compiler/coreSyn/CoreLint.lhs aclocal.m4 | 37 +- compiler/basicTypes/DataCon.lhs | 93 ++- compiler/coreSyn/CoreLint.lhs | 253 +++--- compiler/deSugar/DsExpr.lhs-boot | 15 +- compiler/deSugar/DsMeta.hs | 16 +- compiler/deSugar/Match.lhs-boot | 51 +- compiler/ghc.cabal.in | 6 +- compiler/ghc.mk | 12 +- compiler/hsSyn/Convert.lhs | 20 +- compiler/hsSyn/HsDecls.lhs | 61 +- compiler/hsSyn/HsExpr.lhs-boot | 19 +- compiler/hsSyn/HsUtils.lhs | 24 +- compiler/iface/BuildTyCl.lhs | 8 - compiler/llvmGen/Llvm.hs | 3 + compiler/llvmGen/Llvm/AbsSyn.hs | 25 +- compiler/llvmGen/Llvm/PpLlvm.hs | 14 + compiler/llvmGen/LlvmCodeGen/CodeGen.hs | 31 +- compiler/main/DynFlags.hs | 2 +- compiler/main/HscMain.hs | 72 +- compiler/main/HscStats.lhs | 13 +- compiler/main/HscTypes.lhs | 8 +- compiler/main/InteractiveEval.hs | 21 +- compiler/main/Packages.lhs | 2 +- compiler/nativeGen/SPARC/CodeGen/Gen32.hs-boot | 11 +- compiler/parser/Parser.y.pp | 37 +- compiler/prelude/TysWiredIn.lhs | 20 +- compiler/rename/RnEnv.lhs | 17 +- compiler/rename/RnExpr.lhs-boot | 19 +- compiler/rename/RnNames.lhs | 34 +- compiler/rename/RnSource.lhs | 23 +- compiler/rename/RnTypes.lhs | 6 +- compiler/typecheck/FamInst.lhs | 59 +- compiler/typecheck/TcDeriv.lhs | 2 +- compiler/typecheck/TcExpr.lhs-boot | 25 +- compiler/typecheck/TcHsType.lhs | 59 +- compiler/typecheck/TcInstDcls.lhs | 35 +- compiler/typecheck/TcMatches.lhs-boot | 23 +- compiler/typecheck/TcRnDriver.lhs | 1277 ++++++++++++------------ compiler/typecheck/TcSplice.lhs-boot | 27 +- compiler/typecheck/TcTyClsDecls.lhs | 11 +- compiler/typecheck/TcUnify.lhs-boot | 7 - compiler/types/FamInstEnv.lhs | 56 +- compiler/types/Kind.lhs | 61 +- compiler/types/TyCon.lhs | 48 +- compiler/types/TyCon.lhs-boot | 15 +- compiler/utils/Platform.hs | 20 +- configure.ac | 96 ++- distrib/configure.ac.in | 16 +- distrib/mkDocs/mkDocs | 2 +- distrib/remilestoning.pl | 118 +++ docs/users_guide/7.6.1-notes.xml | 427 ++++++++ docs/users_guide/flags.xml | 13 +- docs/users_guide/intro.xml | 2 +- docs/users_guide/safe_haskell.xml | 2 +- docs/users_guide/ug-ent.xml.in | 2 +- docs/users_guide/using.xml | 10 +- ghc.mk | 43 +- ghc/GhciMonad.hs | 17 +- ghc/InteractiveUI.hs | 81 ++- ghc/Main.hs | 11 +- ghc/ghc-bin.cabal.in | 4 +- ghc/ghc.mk | 8 +- includes/ghc.mk | 22 +- libffi/ghc.mk | 2 +- mk/compiler-ghc.mk | 1 - mk/config.mk.in | 49 +- mk/validate-settings.mk | 3 - rts/Capability.h | 7 +- rts/PosixSource.h | 2 +- rts/RtsUtils.c | 2 +- rts/StgCRun.c | 6 +- rules/build-package-data.mk | 4 +- rules/build-package.mk | 2 +- rules/haddock.mk | 2 +- rules/shell-wrapper.mk | 2 +- sync-all | 4 + utils/ghc-cabal/ghc-cabal.cabal | 2 +- utils/ghc-pkg/ghc.mk | 33 +- utils/ghctags/Main.hs | 2 +- 79 files changed, 2289 insertions(+), 1406 deletions(-) diff --cc compiler/coreSyn/CoreLint.lhs index 6f6e58b,d40ef52..f62d519 --- a/compiler/coreSyn/CoreLint.lhs +++ b/compiler/coreSyn/CoreLint.lhs @@@ -699,7 -701,109 +701,119 @@@ lintTyBndrKind tv then return () -- kind forall else lintKind ki -- type forall + ---------- + checkTcApp :: OutCoercion -> Int -> Type -> LintM OutType + checkTcApp co n ty + | Just tys <- tyConAppArgs_maybe ty + , n < length tys + = return (tys !! n) + | otherwise + = failWithL (hang (ptext (sLit "Bad getNth:") <+> ppr co) + 2 (ptext (sLit "Offending type:") <+> ppr ty)) + ------------------- + lintType :: OutType -> LintM Kind + -- The returned Kind has itself been linted + lintType (TyVarTy tv) + = do { checkTyCoVarInScope tv + ; let kind = tyVarKind tv + ; lintKind kind + ; WARN( isSuperKind kind, msg ) + return kind } + where msg = hang (ptext (sLit "Expecting a type, but got a kind")) + 2 (ptext (sLit "Offending kind:") <+> ppr tv) + + lintType ty@(AppTy t1 t2) + = do { k1 <- lintType t1 + ; lint_ty_app ty k1 [t2] } + + lintType ty@(FunTy t1 t2) + = lint_ty_app ty (mkArrowKinds [argTypeKind, openTypeKind] liftedTypeKind) [t1,t2] + + lintType ty@(TyConApp tc tys) + | tyConHasKind tc -- Guards for SuperKindOon + , not (isUnLiftedTyCon tc) || tys `lengthIs` tyConArity tc + -- Check that primitive types are saturated + -- See Note [The kind invariant] in TypeRep + = lint_ty_app ty (tyConKind tc) tys + | otherwise + = failWithL (hang (ptext (sLit "Malformed type:")) 2 (ppr ty)) + + lintType (ForAllTy tv ty) + = do { lintTyBndrKind tv + ; addInScopeVar tv (lintType ty) } + ++lintType ty@(LitTy l) = lintTyLit l >> return (typeKind ty) ++ + ---------------- + lint_ty_app :: Type -> Kind -> [OutType] -> LintM Kind + lint_ty_app ty k tys + = lint_kind_app (ptext (sLit "type") <+> quotes (ppr ty)) k tys + + ---------------- + lint_co_app :: Coercion -> Kind -> [OutType] -> LintM () + lint_co_app ty k tys + = do { _ <- lint_kind_app (ptext (sLit "coercion") <+> quotes (ppr ty)) k tys + ; return () } + + ---------------- ++lintTyLit :: TyLit -> LintM () ++lintTyLit (NumTyLit n) ++ | n >= 0 = return () ++ | otherwise = failWithL msg ++ where msg = ptext (sLit "Negative type literal:") <+> integer n ++lintTyLit (StrTyLit _) = return () ++ ++---------------- + lint_kind_app :: SDoc -> Kind -> [OutType] -> LintM Kind + -- (lint_kind_app d fun_kind arg_tys) + -- We have an application (f arg_ty1 .. arg_tyn), + -- where f :: fun_kind + -- Takes care of linting the OutTypes + lint_kind_app doc kfn tys = go kfn tys + where + fail_msg = vcat [ hang (ptext (sLit "Kind application error in")) 2 doc + , nest 2 (ptext (sLit "Function kind =") <+> ppr kfn) + , nest 2 (ptext (sLit "Arg types =") <+> ppr tys) ] + + go kfn [] = return kfn + go kfn (ty:tys) = + case splitKindFunTy_maybe kfn of + { Nothing -> + case splitForAllTy_maybe kfn of + { Nothing -> failWithL fail_msg + ; Just (kv, body) -> do + -- Something of kind (forall kv. body) gets instantiated + -- with ty. 'kv' is a kind variable and 'ty' is a kind. + { unless (isSuperKind (tyVarKind kv)) (addErrL fail_msg) + ; lintKind ty + ; go (substKiWith [kv] [ty] body) tys } } + ; Just (kfa, kfb) -> do + -- Something of kind (kfa -> kfb) is applied to ty. 'ty' is + -- a type accepting kind 'kfa'. + { k <- lintType ty + ; lintKind kfa + ; unless (k `isSubKind` kfa) (addErrL fail_msg) + ; go kfb tys } } + + \end{code} + + %************************************************************************ + %* * + Linting coercions + %* * + %************************************************************************ + + \begin{code} + lintInCo :: InCoercion -> LintM OutCoercion + -- Check the coercion, and apply the substitution to it + -- See Note [Linting type lets] + lintInCo co + = addLoc (InCo co) $ + do { co' <- applySubstCo co + ; _ <- lintCoercion co' + ; return co' } + lintKindCoercion :: OutCoercion -> LintM OutKind -- Kind coercions are only reflexivity because they mean kind -- instantiation. See Note [Kind coercions] in Coercion diff --cc compiler/parser/Parser.y.pp index c0f5041,c05f2e1..61eb574 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@@ -1071,8 -1072,6 +1076,8 @@@ atype :: { LHsType RdrName | SIMPLEQUOTE '(' ctype ',' comma_types1 ')' { LL $ HsExplicitTupleTy [] ($3 : $5) } | SIMPLEQUOTE '[' comma_types0 ']' { LL $ HsExplicitListTy placeHolderKind $3 } | '[' ctype ',' comma_types1 ']' { LL $ HsExplicitListTy placeHolderKind ($2 : $4) } - | INTEGER { LL $ HsTyLit $ HsNumberTy $ getINTEGER $1 } - | STRING { LL $ HsTyLit $ HsStringTy $ getSTRING $1 } ++ | INTEGER { LL $ HsTyLit $ HsNumTy $ getINTEGER $1 } ++ | STRING { LL $ HsTyLit $ HsStrTy $ getSTRING $1 } -- An inst_type is what occurs in the head of an instance decl -- e.g. (Foo a, Gaz b) => Wibble a b diff --cc compiler/rename/RnTypes.lhs index 7840c4a,3b86d0b..5275957 --- a/compiler/rename/RnTypes.lhs +++ b/compiler/rename/RnTypes.lhs @@@ -221,13 -221,6 +221,13 @@@ rnHsTyKi isType doc tupleTy@(HsTupleTy tys' <- mapM (rnLHsTyKi isType doc) tys return (HsTupleTy tup_con tys') +-- 1. Perhaps we should use a separate extension here? +-- 2. Check that the integer is positive? +rnHsTyKi isType _ tyLit@(HsTyLit t) = do + data_kinds <- xoptM Opt_DataKinds - unless (data_kinds || isType) (addErr (polyKindsErr tyLit)) ++ unless (data_kinds || isType) (addErr (dataKindsErr tyLit)) + return (HsTyLit t) + rnHsTyKi isType doc (HsAppTy ty1 ty2) = do ty1' <- rnLHsTyKi isType doc ty1 ty2' <- rnLHsTyKi isType doc ty2 diff --cc compiler/typecheck/TcHsType.lhs index 0df0a9b,66b7438..7d6dfeb --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@@ -761,12 -753,8 +761,12 @@@ ds_type (HsExplicitTupleTy kis tys) = d MASSERT( length kis == length tys ) kis' <- mapM zonkTcKindToKind kis tys' <- mapM dsHsType tys - return $ mkTyConApp (buildPromotedDataTyCon (tupleCon BoxedTuple (length kis'))) (kis' ++ tys') + return $ mkTyConApp (buildPromotedDataCon (tupleCon BoxedTuple (length kis'))) (kis' ++ tys') +ds_type (HsTyLit tl) = return $ case tl of + HsNumTy n -> mkNumLitTy n + HsStrTy s -> mkStrLitTy s + ds_type (HsWrapTy (WpKiApps kappas) ty) = do tau <- ds_type ty kappas' <- mapM zonkTcKindToKind kappas _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
