[commit: ghc] wip/ttypeable: Getting there (a52df0a)
git at git.haskell.org
git at git.haskell.org
Sun Jan 29 20:20:42 UTC 2017
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/ttypeable
Link : http://ghc.haskell.org/trac/ghc/changeset/a52df0aa973eb4f711f84f9d0d48391c5f478b8a/ghc
>---------------------------------------------------------------
commit a52df0aa973eb4f711f84f9d0d48391c5f478b8a
Author: Ben Gamari <ben at smart-cactus.org>
Date: Wed Nov 30 17:41:31 2016 -0500
Getting there
>---------------------------------------------------------------
a52df0aa973eb4f711f84f9d0d48391c5f478b8a
compiler/typecheck/TcTypeable.hs | 25 ++++++++++--
libraries/base/Data/Typeable/Internal.hs | 13 ++++--
libraries/base/Type/Reflection/Unsafe.hs | 2 +
libraries/ghci/GHCi/TH/Binary.hs | 69 ++++++++++++++++++++++++++++++--
4 files changed, 98 insertions(+), 11 deletions(-)
diff --git a/compiler/typecheck/TcTypeable.hs b/compiler/typecheck/TcTypeable.hs
index e057934..829d172 100644
--- a/compiler/typecheck/TcTypeable.hs
+++ b/compiler/typecheck/TcTypeable.hs
@@ -178,6 +178,17 @@ mkTypeableTyConBinds tycons
; stuff <- collect_stuff mod mod_expr
; let all_tycons = [ tc' | tc <- tycons, tc' <- tc : tyConATs tc ]
-- We need type representations for any associated types
+
+ -- First extend the type environment with all of the bindings which we
+ -- are going to produce since we may need to refer to them while
+ -- generating the RHSs
+ ; let tycon_rep_bndrs :: [Id]
+ tycon_rep_bndrs = [ rep_id
+ | tc <- all_tycons
+ , Just rep_id <- pure $ tyConRepId stuff tc
+ ]
+ ; gbl_env <- tcExtendGlobalValEnv tycon_rep_bndrs getGblEnv
+
; foldlM (mk_typeable_binds stuff) gbl_env all_tycons }
-- | Generate bindings for the type representation of a wired-in 'TyCon's defined
@@ -297,15 +308,21 @@ mk_typeable_binds stuff gbl_env tycon
(tyConDataCons tycon)
typecheckAndAddBindings gbl_env' $ unionManyBags promoted_reps
+-- | The 'Id' of the @TyCon@ binding for a type constructor.
+tyConRepId :: TypeableStuff -> TyCon -> Maybe Id
+tyConRepId (Stuff {..}) tycon
+ = mkRepId <$> tyConRepName_maybe tycon
+ where
+ mkRepId rep_name = mkExportedVanillaId rep_name (mkTyConTy trTyConTyCon)
+
-- | Make typeable bindings for the given 'TyCon'.
mkTyConRepBinds :: TypeableStuff -> TyCon -> TcRn (LHsBinds Id)
mkTyConRepBinds stuff@(Stuff {..}) tycon
= pprTrace "mkTyConRepBinds" (ppr tycon) $
- case tyConRepName_maybe tycon of
- Just rep_name -> do
+ case tyConRepId stuff tycon of
+ Just tycon_rep_id -> do
tycon_rep_rhs <- mkTyConRepTyConRHS stuff tycon
- let tycon_rep_id = mkExportedVanillaId rep_name (mkTyConTy trTyConTyCon)
- tycon_rep = mkVarBind tycon_rep_id tycon_rep_rhs
+ let tycon_rep = mkVarBind tycon_rep_id tycon_rep_rhs
return $ unitBag tycon_rep
_ -> return emptyBag
diff --git a/libraries/base/Data/Typeable/Internal.hs b/libraries/base/Data/Typeable/Internal.hs
index db1ccb8..773d2ca 100644
--- a/libraries/base/Data/Typeable/Internal.hs
+++ b/libraries/base/Data/Typeable/Internal.hs
@@ -43,7 +43,8 @@ module Data.Typeable.Internal (
-- * TyCon
TyCon, -- Abstract
- tyConPackage, tyConModule, tyConName,
+ tyConPackage, tyConModule, tyConName, tyConKindVars, tyConKindRep,
+ KindRep(..),
rnfTyCon,
-- * TypeRep
@@ -117,6 +118,12 @@ tyConFingerprint :: TyCon -> Fingerprint
tyConFingerprint (TyCon hi lo _ _ _ _)
= Fingerprint (W64# hi) (W64# lo)
+tyConKindVars :: TyCon -> Int
+tyConKindVars (TyCon _ _ _ _ n _) = I# n
+
+tyConKindRep :: TyCon -> KindRep
+tyConKindRep (TyCon _ _ _ _ _ k) = k
+
-- | Helper to fully evaluate 'TyCon' for use as @NFData(rnf)@ implementation
--
-- @since 4.8.0.0
@@ -202,8 +209,8 @@ instance Ord SomeTypeRep where
SomeTypeRep a `compare` SomeTypeRep b =
typeRepFingerprint a `compare` typeRepFingerprint b
-pattern TRFun :: forall fun. ()
- => forall (r1 :: RuntimeRep) (r2 :: RuntimeRep) (arg :: TYPE r1) (res :: TYPE r2). (fun ~ (arg -> res))
+pattern TRFun :: forall k (fun :: k). ()
+ => forall (r1 :: RuntimeRep) (r2 :: RuntimeRep) (arg :: TYPE r1) (res :: TYPE r2). (k ~ Type, fun ~~ (arg -> res))
=> TypeRep arg
-> TypeRep res
-> TypeRep fun
diff --git a/libraries/base/Type/Reflection/Unsafe.hs b/libraries/base/Type/Reflection/Unsafe.hs
index d1897f3..b9f71be 100644
--- a/libraries/base/Type/Reflection/Unsafe.hs
+++ b/libraries/base/Type/Reflection/Unsafe.hs
@@ -14,6 +14,8 @@
-----------------------------------------------------------------------------
module Type.Reflection.Unsafe (
+ tyConKindRep, tyConKindVars,
+ KindRep(..),
mkTrCon, mkTrApp, mkTyCon
) where
diff --git a/libraries/ghci/GHCi/TH/Binary.hs b/libraries/ghci/GHCi/TH/Binary.hs
index 617cb7c..13f62a6 100644
--- a/libraries/ghci/GHCi/TH/Binary.hs
+++ b/libraries/ghci/GHCi/TH/Binary.hs
@@ -14,7 +14,7 @@ import qualified Data.ByteString as B
import Type.Reflection
import Type.Reflection.Unsafe
import Data.Kind (Type)
-import GHC.Exts (TYPE, RuntimeRep)
+import GHC.Exts (TYPE, RuntimeRep(..), VecCount, VecElem)
#else
import Data.Typeable
#endif
@@ -80,9 +80,70 @@ instance Binary TH.PatSynArgs
-- We need Binary TypeRep for serializing annotations
#if MIN_VERSION_base(4,10,0)
+instance Binary VecCount where
+ put = putWord8 . fromIntegral . fromEnum
+ get = toEnum . fromIntegral <$> getWord8
+
+instance Binary VecElem where
+ put = putWord8 . fromIntegral . fromEnum
+ get = toEnum . fromIntegral <$> getWord8
+
+instance Binary RuntimeRep where
+ put (VecRep a b) = putWord8 0 >> put a >> put b
+ put PtrRepLifted = putWord8 1
+ put PtrRepUnlifted = putWord8 2
+ put VoidRep = putWord8 3
+ put IntRep = putWord8 4
+ put WordRep = putWord8 5
+ put Int64Rep = putWord8 6
+ put Word64Rep = putWord8 7
+ put AddrRep = putWord8 8
+ put FloatRep = putWord8 9
+ put DoubleRep = putWord8 10
+ put UnboxedTupleRep = putWord8 11
+ put UnboxedSumRep = putWord8 12
+
+ get = do
+ tag <- getWord8
+ case tag of
+ 0 -> VecRep <$> get <*> get
+ 1 -> pure PtrRepLifted
+ 2 -> pure PtrRepUnlifted
+ 3 -> pure VoidRep
+ 4 -> pure IntRep
+ 5 -> pure WordRep
+ 6 -> pure Int64Rep
+ 7 -> pure Word64Rep
+ 8 -> pure AddrRep
+ 9 -> pure FloatRep
+ 10 -> pure DoubleRep
+ 11 -> pure UnboxedTupleRep
+ 12 -> pure UnboxedSumRep
+
instance Binary TyCon where
- put tc = put (tyConPackage tc) >> put (tyConModule tc) >> put (tyConName tc)
- get = mkTyCon <$> get <*> get <*> get
+ put tc = do
+ put (tyConPackage tc)
+ put (tyConModule tc)
+ put (tyConName tc)
+ put (tyConKindVars tc)
+ put (tyConKindRep tc)
+ get = mkTyCon <$> get <*> get <*> get <*> get <*> get
+
+instance Binary KindRep where
+ put (KindRepTyConApp tc k) = putWord8 0 >> put tc >> put k
+ put (KindRepVar bndr) = putWord8 1 >> put bndr
+ put (KindRepApp a b) = putWord8 2 >> put a >> put b
+ put (KindRepFun a b) = putWord8 3 >> put a >> put b
+ put (KindRepTYPE r) = putWord8 4 >> put r
+
+ get = do
+ tag <- getWord8
+ case tag of
+ 0 -> KindRepTyConApp <$> get <*> get
+ 1 -> KindRepVar <$> get
+ 2 -> KindRepApp <$> get <*> get
+ 3 -> KindRepFun <$> get <*> get
+ 4 -> KindRepTYPE <$> get
putTypeRep :: TypeRep a -> Put
-- Special handling for TYPE, (->), and RuntimeRep due to recursive kind
@@ -120,7 +181,7 @@ getSomeTypeRep = do
3 -> do con <- get :: Get TyCon
SomeTypeRep rep_k <- getSomeTypeRep
ks <- get :: Get [SomeTypeRep]
- return $ mkTrCon con ks
+ return $ SomeTypeRep $ mkTrCon con ks
4 -> do SomeTypeRep f <- getSomeTypeRep
SomeTypeRep x <- getSomeTypeRep
More information about the ghc-commits
mailing list