git @ Cat's Eye Technologies define-opaque / master eg / proper-list.scm
master

Tree @master (Download .tar.gz)

proper-list.scm @master — raw · history · blame 

  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
; SPDX-FileCopyrightText: In 2023, Chris Pressey, the original author of this work, placed it into the public domain.
; For more information, please refer to <https://unlicense.org/>
; SPDX-License-Identifier: Unlicense

; example usage with Chicken Scheme: csi -q -b proper-list.scm

(load "define-opaque-0.3.scm")

; Define a "proper list" data structure, which is either:
; a) nil, or
; b) a cons cell where the tail contains a proper list.

; Part 1.  We'll use `define-opaque-object`, which will get us partway there,
; but as we'll show later, is insufficient to guarantee the proper list property.

(define-opaque-object proper-list make-proper-list (selector value) ('nil 0)
  (
    (proper-list? (lambda ()
      #t))
    (nil (lambda ()
      (make-proper-list 'nil 0)))
    (cons (lambda (head-value tail-value)
      ; NB this is not hugely great, as it's a kind of duck-typing.
      (if (tail-value 'proper-list?)
        (make-proper-list 'cons (cons head-value tail-value))
        (error "Tail is not a proper list: " tail-value))))
    (repr (lambda ()
      (cond
        ((equal? selector 'nil)
          '())
        ((equal? selector 'cons)
          (let* ((head (car value)) (tail (cdr value)))
            (cons head (tail 'repr)))))))
  )
)

(define demo1 (lambda ()
  (let* (
    (list0 (proper-list 'cons 123 (proper-list 'cons 456 (proper-list 'nil))))
  )
    (display (list0 'repr)) (newline)
  )))

(demo1)

(define errorful-demo1 (lambda ()
  (let* (
    (list0 (proper-list 'cons 123 (proper-list 'cons 456 (proper-list 'nil))))
  )
    (display (proper-list 'cons 123 456))
  )))

; Part 2.  Show that we can forge a bogus proper list and trick our
; proper list object into allowing creation of an improper list.

(define-opaque-object forged-list make-forged-list (dummy) (#f)
  (
    (proper-list? (lambda ()
      #t))                 ; lies!
    (repr (lambda ()
      42))                 ; not a list at all
  )
)

(define forgery forged-list)

(define demo2 (lambda ()
  (let* (
    (list0 (proper-list 'cons 123 (proper-list 'cons 456 (proper-list 'nil))))
    (bad-list (proper-list 'cons 789 forgery))
  )
    ; notice the tail is not a list or nil
    (display (bad-list 'repr)) (newline))
))

(demo2)

; Part 3.  Define a proper list data structure using `define-opaque-adt`
; and show that it enforces the desired property of proper lists.

(define-opaque-adt proper-list-adt make-proper-list-adt open-proper-list-adt
  priv '(nil . 0)
  (
    (nil (lambda ()
      (make-proper-list-adt '(nil . 0))))
    (cons (lambda (head-value tail-value)
      (let* ((tail-priv (open-proper-list-adt tail-value)))
        (make-proper-list-adt (cons 'cons (cons head-value tail-value))))))
    (repr (lambda ()
      (cond
        ((equal? (car priv) 'nil)
          '())
        ((equal? (car priv) 'cons)
          (let* ((head (car (cdr priv))) (tail (cdr (cdr priv))))
            (cons head (tail 'repr)))))))
  )
)

(define demo3 (lambda ()
  (let* (
    (list0 (proper-list-adt 'cons 123 (proper-list-adt 'cons 456 (proper-list-adt 'nil))))
  )
    (display (list0 'repr)) (newline))
))

(demo3)

(define errorful-demo3 (lambda ()
  (let* (
    (list0 (proper-list-adt 'cons 123 (proper-list-adt 'cons 456 (proper-list-adt 'nil))))
  )
    (proper-list-adt 'cons 789 forgery))
))