git.iko.soy/streamly
on master help sign in
streamly/core/src/Streamly/Internal/Data/MutByteArray.hs
251 lines 8.6 kB history raw
1{-# LANGUAGE TemplateHaskell #-}
3-- This is required as all the instances in this module are orphan instances.
4{-# OPTIONS_GHC -fno-warn-orphans #-}
6-- |
7-- Module : Streamly.Internal.Data.MutByteArray
8-- Copyright : (c) 2023 Composewell Technologies
9-- License : BSD3-3-Clause
10-- Maintainer : streamly@composewell.com
11-- Portability : GHC
12--
14module Streamly.Internal.Data.MutByteArray
15 (
16 -- * MutByteArray
17 module Streamly.Internal.Data.MutByteArray.Type
18 -- * Unbox
19 , module Streamly.Internal.Data.Unbox
20 , module Streamly.Internal.Data.Unbox.TH
21 -- * Serialize
22 , module Streamly.Internal.Data.Serialize.Type
23 -- * Serialize TH
24 , module Streamly.Internal.Data.Serialize.TH
25 ) where
27--------------------------------------------------------------------------------
28-- Imports
29--------------------------------------------------------------------------------
31import Data.Proxy (Proxy(..))
32import Streamly.Internal.Data.Array (Array(..))
33import GHC.Exts (Int(..), sizeofByteArray#, unsafeCoerce#)
34import GHC.Word (Word8)
36#if __GLASGOW_HASKELL__ >= 900
37import GHC.Num.Integer (Integer(..))
38#else
39import GHC.Integer.GMP.Internals (Integer(..), BigNat(..))
40#endif
42import Streamly.Internal.Data.MutByteArray.Type
43import Streamly.Internal.Data.Serialize.TH
44import Streamly.Internal.Data.Serialize.Type
45import Streamly.Internal.Data.Unbox
46import Streamly.Internal.Data.Unbox.TH
48--------------------------------------------------------------------------------
49-- Common instances
50--------------------------------------------------------------------------------
52-- Note
53-- ====
54--
55-- Even a non-functional change such as changing the order of constructors will
56-- change the instance derivation.
57--
58-- This will not pose a problem if both, encode, and decode are done by the same
59-- version of the application. There *might* be a problem if version that
60-- encodes differs from the version that decodes.
61--
62-- We need to add some compatibility tests using different versions of
63-- dependencies.
64--
65-- Although such chages for the most basic types won't happen we need to detect
66-- if it ever happens.
67--
68-- Should we worry about these kind of changes and this kind of compatibility?
69-- This is a problem for all types of derivations that depend on the order of
70-- constructors, for example, Enum.
72-- Note on Windows build
73-- =====================
74--
75-- On Windows, having template haskell splices here fail the build with the
76-- following error:
77--
78-- @
79-- addLibrarySearchPath: C:\... (Win32 error 3): The system cannot find the path specified.
80-- @
81--
82-- The error might be irrelavant but having these splices triggers it. We should
83-- either fix the problem or avoid the use to template haskell splices in this
84-- file.
85--
86-- Similar issue: https://github.com/haskell/cabal/issues/4741
88-- $(Serialize.deriveSerialize ''Maybe)
89instance Serialize a => Serialize (Maybe a) where
91 {-# INLINE addSizeTo #-}
92 addSizeTo acc x =
93 case x of
94 Nothing -> (acc + 1)
95 Just field0 -> (addSizeTo (acc + 1)) field0
97 {-# INLINE deserializeAt #-}
98 deserializeAt initialOffset arr endOffset = do
99 (i0, tag) <- ((deserializeAt initialOffset) arr) endOffset
100 case tag :: Word8 of
101 0 -> pure (i0, Nothing)
102 1 -> do (i1, a0) <- ((deserializeAt i0) arr) endOffset
103 pure (i1, Just a0)
104 _ -> error "Found invalid tag while peeking (Maybe a)"
106 {-# INLINE serializeAt #-}
107 serializeAt initialOffset arr val =
108 case val of
109 Nothing -> do
110 i0 <- ((serializeAt initialOffset) arr) (0 :: Word8)
111 pure i0
112 Just field0 -> do
113 i0 <- ((serializeAt initialOffset) arr) (1 :: Word8)
114 i1 <- ((serializeAt i0) arr) field0
115 pure i1
117-- $(Serialize.deriveSerialize ''Either)
118instance (Serialize a, Serialize b) => Serialize (Either a b) where
120 {-# INLINE addSizeTo #-}
121 addSizeTo acc x =
122 case x of
123 Left field0 -> (addSizeTo (acc + 1)) field0
124 Right field0 -> (addSizeTo (acc + 1)) field0
126 {-# INLINE deserializeAt #-}
127 deserializeAt initialOffset arr endOffset = do
128 (i0, tag) <- ((deserializeAt initialOffset) arr) endOffset
129 case tag :: Word8 of
130 0 -> do (i1, a0) <- ((deserializeAt i0) arr) endOffset
131 pure (i1, Left a0)
132 1 -> do (i1, a0) <- ((deserializeAt i0) arr) endOffset
133 pure (i1, Right a0)
134 _ -> error "Found invalid tag while peeking (Either a b)"
136 {-# INLINE serializeAt #-}
137 serializeAt initialOffset arr val =
138 case val of
139 Left field0 -> do
140 i0 <- ((serializeAt initialOffset) arr) (0 :: Word8)
141 i1 <- ((serializeAt i0) arr) field0
142 pure i1
143 Right field0 -> do
144 i0 <- ((serializeAt initialOffset) arr) (1 :: Word8)
145 i1 <- ((serializeAt i0) arr) field0
146 pure i1
148instance Serialize (Proxy a) where
150 {-# INLINE addSizeTo #-}
151 addSizeTo acc _ = (acc + 1)
153 {-# INLINE deserializeAt #-}
154 deserializeAt initialOffset _ _ = pure ((initialOffset + 1), Proxy)
156 {-# INLINE serializeAt #-}
157 serializeAt initialOffset _ _ = pure (initialOffset + 1)
159--------------------------------------------------------------------------------
160-- Integer
161--------------------------------------------------------------------------------
163data LiftedInteger
164 = LIS Int
165 | LIP (Array Word)
166 | LIN (Array Word)
168-- $(Serialize.deriveSerialize ''LiftedInteger)
169instance Serialize LiftedInteger where
171 {-# INLINE addSizeTo #-}
172 addSizeTo acc x =
173 case x of
174 LIS field0 -> (addSizeTo (acc + 1)) field0
175 LIP field0 -> (addSizeTo (acc + 1)) field0
176 LIN field0 -> (addSizeTo (acc + 1)) field0
178 {-# INLINE deserializeAt #-}
179 deserializeAt initialOffset arr endOffset = do
180 (i0, tag) <- ((deserializeAt initialOffset) arr) endOffset
181 case tag :: Word8 of
182 0 -> do (i1, a0) <- ((deserializeAt i0) arr) endOffset
183 pure (i1, LIS a0)
184 1 -> do (i1, a0) <- ((deserializeAt i0) arr) endOffset
185 pure (i1, LIP a0)
186 2 -> do (i1, a0) <- ((deserializeAt i0) arr) endOffset
187 pure (i1, LIN a0)
188 _ -> error "Found invalid tag while peeking (LiftedInteger)"
190 {-# INLINE serializeAt #-}
191 serializeAt initialOffset arr val =
192 case val of
193 LIS field0 -> do
194 i0 <- ((serializeAt initialOffset) arr) (0 :: Word8)
195 i1 <- ((serializeAt i0) arr) field0
196 pure i1
197 LIP field0 -> do
198 i0 <- ((serializeAt initialOffset) arr) (1 :: Word8)
199 i1 <- ((serializeAt i0) arr) field0
200 pure i1
201 LIN field0 -> do
202 i0 <- ((serializeAt initialOffset) arr) (2 :: Word8)
203 i1 <- ((serializeAt i0) arr) field0
204 pure i1
206#if __GLASGOW_HASKELL__ >= 900
208{-# INLINE liftInteger #-}
209liftInteger :: Integer -> LiftedInteger
210liftInteger (IS x) = LIS (I# x)
211liftInteger (IP x) =
212 LIP (Array (MutByteArray (unsafeCoerce# x)) 0 (I# (sizeofByteArray# x)))
213liftInteger (IN x) =
214 LIN (Array (MutByteArray (unsafeCoerce# x)) 0 (I# (sizeofByteArray# x)))
216{-# INLINE unliftInteger #-}
217unliftInteger :: LiftedInteger -> Integer
218unliftInteger (LIS (I# x)) = IS x
219unliftInteger (LIP (Array (MutByteArray x) _ _)) = IP (unsafeCoerce# x)
220unliftInteger (LIN (Array (MutByteArray x) _ _)) = IN (unsafeCoerce# x)
222#else
224{-# INLINE liftInteger #-}
225liftInteger :: Integer -> LiftedInteger
226liftInteger (S# x) = LIS (I# x)
227liftInteger (Jp# (BN# x)) =
228 LIP (Array (MutByteArray (unsafeCoerce# x)) 0 (I# (sizeofByteArray# x)))
229liftInteger (Jn# (BN# x)) =
230 LIN (Array (MutByteArray (unsafeCoerce# x)) 0 (I# (sizeofByteArray# x)))
232{-# INLINE unliftInteger #-}
233unliftInteger :: LiftedInteger -> Integer
234unliftInteger (LIS (I# x)) = S# x
235unliftInteger (LIP (Array (MutByteArray x) _ _)) =
236 Jp# (BN# (unsafeCoerce# x))
237unliftInteger (LIN (Array (MutByteArray x) _ _)) =
238 Jn# (BN# (unsafeCoerce# x))
240#endif
242instance Serialize Integer where
243 {-# INLINE addSizeTo #-}
244 addSizeTo i a = addSizeTo i (liftInteger a)
246 {-# INLINE deserializeAt #-}
247 deserializeAt off arr end =
248 fmap unliftInteger <$> deserializeAt off arr end
250 {-# INLINE serializeAt #-}
251 serializeAt off arr val = serializeAt off arr (liftInteger val)