blob: 1e3f225c0a45fcf28c1efd47457fd2fe44966a11 (
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
|
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
module Coolbal.EnvBinary where
import Data.Binary (get)
import Data.Binary.Get (Get, runGet)
import Data.Binary.Put (Put, runPut)
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as BS
import Data.Proxy
import GHC.Generics
class EnvBinary e a | a -> e where
envget :: e -> Get a
envput :: a -> Put
default envget :: (Generic a, GEnvBinary e (Rep a)) => e -> Get a
envget env = to <$> genvget env
default envput :: (Generic a, GEnvBinary e (Rep a)) => a -> Put
envput = genvput (Proxy @e) . from
instance EnvBinary e a => EnvBinary e [a] where
envget env = get >>= getMany id
where
getMany :: ([a] -> [a]) -> Int -> Get [a]
getMany build 0 = return (build [])
getMany build i = do
x <- envget env
x `seq` getMany ((x:) . build) (i-1)
envput = undefined
encode :: EnvBinary e a => a -> ByteString
encode = runPut . envput
decode :: EnvBinary e a => e -> ByteString -> a
decode env = runGet (envget env)
encodeFile :: EnvBinary e a => FilePath -> a -> IO ()
encodeFile f = BS.writeFile f . encode
-- TODO: This is inefficient! See the actual implementation of decodeFile in 'Data.Binary'.
decodeFile :: EnvBinary e a => e -> FilePath -> IO a
decodeFile env f = decode env <$> BS.readFile f
-- TODO: This can very well be implemented for :+: but I just haven't done that
-- yet. Perhaps to do something cool where an n-way disjunction uses only
-- log2(n) bits to encode the choice.
class GEnvBinary e r where
genvget :: e -> Get (r x)
genvput :: proxy e -> r x -> Put
instance GEnvBinary e c => GEnvBinary e (D1 meta c) where
genvget e = M1 <$> genvget e
genvput pr = genvput pr . unM1
instance GEnvBinary e s => GEnvBinary e (C1 meta s) where
genvget e = M1 <$> genvget e
genvput pr = genvput pr . unM1
instance GEnvBinary e f => GEnvBinary e (S1 meta f) where
genvget e = M1 <$> genvget e
genvput pr = genvput pr . unM1
instance EnvBinary e t => GEnvBinary e (Rec0 t) where
genvget e = K1 <$> envget e
genvput _ = envput . unK1
|
