[commit: ghc] wip/generalized-arrow: Implement Data.Typeable.funResultTy (79d404c)

[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/79d404c7934c44b183466d898cb3693eea2df7da/ghc

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

commit 79d404c7934c44b183466d898cb3693eea2df7da
Author: Ben Gamari <ben at smart-cactus.org>
Date:   Tue Mar 15 16:21:58 2016 +0100

    Implement Data.Typeable.funResultTy


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

79d404c7934c44b183466d898cb3693eea2df7da
 libraries/base/Data/Typeable.hs | 15 +++++++++++++++
 1 file changed, 15 insertions(+)

diff --git a/libraries/base/Data/Typeable.hs b/libraries/base/Data/Typeable.hs
index 486c5b8..7718cf3 100644
--- a/libraries/base/Data/Typeable.hs
+++ b/libraries/base/Data/Typeable.hs
@@ -69,6 +69,9 @@ module Data.Typeable
     , rnfTypeRep
     , showsTypeRep
 
+      -- * Observing type representations
+    , funResultTy
+
       -- * Type constructors
     , I.TyCon          -- abstract, instance of: Eq, Show, Typeable
                        -- For now don't export Module to avoid name clashes
@@ -147,6 +150,18 @@ gcast2 x = fmap (\Refl -> x) (eqT :: Maybe (t :~: t'))
 typeRepTyCon :: TypeRep -> TyCon
 typeRepTyCon = I.typeRepXTyCon
 
+-- | Applies a type to a function type. Returns: @Just u@ if the first argument
+-- represents a function of type @t -> u@ and the second argument represents a
+-- function of type @t at . Otherwise, returns @Nothing at .
+funResultTy :: TypeRep -> TypeRep -> Maybe TypeRep
+funResultTy (I.TypeRepX f) (I.TypeRepX x)
+  | Just HRefl <- (I.typeRep :: I.TypeRep Type) `I.eqTypeRep` I.typeRepKind f
+  , I.TRFun arg res <- f
+  , Just HRefl <- arg `I.eqTypeRep` x
+  = Just (I.TypeRepX res)
+  | otherwise
+  = Nothing
+
 -- | Force a 'TypeRep' to normal form.
 rnfTypeRep :: TypeRep -> ()
 rnfTypeRep = I.rnfTypeRepX