tests/monads.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013, 2014, 2015, 2016, 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 (test-monads)
  20   #:use-module (guix tests)
  21   #:use-module (guix store)
  22   #:use-module (guix monads)
  23   #:use-module (guix grafts)
  24   #:use-module (guix derivations)
  25   #:use-module (guix packages)
  26   #:use-module (gnu packages)
  27   #:use-module (gnu packages bootstrap)
  28   #:use-module ((gnu packages base) #:select (coreutils))
  29   #:use-module (ice-9 match)
  30   #:use-module (rnrs io ports)
  31   #:use-module (srfi srfi-1)
  32   #:use-module (srfi srfi-26)
  33   #:use-module (srfi srfi-64))
  34
  35 ;; Test the (guix monads) module.
  36
  37 (define %store
  38   (open-connection-for-tests))
  39
  40 ;; Globally disable grafts because they can trigger early builds.
  41 (%graft? #f)
  42
  43 (define %monads
  44   (list %identity-monad %store-monad %state-monad))
  45
  46 (define %monad-run
  47   (list identity
  48         (cut run-with-store %store <>)
  49         (cut run-with-state <> '())))
  50
  51 (define-syntax-rule (values->list exp)
  52   (call-with-values (lambda () exp)
  53     list))
  54
  55 \f
  56 (test-begin "monads")
  57
  58 (test-assert "monad?"
  59   (and (every monad? %monads)
  60        (every (compose procedure? monad-bind) %monads)
  61        (every (compose procedure? monad-return) %monads)))
  62
  63 ;; The 3 "monad laws": <http://www.haskell.org/haskellwiki/Monad_laws>.
  64
  65 (test-assert "left identity"
  66   (every (lambda (monad run)
  67            (let ((number (random 777)))
  68              (with-monad monad
  69                (define (f x)
  70                  (return (* (1+ number) 2)))
  71
  72                (= (run (>>= (return number) f))
  73                   (run (f number))))))
  74          %monads
  75          %monad-run))
  76
  77 (test-assert "right identity"
  78   (every (lambda (monad run)
  79            (with-monad monad
  80              (let ((number (return (random 777))))
  81                (= (run (>>= number return))
  82                   (run number)))))
  83          %monads
  84          %monad-run))
  85
  86 (test-assert "associativity"
  87   (every (lambda (monad run)
  88            (with-monad monad
  89              (define (f x)
  90                (return (+ 1 x)))
  91              (define (g x)
  92                (return (* 2 x)))
  93
  94              (let ((number (return (random 777))))
  95                (= (run (>>= (>>= number f) g))
  96                   (run (>>= number (lambda (x) (>>= (f x) g))))))))
  97          %monads
  98          %monad-run))
  99
 100 (test-assert "lift"
 101   (every (lambda (monad run)
 102            (let ((f (lift1 1+ monad))
 103                  (g (apply lift1 1+ (list monad))))
 104              (with-monad monad
 105                (let ((number (random 777)))
 106                  (= (run (>>= (return number) f))
 107                     (run (>>= (return number) g))
 108                     (1+ number))))))
 109          %monads
 110          %monad-run))
 111
 112 (test-assert ">>= with more than two arguments"
 113   (every (lambda (monad run)
 114            (let ((1+ (lift1 1+ monad))
 115                  (2* (lift1 (cut * 2 <>) monad)))
 116              (with-monad monad
 117                (let ((number (random 777)))
 118                  (= (run (>>= (return number)
 119                               1+ 1+ 1+
 120                               2* 2* 2*))
 121                     (* 8 (+ number 3)))))))
 122          %monads
 123          %monad-run))
 124
 125 (test-assert "mbegin"
 126   (every (lambda (monad run)
 127            (with-monad monad
 128              (let* ((been-there? #f)
 129                     (number (mbegin monad
 130                               (return 1)
 131                               (begin
 132                                 (set! been-there? #t)
 133                                 (return 2))
 134                               (return 3))))
 135                (and (= (run number) 3)
 136                     been-there?))))
 137          %monads
 138          %monad-run))
 139
 140 (test-assert "mparameterize"
 141   (let ((parameter (make-parameter 'outside)))
 142     (every (lambda (monad run)
 143              (equal?
 144               (run (mlet monad ((outer (return (parameter)))
 145                                 (inner
 146                                  (mparameterize monad ((parameter 'inside))
 147                                    (return (parameter)))))
 148                      (return (list outer inner (parameter)))))
 149               '(outside inside outside)))
 150            %monads
 151            %monad-run)))
 152
 153 (test-assert "mlet* + text-file + package-file"
 154   (run-with-store %store
 155     (mlet* %store-monad ((guile (package-file %bootstrap-guile "bin/guile"))
 156                          (file  (text-file "monadic" guile)))
 157       (return (equal? (call-with-input-file file get-string-all)
 158                       guile)))
 159     #:guile-for-build (package-derivation %store %bootstrap-guile)))
 160
 161 (test-assert "package-file, default system"
 162   ;; The default system should be the one at '>>=' time, not the one at
 163   ;; invocation time.  See <http://bugs.gnu.org/18002>.
 164   (run-with-store %store
 165     (mlet* %store-monad
 166         ((system -> (%current-system))
 167          (file   (parameterize ((%current-system "foobar64-linux"))
 168                    (package-file coreutils "bin/ls")))
 169          (cu     (package->derivation coreutils)))
 170       (return (string=? file
 171                         (string-append (derivation->output-path cu)
 172                                        "/bin/ls"))))
 173     #:guile-for-build (package-derivation %store %bootstrap-guile)))
 174
 175 (test-assert "package-file + package->cross-derivation"
 176   (run-with-store %store
 177     (mlet* %store-monad ((target -> "mips64el-linux-gnu")
 178                          (file (package-file coreutils "bin/ls"
 179                                              #:target target))
 180                          (xcu  (package->cross-derivation coreutils target)))
 181       (let ((output (derivation->output-path xcu)))
 182         (return (string=? file (string-append output "/bin/ls")))))
 183     #:guile-for-build (package-derivation %store %bootstrap-guile)))
 184
 185 (test-assert "interned-file"
 186   (run-with-store %store
 187     (mlet* %store-monad ((file -> (search-path %load-path "guix.scm"))
 188                          (a       (interned-file file))
 189                          (b       (interned-file file "b")))
 190       (return (equal? (call-with-input-file file get-string-all)
 191                       (call-with-input-file a get-string-all)
 192                       (call-with-input-file b get-string-all))))
 193     #:guile-for-build (package-derivation %store %bootstrap-guile)))
 194
 195 (test-assert "mapm"
 196   (every (lambda (monad run)
 197            (with-monad monad
 198              (equal? (run (mapm monad (lift1 1+ monad) (iota 10)))
 199                      (map 1+ (iota 10)))))
 200          %monads
 201          %monad-run))
 202
 203 (test-assert "sequence"
 204   (every (lambda (monad run)
 205            (let* ((input (iota 100))
 206                   (order '()))
 207              (define (frob i)
 208                (mlet monad ((foo (return 'foo)))
 209                  ;; The side effect here is used to keep track of the order in
 210                  ;; which monadic values are bound.  Perform the side effect
 211                  ;; within a '>>=' so that it is performed when the return
 212                  ;; value is actually bound.
 213                  (set! order (cons i order))
 214                  (return i)))
 215
 216              (and (equal? input
 217                           (run (sequence monad (map frob input))))
 218
 219                   ;; Make sure this is from left to right.
 220                   (equal? order (reverse input)))))
 221          %monads
 222          %monad-run))
 223
 224 (test-assert "listm"
 225   (every (lambda (monad run)
 226            (run (with-monad monad
 227                   (let ((lst (listm monad
 228                                     (return 1) (return 2) (return 3))))
 229                     (mlet monad ((lst lst))
 230                       (return (equal? '(1 2 3) lst)))))))
 231          %monads
 232          %monad-run))
 233
 234 (test-assert "anym"
 235   (every (lambda (monad run)
 236            (eq? (run (with-monad monad
 237                        (anym monad
 238                              (lift1 (lambda (x)
 239                                       (and (odd? x) 'odd!))
 240                                     monad)
 241                              (append (make-list 1000 0)
 242                                      (list 1 2)))))
 243                 'odd!))
 244          %monads
 245          %monad-run))
 246
 247 (test-equal "set-current-state"
 248   (list '(a a d) 'd)
 249   (values->list
 250    (run-with-state
 251        (mlet* %state-monad ((init  (current-state))
 252                             (init2 (set-current-state 'b)))
 253          (mbegin %state-monad
 254            (set-current-state 'c)
 255            (set-current-state 'd)
 256            (mlet %state-monad ((last (current-state)))
 257              (return (list init init2 last)))))
 258      'a)))
 259
 260 (test-equal "state-push etc."
 261   (list '((z . 2) (p . (1)) (a . (1))) '(2 1))
 262   (values->list
 263    (run-with-state
 264        (mbegin %state-monad
 265          (state-push 1)    ;(1)
 266          (state-push 2)    ;(2 1)
 267          (mlet* %state-monad ((z (state-pop))        ;(1)
 268                               (p (current-state))
 269                               (a (state-push z)))    ;(2 1)
 270            (return `((z . ,z) (p . ,p) (a . ,a)))))
 271      '())))
 272
 273 (test-end "monads")