guix/monads.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013, 2014, 2015 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             ;; Syntax.
  33             >>=
  34             return
  35             with-monad
  36             mlet
  37             mlet*
  38             mbegin
  39             mwhen
  40             munless
  41             lift0 lift1 lift2 lift3 lift4 lift5 lift6 lift7 lift
  42             listm
  43             foldm
  44             mapm
  45             sequence
  46             anym
  47
  48             ;; Concrete monads.
  49             %identity-monad
  50
  51             %state-monad
  52             state-return
  53             state-bind
  54             current-state
  55             set-current-state
  56             state-push
  57             state-pop
  58             run-with-state))
  59
  60 ;;; Commentary:
  61 ;;;
  62 ;;; This module implements the general mechanism of monads, and provides in
  63 ;;; particular an instance of the "state" monad.  The API was inspired by that
  64 ;;; of Racket's "better-monads" module (see
  65 ;;; <http://planet.racket-lang.org/package-source/toups/functional.plt/1/1/planet-docs/better-monads-guide/index.html>).
  66 ;;; The implementation and use case were influenced by Oleg Kysielov's
  67 ;;; "Monadic Programming in Scheme" (see
  68 ;;; <http://okmij.org/ftp/Scheme/monad-in-Scheme.html>).
  69 ;;;
  70 ;;; Code:
  71
  72 ;; Record type for monads manipulated at run time.
  73 (define-record-type <monad>
  74   (make-monad bind return)
  75   monad?
  76   (bind   monad-bind)
  77   (return monad-return))                         ; TODO: Add 'plus' and 'zero'
  78
  79 (define-syntax define-monad
  80   (lambda (s)
  81     "Define the monad under NAME, with the given bind and return methods."
  82     (define prefix (string->symbol "% "))
  83     (define (make-rtd-name name)
  84       (datum->syntax name
  85                      (symbol-append prefix (syntax->datum name) '-rtd)))
  86
  87     (syntax-case s (bind return)
  88       ((_ name (bind b) (return r))
  89        (with-syntax ((rtd (make-rtd-name #'name)))
  90          #`(begin
  91              (define rtd
  92                ;; The record type, for use at run time.
  93                (make-monad b r))
  94
  95              (define-syntax name
  96                ;; An "inlined record", for use at expansion time.  The goal is
  97                ;; to allow 'bind' and 'return' to be resolved at expansion
  98                ;; time, in the common case where the monad is accessed
  99                ;; directly as NAME.
 100                (lambda (s)
 101                  (syntax-case s (%bind %return)
 102                    ((_ %bind)   #'b)
 103                    ((_ %return) #'r)
 104                    (_           #'rtd))))))))))
 105
 106 (define-syntax-parameter >>=
 107   ;; The name 'bind' is already taken, so we choose this (obscure) symbol.
 108   (lambda (s)
 109     (syntax-violation '>>= ">>= (bind) used outside of 'with-monad'" s)))
 110
 111 (define-syntax-parameter return
 112   (lambda (s)
 113     (syntax-violation 'return "return used outside of 'with-monad'" s)))
 114
 115 (define-syntax with-monad
 116   (lambda (s)
 117     "Evaluate BODY in the context of MONAD, and return its result."
 118     (syntax-case s ()
 119       ((_ monad body ...)
 120        (eq? 'macro (syntax-local-binding #'monad))
 121        ;; MONAD is a syntax transformer, so we can obtain the bind and return
 122        ;; methods by directly querying it.
 123        #'(syntax-parameterize ((>>=    (identifier-syntax (monad %bind)))
 124                                (return (identifier-syntax (monad %return))))
 125            body ...))
 126       ((_ monad body ...)
 127        ;; MONAD refers to the <monad> record that represents the monad at run
 128        ;; time, so use the slow method.
 129        #'(syntax-parameterize ((>>=    (identifier-syntax
 130                                         (monad-bind monad)))
 131                                (return (identifier-syntax
 132                                         (monad-return monad))))
 133            body ...)))))
 134
 135 (define-syntax mlet*
 136   (syntax-rules (->)
 137     "Bind the given monadic values MVAL to the given variables VAR.  When the
 138 form is (VAR -> VAL), bind VAR to the non-monadic value VAL in the same way as
 139 'let'."
 140     ;; Note: the '->' symbol corresponds to 'is:' in 'better-monads.rkt'.
 141     ((_ monad () body ...)
 142      (with-monad monad body ...))
 143     ((_ monad ((var mval) rest ...) body ...)
 144      (with-monad monad
 145        (>>= mval
 146             (lambda (var)
 147               (mlet* monad (rest ...)
 148                 body ...)))))
 149     ((_ monad ((var -> val) rest ...) body ...)
 150      (let ((var val))
 151        (mlet* monad (rest ...)
 152          body ...)))))
 153
 154 (define-syntax mlet
 155   (lambda (s)
 156     (syntax-case s ()
 157       ((_ monad ((var mval ...) ...) body ...)
 158        (with-syntax (((temp ...) (generate-temporaries #'(var ...))))
 159          #'(mlet* monad ((temp mval ...) ...)
 160              (let ((var temp) ...)
 161                body ...)))))))
 162
 163 (define-syntax mbegin
 164   (syntax-rules (%current-monad)
 165     "Bind the given monadic expressions in sequence, returning the result of
 166 the last one."
 167     ((_ %current-monad mexp)
 168      mexp)
 169     ((_ %current-monad mexp rest ...)
 170      (>>= mexp
 171           (lambda (unused-value)
 172             (mbegin %current-monad rest ...))))
 173     ((_ monad mexp)
 174      (with-monad monad
 175        mexp))
 176     ((_ monad mexp rest ...)
 177      (with-monad monad
 178        (>>= mexp
 179             (lambda (unused-value)
 180               (mbegin monad rest ...)))))))
 181
 182 (define-syntax mwhen
 183   (syntax-rules ()
 184     "When CONDITION is true, evaluate EXP0..EXP* as in an 'mbegin'.  When
 185 CONDITION is false, return *unspecified* in the current monad."
 186     ((_ condition exp0 exp* ...)
 187      (if condition
 188          (mbegin %current-monad
 189            exp0 exp* ...)
 190          (return *unspecified*)))))
 191
 192 (define-syntax munless
 193   (syntax-rules ()
 194     "When CONDITION is false, evaluate EXP0..EXP* as in an 'mbegin'.  When
 195 CONDITION is true, return *unspecified* in the current monad."
 196     ((_ condition exp0 exp* ...)
 197      (if condition
 198          (return *unspecified*)
 199          (mbegin %current-monad
 200            exp0 exp* ...)))))
 201
 202 (define-syntax define-lift
 203   (syntax-rules ()
 204     ((_ liftn (args ...))
 205      (define (liftn proc monad)
 206        "Lift PROC to MONAD---i.e., return a monadic function in MONAD."
 207        (lambda (args ...)
 208          (with-monad monad
 209            (return (proc args ...))))))))
 210
 211 (define-lift lift0 ())
 212 (define-lift lift1 (a))
 213 (define-lift lift2 (a b))
 214 (define-lift lift3 (a b c))
 215 (define-lift lift4 (a b c d))
 216 (define-lift lift5 (a b c d e))
 217 (define-lift lift6 (a b c d e f))
 218 (define-lift lift7 (a b c d e f g))
 219
 220 (define (lift proc monad)
 221   "Lift PROC, a procedure that accepts an arbitrary number of arguments, to
 222 MONAD---i.e., return a monadic function in MONAD."
 223   (lambda args
 224     (with-monad monad
 225       (return (apply proc args)))))
 226
 227 (define (foldm monad mproc init lst)
 228   "Fold MPROC over LST, a list of monadic values in MONAD, and return a
 229 monadic value seeded by INIT."
 230   (with-monad monad
 231     (let loop ((lst    lst)
 232                (result init))
 233       (match lst
 234         (()
 235          (return result))
 236         ((head tail ...)
 237          (mlet* monad ((item   head)
 238                        (result (mproc item result)))
 239            (loop tail result)))))))
 240
 241 (define (mapm monad mproc lst)
 242   "Map MPROC over LST, a list of monadic values in MONAD, and return a monadic
 243 list.  LST items are bound from left to right, so effects in MONAD are known
 244 to happen in that order."
 245   (mlet monad ((result (foldm monad
 246                               (lambda (item result)
 247                                 (mlet monad ((item (mproc item)))
 248                                   (return (cons item result))))
 249                               '()
 250                               lst)))
 251     (return (reverse result))))
 252
 253 (define-syntax-rule (sequence monad lst)
 254   "Turn the list of monadic values LST into a monadic list of values, by
 255 evaluating each item of LST in sequence."
 256   ;; XXX: Making it a macro is a bit brutal as it leads to a lot of code
 257   ;; duplication.  However, it allows >>= and return to be open-coded, which
 258   ;; avoids struct-ref's to MONAD and a few closure allocations when using
 259   ;; %STATE-MONAD.
 260   (with-monad monad
 261     (let seq ((lstx   lst)
 262               (result '()))
 263       (match lstx
 264         (()
 265          (return (reverse result)))
 266         ((head . tail)
 267          (>>= head
 268               (lambda (item)
 269                 (seq tail (cons item result)))))))))
 270
 271 (define (anym monad proc lst)
 272   "Apply PROC to the list of monadic values LST; return the first value,
 273 lifted in MONAD, for which PROC returns true."
 274   (with-monad monad
 275     (let loop ((lst lst))
 276       (match lst
 277         (()
 278          (return #f))
 279         ((head tail ...)
 280          (mlet* monad ((value  head)
 281                        (result -> (proc value)))
 282            (if result
 283                (return result)
 284                (loop tail))))))))
 285
 286 (define-syntax listm
 287   (lambda (s)
 288     "Return a monadic list in MONAD from the monadic values MVAL."
 289     (syntax-case s ()
 290       ((_ monad mval ...)
 291        (with-syntax (((val ...) (generate-temporaries #'(mval ...))))
 292          #'(mlet monad ((val mval) ...)
 293              (return (list val ...))))))))
 294
 295
 296 \f
 297 ;;;
 298 ;;; Identity monad.
 299 ;;;
 300
 301 (define-inlinable (identity-return value)
 302   value)
 303
 304 (define-inlinable (identity-bind mvalue mproc)
 305   (mproc mvalue))
 306
 307 (define-monad %identity-monad
 308   (bind   identity-bind)
 309   (return identity-return))
 310
 311 \f
 312 ;;;
 313 ;;; State monad.
 314 ;;;
 315
 316 (define-inlinable (state-return value)
 317   (lambda (state)
 318     (values value state)))
 319
 320 (define-inlinable (state-bind mvalue mproc)
 321   "Bind MVALUE, a value in the state monad, and pass it to MPROC."
 322   (lambda (state)
 323     (call-with-values
 324         (lambda ()
 325           (mvalue state))
 326       (lambda (value state)
 327         ;; Note: as of Guile 2.0.11, declaring a variable to hold the result
 328         ;; of (mproc value) prevents a bit of unfolding/inlining.
 329         ((mproc value) state)))))
 330
 331 (define-monad %state-monad
 332   (bind state-bind)
 333   (return state-return))
 334
 335 (define* (run-with-state mval #:optional (state '()))
 336   "Run monadic value MVAL starting with STATE as the initial state.  Return
 337 two values: the resulting value, and the resulting state."
 338   (mval state))
 339
 340 (define-inlinable (current-state)
 341   "Return the current state as a monadic value."
 342   (lambda (state)
 343     (values state state)))
 344
 345 (define-inlinable (set-current-state value)
 346   "Set the current state to VALUE and return the previous state as a monadic
 347 value."
 348   (lambda (state)
 349     (values state value)))
 350
 351 (define (state-pop)
 352   "Pop a value from the current state and return it as a monadic value.  The
 353 state is assumed to be a list."
 354   (lambda (state)
 355     (match state
 356       ((head . tail)
 357        (values head tail)))))
 358
 359 (define (state-push value)
 360   "Push VALUE to the current state, which is assumed to be a list, and return
 361 the previous state as a monadic value."
 362   (lambda (state)
 363     (values state (cons value state))))
 364
 365 ;;; monads.scm end here