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