[commit: ghc] typeable-with-kinds: Checkpoint: generate explicit representations for all type constructors. (246d2c9)

git at git.haskell.org git at git.haskell.org
Mon Feb 2 04:35:25 UTC 2015


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

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

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

commit 246d2c925d7ffe6a5b61fbdce7372178bf02c217
Author: Iavor S. Diatchki <iavor.diatchki at gmail.com>
Date:   Sun Feb 1 20:33:41 2015 -0800

    Checkpoint: generate explicit representations for all type constructors.
    
    This is probably not quite right yet for the following reasons:
      - The call to generate tycons is called from withing the code that
        derives instances.  This is incorrect, as nothing is generated when
        there is nothing to derive.
    
      - Currently, the representation of the tycon `Test`, its promoted version
        (i.e., kind) `Test`, and a promoted *data* constructor, also `Test`,
        end up having the same representation.   Technically, this might not
        matter as these all have different kinds/sorts, however it is odd,
        and it seems safer to distinguish them.


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

246d2c925d7ffe6a5b61fbdce7372178bf02c217
 compiler/basicTypes/OccName.hs   |  6 ++++
 compiler/prelude/PrelNames.hs    |  3 +-
 compiler/typecheck/TcDeriv.hs    | 74 ++++++++++++++++++++++++++++++++++++++--
 compiler/typecheck/TcGenDeriv.hs | 38 +++++++++++++++++++++
 4 files changed, 118 insertions(+), 3 deletions(-)

diff --git a/compiler/basicTypes/OccName.hs b/compiler/basicTypes/OccName.hs
index efa871d..03f11e6 100644
--- a/compiler/basicTypes/OccName.hs
+++ b/compiler/basicTypes/OccName.hs
@@ -72,6 +72,8 @@ module OccName (
         mkPReprTyConOcc,
         mkPADFunOcc,
 
+        mkTyConRepOcc,
+
         -- ** Deconstruction
         occNameFS, occNameString, occNameSpace,
 
@@ -607,6 +609,7 @@ mkDataConWrapperOcc, mkWorkerOcc,
         mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, mkNewTyCoOcc,
         mkInstTyCoOcc, mkEqPredCoOcc, mkClassOpAuxOcc,
         mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc
+
    :: OccName -> OccName
 
 -- These derived variables have a prefix that no Haskell value could have
@@ -658,6 +661,9 @@ mkGenRCo = mk_simple_deriv tcName "CoRep_"
 mkDataTOcc = mk_simple_deriv varName  "$t"
 mkDataCOcc = mk_simple_deriv varName  "$c"
 
+mkTyConRepOcc :: Maybe String -> OccName -> OccName
+mkTyConRepOcc = mk_simple_deriv_with varName "$tcr"
+
 -- Vectorisation
 mkVectOcc, mkVectTyConOcc, mkVectDataConOcc, mkVectIsoOcc,
  mkPADFunOcc,      mkPReprTyConOcc,
diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs
index 3b40385..5e43b56 100644
--- a/compiler/prelude/PrelNames.hs
+++ b/compiler/prelude/PrelNames.hs
@@ -676,10 +676,11 @@ showString_RDR          = varQual_RDR gHC_SHOW (fsLit "showString")
 showSpace_RDR           = varQual_RDR gHC_SHOW (fsLit "showSpace")
 showParen_RDR           = varQual_RDR gHC_SHOW (fsLit "showParen")
 
-typeRep_RDR, mkTyCon_RDR, mkTyConApp_RDR :: RdrName
+typeRep_RDR, mkTyCon_RDR, mkTyConApp_RDR, typeable_TyCon_RDR :: RdrName
 typeRep_RDR       = varQual_RDR tYPEABLE_INTERNAL    (fsLit "typeRep#")
 mkTyCon_RDR       = varQual_RDR tYPEABLE_INTERNAL    (fsLit "mkTyCon")
 mkTyConApp_RDR    = varQual_RDR tYPEABLE_INTERNAL    (fsLit "mkTyConApp")
+typeable_TyCon_RDR = tcQual_RDR tYPEABLE_INTERNAL    (fsLit "TyCon")
 
 undefined_RDR :: RdrName
 undefined_RDR = varQual_RDR gHC_ERR (fsLit "undefined")
diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs
index 3d980e2..91104f8 100644
--- a/compiler/typecheck/TcDeriv.hs
+++ b/compiler/typecheck/TcDeriv.hs
@@ -382,10 +382,14 @@ tcDeriving tycl_decls inst_decls deriv_decls
         ; let (binds, newTyCons, famInsts, extraInstances) =
                 genAuxBinds loc (unionManyBags (auxDerivStuff : deriv_stuff))
 
+        ; dflags <- getDynFlags
+        ; tcRepBinds <- genTypeableTyConReps dflags
+                          tycl_decls inst_decls
+
         ; (inst_info, rn_binds, rn_dus) <-
-            renameDeriv is_boot (inst_infos ++ (bagToList extraInstances)) binds
+            renameDeriv is_boot (inst_infos ++ (bagToList extraInstances))
+                                            (unionBags tcRepBinds binds)
 
-        ; dflags <- getDynFlags
         ; unless (isEmptyBag inst_info) $
              liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
                         (ddump_deriving inst_info rn_binds newTyCons famInsts))
@@ -414,6 +418,72 @@ tcDeriving tycl_decls inst_decls deriv_decls
 
     hangP s x = text "" $$ hang (ptext (sLit s)) 2 x
 
+genTypeableTyConReps :: DynFlags ->
+                        [LTyClDecl Name] ->
+                        [LInstDecl Name] ->
+                        TcM (Bag (LHsBind RdrName, LSig RdrName))
+genTypeableTyConReps dflags decls insts =
+  do tcs1 <- mapM tyConsFromDecl decls
+     tcs2 <- mapM tyConsFromInst insts
+     return $ listToBag [ genTypeableTyConRep dflags loc tc
+                                          | (loc,tc) <- concat (tcs1 ++ tcs2) ]
+  where
+
+  tyConFromDataCon (L l n) = do dc <- tcLookupDataCon n
+                                return (do tc <- promoteDataCon_maybe dc
+                                           return (l,tc))
+
+  -- Promoted data constructors from a data declaration, or
+  -- a data-family instance.
+  tyConsFromDataRHS = fmap catMaybes
+                    . mapM tyConFromDataCon
+                    . concatMap (con_names . unLoc)
+                    . dd_cons
+
+  -- Tycons from a data-family declaration; not promotable.
+  tyConFromDataFamDecl FamilyDecl { fdLName = L loc name } =
+    do tc <- tcLookupTyCon name
+       return (loc,tc)
+
+
+  -- tycons from a type-level declaration
+  tyConsFromDecl (L _ d)
+
+    -- data or newtype declaration: promoted tycon, tycon, promoted ctrs.
+    | isDataDecl d =
+      do let L loc name = tcdLName d
+         tc           <- tcLookupTyCon name
+         promotedCtrs <- tyConsFromDataRHS (tcdDataDefn d)
+         let tyCons = (loc,tc) : promotedCtrs
+
+         return (case promotableTyCon_maybe tc of
+                   Nothing -> tyCons
+                   Just kc -> (loc,kc) : tyCons)
+
+    -- data family: just the type constructor;  these are not promotable.
+    | isDataFamilyDecl d =
+      do res <- tyConFromDataFamDecl (tcdFam d)
+         return [res]
+
+    -- class: the type constructors of associated data families
+    | isClassDecl d =
+      let isData FamilyDecl { fdInfo = DataFamily } = True
+          isData _ = False
+
+      in mapM tyConFromDataFamDecl (filter isData (map unLoc (tcdATs d)))
+
+    | otherwise = return []
+
+
+  tyConsFromInst (L _ d) =
+    case d of
+      ClsInstD ci      -> fmap concat
+                        $ mapM (tyConsFromDataRHS . dfid_defn . unLoc)
+                        $ cid_datafam_insts ci
+      DataFamInstD dfi -> tyConsFromDataRHS (dfid_defn dfi)
+      TyFamInstD {}    -> return []
+
+
 -- Prints the representable type family instance
 pprRepTy :: FamInst -> SDoc
 pprRepTy fi@(FamInst { fi_tys = lhs })
diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs
index c928108..d8a6d8e 100644
--- a/compiler/typecheck/TcGenDeriv.hs
+++ b/compiler/typecheck/TcGenDeriv.hs
@@ -20,6 +20,7 @@ module TcGenDeriv (
 
         canDeriveAnyClass,
         genDerivedBinds,
+        genTypeableTyConRep,
         FFoldType(..), functorLikeTraverse,
         deepSubtypesContaining, foldDataConArgs,
         mkCoerceClassMethEqn,
@@ -1277,6 +1278,43 @@ gen_Typeable_binds dflags loc tycon
       | wORD_SIZE dflags == 4 = HsWord64Prim "" . fromIntegral
       | otherwise             = HsWordPrim "" . fromIntegral
 
+genTypeableTyConRep :: DynFlags -> SrcSpan -> TyCon ->
+                                (LHsBind RdrName, LSig RdrName)
+genTypeableTyConRep dflags loc tycon =
+      ( mk_easy_FunBind loc rep_name [] tycon_rep
+      , L loc (TypeSig [L loc rep_name] sig_ty PlaceHolder)
+      )
+  where
+    rep_name   = mk_tc_deriv_name tycon (mkTyConRepOcc suf)
+    suf        = if isPromotedTyCon tycon then Just "k" else
+                 if isPromotedDataCon tycon then Just "c" else Nothing
+
+    sig_ty     = nlHsTyVar typeable_TyCon_RDR
+
+    tycon_name = tyConName tycon
+    modl       = nameModule tycon_name
+    pkg        = modulePackageKey modl
+
+    modl_fs    = moduleNameFS (moduleName modl)
+    pkg_fs     = packageKeyFS pkg
+    name_fs    = occNameFS (nameOccName tycon_name)
+
+    tycon_rep = nlHsApps mkTyCon_RDR
+                    (map nlHsLit [int64 high,
+                                  int64 low,
+                                  HsString "" pkg_fs,
+                                  HsString "" modl_fs,
+                                  HsString "" name_fs])
+
+    hashThis = unwords $ map unpackFS [pkg_fs, modl_fs, name_fs]
+    Fingerprint high low = fingerprintString hashThis
+
+    int64
+      | wORD_SIZE dflags == 4 = HsWord64Prim "" . fromIntegral
+      | otherwise             = HsWordPrim "" . fromIntegral
+
+
+
 {-
 ************************************************************************
 *                                                                      *



More information about the ghc-commits mailing list