1 # coding: utf-8
2 # frozen_string_literal: true
3
4
5 # See; お気楽 Haskell プログラミング入門, 中級編 : 二分木と Lisp のリスト
6 # http://www.nct9.ne.jp/m_hiroi/func/haskell19b.html
7
8 module Umu
9
10 module Value
11
12 module Core
13
14 module SExpr
15
16 class Abstract < Object
17 def self.make(xs)
18 ASSERT.kind_of xs, ::Array
19
20 VC.make_s_expr xs
21 end
22
23
24 define_class_method(
25 :meth_make_nil,
26 :nil, [],
27 [], self
28 )
29 def self.meth_make_nil(_loc, _env, _event)
30 VC.make_s_expr_nil
31 end
32
33
34 define_class_method(
35 :meth_make_value,
36 :value, [],
37 [VC::Top], self
38 )
39 def self.meth_make_value(loc, env, event, val)
40 ASSERT.kind_of val, VC::Top
41
42 VC.make_s_expr_value val
43 end
44
45
46 define_class_method(
47 :meth_make_cons,
48 :cons, [],
49 [self, self], self
50 )
51 def self.meth_make_cons(loc, env, event, car, cdr)
52 ASSERT.kind_of car, VC::SExpr::Abstract
53 ASSERT.kind_of cdr, VC::SExpr::Abstract
54
55 VC.make_s_expr_cons car, cdr
56 end
57
58
59 define_class_method(
60 :meth_make,
61 :make, [],
62 [VCM::Abstract], self
63 )
64 def self.meth_make(loc, env, event, xs)
65 ASSERT.kind_of xs, VCM::Abstract
66
67 result = xs.foldr(
68 loc, env, event, VC.make_s_expr_nil
69 ) { |new_loc, new_env, x, s_expr|
70 value = VC.make_s_expr_value x
71
72 VC.make_s_expr_cons value, s_expr
73 }
74
75 ASSERT.kind_of result, VC::SExpr::Abstract
76 end
77
78
79 define_instance_method(
80 :meth_cons,
81 :cons, [],
82 [self], self
83 )
84 def meth_cons(_loc, _env, _event, car)
85 ASSERT.kind_of car, VC::SExpr::Abstract
86
87 VC.make_s_expr_cons car, self
88 end
89
90
91 def to_s
92 self.to_string({})
93 end
94
95
96 def pretty_print(q)
97 q.text self.to_s
98 end
99
100
101 define_instance_method(
102 :meth_is_nil,
103 :nil?, [],
104 [], VCA::Bool
105 )
106 def meth_is_nil(_loc, _env, _event)
107 VC.make_false
108 end
109
110
111 define_instance_method(
112 :meth_is_value,
113 :value?, [],
114 [], VCA::Bool
115 )
116 def meth_is_value(_loc, _env, _event)
117 VC.make_false
118 end
119
120
121 define_instance_method(
122 :meth_is_cons,
123 :cons?, [],
124 [], VCA::Bool
125 )
126 def meth_is_cons(_loc, _env, _event)
127 VC.make_false
128 end
129
130
131 def meth_to_string(loc, env, event)
132 VC.make_string self.to_string
133 end
134
135
136 def meth_to_s_expr(loc, env, event)
137 self
138 end
139 end
140 Abstract.freeze
141
142
143
144 class Nil < Abstract
145 TYPE_SYM = :SExprNil
146
147
148 def to_string(visiteds = {})
149 '%S()'
150 end
151
152
153 define_instance_method(
154 :meth_is_nil,
155 :nil?, [],
156 [], VCA::Bool
157 )
158 def meth_is_nil(_loc, _env, _event)
159 VC.make_true
160 end
161
162
163 define_instance_method(
164 :meth_is_equal,
165 :'==', [],
166 [VC::Top], VCA::Bool
167 )
168 def meth_is_equal(_loc, _env, _event, other)
169 ASSERT.kind_of other, VC::Top
170
171 VC.make_bool other.kind_of?(Nil)
172 end
173 end
174 Nil.freeze
175
176 NIL = Nil.new.freeze
177
178
179
180 class Value < Abstract
181 TYPE_SYM = :SExprValue
182
183
184 attr_reader :val
185
186 def initialize(val)
187 ASSERT.kind_of val, VC::Top
188
189 super()
190
191 @val = val
192 end
193
194
195 def to_string(visiteds = {})
196 format "%%V(%s)", self.val
197 end
198
199
200 def pretty_print(q)
201 PRT.group q, bb:'%V(', eb:')' do
202 q.pp self.val
203 end
204 end
205
206
207 define_instance_method(
208 :meth_is_value,
209 :value?, [],
210 [], VCA::Bool
211 )
212 def meth_is_value(_loc, _env, _event)
213 VC.make_true
214 end
215
216
217 def contents
218 self.val
219 end
220
221
222 define_instance_method(
223 :meth_contents,
224 :contents, [],
225 [], VC::Top
226 )
227 def meth_contents(_loc, _env, _event)
228 self.contents
229 end
230
231
232 define_instance_method(
233 :meth_is_equal,
234 :'==', [],
235 [VC::Top], VCA::Bool
236 )
237 def meth_is_equal(loc, env, event, other)
238 ASSERT.kind_of other, VC::Top
239
240 VC.make_bool(
241 other.kind_of?(Value) &&
242 self.val.meth_is_equal(loc, env, event, other.val).true?
243 )
244 end
245 end
246 Value.freeze
247
248
249
250 class Cons < Abstract
251 TYPE_SYM = :SExprCons
252
253
254 def initialize(car, cdr)
255 ASSERT.kind_of car, SExpr::Abstract
256 ASSERT.kind_of cdr, SExpr::Abstract
257
258 super()
259
260 @mutable_car = car
261 @mutable_cdr = cdr
262 end
263
264
265 def car
266 @mutable_car
267 end
268
269
270 def cdr
271 @mutable_cdr
272 end
273
274
275 def to_string(visiteds = {})
276 format("%%S(%s)",
277 if visiteds.has_key? self.object_id
278 '....'
279 else
280 __to_string__(
281 self,
282 visiteds.merge(self.object_id => true)
283 )
284 end
285 )
286 end
287
288
289 def pretty_print(q)
290 PRT.group q, bb:'%S(', eb:')' do
291 __pretty_print__ q, self
292 end
293 end
294
295
296 def pretty_print_cycle(q)
297 '(....)'
298 end
299
300
301 INDEX_BY_LABELS = {car: 0, cdr: 1}
302
303 def contents
304 VC.make_named_tuple INDEX_BY_LABELS, self.car, self.cdr
305 end
306
307
308 define_instance_method(
309 :meth_car,
310 :car, [],
311 [], VC::SExpr::Abstract
312 )
313 def meth_car(_loc, _env, _event)
314 self.car
315 end
316
317
318 define_instance_method(
319 :meth_cdr,
320 :cdr, [],
321 [], VC::SExpr::Abstract
322 )
323 def meth_cdr(_loc, _env, _event)
324 self.cdr
325 end
326
327
328 define_instance_method(
329 :meth_is_cons,
330 :cons?, [],
331 [], VCA::Bool
332 )
333 def meth_is_cons(_loc, _env, _event)
334 VC.make_true
335 end
336
337
338 define_instance_method(
339 :meth_contents,
340 :contents, [],
341 [], VCP::Named
342 )
343 def meth_contents(_loc, _env, _event)
344 self.contents
345 end
346
347
348 define_instance_method(
349 :meth_set_car!,
350 :'set-car!', [],
351 [SExpr::Abstract], VC::Unit
352 )
353 def meth_set_car!(_loc, _env, _event, car)
354 ASSERT.kind_of car, SExpr::Abstract
355
356 @mutable_car = car
357
358 VC.make_unit
359 end
360
361
362 define_instance_method(
363 :meth_set_cdr!,
364 :'set-cdr!', [],
365 [SExpr::Abstract], VC::Unit
366 )
367 def meth_set_cdr!(_loc, _env, _event, cdr)
368 ASSERT.kind_of cdr, SExpr::Abstract
369
370 @mutable_cdr = cdr
371
372 VC.make_unit
373 end
374
375
376 define_instance_method(
377 :meth_is_equal,
378 :'==', [],
379 [VC::Top], VCA::Bool
380 )
381 def meth_is_equal(loc, env, event, other)
382 ASSERT.kind_of other, VC::Top
383
384 VC.make_bool(
385 other.kind_of?(Cons) &&
386 self.car.meth_is_equal(loc, env, event, other.car).true? &&
387 self.cdr.meth_is_equal(loc, env, event, other.cdr).true?
388 )
389 end
390
391
392 private
393
394 def __to_string__(cons, visiteds = {})
395 ASSERT.kind_of cons, SExpr::Cons
396 ASSERT.kind_of visiteds, ::Hash
397
398 car = cons.car
399 car_str = if visiteds.has_key? car.object_id
400 '....'
401 else
402 cons.car.to_string(
403 visiteds.merge(self.object_id => true)
404 )
405 end
406
407
408 cdr = cons.cdr
409 cdr_str = case cdr
410 when SExpr::Nil
411 ''
412 when SExpr::Value
413 format " . %s", cdr.to_s
414 when SExpr::Cons
415 cddr_str = if visiteds.has_key? cdr.object_id
416 '....'
417 else
418 __to_string__(
419 cdr,
420 visiteds.merge(self.object_id => true)
421 )
422 end
423
424 ' ' + cddr_str
425 else
426 ASSERT.abort cdr.inspect
427 end
428
429 format "%s%s", car_str, cdr_str
430 end
431
432
433 def __pretty_print__(q, cons)
434 ASSERT.kind_of cons, SExpr::Cons
435
436 q.pp cons.car
437
438 cdr = cons.cdr
439 ASSERT.kind_of cdr, SExpr::Abstract
440
441 case cdr
442 when SExpr::Nil
443 # Nothing to do
444 when SExpr::Value
445 q.breakable
446
447 q.text '.'
448
449 q.breakable
450
451 q.pp cdr
452 when SExpr::Cons
453 q.breakable
454
455 __pretty_print__ q, cdr
456 else
457 ASSERT.abort cdr.inspect
458 end
459 end
460 end
461 Cons.freeze
462
463 end # Umu::Value::Core
464
465
466 module_function
467
468 def make_s_expr_nil
469 SExpr::NIL
470 end
471
472
473 def make_s_expr_value(val)
474 ASSERT.kind_of val, VC::Top
475
476 SExpr::Value.new(val).freeze
477 end
478
479
480 def make_s_expr_cons(car, cdr)
481 ASSERT.kind_of car, SExpr::Abstract
482 ASSERT.kind_of cdr, SExpr::Abstract
483
484 SExpr::Cons.new(car, cdr) # Does NOT freeze!!
485 end
486
487 end # Umu::Value::Core
488
489 end # Umu::Value
490
491 end # Umu