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
131
|
implementation module Data.GenCompress
// Samples for testing were taken from Clean Platform ...
// https://gitlab.science.ru.nl/clean-and-itasks/clean-platform
// ... but cut down for brevity.
// -- The following are some additions to test features not included in the sample:
literals =
( 'a', '\x61', '\0141', '\n'
, 17.42E3 // lower-case e or no digits before . are invalid!
, 17.42
, 0x11, 052, 3, 0x3ff
, ['charlist sugar'], [ 'may start with spaces']
, "escapes: \x11 \X11 \052 \d17 \D42 \n \" \' ' \\ "
, ['in a charlist: \x11 \X11 \052 \d17 \D42 \n \" \' " \\ ']
, "unicode: ° →"
)
/* Clean comments can be nested: /* like so */
* Furthermore, // in multiline comments ignore closing */ on the remainder
* Hence this is still part of the comment, and it only closes here: */
/**
* By convention, documentation is in comments starting with two asterisks ...
*/
//* ... or starting with an asterisk in the case of singleline documentation.
// -- end additions
import StdGeneric, StdEnv
from Data.Maybe import :: Maybe(..)
import Data._Array, Data.Func
//--------------------------------------------------
// uncompressor monad
ret :: !.a !u:CompressSt -> (!Maybe .a,!u:CompressSt)
ret a st = (Just a, st)
(>>=) infixl 5
(>>=) pa pb = bind pa pb
where
bind pa pb st
#! (ma, st) = pa st
= case ma of
Nothing -> (Nothing, st)
Just x -> pb x st
//--------------------------------------------------
:: BitVector :== {#Int}
:: BitPos :== Int
:: CompressSt = { cs_pos :: !Int, cs_bits :: !.{#Int} }
mkCompressSt arr = { cs_pos = 0, cs_bits = arr}
:: Compress a :== a -> *CompressSt -> *CompressSt
:: Uncompress a :== .CompressSt -> .(.(Maybe a), .CompressSt)
compressBool :: !Bool !*CompressSt -> *CompressSt
compressBool bit {cs_pos = pos, cs_bits = bits}
#! s = size bits
#! int_pos = pos >> (IF_INT_64_OR_32 6 5)
#! bit_pos = pos bitand (IF_INT_64_OR_32 63 31)
| s == int_pos
= abort "reallocate"
#! int = bits.[int_pos]
#! bit_mask = 1 << bit_pos
#! new_int = if bit (int bitor bit_mask) (int bitand (bitnot bit_mask))
= {cs_pos = inc pos, cs_bits = {bits & [int_pos] = new_int}}
realToBinary32 :: !Real -> (!Int,!Int);
realToBinary32 _ = code {
.d 0 1 r
pop_b 0 | don't do anything
.o 0 2 ii
};
// Alternatively, with inline code:
realToBinary32 _ = code inline {
no_op
};
uncompressArray :: (u:CompressSt -> ((Maybe v:a),w:CompressSt)) -> .(x:CompressSt -> ((Maybe y:(b v:a)),z:CompressSt)) | Array b a, [x w <= u,y <= v,x w <= z]
uncompressArray f
= uncompressInt >>= \s -> uncompress_array 0 s (unsafeCreateArray s)
where
uncompress_array i s arr
| i == s
= ret arr
= f >>= \x -> uncompress_array (inc i) s {arr & [i] = x}
compressList :: (a *CompressSt -> *CompressSt) ![a] -> *CompressSt -> *CompressSt
compressList c xs = compressArray c (list_to_arr xs)
where
list_to_arr :: [b] -> {b} | Array {} b
list_to_arr xs = {x \\ x <- xs}
generic gCompress a :: !a -> *CompressSt -> *CompressSt
gCompress{|Int|} x = compressInt x
gCompress{|EITHER|} cl cr (LEFT x) = cl x o compressBool False
gCompress{|{}|} c xs = compressArray c xs
gCompress{|{!}|} c xs = compressArray c xs
gCompress{|[]|} c xs = compressList c xs
generic gCompressedSize a :: a -> Int
gCompressedSize{|Int|} _ = IF_INT_64_OR_32 64 32
gCompressedSize{|PAIR|} cx cy (PAIR x y) = cx x + cy y
gCompressedSize{|[]|} c xs = foldSt (\x st -> c x + st) xs (IF_INT_64_OR_32 64 32)
gCompressedSize{|{}|} c xs = foldSt (\x st -> c x + st) [x\\x<-:xs] (IF_INT_64_OR_32 64 32)
gCompressedSize{|{!}|} c xs = foldSt (\x st -> c x + st) [x\\x<-:xs] (IF_INT_64_OR_32 64 32)
generic gUncompress a :: (u:CompressSt -> ((Maybe a),u:CompressSt))
gUncompress{|PAIR|} fx fy = fx >>= \x -> fy >>= \y -> ret (PAIR x y)
gUncompress{|CONS|} f = f >>= ret o CONS
gUncompress{|FIELD|} f = f >>= \x -> ret $ FIELD x
gUncompress{|OBJECT|} f = f >>= \x -> ret $ OBJECT x
//-------------------------------------------------------------------------------------
uncompress :: (BitVector -> Maybe a) | gUncompress{|*|} a
uncompress = fst o gUncompress{|*|} o mkCompressSt
compress :: !a -> BitVector | gCompressedSize{|*|} a & gCompress{|*|} a
compress x
#! compressed_size = gCompressedSize{|*|} x
#! arr_size = (compressed_size + (IF_INT_64_OR_32 63 31)) >> (IF_INT_64_OR_32 6 5)
#! bits = createArray arr_size 0
= (gCompress{|*|} x (mkCompressSt bits)).cs_bits
|
