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
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
|
module serialize3Start
/*
Definitions for assignment 3 in AFP 2017
Kind indexed gennerics
Pieter Koopman, pieter@cs.ru.nl
September 2017
use environment: StdMaybe from Libraries/StdLib
*/
import StdEnv, StdMaybe
:: Write a :== a [String] -> [String]
:: Read a :== [String] -> Maybe (a,[String])
// use this as serialize0 for kind *
class serialize a where
write :: a [String] -> [String]
read :: [String] -> Maybe (a,[String])
// ---
instance serialize Bool where
write b c = [toString b:c]
read ["True":r] = Just (True,r)
read ["False":r] = Just (False,r)
read _ = Nothing
instance serialize Int where
write i c = [toString i:c]
read [s:r]
# i = toInt s
| s == toString i
= Just (i,r)
= Nothing
read _ = Nothing
// ---
:: UNIT = UNIT
:: EITHER a b = LEFT a | RIGHT b
:: PAIR a b = PAIR a b
:: CONS a = CONS String a
// ---
:: ListG a :== EITHER (CONS UNIT) (CONS (PAIR a [a]))
fromList :: [a] -> ListG a
fromList [] = LEFT (CONS NilString UNIT)
fromList [a:x] = RIGHT (CONS ConsString (PAIR a x))
toList :: (ListG a) -> [a]
toList (LEFT (CONS NilString UNIT)) = []
toList (RIGHT (CONS ConsString (PAIR a x))) = [a:x]
NilString :== "Nil"
ConsString :== "Cons"
instance serialize [a] | serialize a where
write a s = s
read s = Nothing
// ---
:: Bin a = Leaf | Bin (Bin a) a (Bin a)
:: BinG a :== EITHER (CONS UNIT) (CONS (PAIR (Bin a) (PAIR a (Bin a))))
fromBin :: (Bin a) -> BinG a
fromBin Leaf = LEFT (CONS LeafString UNIT)
fromBin (Bin l a r) = RIGHT (CONS BinString (PAIR l (PAIR a r)))
toBin :: (BinG a) -> Bin a
toBin (LEFT (CONS _ UNIT)) = Leaf
toBin (RIGHT (CONS _ (PAIR l (PAIR a r)))) = Bin l a r
LeafString :== "Leaf"
BinString :== "Bin"
instance == (Bin a) | == a where
(==) Leaf Leaf = True
(==) (Bin l a r) (Bin k b s) = l == k && a == b && r == s
(==) _ _ = False
instance serialize (Bin a) | serialize a where
write b s = s
read l = Nothing
// ---
:: Coin = Head | Tail
:: CoinG :== EITHER (CONS UNIT) (CONS UNIT)
fromCoin :: Coin -> CoinG
fromCoin Head = LEFT (CONS "Head" UNIT)
fromCoin Tail = RIGHT (CONS "Tail" UNIT)
toCoin :: CoinG -> Coin
toCoin (LEFT (CONS _ UNIT)) = Head
toCoin (RIGHT (CONS _ UNIT)) = Tail
instance == Coin where
(==) Head Head = True
(==) Tail Tail = True
(==) _ _ = False
instance serialize Coin where
write c s = s
read l = Nothing
/*
Define a special purpose version for this type that writes and reads
the value (7,True) as ["(","7",",","True",")"]
*/
instance serialize (a,b) | serialize a & serialize b where
write (a,b) c = c
read _ = Nothing
// ---
// output looks nice if compiled with "Basic Values Only" for console in project options
Start =
[test True
,test False
,test 0
,test 123
,test -36
,test [42]
,test [0..4]
,test [[True],[]]
,test [[[1]],[[2],[3,4]],[[]]]
,test (Bin Leaf True Leaf)
,test [Bin (Bin Leaf [1] Leaf) [2] (Bin Leaf [3] (Bin Leaf [4,5] Leaf))]
,test [Bin (Bin Leaf [1] Leaf) [2] (Bin Leaf [3] (Bin (Bin Leaf [4,5] Leaf) [6,7] (Bin Leaf [8,9] Leaf)))]
,test Head
,test Tail
,test (7,True)
,test (Head,(7,[Tail]))
,["End of the tests.\n"]
]
test :: a -> [String] | serialize, == a
test a =
(if (isJust r)
(if (fst jr == a)
(if (isEmpty (tl (snd jr)))
["Oke"]
["Not all input is consumed! ":snd jr])
["Wrong result: ":write (fst jr) []])
["read result is Nothing"]
) ++ [", write produces: ": s]
where
s = write a ["\n"]
r = read s
jr = fromJust r
|
