[commit: ghc] wip/generalized-arrow: Add mkFunTy (e3242bd)

[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/e3242bd82331b1afd225c154ca44e0482db103d9/ghc

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

commit e3242bd82331b1afd225c154ca44e0482db103d9
Author: Ben Gamari <ben at smart-cactus.org>
Date:   Wed Mar 16 23:15:36 2016 +0100

    Add mkFunTy


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

e3242bd82331b1afd225c154ca44e0482db103d9
 libraries/base/Data/Typeable.hs          | 14 ++++++++++++++
 libraries/base/Data/Typeable/Internal.hs |  3 ++-
 2 files changed, 16 insertions(+), 1 deletion(-)

diff --git a/libraries/base/Data/Typeable.hs b/libraries/base/Data/Typeable.hs
index 21f93d2..3eb53c5 100644
--- a/libraries/base/Data/Typeable.hs
+++ b/libraries/base/Data/Typeable.hs
@@ -68,6 +68,7 @@ module Data.Typeable
     , typeRepTyCon
     , rnfTypeRep
     , showsTypeRep
+    , mkFunTy
 
       -- * Observing type representations
     , funResultTy
@@ -168,6 +169,19 @@ funResultTy (I.TypeRepX f) (I.TypeRepX x) =
 -}
 funResultTy _ _ = Nothing
 
+-- | Build a function type.
+mkFunTy :: TypeRep -> TypeRep -> TypeRep
+mkFunTy (I.TypeRepX arg) (I.TypeRepX res)
+  | Just HRefl <- arg `I.eqTypeRep` liftedTy
+  , Just HRefl <- res `I.eqTypeRep` liftedTy
+  = I.TypeRepX (I.TRFun arg res)
+  | otherwise
+  = error $ "mkFunTy: Attempted to construct function type from non-lifted "++
+            "type: arg="++show arg++", res="++show res
+  where liftedTy = I.typeRep :: I.TypeRep *
+  -- TODO: We should be able to support this but the kind of (->) must be
+  -- generalized
+
 -- | Force a 'TypeRep' to normal form.
 rnfTypeRep :: TypeRep -> ()
 rnfTypeRep = I.rnfTypeRepX
diff --git a/libraries/base/Data/Typeable/Internal.hs b/libraries/base/Data/Typeable/Internal.hs
index c145773..2053adb 100644
--- a/libraries/base/Data/Typeable/Internal.hs
+++ b/libraries/base/Data/Typeable/Internal.hs
@@ -187,7 +187,8 @@ pattern TRFun :: forall fun. ()
               => TypeRep arg
               -> TypeRep res
               -> TypeRep fun
-pattern TRFun arg res <- TrApp _ (TrApp _ (eqTypeRep trArrow -> Just HRefl) arg) res
+pattern TRFun arg res <- TrApp _ (TrApp _ (eqTypeRep trArrow -> Just HRefl) arg) res where
+  TRFun arg res = mkTrApp (mkTrApp trArrow arg) res
 
 decomposeFun :: forall fun r.
                 TypeRep fun