Ticket #13059: Store.hs

File Store.hs, 6.4 KB (added by RyanGlScott, 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.Monoid
8import Data.Word
9import Foreign.Storable (Storable, sizeOf)
10import qualified GHC.Integer.GMP.Internals as I
11import GHC.Prim (sizeofByteArray#)
12import GHC.Real (Ratio(..))
13import GHC.Types (Int (I#))
14import Language.Haskell.TH.Syntax
15import StoreImpl
16
17instance Store ()
18instance Store a => Store (Dual a)
19instance Store a => Store (Sum a)
20instance Store a => Store (Product a)
21instance Store a => Store (First a)
22instance Store a => Store (Last a)
23instance Store a => Store (Maybe a)
24instance (Store a, Store b) => Store (Either a b)
25instance (Store a, Store b) => Store (a, b)
26instance (Store a, Store b, Store c) => Store (a, b, c)
27instance (Store a, Store b, Store c, Store d) => Store (a, b, c, d)
28instance (Store a, Store b, Store c, Store d, Store e) =>
29         Store (a, b, c, d, e)
30instance (Store a, Store b, Store c, Store d, Store e, Store f) =>
31         Store (a, b, c, d, e, f)
32instance (Store a,
33          Store b,
34          Store c,
35          Store d,
36          Store e,
37          Store f,
38          Store g) =>
39         Store (a, b, c, d, e, f, g)
40instance Store ModName
41instance Store NameSpace
42instance Store PkgName
43instance Store Info
44instance Store Dec
45instance Store Name
46instance Store OccName
47instance Store NameFlavour
48instance Store Clause
49instance Store Pat
50instance Store Lit
51instance Store Type
52instance Store TyVarBndr
53instance Store TyLit
54instance Store Exp
55instance Store Match
56instance Store Body
57instance Store Guard
58instance Store Stmt
59instance Store Range
60instance Store Con
61instance Store FunDep
62instance Store Foreign
63instance Store Callconv
64instance Store Safety
65instance Store Fixity
66instance Store FixityDirection
67instance Store Pragma
68instance Store Inline
69instance Store RuleMatch
70instance Store Phases
71instance Store RuleBndr
72instance Store AnnTarget
73instance Store FamFlavour
74instance Store TySynEqn
75instance Store Role
76instance Store SourceStrictness
77instance Store SourceUnpackedness
78instance Store DecidedStrictness
79instance Store Overlap
80instance Store Bang
81instance Store TypeFamilyHead
82instance Store InjectivityAnn
83instance Store FamilyResultSig
84
85instance Store Bool where
86  {-# INLINE size #-}
87  {-# INLINE peek #-}
88  {-# INLINE poke #-}
89  size
90    = case () of {
91        ()
92          | (True && (sz0 == sz1)) -> ConstSize (1 + sz0)
93          where
94              sz0 = 0
95              sz1 = 0
96     ;  ()
97          -> (VarSize
98              $ (\ x_aENz
99                   -> (1
100                       + (case x_aENz of {
101                            False -> 0
102                          ; True -> 0 })))) }
103  peek
104    = do { tag <- peek;
105           case tag :: Word8 of {
106             0 -> pure False
107           ; 1 -> pure True
108           ; _ -> (peekException
109                   $ ({-T.pack
110                      $-} ("Found invalid tag while peeking ("
111                         ++ ("ConT GHC.Types.Bool" ++ ")")))) } }
112  poke
113    = \ val
114        -> case val of {
115             False -> do { poke (0 :: Word8) }
116           ; True -> do { poke (1 :: Word8) } }
117
118instance Store Word8 where
119  {-# INLINE size #-}
120  {-# INLINE peek #-}
121  {-# INLINE poke #-}
122  size = sizeStorableTy "Foreign.Storable.Storable GHC.Word.Word8"
123  peek = peekStorableTy "Foreign.Storable.Storable GHC.Word.Word8"
124  poke = pokeStorable
125
126instance Store Char where
127  {-# INLINE size #-}
128  {-# INLINE peek #-}
129  {-# INLINE poke #-}
130  size = sizeStorableTy "Foreign.Storable.Storable GHC.Types.Char"
131  peek = peekStorableTy "Foreign.Storable.Storable GHC.Types.Char"
132  poke = pokeStorable
133
134instance Store Int where
135  {-# INLINE size #-}
136  {-# INLINE peek #-}
137  {-# INLINE poke #-}
138  size = sizeStorableTy "Foreign.Storable.Storable GHC.Types.Int"
139  peek = peekStorableTy "Foreign.Storable.Storable GHC.Types.Int"
140  poke = pokeStorable
141
142instance Store a => Store (Ratio a) where
143    size = combineSize (\(x :% _) -> x) (\(_ :% y) -> y)
144    poke (x :% y) = poke (x, y)
145    peek = uncurry (:%) <$> peek
146    {-# INLINE size #-}
147    {-# INLINE peek #-}
148    {-# INLINE poke #-}
149
150instance Store Integer where
151    size = VarSize $ \ x ->
152        sizeOf (undefined :: Word8) + case x of
153            I.S# _ -> sizeOf (undefined :: Int)
154            I.Jp# (I.BN# arr) -> sizeOf (undefined :: Int) + I# (sizeofByteArray# arr)
155            I.Jn# (I.BN# arr) -> sizeOf (undefined :: Int) + I# (sizeofByteArray# arr)
156    poke (I.S# x) = poke (0 :: Word8) >> poke (I# x)
157    poke (I.Jp# (I.BN# arr)) = do
158        let len = I# (sizeofByteArray# arr)
159        poke (1 :: Word8)
160        poke len
161        pokeFromByteArray arr 0 len
162    poke (I.Jn# (I.BN# arr)) = do
163        let len = I# (sizeofByteArray# arr)
164        poke (2 :: Word8)
165        poke len
166        pokeFromByteArray arr 0 len
167    peek = do
168        tag <- peek :: Peek Word8
169        case tag of
170            0 -> fromIntegral <$> (peek :: Peek Int)
171            1 -> I.Jp# <$> peekBN
172            2 -> I.Jn# <$> peekBN
173            _ -> peekException "Invalid Integer tag"
174      where
175        peekBN = do
176          len <- peek :: Peek Int
177          ByteArray arr <- peekToByteArray "GHC>Integer" len
178          return $ I.BN# arr
179
180instance Store a => Store [a] where
181    size = sizeSequence
182    poke = pokeSequence
183    peek = peekSequence
184    {-# INLINE size #-}
185    {-# INLINE peek #-}
186    {-# INLINE poke #-}
187
188sizeSequence :: forall a. Store a => Size [a]
189-- sizeSequence :: forall t. (IsSequence t, Store (Element t)) => Size t
190sizeSequence = VarSize $ \t ->
191    case size :: Size a of
192        ConstSize n -> n * (length t) + sizeOf (undefined :: Int)
193        VarSize f -> foldl' (\acc x -> acc + f x) (sizeOf (undefined :: Int)) t
194{-# INLINE sizeSequence #-}
195
196pokeSequence :: forall a. Store a => [a] -> Poke ()
197-- pokeSequence :: (IsSequence t, Store (Element t)) => t -> Poke ()
198pokeSequence t =
199  do pokeStorable len
200     Poke (\ptr offset ->
201             do offset' <-
202                  foldlM (\offset' a ->
203                             do (offset'',_) <- runPoke (poke a) ptr offset'
204                                return offset'')
205                          offset
206                          t
207                return (offset',()))
208  where len = length t
209{-# INLINE pokeSequence #-}
210
211peekSequence :: forall a. Store a => Peek [a]
212-- peekSequence :: (IsSequence t, Store (Element t), Index t ~ Int) => Peek t
213peekSequence = do
214    len <- peek
215    replicateM len peek
216{-# INLINE peekSequence #-}