[commit: ghc] wip/generalized-arrow: TysPrim: Generalize kind of (->) (6129750)

[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/6129750a414af87fcf5e4dec48e6470539053f73/ghc

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

commit 6129750a414af87fcf5e4dec48e6470539053f73
Author: Ben Gamari <ben at smart-cactus.org>
Date:   Wed Mar 16 23:28:59 2016 +0100

    TysPrim: Generalize kind of (->)


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

6129750a414af87fcf5e4dec48e6470539053f73
 compiler/prelude/TysPrim.hs | 22 ++++++++++------------
 compiler/types/TyCon.hs     |  6 +++---
 compiler/types/Type.hs      | 14 ++++++++++++--
 3 files changed, 25 insertions(+), 17 deletions(-)

diff --git a/compiler/prelude/TysPrim.hs b/compiler/prelude/TysPrim.hs
index ce25c30..d61892c 100644
--- a/compiler/prelude/TysPrim.hs
+++ b/compiler/prelude/TysPrim.hs
@@ -20,7 +20,7 @@ module TysPrim(
         kKiVar,
 
         -- Kind constructors...
-        tYPETyConName, unliftedTypeKindTyConName,
+        tYPETyCon, tYPETyConName, unliftedTypeKindTyConName,
 
         -- Kinds
         tYPE,
@@ -269,20 +269,18 @@ kKiVar = (mkTemplateTyVars $ repeat liftedTypeKind) !! 10
 funTyConName :: Name
 funTyConName = mkPrimTyConName (fsLit "(->)") funTyConKey funTyCon
 
+-- | The @(->)@ type constructor.
+--
+-- @
+-- (->) :: forall (rep1 :: RuntimeRep) (rep2 :: RuntimeRep).
+--         TYPE rep1 -> TYPE rep2 -> *
+-- @
 funTyCon :: TyCon
-funTyCon = mkFunTyCon funTyConName (map Anon [liftedTypeKind, liftedTypeKind])
-                                   tc_rep_nm
+funTyCon = mkFunTyCon funTyConName tyvars kind tc_rep_nm
   where
-        -- You might think that (->) should have type (?? -> ? -> *), and you'd be right
-        -- But if we do that we get kind errors when saying
-        --      instance Control.Arrow (->)
-        -- because the expected kind is (*->*->*).  The trouble is that the
-        -- expected/actual stuff in the unifier does not go contra-variant, whereas
-        -- the kind sub-typing does.  Sigh.  It really only matters if you use (->) in
-        -- a prefix way, thus:  (->) Int# Int#.  And this is unusual.
-        -- because they are never in scope in the source
-
+    tyvars = map (\tv -> Named tv Invisible) [runtimeRep1TyVar, runtimeRep2TyVar]
     tc_rep_nm = mkPrelTyConRepName funTyConName
+    kind = mkFunTys [tYPE runtimeRep1Ty, tYPE runtimeRep2Ty] liftedTypeKind
 
 {-
 ************************************************************************
diff --git a/compiler/types/TyCon.hs b/compiler/types/TyCon.hs
index b980c9b..3a700f4 100644
--- a/compiler/types/TyCon.hs
+++ b/compiler/types/TyCon.hs
@@ -1194,14 +1194,14 @@ So we compromise, and move their Kind calculation to the call site.
 -- | Given the name of the function type constructor and it's kind, create the
 -- corresponding 'TyCon'. It is reccomended to use 'TyCoRep.funTyCon' if you want
 -- this functionality
-mkFunTyCon :: Name -> [TyBinder] -> Name -> TyCon
-mkFunTyCon name binders rep_nm
+mkFunTyCon :: Name -> [TyBinder] -> Kind -> Name -> TyCon
+mkFunTyCon name binders kind rep_nm
   = FunTyCon {
         tyConUnique  = nameUnique name,
         tyConName    = name,
         tyConBinders = binders,
         tyConResKind = liftedTypeKind,
-        tyConKind    = mkForAllTys binders liftedTypeKind,
+        tyConKind    = mkForAllTys binders kind,
         tyConArity   = 2,
         tcRepName    = rep_nm
     }
diff --git a/compiler/types/Type.hs b/compiler/types/Type.hs
index c5561a3..6ea6a82 100644
--- a/compiler/types/Type.hs
+++ b/compiler/types/Type.hs
@@ -211,7 +211,7 @@ import Class
 import TyCon
 import TysPrim
 import {-# SOURCE #-} TysWiredIn ( listTyCon, typeNatKind
-                                 , typeSymbolKind, liftedTypeKind )
+                                 , typeSymbolKind, runtimeRepTy, liftedTypeKind )
 import PrelNames
 import CoAxiom
 import {-# SOURCE #-} Coercion
@@ -980,6 +980,14 @@ tyConAppArgN n ty
       Just tys -> ASSERT2( n < length tys, ppr n <+> ppr tys ) tys `getNth` n
       Nothing  -> pprPanic "tyConAppArgN" (ppr n <+> ppr 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
+
 -- | 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.
 -- See also 'splitTyConApp_maybe'
@@ -998,7 +1006,9 @@ splitTyConApp_maybe ty                           = repSplitTyConApp_maybe ty
 -- assumes the synonyms have already been dealt with.
 repSplitTyConApp_maybe :: Type -> Maybe (TyCon, [Type])
 repSplitTyConApp_maybe (TyConApp tc tys)         = Just (tc, tys)
-repSplitTyConApp_maybe (ForAllTy (Anon arg) res) = Just (funTyCon, [arg,res])
+repSplitTyConApp_maybe (ForAllTy (Anon arg) res)
+    | Just rep1 <- tyRuntimeRep arg
+    , Just rep2 <- tyRuntimeRep res              = Just (funTyCon, [rep1, rep2, arg, res])
 repSplitTyConApp_maybe _                         = Nothing
 
 -- | Attempts to tease a list type apart and gives the type of the elements if