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
|
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Micro.CBOR (serialise, deserialise) where
import Micro.Types
import Codec.Serialise.Class
import Codec.Serialise.Encoding
import Codec.Serialise.Decoding hiding (DecodeAction(Done, Fail))
import qualified Codec.Serialise as Serialise
#if ! MIN_VERSION_base(4,11,0)
import Data.Monoid
#endif
import qualified Data.ByteString.Lazy as BS
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative
import Data.Word
#endif
serialise :: Tree -> BS.ByteString
serialise = Serialise.serialise
deserialise :: BS.ByteString -> Tree
deserialise = Serialise.deserialise
encodeCtr0 :: Word -> Encoding
encodeCtr2 :: (Serialise a, Serialise b) => Word -> a -> b -> Encoding
encodeCtr0 n = encodeListLen 1 <> encode (n :: Word)
encodeCtr2 n a b = encodeListLen 3 <> encode (n :: Word) <> encode a <> encode b
{-# INLINE encodeCtr0 #-}
{-# INLINE encodeCtr2 #-}
{-# INLINE decodeCtrTag #-}
{-# INLINE decodeCtrBody0 #-}
{-# INLINE decodeCtrBody2 #-}
decodeCtrTag :: Decoder s (Word, Int)
decodeCtrTag = (\len tag -> (tag, len)) <$> decodeListLen <*> decodeWord
decodeCtrBody0 :: Int -> a -> Decoder s a
decodeCtrBody0 1 f = pure f
decodeCtrBody0 x _ = error $ "decodeCtrBody0: impossible tag " ++ show x
decodeCtrBody2
:: (Serialise a, Serialise b) => Int -> (a -> b -> c) -> Decoder s c
decodeCtrBody2 3 f = do x1 <- decode
x2 <- decode
return (f x1 x2)
decodeCtrBody2 x _ = error $ "decodeCtrBody2: impossible tag " ++ show x
instance Serialise Tree where
encode Leaf = encodeCtr0 1
encode (Fork a b) = encodeCtr2 2 a b
decode = do
(t,l) <- decodeCtrTag
case t of
1 -> decodeCtrBody0 l Leaf
2 -> decodeCtrBody2 l Fork
x -> error $ "Serialise Tree: decode: impossible tag " ++ show x
|
