[commit: ghc] type-nats: Merge remote-tracking branch 'origin/master' into type-nats (cfd89e1)
Iavor Diatchki
diatchki at galois.com
Sun Feb 12 22:29:44 CET 2012
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 <iavor.diatchki at gmail.com>
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
More information about the Cvs-ghc
mailing list