guix/monads.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013, 2014 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 (guix store)
  21   #:use-module (guix derivations)
  22   #:use-module (guix packages)
  23   #:use-module ((system syntax)
  24                 #:select (syntax-local-binding))
  25   #:use-module (ice-9 match)
  26   #:use-module (srfi srfi-1)
  27   #:use-module (srfi srfi-9)
  28   #:use-module (srfi srfi-26)
  29   #:export (;; Monads.
  30             define-monad
  31             monad?
  32             monad-bind
  33             monad-return
  34
  35             ;; Syntax.
  36             >>=
  37             return
  38             with-monad
  39             mlet
  40             mlet*
  41             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             %store-monad
  52             store-bind
  53             store-return
  54             store-lift
  55             run-with-store
  56             text-file
  57             text-file*
  58             interned-file
  59             package-file
  60             origin->derivation
  61             package->derivation
  62             built-derivations)
  63   #:replace (imported-modules
  64              compiled-modules))
  65
  66 ;;; Commentary:
  67 ;;;
  68 ;;; This module implements the general mechanism of monads, and provides in
  69 ;;; particular an instance of the "store" monad.  The API was inspired by that
  70 ;;; of Racket's "better-monads" module (see
  71 ;;; <http://planet.racket-lang.org/package-source/toups/functional.plt/1/1/planet-docs/better-monads-guide/index.html>).
  72 ;;; The implementation and use case were influenced by Oleg Kysielov's
  73 ;;; "Monadic Programming in Scheme" (see
  74 ;;; <http://okmij.org/ftp/Scheme/monad-in-Scheme.html>).
  75 ;;;
  76 ;;; The store monad allows us to (1) build sequences of operations in the
  77 ;;; store, and (2) make the store an implicit part of the execution context,
  78 ;;; rather than a parameter of every single function.
  79 ;;;
  80 ;;; Code:
  81
  82 ;; Record type for monads manipulated at run time.
  83 (define-record-type <monad>
  84   (make-monad bind return)
  85   monad?
  86   (bind   monad-bind)
  87   (return monad-return))                         ; TODO: Add 'plus' and 'zero'
  88
  89 (define-syntax define-monad
  90   (lambda (s)
  91     "Define the monad under NAME, with the given bind and return methods."
  92     (define prefix (string->symbol "% "))
  93     (define (make-rtd-name name)
  94       (datum->syntax name
  95                      (symbol-append prefix (syntax->datum name) '-rtd)))
  96
  97     (syntax-case s (bind return)
  98       ((_ name (bind b) (return r))
  99        (with-syntax ((rtd (make-rtd-name #'name)))
 100          #`(begin
 101              (define rtd
 102                ;; The record type, for use at run time.
 103                (make-monad b r))
 104
 105              (define-syntax name
 106                ;; An "inlined record", for use at expansion time.  The goal is
 107                ;; to allow 'bind' and 'return' to be resolved at expansion
 108                ;; time, in the common case where the monad is accessed
 109                ;; directly as NAME.
 110                (lambda (s)
 111                  (syntax-case s (%bind %return)
 112                    ((_ %bind)   #'b)
 113                    ((_ %return) #'r)
 114                    (_           #'rtd))))))))))
 115
 116 (define-syntax-parameter >>=
 117   ;; The name 'bind' is already taken, so we choose this (obscure) symbol.
 118   (lambda (s)
 119     (syntax-violation '>>= ">>= (bind) used outside of 'with-monad'" s)))
 120
 121 (define-syntax-parameter return
 122   (lambda (s)
 123     (syntax-violation 'return "return used outside of 'with-monad'" s)))
 124
 125 (define-syntax with-monad
 126   (lambda (s)
 127     "Evaluate BODY in the context of MONAD, and return its result."
 128     (syntax-case s ()
 129       ((_ monad body ...)
 130        (eq? 'macro (syntax-local-binding #'monad))
 131        ;; MONAD is a syntax transformer, so we can obtain the bind and return
 132        ;; methods by directly querying it.
 133        #'(syntax-parameterize ((>>=    (identifier-syntax (monad %bind)))
 134                                (return (identifier-syntax (monad %return))))
 135            body ...))
 136       ((_ monad body ...)
 137        ;; MONAD refers to the <monad> record that represents the monad at run
 138        ;; time, so use the slow method.
 139        #'(syntax-parameterize ((>>=    (identifier-syntax
 140                                         (monad-bind monad)))
 141                                (return (identifier-syntax
 142                                         (monad-return monad))))
 143            body ...)))))
 144
 145 (define-syntax mlet*
 146   (syntax-rules (->)
 147     "Bind the given monadic values MVAL to the given variables VAR.  When the
 148 form is (VAR -> VAL), bind VAR to the non-monadic value VAL in the same way as
 149 'let'."
 150     ;; Note: the '->' symbol corresponds to 'is:' in 'better-monads.rkt'.
 151     ((_ monad () body ...)
 152      (with-monad monad body ...))
 153     ((_ monad ((var mval) rest ...) body ...)
 154      (with-monad monad
 155        (>>= mval
 156             (lambda (var)
 157               (mlet* monad (rest ...)
 158                 body ...)))))
 159     ((_ monad ((var -> val) rest ...) body ...)
 160      (let ((var val))
 161        (mlet* monad (rest ...)
 162          body ...)))))
 163
 164 (define-syntax mlet
 165   (lambda (s)
 166     (syntax-case s ()
 167       ((_ monad ((var mval ...) ...) body ...)
 168        (with-syntax (((temp ...) (generate-temporaries #'(var ...))))
 169          #'(mlet* monad ((temp mval ...) ...)
 170              (let ((var temp) ...)
 171                body ...)))))))
 172
 173 (define-syntax define-lift
 174   (syntax-rules ()
 175     ((_ liftn (args ...))
 176      (define (liftn proc monad)
 177        "Lift PROC to MONAD---i.e., return a monadic function in MONAD."
 178        (lambda (args ...)
 179          (with-monad monad
 180            (return (proc args ...))))))))
 181
 182 (define-lift lift1 (a))
 183 (define-lift lift2 (a b))
 184 (define-lift lift3 (a b c))
 185 (define-lift lift4 (a b c d))
 186 (define-lift lift5 (a b c d e))
 187 (define-lift lift6 (a b c d e f))
 188 (define-lift lift7 (a b c d e f g))
 189
 190 (define (lift nargs proc monad)
 191   "Lift PROC, a procedure that accepts NARGS arguments, to MONAD---i.e.,
 192 return a monadic function in MONAD."
 193   (lambda args
 194     (with-monad monad
 195       (return (apply proc args)))))
 196
 197 (define (foldm monad mproc init lst)
 198   "Fold MPROC over LST, a list of monadic values in MONAD, and return a
 199 monadic value seeded by INIT."
 200   (with-monad monad
 201     (let loop ((lst    lst)
 202                (result init))
 203       (match lst
 204         (()
 205          (return result))
 206         ((head tail ...)
 207          (mlet* monad ((item   head)
 208                        (result (mproc item result)))
 209            (loop tail result)))))))
 210
 211 (define (mapm monad mproc lst)
 212   "Map MPROC over LST, a list of monadic values in MONAD, and return a monadic
 213 list.  LST items are bound from left to right, so effects in MONAD are known
 214 to happen in that order."
 215   (mlet monad ((result (foldm monad
 216                               (lambda (item result)
 217                                 (mlet monad ((item (mproc item)))
 218                                   (return (cons item result))))
 219                               '()
 220                               lst)))
 221     (return (reverse result))))
 222
 223 (define-inlinable (sequence monad lst)
 224   "Turn the list of monadic values LST into a monadic list of values, by
 225 evaluating each item of LST in sequence."
 226   (with-monad monad
 227     (mapm monad return lst)))
 228
 229 (define (anym monad proc lst)
 230   "Apply PROC to the list of monadic values LST; return the first value,
 231 lifted in MONAD, for which PROC returns true."
 232   (with-monad monad
 233     (let loop ((lst lst))
 234       (match lst
 235         (()
 236          (return #f))
 237         ((head tail ...)
 238          (mlet* monad ((value  head)
 239                        (result -> (proc value)))
 240            (if result
 241                (return result)
 242                (loop tail))))))))
 243
 244 (define-syntax listm
 245   (lambda (s)
 246     "Return a monadic list in MONAD from the monadic values MVAL."
 247     (syntax-case s ()
 248       ((_ monad mval ...)
 249        (with-syntax (((val ...) (generate-temporaries #'(mval ...))))
 250          #'(mlet monad ((val mval) ...)
 251              (return (list val ...))))))))
 252
 253
 254 \f
 255 ;;;
 256 ;;; Identity monad.
 257 ;;;
 258
 259 (define-inlinable (identity-return value)
 260   value)
 261
 262 (define-inlinable (identity-bind mvalue mproc)
 263   (mproc mvalue))
 264
 265 (define-monad %identity-monad
 266   (bind   identity-bind)
 267   (return identity-return))
 268
 269 \f
 270 ;;;
 271 ;;; Store monad.
 272 ;;;
 273
 274 ;; return:: a -> StoreM a
 275 (define-inlinable (store-return value)
 276   "Return VALUE from a monadic function."
 277   ;; The monadic value is just this.
 278   (lambda (store)
 279     value))
 280
 281 ;; >>=:: StoreM a -> (a -> StoreM b) -> StoreM b
 282 (define-inlinable (store-bind mvalue mproc)
 283   "Bind MVALUE in MPROC."
 284   (lambda (store)
 285     (let* ((value   (mvalue store))
 286            (mresult (mproc value)))
 287       (mresult store))))
 288
 289 (define-monad %store-monad
 290   (bind   store-bind)
 291   (return store-return))
 292
 293
 294 (define (store-lift proc)
 295   "Lift PROC, a procedure whose first argument is a connection to the store,
 296 in the store monad."
 297   (define result
 298     (lambda args
 299       (lambda (store)
 300         (apply proc store args))))
 301
 302   (set-object-property! result 'documentation
 303                         (procedure-property proc 'documentation))
 304   result)
 305
 306 ;;;
 307 ;;; Store monad operators.
 308 ;;;
 309
 310 (define* (text-file name text)
 311   "Return as a monadic value the absolute file name in the store of the file
 312 containing TEXT, a string."
 313   (lambda (store)
 314     (add-text-to-store store name text '())))
 315
 316 (define* (text-file* name #:rest text)
 317   "Return as a monadic value a derivation that builds a text file containing
 318 all of TEXT.  TEXT may list, in addition to strings, packages, derivations,
 319 and store file names; the resulting store file holds references to all these."
 320   (define inputs
 321     ;; Transform packages and derivations from TEXT into a valid input list.
 322     (filter-map (match-lambda
 323                  ((? package? p) `("x" ,p))
 324                  ((? derivation? d) `("x" ,d))
 325                  ((x ...) `("x" ,@x))
 326                  ((? string? s)
 327                   (and (direct-store-path? s) `("x" ,s)))
 328                  (x x))
 329                 text))
 330
 331   (define (computed-text text inputs)
 332     ;; Using the lowered INPUTS, return TEXT with derivations replaced with
 333     ;; their output file name.
 334     (define (real-string? s)
 335       (and (string? s) (not (direct-store-path? s))))
 336
 337     (let loop ((inputs inputs)
 338                (text   text)
 339                (result '()))
 340       (match text
 341         (()
 342          (string-concatenate-reverse result))
 343         (((? real-string? head) rest ...)
 344          (loop inputs rest (cons head result)))
 345         ((_ rest ...)
 346          (match inputs
 347            (((_ (? derivation? drv) sub-drv ...) inputs ...)
 348             (loop inputs rest
 349                   (cons (apply derivation->output-path drv
 350                                sub-drv)
 351                         result)))
 352            (((_ file) inputs ...)
 353             ;; FILE is the result of 'add-text-to-store' or so.
 354             (loop inputs rest (cons file result))))))))
 355
 356   (define (builder inputs)
 357     `(call-with-output-file (assoc-ref %outputs "out")
 358        (lambda (port)
 359          (display ,(computed-text text inputs) port))))
 360
 361   ;; TODO: Rewrite using 'gexp->derivation'.
 362   (mlet %store-monad ((inputs (lower-inputs inputs)))
 363     (derivation-expression name (builder inputs)
 364                            #:inputs inputs)))
 365
 366 (define* (interned-file file #:optional name
 367                         #:key (recursive? #t))
 368   "Return the name of FILE once interned in the store.  Use NAME as its store
 369 name, or the basename of FILE if NAME is omitted.
 370
 371 When RECURSIVE? is true, the contents of FILE are added recursively; if FILE
 372 designates a flat file and RECURSIVE? is true, its contents are added, and its
 373 permission bits are kept."
 374   (lambda (store)
 375     (add-to-store store (or name (basename file))
 376                   recursive? "sha256" file)))
 377
 378 (define* (package-file package
 379                        #:optional file
 380                        #:key (system (%current-system)) (output "out"))
 381   "Return as a monadic value the absolute file name of FILE within the
 382 OUTPUT directory of PACKAGE.  When FILE is omitted, return the name of the
 383 OUTPUT directory of PACKAGE."
 384   (lambda (store)
 385     (let* ((drv (package-derivation store package system))
 386            (out (derivation->output-path drv output)))
 387       (if file
 388           (string-append out "/" file)
 389           out))))
 390
 391 (define (lower-inputs inputs)
 392   "Turn any package from INPUTS into a derivation; return the corresponding
 393 input list as a monadic value."
 394   ;; XXX: This procedure is bound to disappear with 'derivation-expression'.
 395   (with-monad %store-monad
 396     (sequence %store-monad
 397               (map (match-lambda
 398                     ((name (? package? package) sub-drv ...)
 399                      (mlet %store-monad ((drv (package->derivation package)))
 400                        (return `(,name ,drv ,@sub-drv))))
 401                     ((name (? string? file))
 402                      (return `(,name ,file)))
 403                     (tuple
 404                      (return tuple)))
 405                    inputs))))
 406
 407 (define derivation-expression
 408   ;; XXX: This procedure is superseded by 'gexp->derivation'.
 409   (store-lift build-expression->derivation))
 410
 411 (define package->derivation
 412   (store-lift package-derivation))
 413
 414 (define origin->derivation
 415   (store-lift package-source-derivation))
 416
 417 (define imported-modules
 418   (store-lift (@ (guix derivations) imported-modules)))
 419
 420 (define compiled-modules
 421   (store-lift (@ (guix derivations) compiled-modules)))
 422
 423 (define built-derivations
 424   (store-lift build-derivations))
 425
 426 (define* (run-with-store store mval
 427                          #:key
 428                          (guile-for-build (%guile-for-build))
 429                          (system (%current-system)))
 430   "Run MVAL, a monadic value in the store monad, in STORE, an open store
 431 connection."
 432   (define (default-guile)
 433     ;; Lazily resolve 'guile-final'.  This module must not refer to (gnu …)
 434     ;; modules directly, to avoid circular dependencies, hence this hack.
 435     (module-ref (resolve-interface '(gnu packages base))
 436                 'guile-final))
 437
 438   (parameterize ((%guile-for-build (or guile-for-build
 439                                        (package-derivation store
 440                                                            (default-guile)
 441                                                            system)))
 442                  (%current-system system))
 443     (mval store)))
 444
 445 ;;; monads.scm end here