test/pattern-specializer/optima-extensions.lisp

   1 ;;;; optima-extensions.lisp --- Tests for extensions of the optima library.
   2 ;;;;
   3 ;;;; Copyright (C) 2014 Jan Moringen
   4 ;;;;
   5 ;;;; Author: Jan Moringen <jmoringe@techfak.uni-bielefeld.de>
   6
   7 (cl:in-package #:pattern-specializer.test)
   8
   9 (def-suite :optima-extensions.pattern-more-specific-p
  10     :in :pattern-specializer)
  11 (in-suite :optima-extensions.pattern-more-specific-p)
  12
  13 (defun process-case (case)
  14   (destructuring-bind (pattern1 pattern2 expected) case
  15     (let* ((pattern1/parsed (optima.core:parse-pattern pattern1))
  16            (pattern2/parsed (optima.core:parse-pattern pattern2))
  17            (result (pattern-specializer::pattern-more-specific-p
  18                     pattern1/parsed pattern2/parsed)))
  19       (is (eq expected result)
  20           "~S < ~S => ~S [not ~S]" pattern1 pattern2 result expected))))
  21
  22 (optima.core:parse-pattern '(and x))
  23
  24 (test constant-pattern
  25   (mapc #'process-case
  26         '((1 1         =)
  27           (1 2         /=)
  28           ("foo" "foo" =)
  29           ("foo" "bar" /=))))
  30
  31 (test variable-pattern
  32   (mapc #'process-case
  33         '((x          x          =)
  34           (x          y          =)
  35           (1          y          <)
  36           ((cons x y) y          <)
  37           (x          1          >)
  38           (x          (cons x y) >))))
  39
  40 (test and-pattern
  41   ;; Cannot test patterns of the form (and SUB-PATTERN) since optima
  42   ;; reduces these to just SUB-PATTERN.
  43   (mapc #'process-case
  44         '((x            (and x y)    =)
  45           (x            (and 1 y)    >)
  46           (x            (and x 1)    >)
  47           (x            (and 1 2)    >)
  48           (1            (and x y)    <)
  49           (1            (and 1 y)    =)
  50           (1            (and x 1)    =)
  51           (1            (and 1 1)    =)
  52           (1            (and 1 2)    /=)
  53           ((cons x y)   (and 1 2)    /=)
  54
  55           ((and x y)    x            =)
  56           ((and 1 y)    x            <)
  57           ((and x 1)    x            <)
  58           ((and 1 2)    x            <)
  59           ((and x y)    1            >)
  60           ((and 1 y)    1            =)
  61           ((and x 1)    1            =)
  62           ((and 1 1)    1            =)
  63           ((and 1 2)    1            /=)
  64           ((and 1 2)    (cons x y)   /=)
  65
  66           ((and x y)    (and x y)    =)
  67           ((and x y)    (and x z)    =)
  68           ((and x y)    (and 1 y)    >)
  69           ((and x y)    (and x 1)    >)
  70           ((and x y)    (and 1 2)    >)
  71           ((and 1 y)    (and x y)    <)
  72           ((and x 1)    (and x y)    <)
  73           ((and 1 2)    (and x y)    <)
  74           ((and 1 y)    (and 1 1)    =)
  75           ((and x 1)    (and 1 1)    =)
  76           ((and 1 2)    (and 1 1)    /=)
  77           ((and 1 1)    (and 1 y)    =)
  78           ((and 1 1)    (and x 1)    =)
  79           ((and 1 1)    (and 1 2)    /=)
  80           ((and 1 1)    (and 1 1)    =)
  81
  82           ((cons 1 2)   (and (cons 1 y) (cons x 2)) =))))
  83
  84 (test or-pattern
  85   ;; Cannot test patterns of the form (or SUB-PATTERN) since optima
  86   ;; reduces these to just SUB-PATTERN.
  87   (mapc #'process-case
  88         '((x          (or x y)    =)
  89           (x          (or 1 y)    =)
  90           (x          (or x 1)    =)
  91           (x          (or 1 2)    >)
  92           (1          (or x y)    <)
  93           (1          (or 1 y)    <)
  94           (1          (or x 1)    <)
  95           (1          (or 1 1)    =)
  96           (1          (or 1 2)    <)
  97           ((cons x y) (or 1 2)    /=)
  98
  99           ((or x y)   x           =)
 100           ((or 1 y)   x           =)
 101           ((or x 1)   x           =)
 102           ((or 1 2)   x           <)
 103           ((or x y)   1           >)
 104           ((or 1 y)   1           >)
 105           ((or x 1)   1           >)
 106           ((or 1 1)   1           =)
 107           ((or 1 2)   1           >)
 108           ((or 1 2)   (cons x y)  /=)
 109
 110           ((or x y)   (or x y)    =)
 111           ((or x y)   (or x z)    =)
 112           ((or x y)   (or 1 y)    =)
 113           ((or x y)   (or x 1)    =)
 114           ((or x y)   (or 1 2)    >)
 115           ((or 1 y)   (or x y)    =)
 116           ((or x 1)   (or x y)    =)
 117           ((or 1 2)   (or x y)    <)
 118           ((or 1 y)   (or 1 1)    >)
 119           ((or x 1)   (or 1 1)    >)
 120           ((or 1 2)   (or 1 1)    >)
 121           ((or 1 1)   (or 1 y)    <)
 122           ((or 1 1)   (or x 1)    <)
 123           ((or 1 1)   (or 1 2)    <)
 124           ((or 1 1)   (or 1 1)    =)
 125
 126           ((cons 1 2) (or (cons 1 y) (cons x 2)) <))))
 127
 128 (test cons-pattern
 129
 130   (mapc #'process-case
 131         '(((cons 1 1) 1          /=)
 132           ((cons 1 1) x          <)
 133
 134           ((cons 1 1) (cons 1 1) =)
 135           ((cons 1 2) (cons 1 1) /=)
 136           ((cons 1 x) (cons 1 1) >)
 137           ((cons 2 1) (cons 1 1) /=)
 138           ((cons x 1) (cons 1 1) >))))
 139
 140 ;;; class-pattern
 141
 142 (defclass foo ()
 143   ((bar :initarg :bar)
 144    (baz :initarg :baz)))
 145 (sb-mop:finalize-inheritance (find-class 'foo)) ; TODO optima bug?
 146
 147 (defclass fez (foo) ())
 148 (sb-mop:finalize-inheritance (find-class 'fez)) ; TODO optima bug?
 149
 150 (test class-pattern
 151
 152   (mapc #'process-case
 153         '(((class real)       (class real)              =)
 154           ((class real)       (class string)            /=)
 155           ((class real)       (class integer)           >)
 156
 157           ((class integer)    (class real)              <)
 158           ((class integer)    (class string)            /=)
 159           ((class integer)    (class integer)           =)
 160
 161           ((class foo)        (class foo)               =)
 162           ((class foo)        (class foo :bar x)        >)
 163           ((class foo)        (class foo :bar 1)        >)
 164           ((class foo)        (class foo :baz x)        >)
 165           ((class foo)        (class foo :baz 1)        >)
 166           ((class foo)        (class foo :bar x :baz 1) >)
 167           ((class foo)        (class foo :bar 1 :baz 1) >)
 168           ((class foo)        (class fez)               >)
 169           ((class foo)        (class fez :bar x)        >)
 170           ((class foo)        (class fez :bar 1)        >)
 171           ((class foo)        (class fez :baz x)        >)
 172           ((class foo)        (class fez :baz 1)        >)
 173           ((class foo)        (class fez :bar x :baz 1) >)
 174           ((class foo)        (class fez :bar 1 :baz 1) >)
 175
 176           ((class foo :bar x) (class foo)               <)
 177           ((class foo :bar x) (class foo :bar x)        =)
 178           ((class foo :bar x) (class foo :bar 1)        >)
 179           ((class foo :bar x) (class foo :baz x)        /=)
 180           ((class foo :bar x) (class foo :baz 1)        /=)
 181           ((class foo :bar x) (class foo :bar x :baz 1) >)
 182           ((class foo :bar x) (class foo :bar 1 :baz 1) >)
 183           ((class foo :bar x) (class fez)               /=)
 184           ((class foo :bar x) (class fez :bar x)        >)
 185           ((class foo :bar x) (class fez :bar 1)        >)
 186           ((class foo :bar x) (class fez :baz x)        /=)
 187           ((class foo :bar x) (class fez :baz 1)        /=)
 188           ((class foo :bar x) (class fez :bar x :baz 1) >)
 189           ((class foo :bar x) (class fez :bar 1 :baz 1) >)
 190
 191           ((class foo :bar 1) (class foo)               <)
 192           ((class foo :bar 1) (class foo :bar x)        <)
 193           ((class foo :bar 1) (class foo :bar 1)        =)
 194           ((class foo :bar 1) (class foo :baz x)        /=)
 195           ((class foo :bar 1) (class foo :baz 1)        /=)
 196           ((class foo :bar 1) (class foo :bar x :baz 1) /=)
 197           ((class foo :bar 1) (class foo :bar 1 :baz 1) >)
 198           ((class foo :bar 1) (class fez)               /=)
 199           ((class foo :bar 1) (class fez :bar x)        /=)
 200           ((class foo :bar 1) (class fez :bar 1)        >)
 201           ((class foo :bar 1) (class fez :baz x)        /=)
 202           ((class foo :bar 1) (class fez :baz 1)        /=)
 203           ((class foo :bar 1) (class fez :bar x :baz 1) /=)
 204           ((class foo :bar 1) (class fez :bar 1 :baz 1) >)
 205
 206           ((class fez)        (class foo)               <)
 207           ((class fez)        (class foo :bar x)        /=)
 208           ((class fez)        (class foo :bar 1)        /=)
 209           ((class fez)        (class foo :baz x)        /=)
 210           ((class fez)        (class foo :baz 1)        /=)
 211           ((class fez)        (class foo :bar x :baz 1) /=)
 212           ((class fez)        (class foo :bar 1 :baz 1) /=)
 213           ((class fez)        (class fez)               =)
 214           ((class fez)        (class fez :bar x)        >)
 215           ((class fez)        (class fez :bar 1)        >)
 216           ((class fez)        (class fez :baz x)        >)
 217           ((class fez)        (class fez :baz 1)        >)
 218           ((class fez)        (class fez :bar x :baz 1) >)
 219           ((class fez)        (class fez :bar 1 :baz 1) >)
 220
 221           ((class foo :bar x) (class foo)               <)
 222
 223           ((class foo :baz 1) (class foo)               <)
 224
 225           ((class foo :bar x) (class foo)               <))))