[commit: ghc] typeable-with-kinds: Construct basic dictionary shapes. (7fa6e0e)

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

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

commit 7fa6e0e2ee07b6e899ab5597c7a306cbff3140dc
Author: Iavor S. Diatchki <diatchki at galois.com>
Date:   Tue Feb 10 11:05:25 2015 -0800

    Construct basic dictionary shapes.


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

7fa6e0e2ee07b6e899ab5597c7a306cbff3140dc
 compiler/deSugar/DsBinds.hs   | 40 +++++++++++++++++++++++++---------------
 compiler/prelude/PrelNames.hs |  7 +++++++
 2 files changed, 32 insertions(+), 15 deletions(-)

diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs
index 3fb42bf..92d2e7f 100644
--- a/compiler/deSugar/DsBinds.hs
+++ b/compiler/deSugar/DsBinds.hs
@@ -885,26 +885,39 @@ dsEvTerm (EvTypeable ev) = dsEvTypeable ev
 
 dsEvTypeable :: EvTypeable -> DsM CoreExpr
 dsEvTypeable ev =
-  do tyCl     <- dsLookupTyCon typeableClassName
-     (rep,ty) <-
+  do tyCl      <- dsLookupTyCon typeableClassName
+     (ty, rep) <-
         case ev of
           EvTypeableTyCon tc ks ts ->
             do let ty = mkTyConApp tc (ks ++ map snd ts)
-               kReps <- mapM kindRep ks
-               tReps <- mapM (getRep tyCl) ts
-               return (tyConRep tc kReps tReps, ty)
+               tcRep     <- undefined
+               kReps     <- mapM kindRep ks
+               tReps     <- mapM (getRep tyCl) ts
+               ctr       <- dsLookupGlobalId mkPolyTyConAppName
+               typeRepTc <- dsLookupTyCon typeRepTyConName
+               let tyRepType = mkTyConApp typeRepTc []
+               return (ty, mkApps (Var ctr)
+                              [ tcRep
+                              , mkListExpr tyRepType kReps
+                              , mkListExpr tyRepType tReps
+                              ])
 
           EvTypeableTyApp t1 t2 ->
             do let ty = mkAppTy (snd t1) (snd t2)
-               e1 <- getRep tyCl t1
-               e2 <- getRep tyCl t2
-               return (tyAppRep e1 e2, ty)
+               e1  <- getRep tyCl t1
+               e2  <- getRep tyCl t2
+               ctr <- dsLookupGlobalId mkAppTyName
+               return (ty, mkApps (Var ctr) [ e1, e2 ])
 
           EvTypeableTyLit ty ->
-            case (isNumLitTy ty, isStrLitTy ty) of
-              (Just n, _) -> return (litRep (show n), ty)
-              (_, Just n) -> return (litRep (show n), ty)
-              _           -> panic "dsEvTypeable: malformed TyLit evidence"
+            do str <- case (isNumLitTy ty, isStrLitTy ty) of
+                        (Just n, _) -> return (show n)
+                        (_, Just n) -> return (show n)
+                        _ -> panic "dsEvTypeable: malformed TyLit evidence"
+               ctr <- dsLookupGlobalId typeLitTypeRepName
+               tag <- mkStringExpr str
+               return (ty, mkApps (Var ctr) [ tag ])
+
 
      return (mkDict tyCl ty rep)
 
@@ -929,9 +942,6 @@ dsEvTypeable ev =
     where proxyT = mkProxyPrimTy (typeKind ty) ty
 
   kindRep k               = undefined
-  tyConRep tc kReps tReps = undefined
-  tyAppRep t1 t2          = undefined
-  litRep str              = undefined
 
 
 
diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs
index 34a696b..d440b43 100644
--- a/compiler/prelude/PrelNames.hs
+++ b/compiler/prelude/PrelNames.hs
@@ -216,6 +216,7 @@ basicKnownKeyNames
 
         -- Typeable
         typeableClassName,
+        typeRepTyConName,
         mkTyConName,
         mkPolyTyConAppName,
         mkAppTyName,
@@ -1040,12 +1041,14 @@ ixClassName = clsQual gHC_ARR (fsLit "Ix") ixClassKey
 
 -- Class Typeable, and functions for constructing `Typeable` dictionaries
 typeableClassName
+  , typeRepTyConName
   , mkTyConName
   , mkPolyTyConAppName
   , mkAppTyName
   , typeLitTypeRepName
   :: Name
 typeableClassName     = clsQual tYPEABLE_INTERNAL (fsLit "Typeable")       typeableClassKey
+typeRepTyConName      = tcQual  tYPEABLE_INTERNAL (fsLit "TypeRep")        typeRepTyConKey
 mkTyConName           = varQual tYPEABLE_INTERNAL (fsLit "mkTyCon")        mkTyConKey
 mkPolyTyConAppName    = varQual tYPEABLE_INTERNAL (fsLit "mkPolyTyConApp") mkPolyTyConAppKey
 mkAppTyName           = varQual tYPEABLE_INTERNAL (fsLit "mkAppTy")        mkAppTyKey
@@ -1557,6 +1560,10 @@ staticPtrInfoTyConKey = mkPreludeTyConUnique 181
 callStackTyConKey :: Unique
 callStackTyConKey = mkPreludeTyConUnique 182
 
+-- Typeables
+typeRepTyConKey :: Unique
+typeRepTyConKey = mkPreludeTyConUnique 183
+
 ---------------- Template Haskell -------------------
 --      USES TyConUniques 200-299
 -----------------------------------------------------