guix/monads.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013, 2014, 2015, 2017, 2022 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (guix monads)
  20   #:use-module ((system syntax)
  21                 #:select (syntax-local-binding))
  22   #:use-module (ice-9 match)
  23   #:use-module (srfi srfi-1)
  24   #:use-module (srfi srfi-9)
  25   #:use-module (srfi srfi-26)
  26   #:export (;; Monads.
  27             define-monad
  28             monad?
  29             monad-bind
  30             monad-return
  31
  32             template-directory
  33
  34             ;; Syntax.
  35             >>=
  36             return
  37             with-monad
  38             mlet
  39             mlet*
  40             mbegin
  41             mwhen
  42             munless
  43             mparameterize
  44             lift0 lift1 lift2 lift3 lift4 lift5 lift6 lift7 lift
  45             listm
  46             foldm
  47             mapm
  48             sequence
  49             anym
  50
  51             ;; Concrete monads.
  52             %identity-monad
  53
  54             %state-monad
  55             state-return
  56             state-bind
  57             current-state
  58             set-current-state
  59             state-push
  60             state-pop
  61             run-with-state))
  62
  63 ;;; Commentary:
  64 ;;;
  65 ;;; This module implements the general mechanism of monads, and provides in
  66 ;;; particular an instance of the "state" monad.  The API was inspired by that
  67 ;;; of Racket's "better-monads" module (see
  68 ;;; <http://planet.racket-lang.org/package-source/toups/functional.plt/1/1/planet-docs/better-monads-guide/index.html>).
  69 ;;; The implementation and use case were influenced by Oleg Kysielov's
  70 ;;; "Monadic Programming in Scheme" (see
  71 ;;; <http://okmij.org/ftp/Scheme/monad-in-Scheme.html>).
  72 ;;;
  73 ;;; Code:
  74
  75 ;; Record type for monads manipulated at run time.
  76 (define-record-type <monad>
  77   (make-monad bind return)
  78   monad?
  79   (bind   monad-bind)
  80   (return monad-return))                         ; TODO: Add 'plus' and 'zero'
  81
  82 (define-syntax define-monad
  83   (lambda (s)
  84     "Define the monad under NAME, with the given bind and return methods."
  85     (define prefix (string->symbol "% "))
  86     (define (make-rtd-name name)
  87       (datum->syntax name
  88                      (symbol-append prefix (syntax->datum name) '-rtd)))
  89
  90     (syntax-case s (bind return)
  91       ((_ name (bind b) (return r))
  92        (with-syntax ((rtd (make-rtd-name #'name)))
  93          #`(begin
  94              (define rtd
  95                ;; The record type, for use at run time.
  96                (make-monad b r))
  97
  98              ;; Instantiate all the templates, specialized for this monad.
  99              (template-directory instantiations name)
 100
 101              (define-syntax name
 102                ;; An "inlined record", for use at expansion time.  The goal is
 103                ;; to allow 'bind' and 'return' to be resolved at expansion
 104                ;; time, in the common case where the monad is accessed
 105                ;; directly as NAME.
 106                (lambda (s)
 107                  (syntax-case s (%bind %return)
 108                    ((_ %bind)   #'b)
 109                    ((_ %return) #'r)
 110                    (_           #'rtd))))))))))
 111
 112 ;; Expansion- and run-time state of the template directory.  This needs to be
 113 ;; available at run time (and not just at expansion time) so we can
 114 ;; instantiate templates defined in other modules, or use instances defined
 115 ;; elsewhere.
 116 (eval-when (load expand eval)
 117   ;; Mapping of syntax objects denoting the template to a pair containing (1)
 118   ;; the syntax object of the parameter over which it is templated, and (2)
 119   ;; the syntax of its body.
 120   (define-once %templates (make-hash-table))
 121
 122   (define (register-template! name param body)
 123     (hash-set! %templates name (cons param body)))
 124
 125   ;; List of template instances, where each entry is a triplet containing the
 126   ;; syntax of the name, the actual parameter for which the template is
 127   ;; specialized, and the syntax object referring to this specialization (the
 128   ;; procedure's identifier.)
 129   (define-once %template-instances '())
 130
 131   (define (register-template-instance! name actual instance)
 132     (set! %template-instances
 133       (cons (list name actual instance) %template-instances))))
 134
 135 (define-syntax template-directory
 136   (lambda (s)
 137     "This is a \"stateful macro\" to register and lookup templates and
 138 template instances."
 139     (define location
 140       (syntax-source s))
 141
 142     (define current-info-port
 143       ;; Port for debugging info.
 144       (const (%make-void-port "w")))
 145
 146     (define location-string
 147       (format #f "~a:~a:~a"
 148               (assq-ref location 'filename)
 149               (and=> (assq-ref location 'line) 1+)
 150               (assq-ref location 'column)))
 151
 152     (define (matching-instance? name actual)
 153       (match-lambda
 154         ((name* instance-param proc)
 155          (and (free-identifier=? name name*)
 156               (or (equal? actual instance-param)
 157                   (and (identifier? actual)
 158                        (identifier? instance-param)
 159                        (free-identifier=? instance-param
 160                                           actual)))
 161               proc))))
 162
 163     (define (instance-identifier name actual)
 164       (define stem
 165         (string-append
 166          " "
 167          (symbol->string (syntax->datum name))
 168          (if (identifier? actual)
 169              (string-append " " (symbol->string (syntax->datum actual)))
 170              "")
 171          " instance"))
 172       (datum->syntax actual (string->symbol stem)))
 173
 174     (define (instance-definition name template actual)
 175       (match template
 176         ((formal . body)
 177          (let ((instance (instance-identifier name actual)))
 178            (format (current-info-port)
 179                    "~a: info: specializing '~a' for '~a' as '~a'~%"
 180                    location-string
 181                    (syntax->datum name) (syntax->datum actual)
 182                    (syntax->datum instance))
 183
 184            (register-template-instance! name actual instance)
 185
 186            #`(begin
 187                (define #,instance
 188                  (let-syntax ((#,formal (identifier-syntax #,actual)))
 189                    #,body))
 190
 191                ;; Generate code to register the thing at run time.
 192                (register-template-instance! #'#,name #'#,actual
 193                                             #'#,instance))))))
 194
 195     (syntax-case s (register! lookup exists? instantiations)
 196       ((_ register! name param body)
 197        ;; Register NAME as a template on PARAM with the given BODY.
 198        (begin
 199          (register-template! #'name #'param #'body)
 200
 201          ;; Generate code to register the template at run time.  XXX: Because
 202          ;; of this, BODY must not contain ellipses.
 203          #'(register-template! #'name #'param #'body)))
 204       ((_ lookup name actual)
 205        ;; Search for an instance of template NAME for this ACTUAL parameter.
 206        ;; On success, expand to the identifier of the instance; otherwise
 207        ;; expand to #f.
 208        (any (matching-instance? #'name #'actual) %template-instances))
 209       ((_ exists? name actual)
 210        ;; Likewise, but return a Boolean.
 211        (let ((result (->bool
 212                       (any (matching-instance? #'name #'actual)
 213                            %template-instances))))
 214          (unless result
 215            (format (current-warning-port)
 216                    "~a: warning: no specialization of template '~a' for '~a'~%"
 217                    location-string
 218                    (syntax->datum #'name) (syntax->datum #'actual)))
 219          result))
 220       ((_ instantiations actual)
 221        ;; Expand to the definitions of all the existing templates
 222        ;; specialized for ACTUAL.
 223        #`(begin
 224            #,@(hash-map->list (cut instance-definition <> <> #'actual)
 225                               %templates))))))
 226
 227 (define-syntax define-template
 228   (lambda (s)
 229     "Define a template, which is a procedure that can be specialized over its
 230 first argument.  In our case, the first argument is typically the identifier
 231 of a monad.
 232
 233 Defining templates for procedures like 'mapm' allows us to make have a
 234 specialized version of those procedures for each monad that we define, such
 235 that calls to:
 236
 237   (mapm %state-monad proc lst)
 238
 239 automatically expand to:
 240
 241   (#{ mapm %state-monad instance}# proc lst)
 242
 243 Here, #{ mapm %state-monad instance}# is specialized for %state-monad, and
 244 thus it contains inline calls to %state-bind and %state-return.  This avoids
 245 repeated calls to 'struct-ref' to get the 'bind' and 'return' procedure of the
 246 monad, and allows 'bind' and 'return' to be inlined, which in turn allows for
 247 more optimizations."
 248     (syntax-case s ()
 249       ((_ (name arg0 args ...) body ...)
 250        (with-syntax ((generic-name (datum->syntax
 251                                     #'name
 252                                     (symbol-append '#{ %}#
 253                                                    (syntax->datum #'name)
 254                                                    '-generic)))
 255                      (original-name #'name))
 256          #`(begin
 257              (template-directory register! name arg0
 258                                  (lambda (args ...)
 259                                    body ...))
 260              (define (generic-name arg0 args ...)
 261                ;; The generic instance of NAME, for when no specialization was
 262                ;; found.
 263                body ...)
 264
 265              (define-syntax name
 266                (lambda (s)
 267                  (syntax-case s ()
 268                    ((_ arg0* args ...)
 269                     ;; Expand to either the specialized instance or the
 270                     ;; generic instance of template ORIGINAL-NAME.
 271                     #'(if (template-directory exists? original-name arg0*)
 272                           ((template-directory lookup original-name arg0*)
 273                            args ...)
 274                           (generic-name arg0* args ...)))
 275                    (_
 276                     #'generic-name))))))))))
 277
 278 (define-syntax-parameter >>=
 279   ;; The name 'bind' is already taken, so we choose this (obscure) symbol.
 280   (lambda (s)
 281     (syntax-violation '>>= ">>= (bind) used outside of 'with-monad'" s)))
 282
 283 (define-syntax-parameter return
 284   (lambda (s)
 285     (syntax-violation 'return "return used outside of 'with-monad'" s)))
 286
 287 (define-syntax-rule (bind-syntax bind)
 288   "Return a macro transformer that handles the expansion of '>>=' expressions
 289 using BIND as the binary bind operator.
 290
 291 This macro exists to allow the expansion of n-ary '>>=' expressions, even
 292 though BIND is simply binary, as in:
 293
 294   (with-monad %state-monad
 295     (>>= (return 1)
 296          (lift 1+ %state-monad)
 297          (lift 1+ %state-monad)))
 298 "
 299   (lambda (stx)
 300     (define (expand body)
 301       (syntax-case body ()
 302         ((_ mval mproc)
 303          #'(bind mval mproc))
 304         ((x mval mproc0 mprocs (... ...))
 305          (expand #'(>>= (>>= mval mproc0)
 306                         mprocs (... ...))))))
 307
 308     (expand stx)))
 309
 310 (define-syntax with-monad
 311   (lambda (s)
 312     "Evaluate BODY in the context of MONAD, and return its result."
 313     (syntax-case s ()
 314       ((_ monad body ...)
 315        (eq? 'macro (syntax-local-binding #'monad))
 316        ;; MONAD is a syntax transformer, so we can obtain the bind and return
 317        ;; methods by directly querying it.
 318        #'(syntax-parameterize ((>>=    (bind-syntax (monad %bind)))
 319                                (return (identifier-syntax (monad %return))))
 320            body ...))
 321       ((_ monad body ...)
 322        ;; MONAD refers to the <monad> record that represents the monad at run
 323        ;; time, so use the slow method.
 324        #'(syntax-parameterize ((>>=    (bind-syntax
 325                                         (monad-bind monad)))
 326                                (return (identifier-syntax
 327                                         (monad-return monad))))
 328            body ...)))))
 329
 330 (define-syntax mlet*
 331   (syntax-rules (->)
 332     "Bind the given monadic values MVAL to the given variables VAR.  When the
 333 form is (VAR -> VAL), bind VAR to the non-monadic value VAL in the same way as
 334 'let'."
 335     ;; Note: the '->' symbol corresponds to 'is:' in 'better-monads.rkt'.
 336     ((_ monad () body ...)
 337      (with-monad monad body ...))
 338     ((_ monad ((var mval) rest ...) body ...)
 339      (with-monad monad
 340        (>>= mval
 341             (lambda (var)
 342               (mlet* monad (rest ...)
 343                 body ...)))))
 344     ((_ monad ((var -> val) rest ...) body ...)
 345      (let ((var val))
 346        (mlet* monad (rest ...)
 347          body ...)))))
 348
 349 (define-syntax mlet
 350   (lambda (s)
 351     (syntax-case s ()
 352       ((_ monad ((var mval ...) ...) body ...)
 353        (with-syntax (((temp ...) (generate-temporaries #'(var ...))))
 354          #'(mlet* monad ((temp mval ...) ...)
 355              (let ((var temp) ...)
 356                body ...)))))))
 357
 358 (define-syntax mbegin
 359   (syntax-rules (%current-monad)
 360     "Bind MEXP and the following monadic expressions in sequence, returning
 361 the result of the last expression.  Every expression in the sequence must be a
 362 monadic expression."
 363     ((_ %current-monad mexp)
 364      mexp)
 365     ((_ %current-monad mexp rest ...)
 366      (>>= mexp
 367           (lambda (unused-value)
 368             (mbegin %current-monad rest ...))))
 369     ((_ monad mexp)
 370      (with-monad monad
 371        mexp))
 372     ((_ monad mexp rest ...)
 373      (with-monad monad
 374        (>>= mexp
 375             (lambda (unused-value)
 376               (mbegin monad rest ...)))))))
 377
 378 (define-syntax mwhen
 379   (syntax-rules ()
 380     "When CONDITION is true, evaluate the sequence of monadic expressions
 381 MEXP0..MEXP* as in an 'mbegin'.  When CONDITION is false, return *unspecified*
 382 in the current monad.  Every expression in the sequence must be a monadic
 383 expression."
 384     ((_ condition mexp0 mexp* ...)
 385      (if condition
 386          (mbegin %current-monad
 387            mexp0 mexp* ...)
 388          (return *unspecified*)))))
 389
 390 (define-syntax munless
 391   (syntax-rules ()
 392     "When CONDITION is false, evaluate the sequence of monadic expressions
 393 MEXP0..MEXP* as in an 'mbegin'.  When CONDITION is true, return *unspecified*
 394 in the current monad.  Every expression in the sequence must be a monadic
 395 expression."
 396     ((_ condition mexp0 mexp* ...)
 397      (if condition
 398          (return *unspecified*)
 399          (mbegin %current-monad
 400            mexp0 mexp* ...)))))
 401
 402 (define-syntax mparameterize
 403   (syntax-rules ()
 404     "This form implements dynamic scoping, similar to 'parameterize', but in a
 405 monadic context."
 406     ((_ monad ((parameter value) rest ...) body ...)
 407      (let ((old-value (parameter)))
 408        (mbegin monad
 409          ;; XXX: Non-local exits are not correctly handled.
 410          (return (parameter value))
 411          (mlet monad ((result (mparameterize monad (rest ...) body ...)))
 412            (parameter old-value)
 413            (return result)))))
 414     ((_ monad () body ...)
 415      (mbegin monad body ...))))
 416
 417 (define-syntax define-lift
 418   (syntax-rules ()
 419     ((_ liftn (args ...))
 420      (define-syntax liftn
 421        (lambda (s)
 422          "Lift PROC to MONAD---i.e., return a monadic function in MONAD."
 423          (syntax-case s ()
 424            ((liftn proc monad)
 425             ;; Inline the result of lifting PROC, such that 'return' can in
 426             ;; turn be open-coded.
 427             #'(lambda (args ...)
 428                 (with-monad monad
 429                   (return (proc args ...)))))
 430            (id
 431             (identifier? #'id)
 432             ;; Slow path: Return a closure-returning procedure (we don't
 433             ;; guarantee (eq? LIFTN LIFTN), but that's fine.)
 434             #'(lambda (proc monad)
 435                 (lambda (args ...)
 436                   (with-monad monad
 437                     (return (proc args ...))))))))))))
 438
 439 (define-lift lift0 ())
 440 (define-lift lift1 (a))
 441 (define-lift lift2 (a b))
 442 (define-lift lift3 (a b c))
 443 (define-lift lift4 (a b c d))
 444 (define-lift lift5 (a b c d e))
 445 (define-lift lift6 (a b c d e f))
 446 (define-lift lift7 (a b c d e f g))
 447
 448 (define (lift proc monad)
 449   "Lift PROC, a procedure that accepts an arbitrary number of arguments, to
 450 MONAD---i.e., return a monadic function in MONAD."
 451   (lambda args
 452     (with-monad monad
 453       (return (apply proc args)))))
 454
 455 (define-template (foldm monad mproc init lst)
 456   "Fold MPROC over LST and return a monadic value seeded by INIT.
 457
 458   (foldm %state-monad (lift2 cons %state-monad) '() '(a b c))
 459   => '(c b a)  ;monadic
 460 "
 461   (with-monad monad
 462     (let loop ((lst    lst)
 463                (result init))
 464       (match lst
 465         (()
 466          (return result))
 467         ((head . tail)
 468          (>>= (mproc head result)
 469               (lambda (result)
 470                 (loop tail result))))))))
 471
 472 (define-template (mapm monad mproc lst)
 473   "Map MPROC over LST and return a monadic list.
 474
 475   (mapm %state-monad (lift1 1+ %state-monad) '(0 1 2))
 476   => (1 2 3)  ;monadic
 477 "
 478   ;; XXX: We don't use 'foldm' because template specialization wouldn't work
 479   ;; in this context.
 480   (with-monad monad
 481     (let mapm ((lst    lst)
 482                (result '()))
 483       (match lst
 484         (()
 485          (return (reverse result)))
 486         ((head . tail)
 487          (>>= (mproc head)
 488               (lambda (head)
 489                 (mapm tail (cons head result)))))))))
 490
 491 (define-template (sequence monad lst)
 492   "Turn the list of monadic values LST into a monadic list of values, by
 493 evaluating each item of LST in sequence."
 494   (with-monad monad
 495     (let seq ((lstx   lst)
 496               (result '()))
 497       (match lstx
 498         (()
 499          (return (reverse result)))
 500         ((head . tail)
 501          (>>= head
 502               (lambda (item)
 503                 (seq tail (cons item result)))))))))
 504
 505 (define-template (anym monad mproc lst)
 506   "Apply MPROC to the list of values LST; return as a monadic value the first
 507 value for which MPROC returns a true monadic value or #f.  For example:
 508
 509   (anym %state-monad (lift1 odd? %state-monad) '(0 1 2))
 510   => #t   ;monadic
 511 "
 512   (with-monad monad
 513     (let loop ((lst lst))
 514       (match lst
 515         (()
 516          (return #f))
 517         ((head . tail)
 518          (>>= (mproc head)
 519               (lambda (result)
 520                 (if result
 521                     (return result)
 522                     (loop tail)))))))))
 523
 524 (define-syntax listm
 525   (lambda (s)
 526     "Return a monadic list in MONAD from the monadic values MVAL."
 527     (syntax-case s ()
 528       ((_ monad mval ...)
 529        (with-syntax (((val ...) (generate-temporaries #'(mval ...))))
 530          #'(mlet monad ((val mval) ...)
 531              (return (list val ...))))))))
 532
 533
 534 \f
 535 ;;;
 536 ;;; Identity monad.
 537 ;;;
 538
 539 (define-inlinable (identity-return value)
 540   value)
 541
 542 (define-inlinable (identity-bind mvalue mproc)
 543   (mproc mvalue))
 544
 545 (define-monad %identity-monad
 546   (bind   identity-bind)
 547   (return identity-return))
 548
 549 \f
 550 ;;;
 551 ;;; State monad.
 552 ;;;
 553
 554 (define-inlinable (state-return value)
 555   (lambda (state)
 556     (values value state)))
 557
 558 (define-inlinable (state-bind mvalue mproc)
 559   "Bind MVALUE, a value in the state monad, and pass it to MPROC."
 560   (lambda (state)
 561     (call-with-values
 562         (lambda ()
 563           (mvalue state))
 564       (lambda (value state)
 565         ;; Note: as of Guile 2.0.11, declaring a variable to hold the result
 566         ;; of (mproc value) prevents a bit of unfolding/inlining.
 567         ((mproc value) state)))))
 568
 569 (define-monad %state-monad
 570   (bind state-bind)
 571   (return state-return))
 572
 573 (define* (run-with-state mval #:optional (state '()))
 574   "Run monadic value MVAL starting with STATE as the initial state.  Return
 575 two values: the resulting value, and the resulting state."
 576   (mval state))
 577
 578 (define-inlinable (current-state)
 579   "Return the current state as a monadic value."
 580   (lambda (state)
 581     (values state state)))
 582
 583 (define-inlinable (set-current-state value)
 584   "Set the current state to VALUE and return the previous state as a monadic
 585 value."
 586   (lambda (state)
 587     (values state value)))
 588
 589 (define (state-pop)
 590   "Pop a value from the current state and return it as a monadic value.  The
 591 state is assumed to be a list."
 592   (lambda (state)
 593     (match state
 594       ((head . tail)
 595        (values head tail)))))
 596
 597 (define (state-push value)
 598   "Push VALUE to the current state, which is assumed to be a list, and return
 599 the previous state as a monadic value."
 600   (lambda (state)
 601     (values state (cons value state))))
 602
 603 ;;; monads.scm end here