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