[commit: ghc] wip/tc/typeable-with-kinds: Checkpoint: generate explicit representations for all type constructors. (267d4d6)
git at git.haskell.org
git at git.haskell.org
Sat Mar 7 16:43:01 UTC 2015
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/tc/typeable-with-kinds
Link : http://ghc.haskell.org/trac/ghc/changeset/267d4d6e4a89b0e623a53e870260bd9fbbb1e3af/ghc
>---------------------------------------------------------------
commit 267d4d6e4a89b0e623a53e870260bd9fbbb1e3af
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.
>---------------------------------------------------------------
267d4d6e4a89b0e623a53e870260bd9fbbb1e3af
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 989f814..320ae62 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 a3d0099..69520eb 100644
--- a/compiler/prelude/PrelNames.hs
+++ b/compiler/prelude/PrelNames.hs
@@ -677,10 +677,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 04023b5..799ca53 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 57718b0..2db507c 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,
@@ -1298,6 +1299,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