guix/monads.scm

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