[commit: ghc] wip/ttypeable: TcTypeable: Fix it (7c41111)

[git at git.haskell.org]

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

On branch  : wip/ttypeable
Link       : http://ghc.haskell.org/trac/ghc/changeset/7c411111ced82df14bc5791667037013474a349f/ghc

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

commit 7c411111ced82df14bc5791667037013474a349f
Author: Ben Gamari <ben at smart-cactus.org>
Date:   Mon Dec 19 12:40:09 2016 -0500

    TcTypeable: Fix it


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

7c411111ced82df14bc5791667037013474a349f
 compiler/typecheck/TcTypeable.hs | 12 ++++++------
 compiler/types/Kind.hs           | 13 ++++++++++++-
 compiler/types/Type.hs-boot      |  2 ++
 3 files changed, 20 insertions(+), 7 deletions(-)

diff --git a/compiler/typecheck/TcTypeable.hs b/compiler/typecheck/TcTypeable.hs
index 829d172..722b22f 100644
--- a/compiler/typecheck/TcTypeable.hs
+++ b/compiler/typecheck/TcTypeable.hs
@@ -20,11 +20,10 @@ import TysPrim ( primTyCons, primTypeableTyCons )
 import TysWiredIn ( tupleTyCon )
 import Id
 import Type
-import Kind ( isConstraintKind )
+import Kind ( isTYPEApp )
 import TyCon
 import DataCon
-import Name ( getOccName, nameOccName )
-import Literal ( mkMachInt )
+import Name ( getOccName )
 import OccName
 import Module
 import NameEnv
@@ -350,7 +349,7 @@ mkTyConRepTyConRHS stuff@(Stuff {..}) tycon
     Fingerprint high low = fingerprintString hashThis
 
     int :: Int -> HsLit
-    int n = HsIntPrim (show n) (toInteger n)
+    int n = HsIntPrim (SourceText $ show n) (toInteger n)
 
     word64 :: Word64 -> HsLit
     word64
@@ -438,7 +437,8 @@ mkTyConKindRep (Stuff {..}) tycon = do
            t2' <- go bndrs t2
            return $ nlHsApps (dataConWrapId kindRepAppDataCon) [t1', t2']
     go _ ty | Just rr <- isTYPEApp ty
-      = pprTrace "mkTyConKeyRepBinds(TYPE)" (ppr rr) $ return $ nlHsApps (dataConWrapId kindRepTYPEDataCon) [rr]
+      = pprTrace "mkTyConKeyRepBinds(TYPE)" (ppr rr) $
+        return $ nlHsApps (dataConWrapId kindRepTYPEDataCon) [nlHsVar $ dataConWrapId rr]
     go bndrs (TyConApp tycon tys)
       | Just rep_name <- tyConRepName_maybe tycon
       = do rep_id <- lookupId rep_name
@@ -449,7 +449,7 @@ mkTyConKindRep (Stuff {..}) tycon = do
                              ]
       | otherwise
       = pprPanic "UnrepresentableThingy" empty
-    go bndrs (ForAllTy (TvBndr var _) ty)
+    go _bndrs (ForAllTy (TvBndr var _) ty)
       = pprPanic "mkTyConKeyRepBinds(forall)" (ppr var $$ ppr ty)
     --  = let bndrs' = extendVarEnv (mapVarEnv (+1) bndrs) var 0
     --    in go bndrs' ty
diff --git a/compiler/types/Kind.hs b/compiler/types/Kind.hs
index b67eec0..6b9567e 100644
--- a/compiler/types/Kind.hs
+++ b/compiler/types/Kind.hs
@@ -8,6 +8,7 @@ module Kind (
         -- ** Predicates on Kinds
         isLiftedTypeKind, isUnliftedTypeKind,
         isConstraintKind,
+        isTYPEApp,
         returnsTyCon, returnsConstraintKind,
         isConstraintKindCon,
         okArrowArgKind, okArrowResultKind,
@@ -19,7 +20,8 @@ module Kind (
 
 #include "HsVersions.h"
 
-import {-# SOURCE #-} Type       ( typeKind, coreViewOneStarKind )
+import {-# SOURCE #-} Type       ( typeKind, coreViewOneStarKind, splitTyConApp_maybe )
+import {-# SOURCE #-} DataCon ( DataCon )
 
 import TyCoRep
 import TyCon
@@ -68,6 +70,15 @@ isConstraintKindCon   tc = tyConUnique tc == constraintKindTyConKey
 isConstraintKind (TyConApp tc _) = isConstraintKindCon tc
 isConstraintKind _               = False
 
+isTYPEApp :: Kind -> Maybe DataCon
+isTYPEApp (TyConApp tc args)
+  | tc `hasKey` tYPETyConKey
+  , [arg] <- args
+  , Just (tc, []) <- splitTyConApp_maybe arg
+  , Just dc <- isPromotedDataCon_maybe tc
+  = Just dc
+isTYPEApp _ = Nothing
+
 -- | Does the given type "end" in the given tycon? For example @k -> [a] -> *@
 -- ends in @*@ and @Maybe a -> [a]@ ends in @[]@.
 returnsTyCon :: Unique -> Type -> Bool
diff --git a/compiler/types/Type.hs-boot b/compiler/types/Type.hs-boot
index 9436d19..5456dd7 100644
--- a/compiler/types/Type.hs-boot
+++ b/compiler/types/Type.hs-boot
@@ -19,3 +19,5 @@ partitionInvisibles :: TyCon -> (a -> Type) -> [a] -> ([a], [a])
 coreView :: Type -> Maybe Type
 
 tyCoVarsOfTypesWellScoped :: [Type] -> [TyVar]
+
+splitTyConApp_maybe :: Type -> Maybe (TyCon, [Type])
\ No newline at end of file