1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
|
{-# LANGUAGE CPP #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE GADTs #-}
{-# OPTIONS_GHC -O2 -funbox-strict-fields #-}
{-# OPTIONS_GHC -Wno-orphans #-}
#if MIN_VERSION_base(4,16,0)
#define HAS_TYPELITCHAR
#endif
-- | Orphan Binary instances for Data.Typeable stuff
module GHC.Utils.Binary.Typeable
( getSomeTypeRep
)
where
#include "HsVersions.h"
import GHC.Prelude
import GHC.Utils.Binary
import GHC.Exts (TYPE, RuntimeRep(..), VecCount(..), VecElem(..))
#if __GLASGOW_HASKELL__ >= 901
import GHC.Exts (Levity(Lifted, Unlifted))
#endif
import GHC.Serialized
import Foreign
import Type.Reflection
import Type.Reflection.Unsafe
import Data.Kind (Type)
instance Binary TyCon where
put_ bh tc = do
put_ bh (tyConPackage tc)
put_ bh (tyConModule tc)
put_ bh (tyConName tc)
put_ bh (tyConKindArgs tc)
put_ bh (tyConKindRep tc)
get bh =
mkTyCon <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh
getSomeTypeRep :: BinHandle -> IO SomeTypeRep
getSomeTypeRep bh = do
tag <- get bh :: IO Word8
case tag of
0 -> return $ SomeTypeRep (typeRep :: TypeRep Type)
1 -> do con <- get bh :: IO TyCon
ks <- get bh :: IO [SomeTypeRep]
return $ SomeTypeRep $ mkTrCon con ks
2 -> do SomeTypeRep f <- getSomeTypeRep bh
SomeTypeRep x <- getSomeTypeRep bh
case typeRepKind f of
Fun arg res ->
case arg `eqTypeRep` typeRepKind x of
Just HRefl ->
case typeRepKind res `eqTypeRep` (typeRep :: TypeRep Type) of
Just HRefl -> return $ SomeTypeRep $ mkTrApp f x
_ -> failure "Kind mismatch in type application" []
_ -> failure "Kind mismatch in type application"
[ " Found argument of kind: " ++ show (typeRepKind x)
, " Where the constructor: " ++ show f
, " Expects kind: " ++ show arg
]
_ -> failure "Applied non-arrow"
[ " Applied type: " ++ show f
, " To argument: " ++ show x
]
3 -> do SomeTypeRep arg <- getSomeTypeRep bh
SomeTypeRep res <- getSomeTypeRep bh
if
| App argkcon _ <- typeRepKind arg
, App reskcon _ <- typeRepKind res
, Just HRefl <- argkcon `eqTypeRep` tYPErep
, Just HRefl <- reskcon `eqTypeRep` tYPErep
-> return $ SomeTypeRep $ Fun arg res
| otherwise -> failure "Kind mismatch" []
_ -> failure "Invalid SomeTypeRep" []
where
tYPErep :: TypeRep TYPE
tYPErep = typeRep
failure description info =
fail $ unlines $ [ "Binary.getSomeTypeRep: "++description ]
++ map (" "++) info
instance Binary SomeTypeRep where
put_ bh (SomeTypeRep rep) = putTypeRep bh rep
get = getSomeTypeRep
instance Typeable a => Binary (TypeRep (a :: k)) where
put_ = putTypeRep
get bh = do
SomeTypeRep rep <- getSomeTypeRep bh
case rep `eqTypeRep` expected of
Just HRefl -> pure rep
Nothing -> fail $ unlines
[ "Binary: Type mismatch"
, " Deserialized type: " ++ show rep
, " Expected type: " ++ show expected
]
where expected = typeRep :: TypeRep a
instance Binary VecCount where
put_ bh = putByte bh . fromIntegral . fromEnum
get bh = toEnum . fromIntegral <$> getByte bh
instance Binary VecElem where
put_ bh = putByte bh . fromIntegral . fromEnum
get bh = toEnum . fromIntegral <$> getByte bh
instance Binary RuntimeRep where
put_ bh (VecRep a b) = putByte bh 0 >> put_ bh a >> put_ bh b
put_ bh (TupleRep reps) = putByte bh 1 >> put_ bh reps
put_ bh (SumRep reps) = putByte bh 2 >> put_ bh reps
#if __GLASGOW_HASKELL__ >= 901
put_ bh (BoxedRep Lifted) = putByte bh 3
put_ bh (BoxedRep Unlifted) = putByte bh 4
#else
put_ bh LiftedRep = putByte bh 3
put_ bh UnliftedRep = putByte bh 4
#endif
put_ bh IntRep = putByte bh 5
put_ bh WordRep = putByte bh 6
put_ bh Int64Rep = putByte bh 7
put_ bh Word64Rep = putByte bh 8
put_ bh AddrRep = putByte bh 9
put_ bh FloatRep = putByte bh 10
put_ bh DoubleRep = putByte bh 11
put_ bh Int8Rep = putByte bh 12
put_ bh Word8Rep = putByte bh 13
put_ bh Int16Rep = putByte bh 14
put_ bh Word16Rep = putByte bh 15
#if __GLASGOW_HASKELL__ >= 809
put_ bh Int32Rep = putByte bh 16
put_ bh Word32Rep = putByte bh 17
#endif
get bh = do
tag <- getByte bh
case tag of
0 -> VecRep <$> get bh <*> get bh
1 -> TupleRep <$> get bh
2 -> SumRep <$> get bh
#if __GLASGOW_HASKELL__ >= 901
3 -> pure (BoxedRep Lifted)
4 -> pure (BoxedRep Unlifted)
#else
3 -> pure LiftedRep
4 -> pure UnliftedRep
#endif
5 -> pure IntRep
6 -> pure WordRep
7 -> pure Int64Rep
8 -> pure Word64Rep
9 -> pure AddrRep
10 -> pure FloatRep
11 -> pure DoubleRep
12 -> pure Int8Rep
13 -> pure Word8Rep
14 -> pure Int16Rep
15 -> pure Word16Rep
#if __GLASGOW_HASKELL__ >= 809
16 -> pure Int32Rep
17 -> pure Word32Rep
#endif
_ -> fail "Binary.putRuntimeRep: invalid tag"
instance Binary KindRep where
put_ bh (KindRepTyConApp tc k) = putByte bh 0 >> put_ bh tc >> put_ bh k
put_ bh (KindRepVar bndr) = putByte bh 1 >> put_ bh bndr
put_ bh (KindRepApp a b) = putByte bh 2 >> put_ bh a >> put_ bh b
put_ bh (KindRepFun a b) = putByte bh 3 >> put_ bh a >> put_ bh b
put_ bh (KindRepTYPE r) = putByte bh 4 >> put_ bh r
put_ bh (KindRepTypeLit sort r) = putByte bh 5 >> put_ bh sort >> put_ bh r
get bh = do
tag <- getByte bh
case tag of
0 -> KindRepTyConApp <$> get bh <*> get bh
1 -> KindRepVar <$> get bh
2 -> KindRepApp <$> get bh <*> get bh
3 -> KindRepFun <$> get bh <*> get bh
4 -> KindRepTYPE <$> get bh
5 -> KindRepTypeLit <$> get bh <*> get bh
_ -> fail "Binary.putKindRep: invalid tag"
instance Binary TypeLitSort where
put_ bh TypeLitSymbol = putByte bh 0
put_ bh TypeLitNat = putByte bh 1
#if defined(HAS_TYPELITCHAR)
put_ bh TypeLitChar = putByte bh 2
#endif
get bh = do
tag <- getByte bh
case tag of
0 -> pure TypeLitSymbol
1 -> pure TypeLitNat
#if defined(HAS_TYPELITCHAR)
2 -> pure TypeLitChar
#endif
_ -> fail "Binary.putTypeLitSort: invalid tag"
putTypeRep :: BinHandle -> TypeRep a -> IO ()
-- Special handling for TYPE, (->), and RuntimeRep due to recursive kind
-- relations.
-- See Note [Mutually recursive representations of primitive types]
putTypeRep bh rep
| Just HRefl <- rep `eqTypeRep` (typeRep :: TypeRep Type)
= put_ bh (0 :: Word8)
putTypeRep bh (Con' con ks) = do
put_ bh (1 :: Word8)
put_ bh con
put_ bh ks
putTypeRep bh (App f x) = do
put_ bh (2 :: Word8)
putTypeRep bh f
putTypeRep bh x
putTypeRep bh (Fun arg res) = do
put_ bh (3 :: Word8)
putTypeRep bh arg
putTypeRep bh res
instance Binary Serialized where
put_ bh (Serialized the_type bytes) = do
put_ bh the_type
put_ bh bytes
get bh = do
the_type <- get bh
bytes <- get bh
return (Serialized the_type bytes)
|
