Last active
November 28, 2023 13:02
-
-
Save kisp/27d67356d155058f603ad90b71eb66f1 to your computer and use it in GitHub Desktop.
Defining an algebraic data type in SBCL using defstruct, deftype, and trivia:match: data Maybe a = Nothing | Just a
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
(in-package :cl-user) | |
;; (ql:quickload '("alexandria" "trivia")) | |
;; Let's define maybe as an algebraic data type. | |
(defstruct (nothing (:constructor nothing ()))) | |
(defstruct (just (:constructor just (value))) value) | |
(deftype maybe () '(or nothing just)) | |
;; (>>=) :: Monad m => m a -> (a -> m b) -> m b | |
(defun bind (a b) | |
(declare (optimize speed (safety 0) (debug 0))) | |
(declare (type maybe a) | |
(type function b)) | |
(trivia:match a | |
((nothing) (nothing)) | |
((just value) (funcall b value)))) | |
;;; trivia does a nice job here matching our maybe type defined as (or | |
;;; nothing just). Note that we are using trivia:match, not | |
;;; trivia:ematch. trivia:match would return NIL if none of the | |
;;; clauses matches. The disassembly of bind below shows, however, | |
;;; that we have code that will match exactly a nothing or a just | |
;;; value. -- Well, the heavy lifting probably comes from the | |
;;; underlying SBCL compiler. | |
;; (disassemble 'bind) | |
;; ; disassembly for BIND | |
;; ; Size: 37 bytes. Origin: #x537A4679 ; BIND | |
;; ; 79: 8B5A01 MOV EBX, [RDX+1] | |
;; ; 7C: 817B4D56010000 CMP DWORD PTR [RBX+77], 342 | |
;; ; 83: 740F JEQ L0 | |
;; ; 85: 488B5205 MOV RDX, [RDX+5] | |
;; ; 89: B902000000 MOV ECX, 2 | |
;; ; 8E: FF7508 PUSH QWORD PTR [RBP+8] | |
;; ; 91: FF60FD JMP [RAX-3] | |
;; ; 94: L0: 31C9 XOR ECX, ECX | |
;; ; 96: FF7508 PUSH QWORD PTR [RBP+8] | |
;; ; 99: E9A4E0B7FC JMP #x50322742 ; #<FDEFN NOTHING> | |
;;; Probably (nothing) should be changed to return a constant +nothing+ | |
;;; value. | |
(defun nothing= (a b) | |
(and (nothing-p a) (nothing-p b))) | |
(alexandria:define-constant +nothing+ (nothing) :test #'nothing=) | |
;; And then we can also have: | |
(define-compiler-macro nothing () '+nothing+) | |
;;; This would give for bind (removing the JMP to #<FDEFN NOTHING>): | |
;; (disassemble 'bind) | |
;; ; disassembly for BIND | |
;; ; Size: 37 bytes. Origin: #x5379B609 ; BIND | |
;; ; 09: 8B5A01 MOV EBX, [RDX+1] | |
;; ; 0C: 817B4D56010000 CMP DWORD PTR [RBX+77], 342 | |
;; ; 13: 740F JEQ L0 | |
;; ; 15: 488B5205 MOV RDX, [RDX+5] | |
;; ; 19: B902000000 MOV ECX, 2 | |
;; ; 1E: FF7508 PUSH QWORD PTR [RBP+8] | |
;; ; 21: FF60FD JMP [RAX-3] | |
;; ; 24: L0: 488B15B5FFFFFF MOV RDX, [RIP-75] ; #S(NOTHING) | |
;; ; 2B: C9 LEAVE | |
;; ; 2C: F8 CLC | |
;; ; 2D: C3 RET | |
;; return :: Monad m => a -> m a | |
(defun result (a) (just a)) | |
;; fromJust :: Maybe a -> a | |
(defun from-just (a) | |
(declare (type maybe a)) | |
(trivia:ematch a | |
((just value) value))) | |
(assert (eql 126 (from-just (bind (result 123) (lambda (x) (result (+ x 3))))))) | |
(assert (nothing-p (bind (nothing) (lambda (x) (result (+ x 3)))))) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment