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