tests/monads.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013 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 store)
  21   #:use-module (guix monads)
  22   #:use-module (guix derivations)
  23   #:use-module ((guix packages)
  24                 #:select (package-derivation %current-system))
  25   #:use-module (gnu packages)
  26   #:use-module (gnu packages bootstrap)
  27   #:use-module (ice-9 match)
  28   #:use-module (rnrs io ports)
  29   #:use-module (srfi srfi-1)
  30   #:use-module (srfi srfi-26)
  31   #:use-module (srfi srfi-64))
  32
  33 ;; Test the (guix store) module.
  34
  35 (define %store
  36   (open-connection))
  37
  38 ;; Make sure we build everything by ourselves.
  39 (set-build-options %store #:use-substitutes? #f)
  40
  41 (define %monads
  42   (list %identity-monad %store-monad))
  43
  44 (define %monad-run
  45   (list identity
  46         (cut run-with-store %store <>)))
  47
  48 \f
  49 (test-begin "monads")
  50
  51 (test-assert "monad?"
  52   (and (every monad? %monads)
  53        (every (compose procedure? monad-bind) %monads)
  54        (every (compose procedure? monad-return) %monads)))
  55
  56 ;; The 3 "monad laws": <http://www.haskell.org/haskellwiki/Monad_laws>.
  57
  58 (test-assert "left identity"
  59   (every (lambda (monad run)
  60            (let ((number (random 777)))
  61              (with-monad monad
  62                (define (f x)
  63                  (return (* (1+ number) 2)))
  64
  65                (= (run (>>= (return number) f))
  66                   (run (f number))))))
  67          %monads
  68          %monad-run))
  69
  70 (test-assert "right identity"
  71   (every (lambda (monad run)
  72            (with-monad monad
  73              (let ((number (return (random 777))))
  74                (= (run (>>= number return))
  75                   (run number)))))
  76          %monads
  77          %monad-run))
  78
  79 (test-assert "associativity"
  80   (every (lambda (monad run)
  81            (with-monad monad
  82              (define (f x)
  83                (return (+ 1 x)))
  84              (define (g x)
  85                (return (* 2 x)))
  86
  87              (let ((number (return (random 777))))
  88                (= (run (>>= (>>= number f) g))
  89                   (run (>>= number (lambda (x) (>>= (f x) g))))))))
  90          %monads
  91          %monad-run))
  92
  93 (test-assert "lift"
  94   (every (lambda (monad run)
  95            (let ((f (lift1 1+ monad)))
  96              (with-monad monad
  97                (let ((number (random 777)))
  98                  (= (run (>>= (return number) f))
  99                     (1+ number))))))
 100          %monads
 101          %monad-run))
 102
 103 (test-assert "mlet* + text-file + package-file"
 104   (run-with-store %store
 105     (mlet* %store-monad ((guile (package-file %bootstrap-guile "bin/guile"))
 106                          (file  (text-file "monadic" guile)))
 107       (return (equal? (call-with-input-file file get-string-all)
 108                       guile)))
 109     #:guile-for-build (package-derivation %store %bootstrap-guile)))
 110
 111 (test-assert "mlet* + derivation-expression"
 112   (run-with-store %store
 113     (mlet* %store-monad ((guile  (package-file %bootstrap-guile "bin/guile"))
 114                          (gdrv   (package->derivation %bootstrap-guile))
 115                          (exp -> `(let ((out (assoc-ref %outputs "out")))
 116                                     (mkdir out)
 117                                     (symlink ,guile
 118                                              (string-append out "/guile-rocks"))))
 119                          (drv    (derivation-expression "rocks" (%current-system)
 120                                                         exp `(("g" ,gdrv))))
 121                          (out -> (derivation->output-path drv))
 122                          (built? (built-derivations (list drv))))
 123       (return (and built?
 124                    (equal? guile
 125                            (readlink (string-append out "/guile-rocks"))))))
 126     #:guile-for-build (package-derivation %store %bootstrap-guile)))
 127
 128 (test-assert "mapm"
 129   (every (lambda (monad run)
 130            (with-monad monad
 131              (equal? (run (mapm monad (lift1 1+ monad) (map return (iota 10))))
 132                      (map 1+ (iota 10)))))
 133          %monads
 134          %monad-run))
 135
 136 (test-assert "sequence"
 137   (every (lambda (monad run)
 138            (let* ((input (iota 100))
 139                   (order '()))
 140              (define (frob i)
 141                ;; The side effect here is used to keep track of the order in
 142                ;; which monadic values are bound.
 143                (set! order (cons i order))
 144                i)
 145
 146              (and (equal? input
 147                           (run (sequence monad
 148                                          (map (lift1 frob monad) input))))
 149
 150                   ;; Make sure this is from left to right.
 151                   (equal? order (reverse input)))))
 152          %monads
 153          %monad-run))
 154
 155 (test-assert "listm"
 156   (every (lambda (monad run)
 157            (run (with-monad monad
 158                   (let ((lst (listm monad
 159                                     (return 1) (return 2) (return 3))))
 160                     (mlet monad ((lst lst))
 161                       (return (equal? '(1 2 3) lst)))))))
 162          %monads
 163          %monad-run))
 164
 165 (test-end "monads")
 166
 167 \f
 168 (exit (= (test-runner-fail-count (test-runner-current)) 0))