-
Notifications
You must be signed in to change notification settings - Fork 7
/
Binary.hs
92 lines (74 loc) · 2.36 KB
/
Binary.hs
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
module Rules.Binary(rules) where
import Data.List (nub,intersperse)
import RuleUtils
rules = [
("Binary", userRuleBinary, "Binary", "Data.Binary binary encoding of terms", Nothing)
]
-- useful helper things
namesupply = [text [x,y] | x <- ['a' .. 'z'],
y <- ['a' .. 'z'] ++ ['A' .. 'Z']]
mknss [] _ = []
mknss (c:cs) ns =
let (thisns,rest) = splitAt (length (types c)) ns
in thisns: mknss cs rest
mkpattern :: Constructor -> [a] -> [Doc] -> Doc
mkpattern c l ns =
if null l then text c
else parens (hsep (text c : take (length l) ns))
instanceheader cls dat =
let fv = vars dat
tycon = name dat
ctx = map (\v-> text cls <+> text v)
parenSpace = parens . hcat . sepWith space
in
hsep [ text "instance"
, opt fv (\v -> parenList (ctx v) <+> text "=>")
, text cls
, opt1 (texts (tycon: fv)) parenSpace id
, text "where"
]
-- begin here for Binary derivation
userRuleBinary dat =
let cs = body dat
cvs = mknss cs namesupply
--k = (ceiling . logBase 256 . realToFrac . length) cs
k = length cs
in
instanceheader "Data.Binary.Binary" dat $$
block ( zipWith3 (putfn k) [0..] cvs cs
++ [getfn k [0..] cvs cs]
)
putfn 1 _ [] c =
text "put" <+> ppCons [] c <+> text "= return ()"
putfn 1 _ cv c =
text "put" <+> ppCons cv c <+> text "= do" $$
nest 8 (
vcat (map (text "Data.Binary.put" <+>) cv)
)
putfn _ n cv c =
text "put" <+> ppCons cv c <+> text "= do" $$
nest 8 (
text "Data.Binary.putWord8" <+> text (show n) $$
vcat (map (text "Data.Binary.put" <+>) cv)
)
ppCons cv c = mkpattern (constructor c) (types c) cv
getfn _ _ [[]] [c] =
text "get = return" <+> ppCons [] c
getfn _ _ [vs] [c] =
text "get = do" $$
vcat (map (\v-> v <+> text "<-" <+> text "get") vs) $$
text "return" <+> ppCons vs c
getfn _ ns cvs cs =
text "get = do" $$
nest 8 (
text "h <- Data.Binary.getWord8" $$
text "case h of" $$
nest 2 ( vcat $
zipWith3 (\n vs c-> text (show n) <+> text "-> do" $$
nest 6 (
vcat (map (\v-> v <+> text "<-" <+> text "Data.Binary.get") vs) $$
text "return" <+> ppCons vs c
))
ns cvs cs ++ [ text "_ -> fail \"invalid binary data found\"" ]
)
)