/
BitsBinary.hs
131 lines (103 loc) · 3.49 KB
/
BitsBinary.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
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
-- stub module to add your own rules.
module Rules.BitsBinary(rules) where
import Data.List (nub,intersperse)
import RuleUtils -- useful to have a look at this too
rules = [
("BitsBinary", userRuleBinary, "Binary", "bit based binary encoding of terms", Nothing)
]
{- datatype that rules manipulate :-
data Data = D { name :: Name, -- type's name
constraints :: [(Class,Var)],
vars :: [Var], -- Parameters
body :: [Body],
derives :: [Class], -- derived classes
statement :: Statement} -- type of statement
| Directive --|
| TypeName Name --| used by derive (ignore)
deriving (Eq,Show)
data Body = Body { constructor :: Constructor,
labels :: [Name], -- [] for a non-record datatype.
types :: [Type]} deriving (Eq,Show)
data Statement = DataStmt | NewTypeStmt deriving (Eq,Show)
type Name = String
type Var = String
type Class = String
type Constructor = String
type Rule = (Tag, Data->Doc)
-}
-- 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 2 . realToFrac . length) cs
in
instanceheader "Binary" dat $$
block ( zipWith3 (putfn k) [0..] cvs cs
++ getfn k [0..] cvs cs
: getFfn k [0..] cvs cs
: zipWith (sizefn k) cvs cs
)
putfn k n cv c =
text "put bh" <+> ppCons cv c <+> text "= do" $$
nest 8 (
text "pos <- putBits bh" <+> text (show k) <+> text (show n) $$
vcat (map (text "put bh" <+>) cv) $$
text "return pos"
)
ppCons cv c = mkpattern (constructor c) (types c) cv
getfn k ns cvs cs =
text "get bh = do" $$
nest 8 (
text "h <- getBits bh" <+> text (show k) $$
text "case h of" $$
nest 2 ( vcat $
zipWith3 (\n vs c-> text (show n) <+> text "-> do" $$
nest 6 (
vcat (map (\v-> v <+> text "<-" <+> text "get bh") vs) $$
text "return" <+> ppCons vs c
))
ns cvs cs ++ [ text "_ -> fail \"invalid binary data found\"" ]
)
)
getFfn k ns cvs cs =
text "getF bh p =" <+>
nest 8 (
text "let (h,p1) = getBitsF bh 1 p in" $$
text "case h of" $$
nest 2 ( vcat $
zipWith3 (\n vs c-> text (show n) <+> text "->" <+>
parens (cons c <> text ",p1") <+>
hsep (map (\_-> text "<< getF bh") vs))
ns cvs cs ++ [ text "_ -> fail \"invalid binary data found\"" ]
)
)
where cons = text . constructor
sizefn k [] c =
text "sizeOf" <+> ppCons [] c <+> text "=" <+> text (show k)
sizefn k cv c =
text "sizeOf" <+> ppCons cv c <+> text "=" <+> text (show k) <+> text "+" <+>
hsep (intersperse (text "+") (map (text "sizeOf" <+>) cv))
-- end of binary derivation