7282ff6dc1cc074a677668090d6d6e80eb163616
[packages/binary.git] / src / Data / Binary / Generic.hs
1 {-# LANGUAGE BangPatterns, CPP, FlexibleInstances, KindSignatures,
2 ScopedTypeVariables, TypeOperators, TypeSynonymInstances #-}
3 {-# LANGUAGE Safe #-}
4 {-# OPTIONS_GHC -fno-warn-orphans #-}
5
6 -----------------------------------------------------------------------------
7 -- |
8 -- Module : Data.Binary.Generic
9 -- Copyright : Bryan O'Sullivan
10 -- License : BSD3-style (see LICENSE)
11 --
12 -- Maintainer : Bryan O'Sullivan <bos@serpentine.com>
13 -- Stability : unstable
14 -- Portability : Only works with GHC 7.2 and newer
15 --
16 -- Instances for supporting GHC generics.
17 --
18 -----------------------------------------------------------------------------
19 module Data.Binary.Generic
20 (
21 ) where
22
23 import Control.Applicative
24 import Data.Binary.Class
25 import Data.Binary.Get
26 import Data.Binary.Put
27 import Data.Bits
28 import Data.Word
29 import Data.Monoid ((<>))
30 import GHC.Generics
31 import Prelude -- Silence AMP warning.
32
33 -- Type without constructors
34 instance GBinaryPut V1 where
35 gput _ = pure ()
36
37 instance GBinaryGet V1 where
38 gget = return undefined
39
40 -- Constructor without arguments
41 instance GBinaryPut U1 where
42 gput U1 = pure ()
43
44 instance GBinaryGet U1 where
45 gget = return U1
46
47 -- Product: constructor with parameters
48 instance (GBinaryPut a, GBinaryPut b) => GBinaryPut (a :*: b) where
49 gput (x :*: y) = gput x <> gput y
50
51 instance (GBinaryGet a, GBinaryGet b) => GBinaryGet (a :*: b) where
52 gget = (:*:) <$> gget <*> gget
53
54 -- Metadata (constructor name, etc)
55 instance GBinaryPut a => GBinaryPut (M1 i c a) where
56 gput = gput . unM1
57
58 instance GBinaryGet a => GBinaryGet (M1 i c a) where
59 gget = M1 <$> gget
60
61 -- Constants, additional parameters, and rank-1 recursion
62 instance Binary a => GBinaryPut (K1 i a) where
63 gput = put . unK1
64
65 instance Binary a => GBinaryGet (K1 i a) where
66 gget = K1 <$> get
67
68 -- Borrowed from the cereal package.
69
70 -- The following GBinary instance for sums has support for serializing
71 -- types with up to 2^64-1 constructors. It will use the minimal
72 -- number of bytes needed to encode the constructor. For example when
73 -- a type has 2^8 constructors or less it will use a single byte to
74 -- encode the constructor. If it has 2^16 constructors or less it will
75 -- use two bytes, and so on till 2^64-1.
76
77 #define GUARD(WORD) (size - 1) <= fromIntegral (maxBound :: WORD)
78 #define PUTSUM(WORD) GUARD(WORD) = putSum (0 :: WORD) (fromIntegral size)
79 #define GETSUM(WORD) GUARD(WORD) = (get :: Get WORD) >>= checkGetSum (fromIntegral size)
80
81 instance ( GSumPut a, GSumPut b
82 , SumSize a, SumSize b) => GBinaryPut (a :+: b) where
83 gput | PUTSUM(Word8) | PUTSUM(Word16) | PUTSUM(Word32) | PUTSUM(Word64)
84 | otherwise = sizeError "encode" size
85 where
86 size = unTagged (sumSize :: Tagged (a :+: b) Word64)
87
88 instance ( GSumGet a, GSumGet b
89 , SumSize a, SumSize b) => GBinaryGet (a :+: b) where
90 gget | GETSUM(Word8) | GETSUM(Word16) | GETSUM(Word32) | GETSUM(Word64)
91 | otherwise = sizeError "decode" size
92 where
93 size = unTagged (sumSize :: Tagged (a :+: b) Word64)
94
95 sizeError :: Show size => String -> size -> error
96 sizeError s size =
97 error $ "Can't " ++ s ++ " a type with " ++ show size ++ " constructors"
98
99 ------------------------------------------------------------------------
100
101 checkGetSum :: (Ord word, Num word, Bits word, GSumGet f)
102 => word -> word -> Get (f a)
103 checkGetSum size code | code < size = getSum code size
104 | otherwise = fail "Unknown encoding for constructor"
105 {-# INLINE checkGetSum #-}
106
107 class GSumGet f where
108 getSum :: (Ord word, Num word, Bits word) => word -> word -> Get (f a)
109
110 class GSumPut f where
111 putSum :: (Num w, Bits w, Binary w) => w -> w -> f a -> Put
112
113 instance (GSumGet a, GSumGet b) => GSumGet (a :+: b) where
114 getSum !code !size | code < sizeL = L1 <$> getSum code sizeL
115 | otherwise = R1 <$> getSum (code - sizeL) sizeR
116 where
117 sizeL = size `shiftR` 1
118 sizeR = size - sizeL
119
120 instance (GSumPut a, GSumPut b) => GSumPut (a :+: b) where
121 putSum !code !size s = case s of
122 L1 x -> putSum code sizeL x
123 R1 x -> putSum (code + sizeL) sizeR x
124 where
125 sizeL = size `shiftR` 1
126 sizeR = size - sizeL
127
128 instance GBinaryGet a => GSumGet (C1 c a) where
129 getSum _ _ = gget
130
131 instance GBinaryPut a => GSumPut (C1 c a) where
132 putSum !code _ x = put code <> gput x
133
134 ------------------------------------------------------------------------
135
136 class SumSize f where
137 sumSize :: Tagged f Word64
138
139 newtype Tagged (s :: * -> *) b = Tagged {unTagged :: b}
140
141 instance (SumSize a, SumSize b) => SumSize (a :+: b) where
142 sumSize = Tagged $ unTagged (sumSize :: Tagged a Word64) +
143 unTagged (sumSize :: Tagged b Word64)
144
145 instance SumSize (C1 c a) where
146 sumSize = Tagged 1