[commit: ghc] ghc-7.8: Make Core Lint check for un-saturated type applications (b15432c)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : ghc-7.8
Link       : http://ghc.haskell.org/trac/ghc/changeset/b15432c826fdad27afc45be617c117876d9f3e08/ghc

>---------------------------------------------------------------

commit b15432c826fdad27afc45be617c117876d9f3e08
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Mon Aug 25 15:10:19 2014 +0100

    Make Core Lint check for un-saturated type applications
    
    Un-saturated type-family and type-synonym applications are
    detected in the front end, but for some reason Lint wasn't
    looking for them.
    
    I came across this when wondering why Trac #9433 didn't give
    a Core Lint error
    
    (cherry picked from commit 8ff4671422090acf9146e3a90dd38e2c6f72aebb)


>---------------------------------------------------------------

b15432c826fdad27afc45be617c117876d9f3e08
 compiler/coreSyn/CoreLint.lhs | 15 +++++++++++----
 1 file changed, 11 insertions(+), 4 deletions(-)

diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs
index 8665ec4..2689900 100644
--- a/compiler/coreSyn/CoreLint.lhs
+++ b/compiler/coreSyn/CoreLint.lhs
@@ -727,13 +727,20 @@ lintType ty@(FunTy t1 t2)    -- (->) has two different rules, for types and kind
        ; lintArrow (ptext (sLit "type or kind") <+> quotes (ppr ty)) k1 k2 }
 
 lintType ty@(TyConApp tc tys)
-  | not (isUnLiftedTyCon tc) || tys `lengthIs` tyConArity tc
-       -- Check that primitive types are saturated
+  | Just ty' <- coreView ty
+  = lintType ty'   -- Expand type synonyms, so that we do not bogusly complain
+                   --  about un-saturated type synonyms
+                   -- 
+
+  | isUnLiftedTyCon tc || isSynTyCon tc
        -- See Note [The kind invariant] in TypeRep
+       -- Also type synonyms and type families
+  , length tys < tyConArity tc
+  = failWithL (hang (ptext (sLit "Un-saturated type application")) 2 (ppr ty))
+
+  | otherwise
   = do { ks <- mapM lintType tys
        ; lint_ty_app ty (tyConKind tc) (tys `zip` ks) }
-  | otherwise
-  = failWithL (hang (ptext (sLit "Malformed type:")) 2 (ppr ty))
 
 lintType (ForAllTy tv ty)
   = do { lintTyBndrKind tv