[commit: ghc] master: Coercible: Do not try to unwrap undersaturated newtypes (2f7d3d8)

[git at git.haskell.org]

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

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/2f7d3d87938571f3627618eaa3ebe94d9d77f02c/ghc

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

commit 2f7d3d87938571f3627618eaa3ebe94d9d77f02c
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Tue Nov 19 12:09:40 2013 +0000

    Coercible: Do not try to unwrap undersaturated newtypes
    
    otherwise we get a panic.


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

2f7d3d87938571f3627618eaa3ebe94d9d77f02c
 compiler/typecheck/TcInteract.lhs |    3 ++-
 compiler/types/TyCon.lhs          |    8 +++++++-
 compiler/types/Type.lhs           |    3 ++-
 3 files changed, 11 insertions(+), 3 deletions(-)

diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs
index c61b8da..d8abaee 100644
--- a/compiler/typecheck/TcInteract.lhs
+++ b/compiler/typecheck/TcInteract.lhs
@@ -1959,6 +1959,7 @@ getCoercibleInst safeMode rdr_env ty1 ty2
   | Just (tc,tyArgs) <- splitTyConApp_maybe ty1,
     Just (_, _, _) <- unwrapNewTyCon_maybe tc,
     not (isRecursiveTyCon tc),
+    newTyConEtadArity tc <= length tyArgs,
     dataConsInScope rdr_env tc -- Do noot look at all tyConsOfTyCon
   = do markDataConsAsUsed rdr_env tc
        let concTy = newTyConInstRhs tc tyArgs
@@ -1969,6 +1970,7 @@ getCoercibleInst safeMode rdr_env ty1 ty2
   | Just (tc,tyArgs) <- splitTyConApp_maybe ty2,
     Just (_, _, _) <- unwrapNewTyCon_maybe tc,
     not (isRecursiveTyCon tc),
+    newTyConEtadArity tc <= length tyArgs,
     dataConsInScope rdr_env tc -- Do noot look at all tyConsOfTyCon
   = do markDataConsAsUsed rdr_env tc
        let concTy = newTyConInstRhs tc tyArgs
@@ -1979,7 +1981,6 @@ getCoercibleInst safeMode rdr_env ty1 ty2
   | otherwise
   = return NoInstance
 
-
 nominalArgsAgree :: TyCon -> [Type] -> [Type] -> Bool
 nominalArgsAgree tc tys1 tys2 = all ok $ zip3 (tyConRoles tc) tys1 tys2
   where ok (r,t1,t2) = r /= Nominal || t1 `eqType` t2
diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs
index e690329..ccc78a2 100644
--- a/compiler/types/TyCon.lhs
+++ b/compiler/types/TyCon.lhs
@@ -73,7 +73,7 @@ module TyCon(
         synTyConDefn_maybe, synTyConRhs_maybe, 
         tyConExtName,           -- External name for foreign types
         algTyConRhs,
-        newTyConRhs, newTyConEtadRhs, unwrapNewTyCon_maybe,
+        newTyConRhs, newTyConEtadArity, newTyConEtadRhs, unwrapNewTyCon_maybe,
         tupleTyConBoxity, tupleTyConSort, tupleTyConArity,
 
         -- ** Manipulating TyCons
@@ -1480,6 +1480,12 @@ newTyConRhs :: TyCon -> ([TyVar], Type)
 newTyConRhs (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon { nt_rhs = rhs }}) = (tvs, rhs)
 newTyConRhs tycon = pprPanic "newTyConRhs" (ppr tycon)
 
+-- | The number of type parameters that need to be passed to a newtype to resolve it. May be less than in the definition if it can be eta-contracted.
+newTyConEtadArity :: TyCon -> Int
+newTyConEtadArity (AlgTyCon {algTcRhs = NewTyCon { nt_etad_rhs = tvs_rhs }})
+        = length (fst tvs_rhs)
+newTyConEtadArity tycon = pprPanic "newTyConEtadArity" (ppr tycon)
+
 -- | Extract the bound type variables and type expansion of an eta-contracted type synonym 'TyCon'.
 -- Panics if the 'TyCon' is not a synonym
 newTyConEtadRhs :: TyCon -> ([TyVar], Type)
diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs
index d06b057..0805337 100644
--- a/compiler/types/Type.lhs
+++ b/compiler/types/Type.lhs
@@ -560,7 +560,8 @@ splitTyConApp_maybe _                 = Nothing
 
 newTyConInstRhs :: TyCon -> [Type] -> Type
 -- ^ Unwrap one 'layer' of newtype on a type constructor and its
--- arguments, using an eta-reduced version of the @newtype@ if possible
+-- arguments, using an eta-reduced version of the @newtype@ if possible.
+-- This requires tys to have at least @newTyConInstArity tycon@ elements.
 newTyConInstRhs tycon tys
     = ASSERT2( equalLength tvs tys1, ppr tycon $$ ppr tys $$ ppr tvs )
       mkAppTys (substTyWith tvs tys1 ty) tys2