[commit: ghc] wip/tdammers/D4394: Fix rebasing-induced failures (af9a1e9)

[git at git.haskell.org]

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

On branch  : wip/tdammers/D4394
Link       : http://ghc.haskell.org/trac/ghc/changeset/af9a1e9dc0390340af16ddc1d9ee0aaa1f94295c/ghc

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

commit af9a1e9dc0390340af16ddc1d9ee0aaa1f94295c
Author: Tobias Dammers <tdammers at gmail.com>
Date:   Fri Mar 30 13:09:59 2018 +0200

    Fix rebasing-induced failures


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

af9a1e9dc0390340af16ddc1d9ee0aaa1f94295c
 compiler/typecheck/TcType.hs |  2 +-
 compiler/types/Coercion.hs   |  4 ++--
 compiler/types/Type.hs       | 12 +++++++++++-
 3 files changed, 14 insertions(+), 4 deletions(-)

diff --git a/compiler/typecheck/TcType.hs b/compiler/typecheck/TcType.hs
index c1cb52c..9758d03 100644
--- a/compiler/typecheck/TcType.hs
+++ b/compiler/typecheck/TcType.hs
@@ -68,7 +68,7 @@ module TcType (
   tcTyConAppTyCon, tcTyConAppTyCon_maybe, tcTyConAppArgs,
   tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys, tcRepSplitAppTy_maybe,
   tcRepGetNumAppTys,
-  tcGetCastedTyVar_maybe, tcGetTyVar_maybe, tcGetTyVar,
+  tcGetCastedTyVar_maybe, tcGetTyVar_maybe, tcGetTyVar, nextRole,
   tcSplitSigmaTy, tcSplitNestedSigmaTys, tcDeepSplitSigmaTy_maybe,
 
   ---------------------------------
diff --git a/compiler/types/Coercion.hs b/compiler/types/Coercion.hs
index 6e6f07c..2807512 100644
--- a/compiler/types/Coercion.hs
+++ b/compiler/types/Coercion.hs
@@ -278,7 +278,7 @@ decomposePiCos orig_kind orig_args orig_co = go [] orig_subst orig_kind orig_arg
         --          ty :: s2
         -- need arg_co :: s2 ~ s1
         --      res_co :: t1[ty |> arg_co / a] ~ t2[ty / b]
-      = let arg_co = mkNthCo 0 (mkSymCo co)
+      = let arg_co = mkNthCo Nominal 0 (mkSymCo co)
             res_co = mkInstCo co (mkNomReflCo ty `mkCoherenceLeftCo` arg_co)
             subst' = extendTCvSubst subst kv ty
         in
@@ -290,7 +290,7 @@ decomposePiCos orig_kind orig_args orig_co = go [] orig_subst orig_kind orig_arg
         --          ty :: s2
         -- need arg_co :: s2 ~ s1
         --      res_co :: t1 ~ t2
-      = let (sym_arg_co, res_co) = decomposeFunCo co
+      = let (sym_arg_co, res_co) = decomposeFunCo Representational co
             arg_co               = mkSymCo sym_arg_co
         in
         go (arg_co : acc_arg_cos) subst res_ki tys res_co
diff --git a/compiler/types/Type.hs b/compiler/types/Type.hs
index 0ddfe09..e599012 100644
--- a/compiler/types/Type.hs
+++ b/compiler/types/Type.hs
@@ -30,7 +30,7 @@ module Type (
         mkTyConApp, mkTyConTy,
         tyConAppTyCon_maybe, tyConAppTyConPicky_maybe,
         tyConAppArgs_maybe, tyConAppTyCon, tyConAppArgs,
-        splitTyConApp_maybe, splitTyConApp, tyConAppArgN,
+        splitTyConApp_maybe, splitTyConApp, tyConAppArgN, nextRole,
         tcRepSplitTyConApp_maybe, tcSplitTyConApp_maybe,
         splitListTyConApp_maybe,
         repSplitTyConApp_maybe,
@@ -1140,6 +1140,16 @@ splitListTyConApp_maybe ty = case splitTyConApp_maybe ty of
   Just (tc,[e]) | tc == listTyCon -> Just e
   _other                          -> Nothing
 
+nextRole :: Type -> Role
+nextRole ty
+  | Just (tc, tys) <- splitTyConApp_maybe ty
+  , let num_tys = length tys
+  , num_tys < tyConArity tc
+  = tyConRoles tc `getNth` num_tys
+
+  | otherwise
+  = Nominal
+
 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.