Ticket #13059: Store-Random.hs

File Store-Random.hs, 4.2 KB (added by dfeuer, 2 years ago)
Line 
1{-# LANGUAGE MagicHash #-}
2{-# LANGUAGE ScopedTypeVariables #-}
3module Store where
4
5import Control.Monad (replicateM)
6import Data.Foldable (foldl', foldlM)
7import Data.Word
8import Foreign.Storable (sizeOf)
9import qualified GHC.Integer.GMP.Internals as I
10import GHC.Prim (sizeofByteArray#)
11import GHC.Types (Int (I#))
12import Language.Haskell.TH.Syntax
13import StoreImpl
14
15{-
16instance (Store a, Store b) => Store (a, b)
17instance (Store a, Store b, Store c) => Store (a, b, c)
18instance (Store a, Store b, Store c, Store d) => Store (a, b, c, d)
19instance (Store a, Store b, Store c, Store d, Store e) =>
20         Store (a, b, c, d, e)
21instance (Store a, Store b, Store c, Store d, Store e, Store f) =>
22         Store (a, b, c, d, e, f)
23instance (Store a,
24          Store b,
25          Store c,
26          Store d,
27          Store e,
28          Store f,
29          Store g) =>
30         Store (a, b, c, d, e, f, g)
31-}
32
33instance Store ModName
34instance Store Name
35instance Store NameFlavour
36instance Store Type
37instance Store TyVarBndr
38instance Store NameSpace
39instance Store PkgName
40instance Store OccName
41instance Store TyLit
42
43instance Store Word8 where
44  {-# INLINE size #-}
45  {-# INLINE peek #-}
46  {-# INLINE poke #-}
47  size = sizeStorableTy "Foreign.Storable.Storable GHC.Word.Word8"
48  peek = peekStorableTy "Foreign.Storable.Storable GHC.Word.Word8"
49  poke = pokeStorable
50
51instance Store Char where
52  {-# INLINE size #-}
53  {-# INLINE peek #-}
54  {-# INLINE poke #-}
55  size = sizeStorableTy "Foreign.Storable.Storable GHC.Types.Char"
56  peek = peekStorableTy "Foreign.Storable.Storable GHC.Types.Char"
57  poke = pokeStorable
58
59instance Store Int where
60  {-# INLINE size #-}
61  {-# INLINE peek #-}
62  {-# INLINE poke #-}
63  size = sizeStorableTy "Foreign.Storable.Storable GHC.Types.Int"
64  peek = peekStorableTy "Foreign.Storable.Storable GHC.Types.Int"
65  poke = pokeStorable
66
67instance Store Integer where
68    size = VarSize $ \ x ->
69        sizeOf (undefined :: Word8) + case x of
70            I.S# _ -> sizeOf (undefined :: Int)
71            I.Jp# (I.BN# arr) -> sizeOf (undefined :: Int) + I# (sizeofByteArray# arr)
72            I.Jn# (I.BN# arr) -> sizeOf (undefined :: Int) + I# (sizeofByteArray# arr)
73    poke (I.S# x) = poke (0 :: Word8) >> poke (I# x)
74    poke (I.Jp# (I.BN# arr)) = do
75        let len = I# (sizeofByteArray# arr)
76        poke (1 :: Word8)
77        poke len
78        pokeFromByteArray arr 0 len
79    poke (I.Jn# (I.BN# arr)) = do
80        let len = I# (sizeofByteArray# arr)
81        poke (2 :: Word8)
82        poke len
83        pokeFromByteArray arr 0 len
84    peek = do
85        tag <- peek :: Peek Word8
86        case tag of
87            0 -> fromIntegral <$> (peek :: Peek Int)
88            1 -> I.Jp# <$> peekBN
89            2 -> I.Jn# <$> peekBN
90            _ -> peekException "Invalid Integer tag"
91      where
92        peekBN = do
93          len <- peek :: Peek Int
94          ByteArray arr <- peekToByteArray "GHC>Integer" len
95          return $ I.BN# arr
96
97instance Store a => Store [a] where
98    size = sizeSequence
99    poke = pokeSequence
100    peek = peekSequence
101    {-# INLINE size #-}
102    {-# INLINE peek #-}
103    {-# INLINE poke #-}
104
105sizeSequence :: forall a. Store a => Size [a]
106--sizeSequence = undefined
107-- sizeSequence :: forall t. (IsSequence t, Store (Element t)) => Size t
108sizeSequence = VarSize $ \t ->
109    case size :: Size a of
110        ConstSize n -> n * (length t) + sizeOf (undefined :: Int)
111        VarSize f -> foldl' (\acc x -> acc + f x) (sizeOf (undefined :: Int)) t
112{-# INLINE sizeSequence #-}
113
114pokeSequence :: forall a. Store a => [a] -> Poke ()
115--pokeSequence = undefined
116-- pokeSequence :: (IsSequence t, Store (Element t)) => t -> Poke ()
117pokeSequence t =
118  do pokeStorable len
119     Poke (\ptr offset ->
120             do offset' <-
121                  foldlM (\offset' a ->
122                             do (offset'',_) <- runPoke (poke a) ptr offset'
123                                return offset'')
124                          offset
125                          t
126                return (offset',()))
127  where len = length t
128{-# INLINE pokeSequence #-}
129
130peekSequence :: forall a. Store a => Peek [a]
131--peekSequence = undefined
132-- peekSequence :: (IsSequence t, Store (Element t), Index t ~ Int) => Peek t
133peekSequence = do
134    len <- peek
135    replicateM len peek
136{-# INLINE peekSequence #-}