diff options
author | Sam T <pxqr.sta@gmail.com> | 2013-08-26 04:50:48 +0400 |
---|---|---|
committer | Sam T <pxqr.sta@gmail.com> | 2013-08-26 04:50:48 +0400 |
commit | 97a6f7ccc7fc87279e8046f9e49061619d8dcdd8 (patch) | |
tree | e8d24fa823226f26b91dcf337552fce61716f328 | |
parent | 37e74d3547766d16a994afe270f0ae2bdcea8af5 (diff) |
+ Added generic decode.
-rw-r--r-- | TODO.org | 2 | ||||
-rw-r--r-- | src/Data/BEncode.hs | 62 |
2 files changed, 49 insertions, 15 deletions
@@ -1,4 +1,4 @@ | |||
1 | * TODO generic decode | 1 | * DONE generic decode |
2 | * TODO tests for generics with record selectors | 2 | * TODO tests for generics with record selectors |
3 | * TODO documentation | 3 | * TODO documentation |
4 | * TODO v0.1.1.0 (reason: Dict ty syn exposed) | 4 | * TODO v0.1.1.0 (reason: Dict ty syn exposed) |
diff --git a/src/Data/BEncode.hs b/src/Data/BEncode.hs index a08b8be..87321f2 100644 --- a/src/Data/BEncode.hs +++ b/src/Data/BEncode.hs | |||
@@ -55,6 +55,7 @@ | |||
55 | {-# LANGUAGE FlexibleContexts #-} | 55 | {-# LANGUAGE FlexibleContexts #-} |
56 | {-# LANGUAGE FlexibleInstances #-} | 56 | {-# LANGUAGE FlexibleInstances #-} |
57 | {-# LANGUAGE MultiParamTypeClasses #-} | 57 | {-# LANGUAGE MultiParamTypeClasses #-} |
58 | {-# LANGUAGE ScopedTypeVariables #-} | ||
58 | #endif | 59 | #endif |
59 | 60 | ||
60 | module Data.BEncode | 61 | module Data.BEncode |
@@ -162,8 +163,12 @@ class BEncodable a where | |||
162 | fromBEncode :: BEncode -> Result a | 163 | fromBEncode :: BEncode -> Result a |
163 | 164 | ||
164 | #if __GLASGOW_HASKELL__ >= 702 | 165 | #if __GLASGOW_HASKELL__ >= 702 |
165 | default fromBEncode :: GBEncodable (Rep a) BEncode => BEncode -> Result a | 166 | default fromBEncode |
166 | fromBEncode = error "default fromBEncode: not implemented" | 167 | :: Generic a |
168 | => GBEncodable (Rep a) BEncode | ||
169 | => BEncode -> Result a | ||
170 | |||
171 | fromBEncode x = to <$> gfrom x | ||
167 | #endif | 172 | #endif |
168 | 173 | ||
169 | decodingError :: String -> Result a | 174 | decodingError :: String -> Result a |
@@ -192,26 +197,38 @@ class GBEncodable f e where | |||
192 | instance BEncodable f | 197 | instance BEncodable f |
193 | => GBEncodable (K1 R f) BEncode where | 198 | => GBEncodable (K1 R f) BEncode where |
194 | {-# INLINE gto #-} | 199 | {-# INLINE gto #-} |
195 | gto (K1 x) = toBEncode x | 200 | gto = toBEncode . unK1 |
196 | 201 | ||
197 | {-# INLINE gfrom #-} | 202 | {-# INLINE gfrom #-} |
198 | gfrom = undefined | 203 | gfrom x = K1 <$> fromBEncode x |
199 | 204 | ||
200 | instance Monoid e | 205 | instance (Eq e, Monoid e) |
201 | => GBEncodable U1 e where | 206 | => GBEncodable U1 e where |
202 | {-# INLINE gto #-} | 207 | {-# INLINE gto #-} |
203 | gto U1 = mempty | 208 | gto U1 = mempty |
204 | 209 | ||
205 | {-# INLINE gfrom #-} | 210 | {-# INLINE gfrom #-} |
206 | gfrom = undefined | 211 | gfrom x |
212 | | x == mempty = pure U1 | ||
213 | | otherwise = decodingError "U1" | ||
207 | 214 | ||
208 | instance (GBEncodable a e, GBEncodable b e, Monoid e) | 215 | instance (GBEncodable a [BEncode], GBEncodable b [BEncode]) |
209 | => GBEncodable (a :*: b) e where | 216 | => GBEncodable (a :*: b) [BEncode] where |
217 | {-# INLINE gto #-} | ||
218 | gto (a :*: b) = gto a ++ gto b | ||
219 | |||
220 | {-# INLINE gfrom #-} | ||
221 | gfrom (x : xs) = (:*:) <$> gfrom [x] <*> gfrom xs | ||
222 | gfrom [] = decodingError "generic: not enough fields" | ||
223 | |||
224 | instance (GBEncodable a Dict, GBEncodable b Dict) | ||
225 | => GBEncodable (a :*: b) Dict where | ||
210 | {-# INLINE gto #-} | 226 | {-# INLINE gto #-} |
211 | gto (a :*: b) = gto a <> gto b | 227 | gto (a :*: b) = gto a <> gto b |
212 | 228 | ||
213 | {-# INLINE gfrom #-} | 229 | {-# INLINE gfrom #-} |
214 | gfrom = undefined | 230 | gfrom = error "gfrom: not implemented" |
231 | |||
215 | 232 | ||
216 | instance (GBEncodable a e, GBEncodable b e) | 233 | instance (GBEncodable a e, GBEncodable b e) |
217 | => GBEncodable (a :+: b) e where | 234 | => GBEncodable (a :+: b) e where |
@@ -220,7 +237,21 @@ instance (GBEncodable a e, GBEncodable b e) | |||
220 | gto (R1 x) = gto x | 237 | gto (R1 x) = gto x |
221 | 238 | ||
222 | {-# INLINE gfrom #-} | 239 | {-# INLINE gfrom #-} |
223 | gfrom = undefined | 240 | gfrom x = case gfrom x of |
241 | Right lv -> return (L1 lv) | ||
242 | Left le -> do | ||
243 | case gfrom x of | ||
244 | Right rv -> return (R1 rv) | ||
245 | Left re -> decodingError $ "generic: both" ++ le ++ " " ++ re | ||
246 | |||
247 | gfromM1S :: forall c. Selector c | ||
248 | => GBEncodable f BEncode | ||
249 | => Dict -> Result (M1 i c f p) | ||
250 | gfromM1S dict | ||
251 | | Just va <- M.lookup (BC.pack name) dict = M1 <$> gfrom va | ||
252 | | otherwise = decodingError $ "generic: Selector not found " ++ show name | ||
253 | where | ||
254 | name = selName (error "gfromM1S: impossible" :: M1 i c f p) | ||
224 | 255 | ||
225 | instance (Selector s, GBEncodable f BEncode) | 256 | instance (Selector s, GBEncodable f BEncode) |
226 | => GBEncodable (M1 S s f) Dict where | 257 | => GBEncodable (M1 S s f) Dict where |
@@ -228,7 +259,7 @@ instance (Selector s, GBEncodable f BEncode) | |||
228 | gto s @ (M1 x) = BC.pack (selName s) `M.singleton` gto x | 259 | gto s @ (M1 x) = BC.pack (selName s) `M.singleton` gto x |
229 | 260 | ||
230 | {-# INLINE gfrom #-} | 261 | {-# INLINE gfrom #-} |
231 | gfrom = undefined | 262 | gfrom = gfromM1S |
232 | 263 | ||
233 | -- TODO DList | 264 | -- TODO DList |
234 | instance GBEncodable f BEncode | 265 | instance GBEncodable f BEncode |
@@ -236,7 +267,8 @@ instance GBEncodable f BEncode | |||
236 | {-# INLINE gto #-} | 267 | {-# INLINE gto #-} |
237 | gto (M1 x) = [gto x] | 268 | gto (M1 x) = [gto x] |
238 | 269 | ||
239 | gfrom = undefined | 270 | gfrom [x] = M1 <$> gfrom x |
271 | gfrom _ = decodingError "generic: empty selector" | ||
240 | {-# INLINE gfrom #-} | 272 | {-# INLINE gfrom #-} |
241 | 273 | ||
242 | instance (Constructor c, GBEncodable f Dict, GBEncodable f [BEncode]) | 274 | instance (Constructor c, GBEncodable f Dict, GBEncodable f [BEncode]) |
@@ -247,7 +279,9 @@ instance (Constructor c, GBEncodable f Dict, GBEncodable f [BEncode]) | |||
247 | | otherwise = BList (gto x) | 279 | | otherwise = BList (gto x) |
248 | 280 | ||
249 | {-# INLINE gfrom #-} | 281 | {-# INLINE gfrom #-} |
250 | gfrom = undefined | 282 | gfrom (BDict a) = M1 <$> gfrom a |
283 | gfrom (BList a) = M1 <$> gfrom a | ||
284 | gfrom _ = decodingError "generic: Constr" | ||
251 | 285 | ||
252 | instance GBEncodable f e | 286 | instance GBEncodable f e |
253 | => GBEncodable (M1 D d f) e where | 287 | => GBEncodable (M1 D d f) e where |
@@ -255,7 +289,7 @@ instance GBEncodable f e | |||
255 | gto (M1 x) = gto x | 289 | gto (M1 x) = gto x |
256 | 290 | ||
257 | {-# INLINE gfrom #-} | 291 | {-# INLINE gfrom #-} |
258 | gfrom = undefined | 292 | gfrom x = M1 <$> gfrom x |
259 | 293 | ||
260 | #endif | 294 | #endif |
261 | 295 | ||