[commit: ghc] wip/generalized-arrow: Fixes (1d46fbd)

[git at git.haskell.org]

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

On branch  : wip/generalized-arrow
Link       : http://ghc.haskell.org/trac/ghc/changeset/1d46fbd3b6f30da1e0afc391aad63d5cda50081a/ghc

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

commit 1d46fbd3b6f30da1e0afc391aad63d5cda50081a
Author: Ben Gamari <ben at smart-cactus.org>
Date:   Fri Mar 25 12:48:08 2016 +0100

    Fixes


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

1d46fbd3b6f30da1e0afc391aad63d5cda50081a
 compiler/types/Type.hs | 42 +++++++++++++++++++++++++++++-------------
 1 file changed, 29 insertions(+), 13 deletions(-)

diff --git a/compiler/types/Type.hs b/compiler/types/Type.hs
index 6ea6a82..7354b16 100644
--- a/compiler/types/Type.hs
+++ b/compiler/types/Type.hs
@@ -657,8 +657,10 @@ repSplitAppTy_maybe :: Type -> Maybe (Type,Type)
 -- ^ Does the AppTy split as in 'splitAppTy_maybe', but assumes that
 -- any Core view stuff is already done
 repSplitAppTy_maybe (ForAllTy (Anon ty1) ty2)
-                                      = Just (TyConApp funTyCon [ty1], ty2)
-repSplitAppTy_maybe (AppTy ty1 ty2)   = Just (ty1, ty2)
+  | Just rep1 <- tyRuntimeRep_maybe ty1
+  , Just rep2 <- tyRuntimeRep_maybe ty2 = Just (TyConApp funTyCon [rep1, rep2, ty1], ty2)
+  | otherwise                           = pprPanic "repSplitAppTy_maybe" (ppr ty1 $$ ppr ty2)
+repSplitAppTy_maybe (AppTy ty1 ty2)     = Just (ty1, ty2)
 repSplitAppTy_maybe (TyConApp tc tys)
   | mightBeUnsaturatedTyCon tc || tys `lengthExceeds` tyConArity tc
   , Just (tys', ty') <- snocView tys
@@ -673,7 +675,9 @@ tcRepSplitAppTy_maybe :: Type -> Maybe (Type,Type)
 -- any coreView stuff is already done. Refuses to look through (c => t)
 tcRepSplitAppTy_maybe (ForAllTy (Anon ty1) ty2)
   | isConstraintKind (typeKind ty1)     = Nothing  -- See Note [Decomposing fat arrow c=>t]
-  | otherwise                           = Just (TyConApp funTyCon [ty1], ty2)
+  | Just rep1 <- tyRuntimeRep_maybe ty1
+  , Just rep2 <- tyRuntimeRep_maybe ty2 = Just (TyConApp funTyCon [rep1, rep2, ty1], ty2)
+  | otherwise                           = pprPanic "repSplitAppTy_maybe" (ppr ty1 $$ ppr ty2)
 tcRepSplitAppTy_maybe (AppTy ty1 ty2)   = Just (ty1, ty2)
 tcRepSplitAppTy_maybe (TyConApp tc tys)
   | mightBeUnsaturatedTyCon tc || tys `lengthExceeds` tyConArity tc
@@ -704,8 +708,11 @@ splitAppTys ty = split ty ty []
             (tc_args1, tc_args2) = splitAt n tc_args
         in
         (TyConApp tc tc_args1, tc_args2 ++ args)
-    split _   (ForAllTy (Anon ty1) ty2) args = ASSERT( null args )
+    split _   (ForAllTy (Anon ty1) ty2) args
+      | Just rep1 <- tyRuntimeRep_maybe ty1
+      , Just rep2 <- tyRuntimeRep_maybe ty2  = ASSERT( null args )
                                                (TyConApp funTyCon [], [ty1,ty2])
+      | otherwise                            = pprPanic "splitAppTys" (ppr ty1 $$ ppr ty2 $$ ppr args)
     split orig_ty _                     args = (orig_ty, args)
 
 -- | Like 'splitAppTys', but doesn't look through type synonyms
@@ -719,8 +726,11 @@ repSplitAppTys ty = split ty []
             (tc_args1, tc_args2) = splitAt n tc_args
         in
         (TyConApp tc tc_args1, tc_args2 ++ args)
-    split (ForAllTy (Anon ty1) ty2) args = ASSERT( null args )
+    split (ForAllTy (Anon ty1) ty2) args
+      | Just rep1 <- tyRuntimeRep_maybe ty1
+      , Just rep2 <- tyRuntimeRep_maybe ty2= ASSERT( null args )
                                            (TyConApp funTyCon [], [ty1, ty2])
+      | otherwise                          = pprPanic "repSplitAppTys" (ppr ty1 $$ ppr ty2 $$ ppr args)
     split ty args = (ty, args)
 
 {-
@@ -935,7 +945,7 @@ applyTysX tvs body_ty arg_tys
 -- its arguments.  Applies its arguments to the constructor from left to right.
 mkTyConApp :: TyCon -> [Type] -> Type
 mkTyConApp tycon tys
-  | isFunTyCon tycon, [ty1,ty2] <- tys
+  | isFunTyCon tycon, [_rep1,_rep2,ty1,ty2] <- tys
   = ForAllTy (Anon ty1) ty2
 
   | otherwise
@@ -982,11 +992,16 @@ tyConAppArgN n ty
 
 -- | If given a type @TYPE (rr :: RuntimeRep)@ then returns @Just rr@
 -- otherwise @Nothing at .
-tyRuntimeRep :: Type -> Maybe Type
-tyRuntimeRep (TyConApp tc [rr])
-  | tc == tYPETyCon = ASSERT(typeKind rr `eqType` runtimeRepTy)
-                      Just rr
-tyRuntimeRep _      = Nothing
+tyRuntimeRep_maybe :: Type -> Maybe Type
+tyRuntimeRep_maybe (TyConApp tc [rr])
+  | tc == tYPETyCon       = ASSERT(typeKind rr `eqType` runtimeRepTy)
+                            Just rr
+tyRuntimeRep_maybe _      = Nothing
+
+tyRuntimeRep :: Type -> Type
+tyRuntimeRep ty
+  | Just rep <- tyRuntimeRep_maybe ty = rep
+  | otherwise                         = pprPanic "tyRuntimeRep" (ppr ty)
 
 -- | Attempts to tease a type apart into a type constructor and the application
 -- of a number of arguments to that constructor. Panics if that is not possible.
@@ -1007,8 +1022,9 @@ splitTyConApp_maybe ty                           = repSplitTyConApp_maybe ty
 repSplitTyConApp_maybe :: Type -> Maybe (TyCon, [Type])
 repSplitTyConApp_maybe (TyConApp tc tys)         = Just (tc, tys)
 repSplitTyConApp_maybe (ForAllTy (Anon arg) res)
-    | Just rep1 <- tyRuntimeRep arg
-    , Just rep2 <- tyRuntimeRep res              = Just (funTyCon, [rep1, rep2, arg, res])
+  | Just rep1 <- tyRuntimeRep_maybe arg
+  , Just rep2 <- tyRuntimeRep_maybe res          = Just (funTyCon, [rep1, rep2, arg, res])
+  | otherwise                                    = pprPanic "repSplitTyConApp_maybe" (ppr arg $$ ppr res)
 repSplitTyConApp_maybe _                         = Nothing
 
 -- | Attempts to tease a list type apart and gives the type of the elements if