blob: 1d879f229686f219f67f89b202fa9eaecd423681 (
plain)
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
|
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE RankNTypes #-}
-----------------------------------------------------------------------------
-- | Modified from cereal, which is
-- Copyright : Lennart Kolmodin, Galois Inc. 2009
-- License : BSD3-style
module T9630a (
Serialize(..), GSerialize (..), Putter, Get
) where
import Data.ByteString.Builder (Builder)
import Data.ByteString as B
import GHC.Generics
import Control.Applicative (Applicative (..), (<$>))
class Serialize t where
put :: Putter t
get :: Get t
instance Serialize () where
put () = pure ()
get = pure ()
-- Generics
class GSerialize f where
gPut :: Putter (f a)
gGet :: Get (f a)
instance (GSerialize a, GSerialize b) => GSerialize (a :*: b) where
gPut (a :*: b) = gPut a *> gPut b
gGet = (:*:) <$> gGet <*> gGet
instance GSerialize a => GSerialize (M1 i c a) where
gPut = gPut . unM1
gGet = M1 <$> gGet
instance Serialize a => GSerialize (K1 i a) where
gPut = put . unK1
gGet = K1 <$> get
-- Put
data PairS a = PairS a !Builder
newtype PutM a = Put { unPut :: PairS a }
type Put = PutM ()
type Putter a = a -> Put
instance Functor PutM where
fmap f m = Put $ let PairS a w = unPut m in PairS (f a) w
instance Applicative PutM where
pure a = Put (PairS a mempty)
m <*> k = Put $
let PairS f w = unPut m
PairS x w' = unPut k
in PairS (f x) (w `mappend` w')
-- Get
data Result r = Fail String B.ByteString
| Partial (B.ByteString -> Result r)
| Done r B.ByteString
newtype Get a = Get
{ unGet :: forall r. Input -> Buffer -> More
-> Failure r -> Success a r
-> Result r }
type Input = B.ByteString
type Buffer = Maybe B.ByteString
type Failure r = Input -> Buffer -> More -> [String] -> String -> Result r
type Success a r = Input -> Buffer -> More -> a -> Result r
data More
= Complete
| Incomplete (Maybe Int)
deriving (Eq)
instance Functor Get where
fmap p m = Get $ \ s0 b0 m0 kf ks ->
unGet m s0 b0 m0 kf $ \ s1 b1 m1 a -> ks s1 b1 m1 (p a)
instance Applicative Get where
pure a = Get $ \ s0 b0 m0 _ ks -> ks s0 b0 m0 a
f <*> x = Get $ \ s0 b0 m0 kf ks ->
unGet f s0 b0 m0 kf $ \ s1 b1 m1 g ->
unGet x s1 b1 m1 kf $ \ s2 b2 m2 y -> ks s2 b2 m2 (g y)
|
