Merge remote-tracking branch 'origin/master' into type-nats
authorIavor S. Diatchki <iavor.diatchki@gmail.com>
Sun, 12 Feb 2012 21:29:29 +0000 (13:29 -0800)
committerIavor S. Diatchki <iavor.diatchki@gmail.com>
Sun, 12 Feb 2012 21:29:29 +0000 (13:29 -0800)
Conflicts:
compiler/coreSyn/CoreLint.lhs

1  2 
compiler/coreSyn/CoreLint.lhs
compiler/parser/Parser.y.pp
compiler/rename/RnTypes.lhs
compiler/typecheck/TcHsType.lhs
compiler/types/FamInstEnv.lhs
compiler/types/Kind.lhs
mk/validate-settings.mk

@@@ -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
@@@ -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
@@@ -221,13 -221,6 +221,13 @@@ rnHsTyKi isType doc tupleTy@(HsTupleTy 
      tys' <- mapM (rnLHsTyKi isType doc) tys
      return (HsTupleTy tup_con tys')
  
-     unless (data_kinds || isType) (addErr (polyKindsErr tyLit))
 +-- 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 (dataKindsErr tyLit))
 +    return (HsTyLit t)
 +
  rnHsTyKi isType doc (HsAppTy ty1 ty2) = do
      ty1' <- rnLHsTyKi isType doc ty1
      ty2' <- rnLHsTyKi isType doc ty2
@@@ -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
Simple merge
Simple merge
Simple merge