[commit: ghc] wip/generalized-arrow: Internal things (1f0ffda)

[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/1f0ffda9e636bd78628619b81a59683cdf3ef20c/ghc

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

commit 1f0ffda9e636bd78628619b81a59683cdf3ef20c
Author: Ben Gamari <ben at smart-cactus.org>
Date:   Wed Mar 16 17:51:27 2016 +0100

    Internal things


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

1f0ffda9e636bd78628619b81a59683cdf3ef20c
 libraries/base/Data/Typeable/Internal.hs | 35 ++++++++++++++++++++++++++------
 libraries/base/Type/Reflection.hs        |  1 +
 2 files changed, 30 insertions(+), 6 deletions(-)

diff --git a/libraries/base/Data/Typeable/Internal.hs b/libraries/base/Data/Typeable/Internal.hs
index 3b84aba..dd66283 100644
--- a/libraries/base/Data/Typeable/Internal.hs
+++ b/libraries/base/Data/Typeable/Internal.hs
@@ -71,6 +71,8 @@ module Data.Typeable.Internal (
     mkTrCon, mkTrApp, mkTyCon, mkTyCon#,
     typeSymbolTypeRep, typeNatTypeRep,
 
+    debugShow,
+
     -- * Representations for primitive types
     trTYPE,
     trTYPE'PtrRepLifted,
@@ -317,6 +319,22 @@ typeRepXFingerprint (TypeRepX t) = typeRepFingerprint t
 
 ----------------- Showing TypeReps --------------------
 
+debugShow :: TypeRep a -> String
+debugShow rep
+  | Just HRefl <- rep `eqTypeRep` (typeRep :: TypeRep Type) = "Type"
+  | Just HRefl <- rep `eqTypeRep` (typeRep :: TypeRep RuntimeRep) = "RuntimeRep"
+  | (tc, _) <- splitApps rep
+  , isArrowTyCon tc = "Arrow"
+debugShow (TrApp _ f x) = "App ("++debugShow f++") ("++debugShow x++")"
+debugShow (TrTyCon _ x k)
+    | isArrowTyCon x = "Arrow"
+    | "->" <- show x = "Arrow #" ++ show ( tyConFingerprint x
+                                         , tyConFingerprint trArrowTyCon
+                                         , tyConFingerprint $ typeRepTyCon (typeRep :: TypeRep (->))
+                                         , typeRepTyCon (typeRep :: TypeRep (->))
+                                         )
+    | otherwise = show x++" :: "++debugShow k
+
 instance Show (TypeRep (a :: k)) where
   showsPrec _ rep
     | isListTyCon tc, [ty] <- tys =
@@ -325,16 +343,18 @@ instance Show (TypeRep (a :: k)) where
       showChar '(' . showArgs (showChar ',') tys . showChar ')'
     where (tc, tys) = splitApps rep
   showsPrec p (TrTyCon _ tycon _) = showsPrec p tycon
+  showsPrec _ (TrApp _ (TrTyCon _ tycon _) x)
+    | isArrowTyCon tycon =
+      shows x . showString " ->"
+
   showsPrec p (TrApp _ f x)
-    | Just HRefl <- f `eqTypeRep` (typeRep :: TypeRep (->)) =
-      shows x . showString " -> "
     | otherwise =
-      showsPrec p f . space . showParen need_parens (showsPrec 10 x)
+      showParen (p > 9) $
+      showsPrec p f .
+      space .
+      showsPrec 9 x
     where
       space = showChar ' '
-      need_parens = case x of
-                        TrApp {}   -> True
-                        TrTyCon {} -> False
 
 instance Show TypeRepX where
   showsPrec p (TypeRepX ty) = showsPrec p ty
@@ -346,6 +366,9 @@ splitApps = go []
     go xs (TrTyCon _ tc _) = (tc, xs)
     go xs (TrApp _ f x)    = go (TypeRepX x : xs) f
 
+isArrowTyCon :: TyCon -> Bool
+isArrowTyCon tc = tc == typeRepTyCon (typeRep :: TypeRep (->))
+
 isListTyCon :: TyCon -> Bool
 isListTyCon tc = tc == typeRepTyCon (typeRep :: TypeRep [Int])
 
diff --git a/libraries/base/Type/Reflection.hs b/libraries/base/Type/Reflection.hs
index 8057a2e..480e148 100644
--- a/libraries/base/Type/Reflection.hs
+++ b/libraries/base/Type/Reflection.hs
@@ -37,6 +37,7 @@ module Type.Reflection
     , I.tyConModule
     , I.tyConName
     , I.rnfTyCon
+    , I.debugShow
     ) where
 
 import qualified Data.Typeable.Internal as I