[commit: ghc] typeable-with-kinds: Put it all together. (6b4240b)

[git at git.haskell.org]

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

On branch  : typeable-with-kinds
Link       : http://ghc.haskell.org/trac/ghc/changeset/6b4240b8cda4e8a463141a61d0664896ab1c6b4b/ghc

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

commit 6b4240b8cda4e8a463141a61d0664896ab1c6b4b
Author: Iavor S. Diatchki <diatchki at galois.com>
Date:   Tue Feb 10 11:50:22 2015 -0800

    Put it all together.


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

6b4240b8cda4e8a463141a61d0664896ab1c6b4b
 compiler/deSugar/DsBinds.hs      | 40 +++++++++++++++++++++++++++++++++++++---
 compiler/typecheck/TcInteract.hs |  5 +++++
 2 files changed, 42 insertions(+), 3 deletions(-)

diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs
index 11bd4b8..707a963 100644
--- a/compiler/deSugar/DsBinds.hs
+++ b/compiler/deSugar/DsBinds.hs
@@ -40,7 +40,8 @@ import Digraph
 
 import PrelNames
 import TysPrim ( mkProxyPrimTy )
-import TyCon      ( isTupleTyCon, tyConDataCons_maybe )
+import TyCon      ( isTupleTyCon, tyConDataCons_maybe
+                  , tyConName, isPromotedTyCon, isPromotedDataCon )
 import TcEvidence
 import TcType
 import Type
@@ -73,6 +74,7 @@ import Util
 import Control.Monad( when )
 import MonadUtils
 import Control.Monad(liftM)
+import Fingerprint(Fingerprint(..), fingerprintString)
 
 {-
 ************************************************************************
@@ -888,9 +890,12 @@ dsEvTypeable ev =
   do tyCl      <- dsLookupTyCon typeableClassName
      (ty, rep) <-
         case ev of
+
           EvTypeableTyCon tc ks ts ->
             do ctr       <- dsLookupGlobalId mkPolyTyConAppName
+               mkTyCon   <- dsLookupGlobalId mkTyConName
                typeRepTc <- dsLookupTyCon typeRepTyConName
+               dflags    <- getDynFlags
                let tyRepType = mkTyConApp typeRepTc []
                    mkRep cRep kReps tReps = mkApps (Var ctr)
                                                    [ cRep
@@ -903,11 +908,11 @@ dsEvTypeable ev =
                      case splitTyConApp_maybe k of
                        Nothing -> panic "dsEvTypeable: not a kind constructor"
                        Just (kc,ks) ->
-                         do kcRep <- undefined kc
+                         do kcRep <- tyConRep dflags mkTyCon kc
                             reps  <- mapM kindRep ks
                             return (mkRep kcRep [] reps)
 
-               tcRep     <- undefined tc
+               tcRep     <- tyConRep dflags mkTyCon tc
 
                kReps     <- mapM kindRep ks
                tReps     <- mapM (getRep tyCl) ts
@@ -957,6 +962,35 @@ dsEvTypeable ev =
                             (getTypeableCo tc ty)
     where proxyT = mkProxyPrimTy (typeKind ty) ty
 
+  -- This part could be cached
+  tyConRep dflags mkTyCon tc =
+    do pkgStr  <- mkStringExprFS pkg_fs
+       modStr  <- mkStringExprFS modl_fs
+       nameStr <- mkStringExprFS name_fs
+       return (mkApps (Var mkTyCon) [ int64 high, int64 low
+                                    , pkgStr, modStr, nameStr
+                                    ])
+    where
+    tycon_name                = tyConName tc
+    modl                      = nameModule tycon_name
+    pkg                       = modulePackageKey modl
+
+    modl_fs                   = moduleNameFS (moduleName modl)
+    pkg_fs                    = packageKeyFS pkg
+    name_fs                   = occNameFS (nameOccName tycon_name)
+    hash_name_fs
+      | isPromotedTyCon tc    = appendFS (mkFastString "$k") name_fs
+      | isPromotedDataCon tc  = appendFS (mkFastString "$c") name_fs
+      | otherwise             = name_fs
+
+    hashThis = unwords $ map unpackFS [pkg_fs, modl_fs, hash_name_fs]
+    Fingerprint high low = fingerprintString hashThis
+
+    int64
+      | wORD_SIZE dflags == 4 = mkWord64LitWord64
+      | otherwise             = mkWordLit dflags . fromIntegral
+
+
 
 
 
diff --git a/compiler/typecheck/TcInteract.hs b/compiler/typecheck/TcInteract.hs
index 7293f57..1a01441 100644
--- a/compiler/typecheck/TcInteract.hs
+++ b/compiler/typecheck/TcInteract.hs
@@ -1639,6 +1639,11 @@ matchClassInst _ clas [ ty ] _
     = panicTcS (text "Unexpected evidence for" <+> ppr (className clas)
                      $$ vcat (map (ppr . idType) (classMethods clas)))
 
+
+
+matchClassInst inerts clas [k,t] loc
+  | className clas == typeableClassName = matchTypeableClass clas k t loc
+
 matchClassInst inerts clas tys loc
    = do { dflags <- getDynFlags
         ; tclvl <- getTcLevel