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-parameter >>=
 278   ;; The name 'bind' is already taken, so we choose this (obscure) symbol.
 279   (lambda (s)
 280     (syntax-violation '>>= ">>= (bind) used outside of 'with-monad'" s)))
 281
 282 (define-syntax-parameter return
 283   (lambda (s)
 284     (syntax-violation 'return "return used outside of 'with-monad'" s)))
 285
 286 (define-syntax-rule (bind-syntax bind)
 287   "Return a macro transformer that handles the expansion of '>>=' expressions
 288 using BIND as the binary bind operator.
 289
 290 This macro exists to allow the expansion of n-ary '>>=' expressions, even
 291 though BIND is simply binary, as in:
 292
 293   (with-monad %state-monad
 294     (>>= (return 1)
 295          (lift 1+ %state-monad)
 296          (lift 1+ %state-monad)))
 297 "
 298   (lambda (stx)
 299     (define (expand body)
 300       (syntax-case body ()
 301         ((_ mval mproc)
 302          #'(bind mval mproc))
 303         ((x mval mproc0 mprocs (... ...))
 304          (expand #'(>>= (>>= mval mproc0)
 305                         mprocs (... ...))))))
 306
 307     (expand stx)))
 308
 309 (define-syntax with-monad
 310   (lambda (s)
 311     "Evaluate BODY in the context of MONAD, and return its result."
 312     (syntax-case s ()
 313       ((_ monad body ...)
 314        (eq? 'macro (syntax-local-binding #'monad))
 315        ;; MONAD is a syntax transformer, so we can obtain the bind and return
 316        ;; methods by directly querying it.
 317        #'(syntax-parameterize ((>>=    (bind-syntax (monad %bind)))
 318                                (return (identifier-syntax (monad %return))))
 319            body ...))
 320       ((_ monad body ...)
 321        ;; MONAD refers to the <monad> record that represents the monad at run
 322        ;; time, so use the slow method.
 323        #'(syntax-parameterize ((>>=    (bind-syntax
 324                                         (monad-bind monad)))
 325                                (return (identifier-syntax
 326                                         (monad-return monad))))
 327            body ...)))))
 328
 329 (define-syntax mlet*
 330   (syntax-rules (->)
 331     "Bind the given monadic values MVAL to the given variables VAR.  When the
 332 form is (VAR -> VAL), bind VAR to the non-monadic value VAL in the same way as
 333 'let'."
 334     ;; Note: the '->' symbol corresponds to 'is:' in 'better-monads.rkt'.
 335     ((_ monad () body ...)
 336      (with-monad monad body ...))
 337     ((_ monad ((var mval) rest ...) body ...)
 338      (with-monad monad
 339        (>>= mval
 340             (lambda (var)
 341               (mlet* monad (rest ...)
 342                 body ...)))))
 343     ((_ monad ((var -> val) rest ...) body ...)
 344      (let ((var val))
 345        (mlet* monad (rest ...)
 346          body ...)))))
 347
 348 (define-syntax mlet
 349   (lambda (s)
 350     (syntax-case s ()
 351       ((_ monad ((var mval ...) ...) body ...)
 352        (with-syntax (((temp ...) (generate-temporaries #'(var ...))))
 353          #'(mlet* monad ((temp mval ...) ...)
 354              (let ((var temp) ...)
 355                body ...)))))))
 356
 357 (define-syntax mbegin
 358   (syntax-rules (%current-monad)
 359     "Bind MEXP and the following monadic expressions in sequence, returning
 360 the result of the last expression.  Every expression in the sequence must be a
 361 monadic expression."
 362     ((_ %current-monad mexp)
 363      mexp)
 364     ((_ %current-monad mexp rest ...)
 365      (>>= mexp
 366           (lambda (unused-value)
 367             (mbegin %current-monad rest ...))))
 368     ((_ monad mexp)
 369      (with-monad monad
 370        mexp))
 371     ((_ monad mexp rest ...)
 372      (with-monad monad
 373        (>>= mexp
 374             (lambda (unused-value)
 375               (mbegin monad rest ...)))))))
 376
 377 (define-syntax mwhen
 378   (syntax-rules ()
 379     "When CONDITION is true, evaluate the sequence of monadic expressions
 380 MEXP0..MEXP* as in an 'mbegin'.  When CONDITION is false, return *unspecified*
 381 in the current monad.  Every expression in the sequence must be a monadic
 382 expression."
 383     ((_ condition mexp0 mexp* ...)
 384      (if condition
 385          (mbegin %current-monad
 386            mexp0 mexp* ...)
 387          (return *unspecified*)))))
 388
 389 (define-syntax munless
 390   (syntax-rules ()
 391     "When CONDITION is false, evaluate the sequence of monadic expressions
 392 MEXP0..MEXP* as in an 'mbegin'.  When CONDITION is true, return *unspecified*
 393 in the current monad.  Every expression in the sequence must be a monadic
 394 expression."
 395     ((_ condition mexp0 mexp* ...)
 396      (if condition
 397          (return *unspecified*)
 398          (mbegin %current-monad
 399            mexp0 mexp* ...)))))
 400
 401 (define-syntax define-lift
 402   (syntax-rules ()
 403     ((_ liftn (args ...))
 404      (define-syntax liftn
 405        (lambda (s)
 406          "Lift PROC to MONAD---i.e., return a monadic function in MONAD."
 407          (syntax-case s ()
 408            ((liftn proc monad)
 409             ;; Inline the result of lifting PROC, such that 'return' can in
 410             ;; turn be open-coded.
 411             #'(lambda (args ...)
 412                 (with-monad monad
 413                   (return (proc args ...)))))
 414            (id
 415             (identifier? #'id)
 416             ;; Slow path: Return a closure-returning procedure (we don't
 417             ;; guarantee (eq? LIFTN LIFTN), but that's fine.)
 418             #'(lambda (proc monad)
 419                 (lambda (args ...)
 420                   (with-monad monad
 421                     (return (proc args ...))))))))))))
 422
 423 (define-lift lift0 ())
 424 (define-lift lift1 (a))
 425 (define-lift lift2 (a b))
 426 (define-lift lift3 (a b c))
 427 (define-lift lift4 (a b c d))
 428 (define-lift lift5 (a b c d e))
 429 (define-lift lift6 (a b c d e f))
 430 (define-lift lift7 (a b c d e f g))
 431
 432 (define (lift proc monad)
 433   "Lift PROC, a procedure that accepts an arbitrary number of arguments, to
 434 MONAD---i.e., return a monadic function in MONAD."
 435   (lambda args
 436     (with-monad monad
 437       (return (apply proc args)))))
 438
 439 (define-template (foldm monad mproc init lst)
 440   "Fold MPROC over LST and return a monadic value seeded by INIT.
 441
 442   (foldm %state-monad (lift2 cons %state-monad) '() '(a b c))
 443   => '(c b a)  ;monadic
 444 "
 445   (with-monad monad
 446     (let loop ((lst    lst)
 447                (result init))
 448       (match lst
 449         (()
 450          (return result))
 451         ((head . tail)
 452          (>>= (mproc head result)
 453               (lambda (result)
 454                 (loop tail result))))))))
 455
 456 (define-template (mapm monad mproc lst)
 457   "Map MPROC over LST and return a monadic list.
 458
 459   (mapm %state-monad (lift1 1+ %state-monad) '(0 1 2))
 460   => (1 2 3)  ;monadic
 461 "
 462   ;; XXX: We don't use 'foldm' because template specialization wouldn't work
 463   ;; in this context.
 464   (with-monad monad
 465     (let mapm ((lst    lst)
 466                (result '()))
 467       (match lst
 468         (()
 469          (return (reverse result)))
 470         ((head . tail)
 471          (>>= (mproc head)
 472               (lambda (head)
 473                 (mapm tail (cons head result)))))))))
 474
 475 (define-template (sequence monad lst)
 476   "Turn the list of monadic values LST into a monadic list of values, by
 477 evaluating each item of LST in sequence."
 478   (with-monad monad
 479     (let seq ((lstx   lst)
 480               (result '()))
 481       (match lstx
 482         (()
 483          (return (reverse result)))
 484         ((head . tail)
 485          (>>= head
 486               (lambda (item)
 487                 (seq tail (cons item result)))))))))
 488
 489 (define-template (anym monad mproc lst)
 490   "Apply MPROC to the list of values LST; return as a monadic value the first
 491 value for which MPROC returns a true monadic value or #f.  For example:
 492
 493   (anym %state-monad (lift1 odd? %state-monad) '(0 1 2))
 494   => #t   ;monadic
 495 "
 496   (with-monad monad
 497     (let loop ((lst lst))
 498       (match lst
 499         (()
 500          (return #f))
 501         ((head . tail)
 502          (>>= (mproc head)
 503               (lambda (result)
 504                 (if result
 505                     (return result)
 506                     (loop tail)))))))))
 507
 508 (define-syntax listm
 509   (lambda (s)
 510     "Return a monadic list in MONAD from the monadic values MVAL."
 511     (syntax-case s ()
 512       ((_ monad mval ...)
 513        (with-syntax (((val ...) (generate-temporaries #'(mval ...))))
 514          #'(mlet monad ((val mval) ...)
 515              (return (list val ...))))))))
 516
 517
 518 \f
 519 ;;;
 520 ;;; Identity monad.
 521 ;;;
 522
 523 (define-inlinable (identity-return value)
 524   value)
 525
 526 (define-inlinable (identity-bind mvalue mproc)
 527   (mproc mvalue))
 528
 529 (define-monad %identity-monad
 530   (bind   identity-bind)
 531   (return identity-return))
 532
 533 \f
 534 ;;;
 535 ;;; State monad.
 536 ;;;
 537
 538 (define-inlinable (state-return value)
 539   (lambda (state)
 540     (values value state)))
 541
 542 (define-inlinable (state-bind mvalue mproc)
 543   "Bind MVALUE, a value in the state monad, and pass it to MPROC."
 544   (lambda (state)
 545     (call-with-values
 546         (lambda ()
 547           (mvalue state))
 548       (lambda (value state)
 549         ;; Note: as of Guile 2.0.11, declaring a variable to hold the result
 550         ;; of (mproc value) prevents a bit of unfolding/inlining.
 551         ((mproc value) state)))))
 552
 553 (define-monad %state-monad
 554   (bind state-bind)
 555   (return state-return))
 556
 557 (define* (run-with-state mval #:optional (state '()))
 558   "Run monadic value MVAL starting with STATE as the initial state.  Return
 559 two values: the resulting value, and the resulting state."
 560   (mval state))
 561
 562 (define-inlinable (current-state)
 563   "Return the current state as a monadic value."
 564   (lambda (state)
 565     (values state state)))
 566
 567 (define-inlinable (set-current-state value)
 568   "Set the current state to VALUE and return the previous state as a monadic
 569 value."
 570   (lambda (state)
 571     (values state value)))
 572
 573 (define (state-pop)
 574   "Pop a value from the current state and return it as a monadic value.  The
 575 state is assumed to be a list."
 576   (lambda (state)
 577     (match state
 578       ((head . tail)
 579        (values head tail)))))
 580
 581 (define (state-push value)
 582   "Push VALUE to the current state, which is assumed to be a list, and return
 583 the previous state as a monadic value."
 584   (lambda (state)
 585     (values state (cons value state))))
 586
 587 ;;; monads.scm end here