├── test ├── utils.lisp ├── repeater-minute.lisp ├── repeater-day-name.lisp ├── packages.lisp ├── repeater-month-name.lisp ├── numerize.lisp ├── repeater-time.lisp ├── repeater-week.lisp ├── repeater-year.lisp ├── repeater-hour.lisp ├── repeater-fortnight.lisp ├── repeater-month.lisp ├── repeater-weekend.lisp ├── datetime.lisp ├── lisp-unit.lisp └── parsing.lisp ├── repeaters.org ├── chronicity.org ├── src ├── utils.lisp ├── grabber.lisp ├── pointer.lisp ├── packages.lisp ├── repeaters │ ├── repeater-second.lisp │ ├── repeater-day-name.lisp │ ├── repeater-day.lisp │ ├── repeater-month.lisp │ ├── repeater-hour.lisp │ ├── repeater-week.lisp │ ├── repeater-year.lisp │ ├── repeater-minute.lisp │ ├── repeater-fortnight.lisp │ ├── repeater-month-name.lisp │ ├── repeater-weekend.lisp │ ├── repeater-day-portion.lisp │ └── repeater-time.lisp ├── ordinal.lisp ├── separator.lisp ├── scalar.lisp ├── repeater.lisp ├── numerize.lisp ├── chronicity.lisp ├── handlers.lisp ├── datetime.lisp └── handler-defs.lisp ├── numerization.org ├── chronicity-test.asd ├── LICENSE ├── chronicity.asd └── README.md /test/utils.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- 2 | ;;; utils.lisp 3 | 4 | ;;; See the LICENSE file for licensing information. 5 | 6 | (cl:in-package #:chronicity-test) 7 | 8 | (defmacro assert-datetime= (expected form) 9 | (let ((value (gensym "RESULT-"))) 10 | `(let ((,value ,form)) 11 | (assert-true (and ,value (datetime= ,expected ,value)) ,value)))) 12 | -------------------------------------------------------------------------------- /repeaters.org: -------------------------------------------------------------------------------- 1 | #+STARTUP: showall 2 | 3 | + [X] repeater_day_name.rb 4 | + [X] repeater_day_portion.rb 5 | + [X] repeater_day.rb 6 | + [X] repeater_fortnight.rb 7 | + [X] repeater_hour.rb 8 | + [X] repeater_minute.rb 9 | + [X] repeater_month_name.rb 10 | + [X] repeater_month.rb 11 | + [ ] repeater_season_name.rb 12 | + [ ] repeater_season.rb 13 | + [X] repeater_second.rb 14 | + [X] repeater_time.rb 15 | + [ ] repeater_weekday.rb 16 | + [X] repeater_weekend.rb 17 | + [X] repeater_week.rb 18 | + [X] repeater_year.rb 19 | -------------------------------------------------------------------------------- /chronicity.org: -------------------------------------------------------------------------------- 1 | #+STARTUP: showall 2 | 3 | * Elements 4 | ** Repeater 5 | January, February, etc. 6 | Monday, Tuesday, etc. 7 | Days 8 | Day of week 9 | Hours - 5:00PM 10 | ** Grabber 11 | last, this, next 12 | ** Pointer 13 | past, future, in, from 14 | ** Scalar 15 | Numbers, 1-31, 1-12, etc 16 | ** Ordinal 17 | 1st, 2nd, 3rd, etc. 18 | ** Separator 19 | , / - etc. 20 | ** TimeZone 21 | IST, GMT, etc. 22 | 23 | * TODOs 24 | ** Regex (foo|bar) in SLIME 25 | ** Bug in test_offset of test_RepeaterFortnight.rb 26 | ** Handle ambiguous times (12:34, etc.) 27 | 28 | -------------------------------------------------------------------------------- /src/utils.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- 2 | ;;; utils.lisp 3 | 4 | ;;; See the LICENSE file for licensing information. 5 | 6 | (cl:in-package #:chronicity) 7 | 8 | (defmacro aif (test then else) 9 | `(let ((it ,test)) 10 | (if it 11 | ,then 12 | ,else))) 13 | 14 | (defmacro awhen (test &body body) 15 | `(let ((it ,test)) 16 | (when it 17 | ,@body))) 18 | 19 | (defmacro rr-all-f (place regex replacement &rest args) 20 | `(setf ,place (cl-ppcre:regex-replace-all ,regex ,place ,replacement ,@args))) 21 | 22 | -------------------------------------------------------------------------------- /numerization.org: -------------------------------------------------------------------------------- 1 | #+STARTUP: showall 2 | 3 | * direct numbers 4 | 5 | * ten prefixes 6 | 7 | * big prefixes 8 | ** hundred 9 | ** thousand 10 | ** million 11 | ** billion 12 | ** trillion 13 | 14 | * Algorithm 15 | 1. sum<-0, multiplier<-1, tsum<-0. Start from right. 16 | 2. No tokens left? sum<-sum+(tsum * multiplier). Exit and return sum. 17 | 3. Is it a direct or a ten prefix? Then go to 4. 18 | 4. We are at a hundreds prefix. sum<-sum+(tsum * multiplier), tsum<-0, multiplier<-prefix value. Go left. Go to 2. 19 | 5. We are at a tens or a direct prefix. tsum<-tsum+prefix value. Go left. Go to 2. 20 | 21 | 22 | 23 | 24 | -------------------------------------------------------------------------------- /src/grabber.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- 2 | ;;; grabber.lisp 3 | 4 | ;;; See the LICENSE file for licensing information. 5 | 6 | (cl:in-package #:chronicity) 7 | 8 | ;;; Enable cl-interpol reader 9 | 10 | #.(cl-interpol:enable-interpol-syntax) 11 | 12 | (defclass grabber (tag) 13 | ()) 14 | 15 | (defmethod scan-tokens ((tag (eql 'grabber)) tokens) 16 | (let ((scan-map '(("last" :last) 17 | ("this" :this) 18 | ("next" :next)))) 19 | (dolist (token tokens tokens) 20 | (loop 21 | for (regex value) in scan-map 22 | when (cl-ppcre:scan regex (token-word token)) 23 | do (tag (create-tag 'grabber value) token))))) 24 | 25 | ;;; Disable cl-interpol reader 26 | 27 | #.(cl-interpol:disable-interpol-syntax) -------------------------------------------------------------------------------- /src/pointer.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- 2 | ;;; pointer.lisp 3 | 4 | ;;; See the LICENSE file for licensing information. 5 | 6 | (cl:in-package #:chronicity) 7 | 8 | ;;; Enable cl-interpol reader 9 | 10 | #.(cl-interpol:enable-interpol-syntax) 11 | 12 | ;;; TODO: scan should get an EQL symbol 13 | (defclass pointer (tag) 14 | ()) 15 | 16 | (defmethod scan-tokens ((tag (eql 'pointer)) tokens) 17 | (dolist (token tokens) 18 | (awhen (scan-for-pointers token) (tag it token)))) 19 | 20 | (defun scan-for-pointers (token) 21 | (let ((scan-map '((#?r"\bpast\b" :past) 22 | (#?r"\bfuture\b" :future) 23 | (#?r"\bin\b" :future)))) 24 | (loop 25 | for (regex value) in scan-map 26 | when (cl-ppcre:scan regex (token-word token)) 27 | return (create-tag 'pointer value)))) 28 | 29 | ;;; Disable cl-interpol reader 30 | 31 | #.(cl-interpol:disable-interpol-syntax) -------------------------------------------------------------------------------- /src/packages.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- 2 | ;;; packages.lisp 3 | 4 | ;;; See the LICENSE file for licensing information. 5 | 6 | (cl:in-package #:cl-user) 7 | 8 | (defpackage #:chronicity 9 | (:use #:cl) 10 | (:export #:parse 11 | #:*now* 12 | #:*context* 13 | #:*guess* 14 | #:*ambiguous-time-range* 15 | #:*endian-preference* 16 | ;; Datetime 17 | #:datetime 18 | #:make-datetime 19 | #:make-date 20 | #:make-time 21 | #:year-of 22 | #:month-of 23 | #:day-of 24 | #:hour-of 25 | #:minute-of 26 | #:sec-of 27 | #:dow-of 28 | ;; Span 29 | #:span 30 | #:span-start 31 | #:span-end 32 | #:span-end-included-p 33 | #:span-default 34 | ;; Miscellaneous datetime data 35 | #:month-name 36 | #:dow-name 37 | ;; Token 38 | #:token-word 39 | #:token-tags) 40 | (:import-from #:cl-ppcre #:scan)) 41 | 42 | -------------------------------------------------------------------------------- /chronicity-test.asd: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- 2 | ;;; chronicity-test.asd 3 | 4 | ;;; See the LICENSE file for licensing information. 5 | 6 | (cl:defpackage #:chronicity-test-system 7 | (:use #:cl #:asdf)) 8 | 9 | (cl:in-package #:chronicity-test-system) 10 | 11 | (defsystem #:chronicity-test 12 | :author "Chaitanya Gupta" 13 | :maintainer "Chaitanya Gupta" 14 | :depends-on ("chronicity" "lisp-unit") 15 | :components 16 | ((:module test 17 | :serial t 18 | :components 19 | ((:file "packages") 20 | (:file "utils") 21 | (:file "numerize") 22 | (:file "datetime") 23 | (:file "repeater-day-name") 24 | (:file "repeater-fortnight") 25 | (:file "repeater-hour") 26 | (:file "repeater-minute") 27 | (:file "repeater-month-name") 28 | (:file "repeater-month") 29 | (:file "repeater-time") 30 | (:file "repeater-week") 31 | (:file "repeater-weekend") 32 | (:file "repeater-year") 33 | (:file "parsing"))))) 34 | 35 | -------------------------------------------------------------------------------- /src/repeaters/repeater-second.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- 2 | ;;; repeater-second.lisp 3 | 4 | ;;; See the LICENSE file for licensing information. 5 | 6 | (cl:in-package #:chronicity) 7 | 8 | (defclass repeater-sec (repeater) 9 | ((current :initform nil))) 10 | 11 | (defmethod r-next ((repeater repeater-sec) pointer) 12 | (with-slots (current now) 13 | repeater 14 | (if (not current) 15 | (case pointer 16 | (:future (setf current (datetime-incr now :sec))) 17 | (:past (setf current (datetime-decr now :sec)))) 18 | (case pointer 19 | (:future (datetime-incf current :sec)) 20 | (:past (datetime-decf current :sec)))) 21 | (make-span current (datetime-incr current :sec)))) 22 | 23 | (defmethod r-this ((repeater repeater-sec) pointer) 24 | (with-slots (now) 25 | repeater 26 | (make-span now (datetime-incr now :sec)))) 27 | 28 | (defmethod r-offset ((repeater repeater-sec) span amount pointer) 29 | (span+ span (* amount (if (eql pointer :future) 1 -1)) :sec)) 30 | 31 | (defmethod r-width ((repeater repeater-sec)) 32 | +sec-seconds+) 33 | 34 | -------------------------------------------------------------------------------- /src/repeaters/repeater-day-name.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- 2 | ;;; repeater-day-name.lisp 3 | 4 | ;;; See the LICENSE file for licensing information. 5 | 6 | (cl:in-package #:chronicity) 7 | 8 | (defclass repeater-day-name (repeater) 9 | ((current :initform nil))) 10 | 11 | (defmethod r-next ((repeater repeater-day-name) pointer) 12 | (let ((direction (if (eql pointer :future) 1 -1))) 13 | (with-slots (current now) 14 | repeater 15 | (if (not current) 16 | (setf current (datetime-incr (copy-date now) :day direction)) 17 | (setf current (datetime-incr current :day direction))) 18 | (loop 19 | with dow-index = (dow-index (tag-type repeater)) 20 | while (/= (dow-of current) dow-index) 21 | do (setf current (datetime-incr current :day direction))) 22 | (make-span current (datetime-incr current :day) t)))) 23 | 24 | (defmethod r-this ((repeater repeater-day-name) pointer) 25 | (when (member pointer (list :future :none)) 26 | (setf pointer :future)) 27 | (r-next repeater pointer)) 28 | 29 | (defmethod r-width ((repeater repeater-day-name)) 30 | +day-seconds+) -------------------------------------------------------------------------------- /src/ordinal.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- 2 | ;;; ordinal.lisp 3 | 4 | ;;; See the LICENSE file for licensing information. 5 | 6 | (cl:in-package #:chronicity) 7 | 8 | ;;; Enable cl-interpol reader 9 | 10 | #.(cl-interpol:enable-interpol-syntax) 11 | 12 | (defclass ordinal (tag) 13 | ()) 14 | 15 | (defmethod scan-tokens ((tag (eql 'ordinal)) tokens) 16 | (dolist (token tokens tokens) 17 | (awhen (scan-for-ordinals token) (tag it token)) 18 | (awhen (scan-for-ordinal-days token) (tag it token)))) 19 | 20 | (defun scan-for-ordinals (token) 21 | (when (cl-ppcre:scan #?r"^(\d*)(st|nd|rd|th)$" (token-word token)) 22 | (create-tag 'ordinal (parse-integer (token-word token) 23 | :junk-allowed t)))) 24 | 25 | (defclass ordinal-day (ordinal) 26 | ()) 27 | 28 | (defun scan-for-ordinal-days (token) 29 | (when (cl-ppcre:scan #?r"^(\d*)(st|nd|rd|th)$" (token-word token)) 30 | (let ((num (parse-integer (token-word token) :junk-allowed t))) 31 | (when (<= num 31) 32 | (create-tag 'ordinal-day num))))) 33 | 34 | ;;; Disable cl-interpol reader 35 | 36 | #.(cl-interpol:disable-interpol-syntax) 37 | 38 | -------------------------------------------------------------------------------- /src/repeaters/repeater-day.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- 2 | ;;; repeater-day.lisp 3 | 4 | ;;; See the LICENSE file for licensing information. 5 | 6 | (cl:in-package #:chronicity) 7 | 8 | (defclass repeater-day (repeater) 9 | ((current :initform nil))) 10 | 11 | (defmethod r-next ((repeater repeater-day) pointer) 12 | (with-slots (current now) 13 | repeater 14 | (when (not current) 15 | (setf current (copy-date now))) 16 | (let ((direction (if (eql pointer :future) 1 -1))) 17 | (setf current (datetime-incr current :day direction)) 18 | (make-span current (datetime-incr current :day) t)))) 19 | 20 | (defmethod r-this ((repeater repeater-day) pointer) 21 | (with-slots (current now) 22 | repeater 23 | (ecase pointer 24 | (:future (make-span now (start-of-day (datetime-incr now :day)) t)) 25 | (:past (make-span (copy-date now) now t)) 26 | (:none (make-span (copy-date now) 27 | (start-of-day (datetime-incr now :day)) 28 | t 29 | now))))) 30 | 31 | (defmethod r-offset ((repeater repeater-day) span amount pointer) 32 | (let ((offset (* (if (eql pointer :future) 1 -1) amount))) 33 | (span+ span offset :day))) 34 | 35 | (defmethod r-width ((repeater repeater-day)) 36 | +day-seconds+) 37 | -------------------------------------------------------------------------------- /src/repeaters/repeater-month.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- 2 | ;;; repeater-month.lisp 3 | 4 | ;;; See the LICENSE file for licensing information. 5 | 6 | (cl:in-package #:chronicity) 7 | 8 | (defclass repeater-month (repeater) 9 | ((current :initform nil))) 10 | 11 | (defmethod r-next ((repeater repeater-month) pointer) 12 | (let ((offset (if (eql pointer :future) 1 -1))) 13 | (with-slots (current now) 14 | repeater 15 | (if (not current) 16 | (setf current (start-of-month (datetime-incr now :month offset))) 17 | (setf current (start-of-month (datetime-incr current :month offset)))) 18 | (make-span current (datetime-incr (copy-date current) :month))))) 19 | 20 | (defmethod r-this ((repeater repeater-month) pointer) 21 | (with-slots (now) 22 | repeater 23 | (ecase pointer 24 | (:future (make-span now (datetime-incr (copy-date now :day 1) :month))) 25 | (:past (make-span (copy-date now :day 1) now)) 26 | (:none (make-span (copy-date now :day 1) 27 | (datetime-incr (copy-date now :day 1) :month) 28 | nil 29 | now))))) 30 | 31 | (defmethod r-offset ((repeater repeater-month) span amount pointer) 32 | (let ((offset (* (if (eql pointer :future) 1 -1) amount))) 33 | (span+ span offset :month))) 34 | 35 | (defmethod r-width ((repeater repeater-month)) 36 | +month-seconds+) 37 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2009-2016 Chaitanya Gupta 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions 6 | are met: 7 | 8 | 1. Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | 2. Redistributions in binary form must reproduce the above copyright 12 | notice, this list of conditions and the following disclaimer in the 13 | documentation and/or other materials provided with the distribution. 14 | 15 | 3. The name of the author may not be used to endorse or promote products 16 | derived from this software without specific prior written permission. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR 19 | IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES 20 | OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. 21 | IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, 22 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT 23 | NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 24 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 25 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 26 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF 27 | THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 28 | -------------------------------------------------------------------------------- /test/repeater-minute.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- 2 | ;;; repeater-minute.lisp 3 | 4 | ;;; See the LICENSE file for licensing information. 5 | 6 | (cl:in-package #:chronicity-test) 7 | 8 | (define-test repeater-minute-next-future 9 | (let* ((now (make-datetime 2008 6 25 7 15 30)) 10 | (minutes (create-tag 'repeater-minute :minute :now now)) 11 | (next-minute)) 12 | 13 | (setf next-minute (r-next minutes :future)) 14 | (assert-datetime= (make-datetime 2008 6 25 7 16) (span-start next-minute)) 15 | (assert-datetime= (make-datetime 2008 6 25 7 17) (span-end next-minute)) 16 | 17 | (setf next-minute (r-next minutes :future)) 18 | (assert-datetime= (make-datetime 2008 6 25 7 17) (span-start next-minute)) 19 | (assert-datetime= (make-datetime 2008 6 25 7 18) (span-end next-minute)))) 20 | 21 | (define-test repeater-minute-next-past 22 | (let* ((now (make-datetime 2008 6 25 7 15 30)) 23 | (minutes (create-tag 'repeater-minute :minute :now now)) 24 | (next-minute)) 25 | 26 | (setf next-minute (r-next minutes :past)) 27 | (assert-datetime= (make-datetime 2008 6 25 7 14) (span-start next-minute)) 28 | (assert-datetime= (make-datetime 2008 6 25 7 15) (span-end next-minute)) 29 | 30 | (setf next-minute (r-next minutes :past)) 31 | (assert-datetime= (make-datetime 2008 6 25 7 13) (span-start next-minute)) 32 | (assert-datetime= (make-datetime 2008 6 25 7 14) (span-end next-minute)))) 33 | 34 | -------------------------------------------------------------------------------- /src/repeaters/repeater-hour.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- 2 | ;;; repeater-hour.lisp 3 | 4 | ;;; See the LICENSE file for licensing information. 5 | 6 | (cl:in-package #:chronicity) 7 | 8 | (defclass repeater-hour (repeater) 9 | ((current :initform nil))) 10 | 11 | (defmethod r-next ((repeater repeater-hour) pointer) 12 | (with-slots (current now) 13 | repeater 14 | (if (not current) 15 | (case pointer 16 | (:future (setf current (start-of-hour (datetime-incr now :hour)))) 17 | (:past (setf current (start-of-hour (datetime-decr now :hour))))) 18 | (case pointer 19 | (:future (datetime-incf current :hour)) 20 | (:past (datetime-decf current :hour)))) 21 | (make-span current (datetime-incr current :hour)))) 22 | 23 | (defmethod r-this ((repeater repeater-hour) pointer) 24 | (with-slots (now) 25 | repeater 26 | (case pointer 27 | (:future (make-span now 28 | (start-of-hour (datetime-incr now :hour)))) 29 | (:past (make-span (start-of-hour now) 30 | now)) 31 | (:none (make-span (start-of-hour now) 32 | (start-of-hour (datetime-incr now :hour)) 33 | nil 34 | now))))) 35 | 36 | (defmethod r-offset ((repeater repeater-hour) span amount pointer) 37 | (span+ span (* amount (if (eql pointer :future) 1 -1)) :hour)) 38 | 39 | (defmethod r-width ((repeater repeater-hour)) 40 | +hour-seconds+) 41 | 42 | -------------------------------------------------------------------------------- /src/repeaters/repeater-week.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- 2 | ;;; repeater-week.lisp 3 | 4 | ;;; See the LICENSE file for licensing information. 5 | 6 | (cl:in-package #:chronicity) 7 | 8 | (defclass repeater-week (repeater) 9 | ((current-week-start :initform nil))) 10 | 11 | (defmethod r-next ((repeater repeater-week) pointer) 12 | (with-slots (current-week-start now) 13 | repeater 14 | (if (not current-week-start) 15 | (setf current-week-start 16 | (case pointer 17 | (:future (datetime-incr (start-of-week now) :week)) 18 | (:past (datetime-decr (start-of-week now) :week)))) 19 | (if (eql pointer :future) 20 | (datetime-incf current-week-start :week) 21 | (datetime-decf current-week-start :week))) 22 | (make-span current-week-start (datetime-incr current-week-start :day 7)))) 23 | 24 | (defmethod r-this ((repeater repeater-week) pointer) 25 | (with-slots (now) 26 | repeater 27 | (ecase pointer 28 | (:future (make-span now (datetime-incr (start-of-week now) :week))) 29 | (:past (make-span (start-of-week now) now)) 30 | (:none (make-span (start-of-week now) 31 | (datetime-incr (start-of-week now) :week) 32 | nil 33 | now))))) 34 | 35 | (defmethod r-offset ((repeater repeater-week) span amount pointer) 36 | (span+ span (* amount (if (eql pointer :future) 1 -1)) :week)) 37 | 38 | (defmethod r-width ((repeater repeater-week)) 39 | +week-seconds+) 40 | 41 | -------------------------------------------------------------------------------- /src/repeaters/repeater-year.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- 2 | ;;; repeater-year.lisp 3 | 4 | ;;; See the LICENSE file for licensing information. 5 | 6 | (cl:in-package #:chronicity) 7 | 8 | (defclass repeater-year (repeater) 9 | ((current-year :initform nil))) 10 | 11 | (defmethod r-next ((repeater repeater-year) pointer) 12 | (with-slots (current-year now) 13 | repeater 14 | (if (not current-year) 15 | (case pointer 16 | (:future (setf current-year (year-of (datetime-incr now :year)))) 17 | (:past (setf current-year (year-of (datetime-decr now :year))))) 18 | (setf current-year (if (eql pointer :future) 19 | (1+ current-year) 20 | (1- current-year)))) 21 | (make-span (make-date current-year) (make-date (1+ current-year))))) 22 | 23 | (defmethod r-this ((repeater repeater-year) pointer) 24 | (with-slots (now) 25 | repeater 26 | (case pointer 27 | (:future (make-span now (start-of-year (datetime-incr now :year)))) 28 | (:past (make-span (start-of-year now) now)) 29 | (:none (make-span (start-of-year now) 30 | (start-of-year (datetime-incr now :year)) 31 | nil 32 | now))))) 33 | 34 | (defmethod r-offset ((repeater repeater-year) span amount pointer) 35 | (span+ span (* amount (if (eql pointer :future) 1 -1)) :year)) 36 | 37 | (defmethod r-width ((repeater repeater-year)) 38 | +year-seconds+) 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | -------------------------------------------------------------------------------- /src/repeaters/repeater-minute.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- 2 | ;;; repeater-minute.lisp 3 | 4 | ;;; See the LICENSE file for licensing information. 5 | 6 | (cl:in-package #:chronicity) 7 | 8 | (defclass repeater-minute (repeater) 9 | ((current :initform nil))) 10 | 11 | (defmethod r-next ((repeater repeater-minute) pointer) 12 | (with-slots (current now) 13 | repeater 14 | (if (not current) 15 | (case pointer 16 | (:future (setf current (start-of-minute (datetime-incr now :minute)))) 17 | (:past (setf current (start-of-minute (datetime-decr now :minute))))) 18 | (case pointer 19 | (:future (datetime-incf current :minute)) 20 | (:past (datetime-decf current :minute)))) 21 | (make-span current (datetime-incr current :minute)))) 22 | 23 | (defmethod r-this ((repeater repeater-minute) pointer) 24 | (with-slots (now) 25 | repeater 26 | (case pointer 27 | (:future (make-span now 28 | (start-of-minute (datetime-incr now :minute)))) 29 | (:past (make-span (start-of-minute now) 30 | now)) 31 | (:none (make-span (start-of-minute now) 32 | (start-of-minute (datetime-incr now :minute)) 33 | nil 34 | now))))) 35 | 36 | (defmethod r-offset ((repeater repeater-minute) span amount pointer) 37 | (span+ span (* amount (if (eql pointer :future) 1 -1)) :minute)) 38 | 39 | (defmethod r-width ((repeater repeater-minute)) 40 | +minute-seconds+) 41 | 42 | -------------------------------------------------------------------------------- /src/repeaters/repeater-fortnight.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- 2 | ;;; repeater-fortnight.lisp 3 | 4 | ;;; See the LICENSE file for licensing information. 5 | 6 | (cl:in-package #:chronicity) 7 | 8 | (defclass repeater-fortnight (repeater) 9 | ((current-fortnight-start :initform nil))) 10 | 11 | (defmethod r-next ((repeater repeater-fortnight) pointer) 12 | (with-slots (current-fortnight-start now) 13 | repeater 14 | (let ((sunday (start-of-week now))) 15 | (if (not current-fortnight-start) 16 | (case pointer 17 | (:future (setf current-fortnight-start (datetime-incr sunday :week))) 18 | (:past (setf current-fortnight-start (datetime-decr sunday :week 2)))) 19 | (let ((amount (* 2 (if (eql pointer :future) 1 -1)))) 20 | (datetime-incf current-fortnight-start :week amount))) 21 | (make-span current-fortnight-start 22 | (datetime-incr current-fortnight-start :week 2))))) 23 | 24 | (defmethod r-this ((repeater repeater-fortnight) pointer) 25 | (with-slots (now) 26 | repeater 27 | (let ((sunday (start-of-week now))) 28 | (case pointer 29 | (:future (make-span now (datetime-incr sunday :week 2))) 30 | (:past (make-span sunday now)) 31 | (:none (make-span sunday (datetime-incr sunday :week 2) nil now)))))) 32 | 33 | (defmethod r-offset ((repeater repeater-fortnight) span amount pointer) 34 | (span+ span (* 2 amount (if (eql pointer :future) 1 -1)) :week)) 35 | 36 | (defmethod r-width ((repeater repeater-fortnight)) 37 | +fortnight-seconds+) 38 | 39 | -------------------------------------------------------------------------------- /src/repeaters/repeater-month-name.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- 2 | ;;; repeater-month-name.lisp 3 | 4 | ;;; See the LICENSE file for licensing information. 5 | 6 | (cl:in-package #:chronicity) 7 | 8 | (defclass repeater-month-name (repeater) 9 | ((current :initform nil))) 10 | 11 | (defmethod r-next ((repeater repeater-month-name) pointer) 12 | (with-slots (current now) 13 | repeater 14 | (if (not current) 15 | (let* ((target-month (month-index (tag-type repeater))) 16 | (now-month (month-of now)) 17 | (now-year (year-of now)) 18 | (target-year (ecase pointer 19 | (:future (cond ((<= now-month target-month) now-year) 20 | (t (1+ now-year)))) 21 | (:none (cond ((<= now-month target-month) now-year) 22 | (t (1+ now-year)))) 23 | (:past (cond ((>= now-month target-month) now-year) 24 | (t (1- now-year))))))) 25 | (setf current (make-date target-year target-month))) 26 | (ecase pointer 27 | (:future (setf current (datetime-incr current :year 1))) 28 | (:past (setf current (datetime-decr current :year 1))))) 29 | (make-span current (datetime-incr current :month 1)))) 30 | 31 | (defmethod r-this ((repeater repeater-month-name) pointer) 32 | (ecase pointer 33 | (:past (r-next repeater :past)) 34 | ((:future :none) (r-next repeater :none)))) 35 | 36 | (defmethod r-width ((repeater repeater-month-name)) 37 | +month-seconds+) 38 | 39 | (defmethod r-index ((repeater repeater-month-name)) 40 | (month-index (tag-type repeater))) -------------------------------------------------------------------------------- /test/repeater-day-name.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- 2 | ;;; repeater-day-name.lisp 3 | 4 | ;;; See the LICENSE file for licensing information. 5 | 6 | (cl:in-package #:chronicity-test) 7 | 8 | (define-test repeater-day-name-match 9 | (let* ((token (create-token "saturday")) 10 | (repeater (chronicity::scan-for-day-names token))) 11 | (assert-true (typep repeater 'repeater-day-name) (class-of repeater)) 12 | (assert-eql :saturday (tag-type repeater))) 13 | (let* ((token (create-token "sunday")) 14 | (repeater (chronicity::scan-for-day-names token))) 15 | (assert-true (typep repeater 'repeater-day-name) (class-of repeater)) 16 | (assert-eql :sunday (tag-type repeater)))) 17 | 18 | (define-test repeater-day-name-next-future 19 | (let* ((now (make-datetime 2006 8 16 14)) 20 | (mondays (create-tag 'repeater-day-name :monday :now now)) 21 | (span nil)) 22 | (setf span (r-next mondays :future)) 23 | (assert-datetime= (make-datetime 2006 8 21) (span-start span)) 24 | (assert-datetime= (make-datetime 2006 8 22) (span-end span)) 25 | 26 | (setf span (r-next mondays :future)) 27 | (assert-datetime= (make-datetime 2006 8 28) (span-start span)) 28 | (assert-datetime= (make-datetime 2006 8 29) (span-end span)))) 29 | 30 | (define-test repeater-day-name-next-past 31 | (let* ((now (make-datetime 2006 8 16 14)) 32 | (mondays (create-tag 'repeater-day-name :monday :now now)) 33 | (span nil)) 34 | (setf span (r-next mondays :past)) 35 | (assert-datetime= (make-datetime 2006 8 14) (span-start span)) 36 | (assert-datetime= (make-datetime 2006 8 15) (span-end span)) 37 | 38 | (setf span (r-next mondays :past)) 39 | (assert-datetime= (make-datetime 2006 8 7) (span-start span)) 40 | (assert-datetime= (make-datetime 2006 8 8) (span-end span)))) 41 | 42 | 43 | 44 | 45 | 46 | 47 | -------------------------------------------------------------------------------- /test/packages.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- 2 | ;;; packages.lisp 3 | 4 | ;;; See the LICENSE file for licensing information. 5 | 6 | (cl:in-package #:cl-user) 7 | 8 | (defpackage #:chronicity-test 9 | (:use #:cl #:lisp-unit #:chronicity) 10 | (:export #:run-suite)) 11 | 12 | (do-symbols (s :chronicity) 13 | (let ((name (symbol-name s))) 14 | (when (and (eql (symbol-package s) (find-package :chronicity)) 15 | (or (member name (list "PARSE" 16 | "NUMERIZE" 17 | "CREATE-TOKEN" 18 | "CREATE-TAG" 19 | "TAG-TYPE" 20 | "TAG-NOW" 21 | "R-NEXT" 22 | "R-THIS" 23 | "R-WIDTH" 24 | "R-OFFSET" 25 | "NOW" 26 | "TICK-TIME" 27 | "YEAR-OF" 28 | "MONTH-OF" 29 | "DAY-OF" 30 | "HOUR-OF" 31 | "MINUTE-OF" 32 | "SEC-OF" 33 | "DOW-OF" 34 | "DAY-SEC-OF") 35 | :test #'string=) 36 | (search "REPEATER" name) 37 | (search "DATE" name) 38 | (search "TIME" name) 39 | (search "DATETIME" name) 40 | (search "SPAN" name))) 41 | (import s :chronicity-test)))) 42 | 43 | (in-package #:chronicity-test) 44 | 45 | (defun run-suite () 46 | (run-tests :all :chronicity-test)) 47 | 48 | -------------------------------------------------------------------------------- /src/separator.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- 2 | ;;; separator.lisp 3 | 4 | ;;; See the LICENSE file for licensing information. 5 | 6 | (cl:in-package #:chronicity) 7 | 8 | ;;; TODO: the 'of' separator? or is it a pointer? 9 | 10 | ;;; Enable cl-interpol reader 11 | 12 | #.(cl-interpol:enable-interpol-syntax) 13 | 14 | (defclass separator (tag) 15 | ()) 16 | 17 | (defmethod scan-tokens ((tag (eql 'separator)) tokens) 18 | (dolist (token tokens tokens) 19 | (awhen (scan-for-commas token) (tag it token)) 20 | (awhen (scan-for-slash-or-dash token) (tag it token)) 21 | (awhen (scan-for-at token) (tag it token)) 22 | (awhen (scan-for-in token) (tag it token)) 23 | (awhen (scan-for-on token) (tag it token)))) 24 | 25 | (defclass separator-comma (separator) 26 | ()) 27 | 28 | (defun scan-for-commas (token) 29 | (and (scan "^,$" (token-word token)) 30 | (create-tag 'separator-comma :comma))) 31 | 32 | (defclass separator-slash-or-dash (separator) 33 | ()) 34 | 35 | (defun scan-for-slash-or-dash (token) 36 | (let ((scan-map '((#?r"^-$" :comma) 37 | (#?r"^\/$" :slash)))) 38 | (loop 39 | for (regex value) in scan-map 40 | when (scan regex (token-word token)) 41 | return (create-tag 'separator-slash-or-dash value)))) 42 | 43 | (defclass separator-at (separator) 44 | ()) 45 | 46 | (defun scan-for-at (token) 47 | (and (scan #?r"^(at|@)$" (token-word token)) 48 | (create-tag 'separator-at :at))) 49 | 50 | (defclass separator-in (separator) 51 | ()) 52 | 53 | (defun scan-for-in (token) 54 | (and (scan #?r"^in$" (token-word token)) 55 | (create-tag 'separator-in :in))) 56 | 57 | (defclass separator-on (separator) 58 | ()) 59 | 60 | (defun scan-for-on (token) 61 | (and (scan #?r"^on$" (token-word token)) 62 | (create-tag 'separator-on :on))) 63 | 64 | ;;; Disable cl-interpol reader 65 | 66 | #.(cl-interpol:disable-interpol-syntax) -------------------------------------------------------------------------------- /test/repeater-month-name.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- 2 | ;;; repeater-month-name.lisp 3 | 4 | ;;; See the LICENSE file for licensing information. 5 | 6 | (cl:in-package #:chronicity-test) 7 | 8 | (define-test repeater-month-name-next 9 | (let* ((now (make-datetime 2006 8 16 14)) 10 | (mays (create-tag 'repeater-month-name :may :now now)) 11 | (decembers (create-tag 'repeater-month-name :december :now now)) 12 | (next-may nil) 13 | (next-december nil)) 14 | ;; future 15 | (setf next-may (r-next mays :future)) 16 | (assert-datetime= (make-datetime 2007 5) (span-start next-may)) 17 | (assert-datetime= (make-datetime 2007 6) (span-end next-may)) 18 | 19 | (setf next-may (r-next mays :future)) 20 | (assert-datetime= (make-datetime 2008 5) (span-start next-may)) 21 | (assert-datetime= (make-datetime 2008 6) (span-end next-may)) 22 | 23 | (setf next-december (r-next decembers :future)) 24 | (assert-datetime= (make-datetime 2006 12) (span-start next-december)) 25 | (assert-datetime= (make-datetime 2007 1) (span-end next-december)) 26 | 27 | ;; past 28 | (setf mays (create-tag 'repeater-month-name :may :now now)) 29 | 30 | (setf next-may (r-next mays :past)) 31 | (assert-datetime= (make-datetime 2006 5) (span-start next-may)) 32 | 33 | (setf next-may (r-next mays :past)) 34 | (assert-datetime= (make-datetime 2005 5) (span-start next-may)))) 35 | 36 | (define-test repeater-month-name-this 37 | (let* ((now (make-datetime 2006 8 16 14)) 38 | (octobers (create-tag 'repeater-month-name :october :now now)) 39 | (this-october (r-this octobers :future)) 40 | (aprils (create-tag 'repeater-month-name :april :now now)) 41 | (this-april (r-this aprils :past))) 42 | (assert-datetime= (make-datetime 2006 10 1) (span-start this-october)) 43 | (assert-datetime= (make-datetime 2006 11 1) (span-end this-october)) 44 | 45 | (assert-datetime= (make-datetime 2006 4 1) (span-start this-april)) 46 | (assert-datetime= (make-datetime 2006 5 1) (span-end this-april)))) 47 | 48 | -------------------------------------------------------------------------------- /chronicity.asd: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- 2 | ;;; chronicity.asd 3 | 4 | ;;; See the LICENSE file for licensing information. 5 | 6 | (cl:defpackage #:chronicity-system 7 | (:use #:cl #:asdf)) 8 | 9 | (cl:in-package #:chronicity-system) 10 | 11 | (defsystem #:chronicity 12 | :description "A natural language date and time parser for Common Lisp" 13 | :version "0.4.1" 14 | :author "Chaitanya Gupta" 15 | :maintainer "Chaitanya Gupta" 16 | :license "BSD" 17 | :depends-on (:cl-ppcre :cl-interpol :local-time) 18 | :components 19 | ((:module src 20 | :serial t 21 | :components 22 | ((:file "packages") 23 | (:file "utils") 24 | (:file "datetime") 25 | (:file "numerize") 26 | (:file "chronicity") 27 | (:file "repeater") 28 | (:module repeaters 29 | :components 30 | ((:file "repeater-year") 31 | ;; (:file "repeater-season") 32 | ;; (:file "repeater-season-name") 33 | (:file "repeater-month") 34 | (:file "repeater-month-name") 35 | (:file "repeater-fortnight") 36 | (:file "repeater-week") 37 | (:file "repeater-weekend") 38 | (:file "repeater-day") 39 | (:file "repeater-day-name") 40 | (:file "repeater-day-portion") 41 | (:file "repeater-hour") 42 | (:file "repeater-minute") 43 | (:file "repeater-second") 44 | (:file "repeater-time"))) 45 | (:file "grabber") 46 | (:file "pointer") 47 | (:file "scalar") 48 | (:file "ordinal") 49 | (:file "separator") 50 | (:file "handlers") 51 | (:file "handler-defs"))))) 52 | 53 | (defmethod perform ((o test-op) (c (eql (find-system :chronicity)))) 54 | (operate 'load-op :chronicity-test) 55 | (funcall (intern (symbol-name :run-suite) :chronicity-test))) 56 | -------------------------------------------------------------------------------- /test/numerize.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- 2 | ;;; numerize.lisp 3 | 4 | ;;; See the LICENSE file for licensing information. 5 | 6 | (in-package #:chronicity-test) 7 | 8 | ;;; Numerizer tests 9 | 10 | (defparameter *numerizer-test-map* 11 | '(("one" 1) 12 | ("five" 5) 13 | ("ten" 10) 14 | ("eleven" 11) 15 | ("twelve" 12) 16 | ("thirteen" 13) 17 | ("fourteen" 14) 18 | ("fifteen" 15) 19 | ("sixteen" 16) 20 | ("seventeen" 17) 21 | ("eighteen" 18) 22 | ("nineteen" 19) 23 | ("twenty" 20) 24 | ("first" "1st") 25 | ("third" "3rd") 26 | ("fifth" "5th") 27 | ("nineteenth" "19th") 28 | ("sixtieth" "60th") 29 | ("twenty seven" 27) 30 | ("thirty-one" 31) 31 | ("fifty nine" 59) 32 | ("one hundred" 100) 33 | ("one hundredth" "100th") 34 | ("one hundred and fifty" 150) 35 | ("one hundred and fiftieth" "150th") 36 | ("two-hundred" 200) 37 | ("nine hundred and ninety nine" 999) 38 | ("nine hundred and ninety ninth" "999th") 39 | ("one thousand" 1000) 40 | ("twelve hundred" 1200) 41 | ("twelve hundredth" "1200th") 42 | ("one thousand two hundred" 1200) 43 | ("seventeen thousand" 17000) 44 | ("a hundred" "a 100") 45 | ("seventy four thousand and two" 74002) 46 | ("ninety nine thousand nine hundred ninety nine" 99999) 47 | ("ninety nine thousand nine hundred ninety nineth" "99999th") 48 | ("one lakh ten thousand two hundred and seven" "110207") 49 | ("three crore one lakh ten thousand two hundred and seven" "30110207") 50 | ("two hundred fifty thousand" 250000) 51 | ("one million" 1000000) 52 | ("one million two hundred fifty thousand and seven" 1250007) 53 | ("one million two hundred fifty thousand and seventh" "1250007th") 54 | ("one billion" 1000000000) 55 | ("one billion and one" 1000000001) 56 | ("two foo" "2 foo") 57 | ("a four" "a 4") 58 | ("foo seven bar" "foo 7 bar") 59 | ("seven hours before now" "7 hours before now") 60 | ("three hundred and sixty two days from now" "362 days from now"))) 61 | 62 | (define-test numerizer-test 63 | (loop 64 | for (string result) in *numerizer-test-map* 65 | for result-string = (format nil "~A" result) 66 | do (assert-equal result-string (chronicity-numerizer:numerize string) 67 | string))) 68 | 69 | -------------------------------------------------------------------------------- /src/scalar.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- 2 | ;;; scalar.lisp 3 | 4 | ;;; See the LICENSE file for licensing information. 5 | 6 | (cl:in-package #:chronicity) 7 | 8 | ;;; Enable cl-interpol reader 9 | 10 | #.(cl-interpol:enable-interpol-syntax) 11 | 12 | (defclass scalar (tag) 13 | ()) 14 | 15 | (defmethod scan-tokens ((tag (eql 'scalar)) tokens) 16 | (loop 17 | for (token post-token) on tokens 18 | do 19 | (awhen (scan-for-scalars token post-token) (tag it token)) 20 | (awhen (scan-for-scalar-days token post-token) (tag it token)) 21 | (awhen (scan-for-scalar-months token post-token) (tag it token)) 22 | (awhen (scan-for-scalar-years token post-token) (tag it token))) 23 | tokens) 24 | 25 | (defparameter *day-portions* 26 | (list :am :pm :morning :afternoon :evening :night)) 27 | 28 | (defun check-post-token (token) 29 | (or (not token) 30 | (not (member (token-word token) 31 | (mapcar #'string *day-portions*) 32 | :test #'equalp)))) 33 | 34 | (defun scan-for-scalars (token post-token) 35 | (when (and (cl-ppcre:scan #?r"^\d*$" (token-word token)) 36 | (check-post-token post-token)) 37 | (create-tag 'scalar (parse-integer (token-word token))))) 38 | 39 | (defclass scalar-day (scalar) 40 | ()) 41 | 42 | (defun scan-for-scalar-days (token post-token) 43 | (when (and (cl-ppcre:scan #?r"^\d\d?$" (token-word token)) 44 | (<= (parse-integer (token-word token)) 31) 45 | (check-post-token post-token)) 46 | (create-tag 'scalar-day (parse-integer (token-word token))))) 47 | 48 | (defclass scalar-month (scalar) 49 | ()) 50 | 51 | (defun scan-for-scalar-months (token post-token) 52 | (when (and (cl-ppcre:scan #?r"^\d\d?$" (token-word token)) 53 | (<= (parse-integer (token-word token)) 12) 54 | (check-post-token post-token)) 55 | (create-tag 'scalar-month (parse-integer (token-word token))))) 56 | 57 | (defclass scalar-year (scalar) 58 | ()) 59 | 60 | (defun scan-for-scalar-years (token post-token) 61 | (when (and (cl-ppcre:scan #?r"^([1-9]\d)?\d\d?$" (token-word token)) 62 | (check-post-token post-token)) 63 | (let* ((year (parse-integer (token-word token))) 64 | (guessed-year (cond 65 | ((< year 70) (+ year 2000)) 66 | ((< year 100) (+ year 1900)) 67 | (t year)))) 68 | (create-tag 'scalar-year guessed-year)))) 69 | 70 | ;;; Disable cl-interpol reader 71 | 72 | #.(cl-interpol:disable-interpol-syntax) -------------------------------------------------------------------------------- /test/repeater-time.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- 2 | ;;; repeater-time.lisp 3 | 4 | ;;; See the LICENSE file for licensing information. 5 | 6 | (cl:in-package #:chronicity-test) 7 | 8 | (define-test repeater-time-next-future 9 | (let* ((now (make-datetime 2006 8 16 14)) 10 | (tr (create-tag 'repeater-time "4:00" :now now))) 11 | 12 | (assert-datetime= (make-datetime 2006 8 16 16) (span-start (r-next tr :future))) 13 | (assert-datetime= (make-datetime 2006 8 17 4) (span-start (r-next tr :future))) 14 | 15 | (setf tr (create-tag 'repeater-time "13:00" :now now)) 16 | (assert-datetime= (make-datetime 2006 8 17 13) (span-start (r-next tr :future))) 17 | (assert-datetime= (make-datetime 2006 8 18 13) (span-start (r-next tr :future))) 18 | 19 | (setf tr (create-tag 'repeater-time "0400" :now now)) 20 | (assert-datetime= (make-datetime 2006 8 17 4) (span-start (r-next tr :future))) 21 | (assert-datetime= (make-datetime 2006 8 18 4) (span-start (r-next tr :future))))) 22 | 23 | (define-test repeater-time-next-past 24 | (let* ((now (make-datetime 2006 8 16 14)) 25 | (tr (create-tag 'repeater-time "4:00" :now now))) 26 | 27 | (assert-datetime= (make-datetime 2006 8 16 4) (span-start (r-next tr :past))) 28 | (assert-datetime= (make-datetime 2006 8 15 16) (span-start (r-next tr :past))) 29 | 30 | (setf tr (create-tag 'repeater-time "13:00" :now now)) 31 | (assert-datetime= (make-datetime 2006 8 16 13) (span-start (r-next tr :past))) 32 | (assert-datetime= (make-datetime 2006 8 15 13) (span-start (r-next tr :past))))) 33 | 34 | (define-test repeater-time-test-type 35 | (let ((tr nil)) 36 | (flet ((!create-tag (str) 37 | (create-tag 'repeater-time str)) 38 | (!time (tr) 39 | (tick-time (tag-type tr)))) 40 | (setf tr (!create-tag "4")) 41 | (assert-datetime= (make-time 4) (!time tr)) 42 | 43 | (setf tr (!create-tag "14")) 44 | (assert-datetime= (make-time 14) (!time tr)) 45 | 46 | (setf tr (!create-tag "4:00")) 47 | (assert-datetime= (make-time 4) (!time tr)) 48 | 49 | (setf tr (!create-tag "4:30")) 50 | (assert-datetime= (make-time 4 30) (!time tr)) 51 | 52 | (setf tr (!create-tag "1400")) 53 | (assert-datetime= (make-time 14) (!time tr)) 54 | 55 | (setf tr (!create-tag "0400")) 56 | (assert-datetime= (make-time 4) (!time tr)) 57 | 58 | (setf tr (!create-tag "04")) 59 | (assert-datetime= (make-time 4) (!time tr)) 60 | 61 | (setf tr (!create-tag "400")) 62 | (assert-datetime= (make-time 4) (!time tr))))) 63 | 64 | -------------------------------------------------------------------------------- /test/repeater-week.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- 2 | ;;; repeater-week.lisp 3 | 4 | ;;; See the LICENSE file for licensing information. 5 | 6 | (cl:in-package #:chronicity-test) 7 | 8 | (define-test repeater-week-next-future 9 | (let* ((now (make-datetime 2006 8 16 14)) 10 | (weeks (create-tag 'repeater-week :week :now now)) 11 | (next-week)) 12 | 13 | (setf next-week (r-next weeks :future)) 14 | (assert-datetime= (make-datetime 2006 8 20) (span-start next-week)) 15 | (assert-datetime= (make-datetime 2006 8 27) (span-end next-week)) 16 | 17 | (setf next-week (r-next weeks :future)) 18 | (assert-datetime= (make-datetime 2006 8 27) (span-start next-week)) 19 | (assert-datetime= (make-datetime 2006 9 3) (span-end next-week)))) 20 | 21 | (define-test repeater-week-next-past 22 | (let* ((now (make-datetime 2006 8 16 14)) 23 | (weeks (create-tag 'repeater-week :week :now now)) 24 | (next-week)) 25 | 26 | (setf next-week (r-next weeks :past)) 27 | (assert-datetime= (make-datetime 2006 8 6) (span-start next-week)) 28 | (assert-datetime= (make-datetime 2006 8 13) (span-end next-week)) 29 | 30 | (setf next-week (r-next weeks :past)) 31 | (assert-datetime= (make-datetime 2006 7 30) (span-start next-week)) 32 | (assert-datetime= (make-datetime 2006 8 6) (span-end next-week)))) 33 | 34 | (define-test repeater-week-this-future 35 | (let* ((now (make-datetime 2006 8 16 14)) 36 | (weeks (create-tag 'repeater-week :week :now now)) 37 | (this-week)) 38 | 39 | (setf this-week (r-this weeks :future)) 40 | (assert-datetime= (make-datetime 2006 8 16 14) (span-start this-week)) 41 | (assert-datetime= (make-datetime 2006 8 20) (span-end this-week)))) 42 | 43 | (define-test repeater-week-this-past 44 | (let* ((now (make-datetime 2006 8 16 14)) 45 | (weeks (create-tag 'repeater-week :week :now now)) 46 | (this-week)) 47 | 48 | (setf this-week (r-this weeks :past)) 49 | (assert-datetime= (make-datetime 2006 8 13 0) (span-start this-week)) 50 | (assert-datetime= (make-datetime 2006 8 16 14) (span-end this-week)))) 51 | 52 | (define-test repeater-week-offset 53 | (let* ((now (make-datetime 2006 8 16 14)) 54 | (span (make-span now (datetime-incr now :sec))) 55 | (offset-span (r-offset (create-tag 'repeater-week :week) 56 | span 3 :future))) 57 | (assert-datetime= (make-datetime 2006 9 6 14) (span-start offset-span)) 58 | (assert-datetime= (make-datetime 2006 9 6 14 0 1) (span-end offset-span)))) 59 | 60 | 61 | 62 | 63 | 64 | 65 | -------------------------------------------------------------------------------- /test/repeater-year.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- 2 | ;;; repeater-year.lisp 3 | 4 | ;;; See the LICENSE file for licensing information. 5 | 6 | (cl:in-package #:chronicity-test) 7 | 8 | (define-test repeater-year-next-future 9 | (let* ((now (make-datetime 2006 8 16 14)) 10 | (years (create-tag 'repeater-year :year :now now)) 11 | (next-year)) 12 | 13 | (setf next-year (r-next years :future)) 14 | (assert-datetime= (make-datetime 2007 1 1) (span-start next-year)) 15 | (assert-datetime= (make-datetime 2008 1 1) (span-end next-year)) 16 | 17 | (setf next-year (r-next years :future)) 18 | (assert-datetime= (make-datetime 2008 1 1) (span-start next-year)) 19 | (assert-datetime= (make-datetime 2009 1 1) (span-end next-year)))) 20 | 21 | (define-test repeater-year-next-past 22 | (let* ((now (make-datetime 2006 8 16 14)) 23 | (years (create-tag 'repeater-year :year :now now)) 24 | (next-year)) 25 | 26 | (setf next-year (r-next years :past)) 27 | (assert-datetime= (make-datetime 2005 1 1) (span-start next-year)) 28 | (assert-datetime= (make-datetime 2006 1 1) (span-end next-year)) 29 | 30 | (setf next-year (r-next years :past)) 31 | (assert-datetime= (make-datetime 2004 1 1) (span-start next-year)) 32 | (assert-datetime= (make-datetime 2005 1 1) (span-end next-year)))) 33 | 34 | (define-test repeater-year-this 35 | (let* ((now (make-datetime 2006 8 16 14)) 36 | (years (create-tag 'repeater-year :year :now now)) 37 | (this-year)) 38 | 39 | (setf this-year (r-this years :future)) 40 | (assert-datetime= (make-datetime 2006 8 16 14) (span-start this-year)) 41 | (assert-datetime= (make-datetime 2007 1 1) (span-end this-year)) 42 | 43 | (setf this-year (r-this years :past)) 44 | (assert-datetime= (make-datetime 2006 1 1) (span-start this-year)) 45 | (assert-datetime= (make-datetime 2006 8 16 14) (span-end this-year)))) 46 | 47 | (define-test repeater-year-offset 48 | (let* ((now (make-datetime 2006 8 16 14)) 49 | (span (make-span now (datetime-incr now :sec))) 50 | (repeater (create-tag 'repeater-year :year)) 51 | (offset-span)) 52 | 53 | (setf offset-span (r-offset repeater span 3 :future)) 54 | (assert-datetime= (make-datetime 2009 8 16 14) (span-start offset-span)) 55 | (assert-datetime= (make-datetime 2009 8 16 14 0 1) (span-end offset-span)) 56 | 57 | (setf offset-span (r-offset repeater span 10 :past)) 58 | (assert-datetime= (make-datetime 1996 8 16 14) (span-start offset-span)) 59 | (assert-datetime= (make-datetime 1996 8 16 14 0 1) (span-end offset-span)))) 60 | 61 | -------------------------------------------------------------------------------- /src/repeaters/repeater-weekend.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- 2 | ;;; repeater-weekend.lisp 3 | 4 | ;;; See the LICENSE file for licensing information. 5 | 6 | (cl:in-package #:chronicity) 7 | 8 | (defclass repeater-weekend (repeater) 9 | ((current-weekend-start :initform nil))) 10 | 11 | (defmethod r-next ((repeater repeater-weekend) pointer) 12 | (with-slots (current-weekend-start now) 13 | repeater 14 | (if (not current-weekend-start) 15 | (case pointer 16 | (:future 17 | (let ((sat-repeater (create-tag 'repeater-day-name :saturday))) 18 | (setf (tag-now sat-repeater) now) 19 | (setf current-weekend-start (span-start (r-next sat-repeater :future))))) 20 | (:past 21 | (let ((sat-repeater (create-tag 'repeater-day-name :saturday))) 22 | (setf (tag-now sat-repeater) (datetime-incr now :day)) 23 | (setf current-weekend-start (span-start (r-next sat-repeater :past)))))) 24 | (let ((direction (if (eql pointer :future) 1 -1))) 25 | (setf current-weekend-start (datetime-incr current-weekend-start :week direction)))) 26 | (make-span current-weekend-start (datetime-incr current-weekend-start :day 2)))) 27 | 28 | ;;; TODO: We should fix, and understand this better 29 | (defmethod r-this ((repeater repeater-weekend) pointer) 30 | (with-slots (now) 31 | repeater 32 | (case pointer 33 | ((:future :none) 34 | (let ((sat-repeater (create-tag 'repeater-day-name :saturday))) 35 | (setf (tag-now sat-repeater) now) 36 | (let ((saturday (span-start (r-next sat-repeater :future)))) 37 | (make-span saturday (datetime-incr saturday :day 2))))) 38 | (:past 39 | (let ((sat-repeater (create-tag 'repeater-day-name :saturday))) 40 | (setf (tag-now sat-repeater) now) 41 | (let ((saturday (span-start (r-next sat-repeater :past)))) 42 | (make-span saturday (datetime-incr saturday :day 2)))))))) 43 | 44 | (defmethod r-offset ((repeater repeater-weekend) span amount pointer) 45 | (let* ((direction (if (eql pointer :future) 1 -1)) 46 | (weekend-repeater (create-tag 'repeater-weekend 47 | :weekend 48 | :now (span-start span))) 49 | (start (datetime-incr (span-start (r-next weekend-repeater pointer)) 50 | :week 51 | (* (1- amount) direction)))) 52 | (make-span start (datetime-incr start :sec (span-width span))))) 53 | 54 | (defmethod r-width ((repeater repeater-weekend)) 55 | +weekend-seconds+) 56 | 57 | -------------------------------------------------------------------------------- /test/repeater-hour.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- 2 | ;;; repeater-hour.lisp 3 | 4 | ;;; See the LICENSE file for licensing information. 5 | 6 | (cl:in-package #:chronicity-test) 7 | 8 | (define-test repeater-hour-next-future 9 | (let* ((now (make-datetime 2006 8 16 14)) 10 | (hours (create-tag 'repeater-hour :hour :now now)) 11 | (next-hour)) 12 | 13 | (setf next-hour (r-next hours :future)) 14 | (assert-datetime= (make-datetime 2006 8 16 15) (span-start next-hour)) 15 | (assert-datetime= (make-datetime 2006 8 16 16) (span-end next-hour)) 16 | 17 | (setf next-hour (r-next hours :future)) 18 | (assert-datetime= (make-datetime 2006 8 16 16) (span-start next-hour)) 19 | (assert-datetime= (make-datetime 2006 8 16 17) (span-end next-hour)))) 20 | 21 | (define-test repeater-hour-next-past 22 | (let* ((now (make-datetime 2006 8 16 14)) 23 | (hours (create-tag 'repeater-hour :hour :now now)) 24 | (next-hour)) 25 | 26 | (setf next-hour (r-next hours :past)) 27 | (assert-datetime= (make-datetime 2006 8 16 13) (span-start next-hour)) 28 | (assert-datetime= (make-datetime 2006 8 16 14) (span-end next-hour)) 29 | 30 | (setf next-hour (r-next hours :past)) 31 | (assert-datetime= (make-datetime 2006 8 16 12) (span-start next-hour)) 32 | (assert-datetime= (make-datetime 2006 8 16 13) (span-end next-hour)))) 33 | 34 | (define-test repeater-hour-this 35 | (let* ((now (make-datetime 2006 8 16 14 30)) 36 | (hours (create-tag 'repeater-hour :hour :now now)) 37 | (this-hour)) 38 | 39 | (setf this-hour (r-this hours :future)) 40 | (assert-datetime= (make-datetime 2006 8 16 14 30) (span-start this-hour)) 41 | (assert-datetime= (make-datetime 2006 8 16 15) (span-end this-hour)) 42 | 43 | (setf this-hour (r-this hours :past)) 44 | (assert-datetime= (make-datetime 2006 8 16 14) (span-start this-hour)) 45 | (assert-datetime= (make-datetime 2006 8 16 14 30) (span-end this-hour)))) 46 | 47 | (define-test repeater-hour-offset 48 | (let* ((now (make-datetime 2006 8 16 14)) 49 | (span (make-span now (datetime-incr now :sec))) 50 | (offset-span) 51 | (repeater (create-tag 'repeater-hour :hour))) 52 | 53 | (setf offset-span (r-offset repeater span 3 :future)) 54 | (assert-datetime= (make-datetime 2006 8 16 17) (span-start offset-span)) 55 | (assert-datetime= (make-datetime 2006 8 16 17 0 1) (span-end offset-span)) 56 | 57 | (setf offset-span (r-offset repeater span 24 :past)) 58 | (assert-datetime= (make-datetime 2006 8 15 14) (span-start offset-span)) 59 | (assert-datetime= (make-datetime 2006 8 15 14 0 1) (span-end offset-span)))) 60 | 61 | -------------------------------------------------------------------------------- /test/repeater-fortnight.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- 2 | ;;; repeater-fortnight.lisp 3 | 4 | ;;; See the LICENSE file for licensing information. 5 | 6 | (cl:in-package #:chronicity-test) 7 | 8 | (define-test repeater-fortnight-next-future 9 | (let* ((now (make-datetime 2006 8 16 14)) 10 | (fortnights (create-tag 'repeater-fortnight :fortnight :now now)) 11 | (next-fortnight)) 12 | (setf next-fortnight (r-next fortnights :future)) 13 | (assert-datetime= (make-datetime 2006 8 20) (span-start next-fortnight)) 14 | (assert-datetime= (make-datetime 2006 9 3) (span-end next-fortnight)) 15 | 16 | (setf next-fortnight (r-next fortnights :future)) 17 | (assert-datetime= (make-datetime 2006 9 3) (span-start next-fortnight)) 18 | (assert-datetime= (make-datetime 2006 9 17) (span-end next-fortnight)))) 19 | 20 | (define-test repeater-fortnight-next-past 21 | (let* ((now (make-datetime 2006 8 16 14)) 22 | (fortnights (create-tag 'repeater-fortnight :fortnight :now now)) 23 | (next-fortnight)) 24 | (setf next-fortnight (r-next fortnights :past)) 25 | (assert-datetime= (make-datetime 2006 7 30) (span-start next-fortnight)) 26 | (assert-datetime= (make-datetime 2006 8 13) (span-end next-fortnight)) 27 | 28 | (setf next-fortnight (r-next fortnights :past)) 29 | (assert-datetime= (make-datetime 2006 7 16) (span-start next-fortnight)) 30 | (assert-datetime= (make-datetime 2006 7 30) (span-end next-fortnight)))) 31 | 32 | (define-test repeater-fortnight-this-future 33 | (let* ((now (make-datetime 2006 8 16 14)) 34 | (fortnights (create-tag 'repeater-fortnight :fortnight :now now)) 35 | (this-fortnight (r-this fortnights :future))) 36 | (assert-datetime= (make-datetime 2006 8 16 14) (span-start this-fortnight)) 37 | (assert-datetime= (make-datetime 2006 8 27) (span-end this-fortnight)))) 38 | 39 | (define-test repeater-fortnight-this-past 40 | (let* ((now (make-datetime 2006 8 16 14)) 41 | (fortnights (create-tag 'repeater-fortnight :fortnight :now now)) 42 | (this-fortnight (r-this fortnights :past))) 43 | (assert-datetime= (make-datetime 2006 8 13 0) (span-start this-fortnight)) 44 | (assert-datetime= (make-datetime 2006 8 16 14) (span-end this-fortnight)))) 45 | 46 | (define-test repeater-fortnight-offset 47 | (let* ((now (make-datetime 2006 8 16 14)) 48 | (span (make-span now (datetime-incr now :sec))) 49 | (offset-span (r-offset (create-tag 'repeater-fortnight :fortnight) 50 | span 3 :future))) 51 | (assert-datetime= (make-datetime 2006 9 27 14) (span-start offset-span)) 52 | (assert-datetime= (make-datetime 2006 9 27 14 0 1) (span-end offset-span)))) 53 | 54 | 55 | 56 | -------------------------------------------------------------------------------- /test/repeater-month.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- 2 | ;;; repeater-month.lisp 3 | 4 | ;;; See the LICENSE file for licensing information. 5 | 6 | (cl:in-package #:chronicity-test) 7 | 8 | (define-test repeater-month-offset 9 | (let* ((repeater (create-tag 'repeater-month :month))) 10 | 11 | ;; random date 12 | (let* ((now (make-datetime 2006 8 16 14)) 13 | (span (make-span now (datetime-incr now :hour))) 14 | offset-span) 15 | (setf offset-span (r-offset repeater span 1 :future)) 16 | (assert-datetime= (make-datetime 2006 9 16 14) (span-start offset-span)) 17 | (assert-datetime= (make-datetime 2006 9 16 15) (span-end offset-span)) 18 | (setf offset-span (r-offset repeater span 1 :past)) 19 | (assert-datetime= (make-datetime 2006 7 16 14) (span-start offset-span)) 20 | (assert-datetime= (make-datetime 2006 7 16 15) (span-end offset-span))) 21 | 22 | ;; month boundary start 23 | (let* ((now (make-datetime 2006 1 1 0)) 24 | (span (make-span now (datetime-incr now :hour))) 25 | offset-span) 26 | (setf offset-span (r-offset repeater span 1 :future)) 27 | (assert-datetime= (make-datetime 2006 2 1 0) (span-start offset-span)) 28 | (assert-datetime= (make-datetime 2006 2 1 1) (span-end offset-span)) 29 | (setf offset-span (r-offset repeater span 1 :past)) 30 | (assert-datetime= (make-datetime 2005 12 1 0) (span-start offset-span)) 31 | (assert-datetime= (make-datetime 2005 12 1 1) (span-end offset-span))) 32 | 33 | ;; month boundary end 34 | (let* ((now (make-datetime 2006 1 31 23)) 35 | (span (make-span now (datetime-incr now :hour))) 36 | offset-span) 37 | (setf offset-span (r-offset repeater span 1 :future)) 38 | (assert-datetime= (make-datetime 2006 2 28 23) (span-start offset-span)) 39 | (assert-datetime= (make-datetime 2006 3 1 0) (span-end offset-span)) 40 | (setf offset-span (r-offset repeater span 1 :past)) 41 | (assert-datetime= (make-datetime 2005 12 31 23) (span-start offset-span)) 42 | (assert-datetime= (make-datetime 2006 1 1 0) (span-end offset-span))) 43 | 44 | ;; month boundar start - leap year 45 | (let* ((now (make-datetime 2008 2 1 0)) 46 | (span (make-span now (datetime-incr now :hour))) 47 | offset-span) 48 | (setf offset-span (r-offset repeater span 1 :future)) 49 | (assert-datetime= (make-datetime 2008 3 1 0) (span-start offset-span)) 50 | (assert-datetime= (make-datetime 2008 3 1 1) (span-end offset-span)) 51 | (setf offset-span (r-offset repeater span 1 :past)) 52 | (assert-datetime= (make-datetime 2008 1 1 0) (span-start offset-span)) 53 | (assert-datetime= (make-datetime 2008 1 1 1) (span-end offset-span))))) 54 | -------------------------------------------------------------------------------- /test/repeater-weekend.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- 2 | ;;; repeater-weekend.lisp 3 | 4 | ;;; See the LICENSE file for licensing information. 5 | 6 | (cl:in-package #:chronicity-test) 7 | 8 | (define-test repeater-weekend-next-future 9 | (let* ((now (make-datetime 2006 8 16 14)) 10 | (weekend (create-tag 'repeater-weekend :weekend :now now)) 11 | (next-weekend (r-next weekend :future))) 12 | 13 | (assert-datetime= (make-datetime 2006 8 19) (span-start next-weekend)) 14 | (assert-datetime= (make-datetime 2006 8 21) (span-end next-weekend)))) 15 | 16 | (define-test repeater-weekend-next-past 17 | (let* ((now (make-datetime 2006 8 16 14)) 18 | (weekend (create-tag 'repeater-weekend :weekend :now now)) 19 | (next-weekend (r-next weekend :past))) 20 | 21 | (assert-datetime= (make-datetime 2006 8 12) (span-start next-weekend)) 22 | (assert-datetime= (make-datetime 2006 8 14) (span-end next-weekend)))) 23 | 24 | (define-test repeater-weekend-this-future 25 | (let* ((now (make-datetime 2006 8 16 14)) 26 | (weekend (create-tag 'repeater-weekend :weekend :now now)) 27 | (next-weekend (r-this weekend :future))) 28 | 29 | (assert-datetime= (make-datetime 2006 8 19) (span-start next-weekend)) 30 | (assert-datetime= (make-datetime 2006 8 21) (span-end next-weekend)))) 31 | 32 | (define-test repeater-weekend-this-past 33 | (let* ((now (make-datetime 2006 8 16 14)) 34 | (weekend (create-tag 'repeater-weekend :weekend :now now)) 35 | (next-weekend (r-this weekend :past))) 36 | 37 | (assert-datetime= (make-datetime 2006 8 12) (span-start next-weekend)) 38 | (assert-datetime= (make-datetime 2006 8 14) (span-end next-weekend)))) 39 | 40 | (define-test repeater-weekend-this-none 41 | (let* ((now (make-datetime 2006 8 16 14)) 42 | (weekend (create-tag 'repeater-weekend :weekend :now now)) 43 | (next-weekend (r-this weekend :none))) 44 | 45 | (assert-datetime= (make-datetime 2006 8 19) (span-start next-weekend)) 46 | (assert-datetime= (make-datetime 2006 8 21) (span-end next-weekend)))) 47 | 48 | (define-test repeater-weekend-offset 49 | (let* ((now (make-datetime 2006 8 16 14)) 50 | (span (make-span now (datetime-incr now :sec))) 51 | (repeater (create-tag 'repeater-weekend :weekend)) 52 | (offset-span)) 53 | 54 | (setf offset-span (r-offset repeater span 3 :future)) 55 | (assert-datetime= (make-datetime 2006 9 2) (span-start offset-span)) 56 | (assert-datetime= (make-datetime 2006 9 2 0 0 1) (span-end offset-span)) 57 | 58 | (setf offset-span (r-offset repeater span 1 :past)) 59 | (assert-datetime= (make-datetime 2006 8 12) (span-start offset-span)) 60 | (assert-datetime= (make-datetime 2006 8 12 0 0 1) (span-end offset-span)) 61 | 62 | (setf offset-span (r-offset repeater span 0 :future)) 63 | (assert-datetime= (make-datetime 2006 8 12) (span-start offset-span)) 64 | (assert-datetime= (make-datetime 2006 8 12 0 0 1) (span-end offset-span)))) -------------------------------------------------------------------------------- /src/repeaters/repeater-day-portion.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- 2 | ;;; repeater-day-portion.lisp 3 | 4 | ;;; See the LICENSE file for licensing information. 5 | 6 | (cl:in-package #:chronicity) 7 | 8 | (defparameter *morning* (make-span (make-time 6) (make-time 12))) 9 | (defparameter *afternoon* (make-span (make-time 13) (make-time 17))) 10 | (defparameter *evening* (make-span (make-time 17) (make-time 20))) 11 | (defparameter *night* (make-span (make-time 20) (make-time 24))) 12 | 13 | (defclass repeater-day-portion (repeater) 14 | ((range :initform nil) 15 | (current :initform nil))) 16 | 17 | (defmethod initialize-instance :after ((repeater repeater-day-portion) &key type) 18 | (with-slots (range current) 19 | repeater 20 | (etypecase type 21 | (integer (setf range (make-span (make-time type) (make-time (+ type 12))))) 22 | (symbol (setf range (ecase type 23 | (:am (make-span (make-time 0) (make-time 12) nil)) 24 | (:pm (make-span (make-time 12) (make-time 24) nil)) 25 | (:morning *morning*) 26 | (:afternoon *afternoon*) 27 | (:evening *evening*) 28 | (:night *night*))))))) 29 | 30 | (defmethod r-next ((repeater repeater-day-portion) pointer) 31 | (with-slots (range current now) 32 | repeater 33 | (if (not current) 34 | (let* ((now-sec (day-sec-of now)) 35 | (range-start (span-start range)) 36 | (range-start-sec (day-sec-of range-start)) 37 | (start (cond 38 | ((< now-sec range-start-sec) 39 | (case pointer 40 | (:future (merge-datetime now range-start)) 41 | (:past (merge-datetime (datetime-decr now :day) range-start)))) 42 | ((> now-sec range-start-sec) 43 | (case pointer 44 | (:future (merge-datetime (datetime-incr now :day) range-start)) 45 | (:past (merge-datetime now range-start)))) 46 | (t 47 | (case pointer 48 | (:future (merge-datetime (datetime-incr now :day) range-start)) 49 | (:past (merge-datetime (datetime-decr now :day) range-start))))))) 50 | (if start 51 | (setf current (make-span start (merge-datetime start (span-end range)))) 52 | (error "Start should not be NIL."))) 53 | (case pointer 54 | (:future (setf current (span+ current 1 :day))) 55 | (:past (setf current (span- current 1 :day))))))) 56 | 57 | (defmethod r-this ((repeater repeater-day-portion) pointer) 58 | (with-slots (range current now) 59 | repeater 60 | (let ((start (merge-datetime now (span-start range)))) 61 | (setf current (make-span start (merge-datetime start (span-end range))))))) 62 | 63 | (defmethod r-offset ((repeater repeater-day-portion) span amount pointer) 64 | (setf (tag-now repeater) (span-start span)) 65 | (let* ((portion-span (r-next repeater pointer)) 66 | (direction (if (eql pointer :future) 1 -1)) 67 | (offset (* direction (1- amount)))) 68 | (span+ portion-span offset :day))) 69 | 70 | (defmethod r-width ((repeater repeater-day-portion)) 71 | (with-slots (range current now) 72 | repeater 73 | (or range (error "RANGE is not set.")) ; Isn't this redundant? 74 | (if current 75 | (- (datetime-to-universal (span-end current)) 76 | (datetime-to-universal (span-start current))) 77 | (- (datetime-to-universal (span-end range)) 78 | (datetime-to-universal (span-start range)))))) -------------------------------------------------------------------------------- /src/repeater.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- 2 | ;;; repeater.lisp 3 | 4 | ;;; See the LICENSE file for licensing information. 5 | 6 | (cl:in-package #:chronicity) 7 | 8 | ;;; Enable cl-interpol reader 9 | 10 | #.(cl-interpol:enable-interpol-syntax) 11 | 12 | ;;; TODO: Class definitions for each kind of repeater, also return 13 | ;;; these class instances instead of a keyword 14 | 15 | (defclass repeater (tag) 16 | ()) 17 | 18 | (defgeneric r-next (repeater pointer)) 19 | 20 | (defgeneric r-this (repeater pointer)) 21 | 22 | (defgeneric r-offset (repeater span amount pointer)) 23 | 24 | (defgeneric r-width (repeater)) 25 | 26 | (defmethod scan-tokens ((tag (eql 'repeater)) tokens) 27 | (dolist (token tokens tokens) 28 | (awhen (scan-for-month-names token) (tag it token)) 29 | (awhen (scan-for-day-names token) (tag it token)) 30 | (awhen (scan-for-day-portions token) (tag it token)) 31 | (awhen (scan-for-times token) (tag it token)) 32 | (awhen (scan-for-units token) (tag it token)))) 33 | 34 | (defun scan-for-month-names (token &aux (word (token-word token))) 35 | (let ((scan-map '((#?r"^jan\.?(uary)?$" :january) 36 | (#?r"^feb\.?(ruary)?$" :february) 37 | (#?r"^mar\.?(ch)?$" :march) 38 | (#?r"^apr\.?(il)?$" :april) 39 | (#?r"^may$" :may) 40 | (#?r"^jun\.?e?$" :june) 41 | (#?r"^jul\.?y?$" :july) 42 | (#?r"^aug\.?(ust)?$" :august) 43 | (#?r"^sep\.?(t\.?|tember)?$" :september) 44 | (#?r"^oct\.?(ober)?$" :october) 45 | (#?r"^nov\.?(ember)?$" :november) 46 | (#?r"^dec\.?(ember)?$" :december)))) 47 | (loop 48 | for (regex keyword) in scan-map 49 | when (cl-ppcre:scan regex word) 50 | return (create-tag 'repeater-month-name keyword)))) 51 | 52 | ;;; TODO: Check for spelling mistakes 53 | (defun scan-for-day-names (token &aux (word (token-word token))) 54 | (let ((scan-map '((#?r"m[ou]n(day)?$" :monday) 55 | (#?r"t(ue|eu|oo|u|)s(day)?$" :tuesday) 56 | (#?r"tue$" :tuesday) 57 | (#?r"we(dnes|nds|nns)day$" :wednesday) 58 | (#?r"wed$" :wednesday) 59 | (#?r"th(urs|ers)day$" :thursday) 60 | (#?r"thu$" :thursday) 61 | (#?r"fr[iy](day)?$" :friday) 62 | (#?r"sat(t?[ue]rday)?$" :saturday) 63 | (#?r"su[nm](day)?$" :sunday)))) 64 | (loop 65 | for (regex keyword) in scan-map 66 | when (cl-ppcre:scan regex word) 67 | return (create-tag 'repeater-day-name keyword)))) 68 | 69 | (defun scan-for-day-portions (token &aux (word (token-word token))) 70 | (let ((scan-map '(("^ams?$" :am) 71 | ("^pms?$" :pm) 72 | ("^mornings?$" :morning) 73 | ("^afternoons?$" :afternoon) 74 | ("^evenings?$" :evening) 75 | ("^(night|nite)s?$" :night)))) 76 | (loop 77 | for (regex keyword) in scan-map 78 | when (cl-ppcre:scan regex word) 79 | return (create-tag 'repeater-day-portion keyword)))) 80 | 81 | ;;; TODO: repeater.rb has options here, what does it do? 82 | (defun scan-for-times (token &aux (word (token-word token))) 83 | (when (cl-ppcre:scan #?r"^\d{1,2}(:?\d{2})?([\.:]?\d{2})?$" word) 84 | (create-tag 'repeater-time word))) 85 | 86 | (defun scan-for-units (token &aux (word (token-word token))) 87 | (let ((scan-map '((#?/^years?$/ :year) 88 | (#?/^seasons?$/ :season) 89 | (#?/^months?$/ :month) 90 | (#?/^fortnights?$/ :fortnight) 91 | (#?/^weeks?$/ :week) 92 | (#?/^weekends?$/ :weekend) 93 | (#?/^days?$/ :day) 94 | (#?/^hours?$/ :hour) 95 | (#?/^minutes?$/ :minute) 96 | (#?/^seconds?$/ :sec)))) 97 | (loop 98 | for (regex keyword) in scan-map 99 | when (cl-ppcre:scan regex word) 100 | return (create-tag (intern (format nil "REPEATER-~A" keyword) :chronicity) 101 | keyword)))) 102 | 103 | ;;; We wrap CHECK-POINTER around the R-NEXT and R-THIS so that pointer 104 | ;;; is checked for sanity before any invocation of these methods 105 | 106 | (defun check-pointer (pointer) 107 | (let ((list (list :future :none :past))) 108 | (unless (member pointer list) 109 | (error "POINTER must be one of ~{~S~^, ~}" list)))) 110 | 111 | (defmethod r-next :around ((repeater repeater) pointer) 112 | (check-pointer pointer) 113 | (call-next-method)) 114 | 115 | (defmethod r-this :around ((repeater repeater) pointer) 116 | (check-pointer pointer) 117 | (call-next-method)) 118 | 119 | ;;; Disable cl-interpol reader 120 | 121 | #.(cl-interpol:disable-interpol-syntax) 122 | 123 | 124 | -------------------------------------------------------------------------------- /src/repeaters/repeater-time.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- 2 | ;;; repeater-time.lisp 3 | 4 | ;;; See the LICENSE file for licensing information. 5 | 6 | (cl:in-package #:chronicity) 7 | 8 | #.(cl-interpol:enable-interpol-syntax) 9 | 10 | (defclass repeater-time (repeater) 11 | ((current :initform nil))) 12 | 13 | (defclass tick () 14 | ((time :initarg :time :accessor tick-time) 15 | (ambiguousp :initarg :ambiguousp :accessor tick-ambiguousp))) 16 | 17 | (defmethod print-object ((x tick) stream) 18 | (print-unreadable-object (x stream :type t) 19 | (format stream "~A~:[~; AMBIGUOUS~]" 20 | (tick-time x) 21 | (tick-ambiguousp x)))) 22 | 23 | (defun make-tick (time ambiguousp) 24 | (make-instance 'tick :time time :ambiguousp ambiguousp)) 25 | 26 | (defmethod initialize-instance :after ((repeater repeater-time) &key type &allow-other-keys) 27 | (let* ((ts (cl-ppcre:regex-replace-all #?r"\:" type "")) 28 | (ts-size (length ts))) 29 | (setf (slot-value repeater 'type) 30 | (cond 31 | ((<= 1 ts-size 2) 32 | (let ((hours (parse-integer ts))) 33 | (if (= hours 12) 34 | (make-tick (make-time 0) t) ; Now why would I do that? 35 | (make-tick (make-time hours) t)))) 36 | ((= ts-size 3) 37 | (make-tick (make-time (parse-integer ts :start 0 :end 1) 38 | (parse-integer ts :start 1)) 39 | t)) 40 | ((= ts-size 4) 41 | (let* ((hours (parse-integer ts :end 2)) 42 | (minutes (parse-integer ts :start 2)) 43 | (ambiguousp (and (scan ":" type) 44 | (/= (parse-integer ts :end 1) 0) ; Redundant? 45 | (<= hours 12)))) 46 | (if (= hours 12) 47 | (make-tick (make-time 0 minutes) ambiguousp) ; Still makes no sense to me 48 | (make-tick (make-time hours minutes) ambiguousp)))) 49 | ((= ts-size 5) 50 | (make-tick (make-time (parse-integer ts :end 1) 51 | (parse-integer ts :start 1 :end 3) 52 | (parse-integer ts :start 3 :end 5)) 53 | t)) 54 | ((= ts-size 6) 55 | (let* ((hours (parse-integer ts :end 2)) 56 | (minutes (parse-integer ts :start 2 :end 4)) 57 | (secs (parse-integer ts :start 4)) 58 | (ambiguousp (and (scan ":" type) 59 | (/= (parse-integer ts :end 1) 0) ; Redundant? 60 | (<= hours 12)))) 61 | (if (= hours 12) 62 | (make-tick (make-time 0 minutes secs) ambiguousp) 63 | (make-tick (make-time hours minutes secs) ambiguousp)))) 64 | (t (error "TIME cannot exceed 6 digits.")))))) 65 | 66 | (defmethod r-next ((repeater repeater-time) pointer) 67 | (let* ((first-time-p nil) 68 | (tick (tag-type repeater)) 69 | (tick-time (tick-time tick)) 70 | (halfday-hours 12)) 71 | (with-slots (current now) 72 | repeater 73 | (unless current 74 | (setf first-time-p t) 75 | (let* ((midnight (copy-date now)) 76 | (yesterday-midnight (datetime-decr midnight :day)) 77 | (tomorrow-midnight (datetime-incr midnight :day)) 78 | (midnight+tick (merge-datetime midnight tick-time)) 79 | (midday+tick (datetime-incr midnight+tick :hour halfday-hours)) 80 | (tomorrow+tick (merge-datetime tomorrow-midnight tick-time)) 81 | (yesterday+tick (merge-datetime yesterday-midnight tick-time))) 82 | (if (eql pointer :future) 83 | (if (tick-ambiguousp tick) 84 | (loop 85 | for time in (list midnight+tick midday+tick tomorrow+tick) 86 | thereis (and (datetime>= time now) (setf current time))) 87 | (loop 88 | for time in (list midnight+tick tomorrow+tick) 89 | thereis (and (datetime>= time now) (setf current time)))) 90 | (if (tick-ambiguousp tick) 91 | (loop 92 | for time in (list midday+tick midnight+tick (datetime-incr yesterday+tick :hour halfday-hours)) 93 | thereis (and (datetime<= time now) (setf current time))) 94 | (loop 95 | for time in (list midnight+tick yesterday+tick) 96 | thereis (and (datetime<= time now) (setf current time))))))) 97 | (unless first-time-p 98 | (setf current (if (tick-ambiguousp tick) 99 | (datetime-incr current :hour (if (eql pointer :future) halfday-hours (- halfday-hours))) 100 | (datetime-incr current :day (if (eql pointer :future) 1 -1))))) 101 | (make-span current (datetime-incr current :sec))))) 102 | 103 | (defmethod r-this ((repeater repeater-time) pointer) 104 | (when (eql pointer :none) 105 | (setf pointer :future)) 106 | (r-next repeater pointer)) 107 | 108 | (defmethod r-width ((repeater repeater-time)) 109 | 1) 110 | 111 | #.(cl-interpol:disable-interpol-syntax) -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Chronicity 2 | 3 | A natural language date and time parser for Common Lisp. 4 | 5 | Inspired by (and copied verbatim from) from [Chronic][], the natural 6 | language date and time parser for Ruby by Tom Preston-Werner. 7 | 8 | [Chronic]: http://chronic.rubyforge.org/ 9 | 10 | To understand how Chronicity works, read this post: [Writing a natural language 11 | date and time parser](https://lisper.in/nlp-date-parser) 12 | 13 | ## Download and Installation 14 | 15 | Use [quicklisp][]: 16 | 17 | (ql:quickload "chronicity") 18 | 19 | Or get the cutting-edge version from github: 20 | https://github.com/chaitanyagupta/chronicity/tree/master 21 | 22 | Or get the latest stable release (usually updates before quicklisp): 23 | https://github.com/chaitanyagupta/chronicity/releases 24 | 25 | [quicklisp]: https://www.quicklisp.org 26 | 27 | ## Usage 28 | 29 | Use `CHRONICITY:PARSE` to parse date/time strings. 30 | 31 | If `*NOW*` is not set, "now" is assumed to be this instant. All relative 32 | date/time calculations are made with respect to `*NOW*`. 33 | 34 | (setf chronicity:*now* (chronicity:make-datetime 2009 3 27 12 34 56)) 35 | => @2009-03-27T12:34:56.000000+05:30 36 | 37 | (chronicity:parse "today") 38 | => @2009-03-27T13:00:00.000000+05:30 39 | 40 | (chronicity:parse "tomorrow" :now (chronicity:make-date 2009 1 1)) 41 | => @2009-01-02T00:00:00.000000+05:30 42 | 43 | (chronicity:parse "3 days from now") 44 | => @2009-03-30T12:34:56.000000+05:30 45 | 46 | (chronicity:parse "next month") 47 | => @2009-04-01T00:00:00.000000+05:30 48 | 49 | `:ENDIAN-PREFERENCE` indicates which date format to prefer in case of 50 | ambiguity over days and months. `:LITTLE` indicates the format 51 | "dd/mm/yyyy", `:MIDDLE` indicates "mm/dd/yyy". Default is :LITTLE. 52 | 53 | (chronicity:parse "1/2/2003") 54 | => @2003-02-01T00:00:00.000000+05:30 55 | 56 | (chronicity:parse "1/2/2003" :endian-preference :middle) 57 | => @2003-01-02T00:00:00.000000+05:30 58 | 59 | Default value for `:CONTEXT` is `:FUTURE`. 60 | 61 | (chronicity:parse "April 1st at 12:30 PM") 62 | => @2009-04-01T12:30:00.000000+05:30 63 | 64 | (chronicity:parse "April 1st at 12:30 PM" :context :past) 65 | => @2008-04-01T12:30:00.000000+05:30 66 | 67 | `CHRONICITY:PARSE` usually returns a DATETIME object. Its attributes can 68 | be accessed using the datetime readers. 69 | 70 | (chronicity:parse "next month" :guess :end) 71 | => @2009-04-30T23:59:59.000000+05:30 72 | 73 | (values (chronicity:year-of *) 74 | (chronicity:month-of *) 75 | (chronicity:day-of *) 76 | (chronicity:hour-of *) 77 | (chronicity:minute-of *) 78 | (chronicity:sec-of *)) 79 | => 2009, 4, 30, 23, 59, 59 80 | 81 | Passing `NIL` as the value for `:GUESS` returns a `SPAN`, which is a range 82 | of datetime values. 83 | 84 | (chronicity:parse "next month" :guess nil) 85 | => # 86 | 87 | (values (chronicity:span-start *) 88 | (chronicity:span-end *) 89 | (chronicity:span-end-included-p *)) 90 | => @2009-04-01T00:00:00.000000+05:30, 91 | @2009-05-01T00:00:00.000000+05:30, 92 | NIL 93 | 94 | Other possible values are `:START`, `:MIDDLE`, or `:END` which return 95 | the start, mid-point or the end of a span respectively. 96 | 97 | ## Input Examples 98 | 99 | Simple 100 | 101 | thursday 102 | november 103 | summer 104 | friday 13:00 105 | mon 2:35 106 | 4pm 107 | 6 in the morning 108 | friday 1pm 109 | sat 7 in the evening 110 | yesterday 111 | today 112 | tomorrow 113 | this tuesday 114 | next month 115 | this morning 116 | last night 117 | this second 118 | yesterday at 4:00 119 | last friday at 20:00 120 | last week tuesday 121 | tomorrow at 6:45pm 122 | afternoon yesterday 123 | thursday last week 124 | 125 | Complex 126 | 127 | 3 years ago 128 | 5 months before now 129 | 7 hours ago 130 | 7 days from now 131 | 1 week hence 132 | in 3 hours 133 | 1 year ago tomorrow 134 | 3 months ago saturday at 5:00 pm 135 | 7 hours before tomorrow at noon 136 | 3rd wednesday in november 137 | 3rd month next year 138 | 3rd thursday this september 139 | 4th day last week 140 | 141 | Specific Dates 142 | 143 | January 5 144 | dec 25 145 | may 27th 146 | October 2006 147 | oct 06 148 | jan 3 2010 149 | february 14, 2004 150 | 3 jan 2000 151 | 17 april 85 152 | 5/27/1979 153 | 27/5/1979 154 | 05/06 155 | 1979-05-27 156 | Friday 157 | 5 158 | 4:00 159 | 17:00 160 | 0800 161 | 162 | Specific Times (many of the above with an added time) 163 | 164 | January 5 at 7pm 165 | 1979-05-27 05:00:00 166 | etc 167 | 168 | ## Limitations 169 | 170 | Chronicity only works with the current timezone (as returned by 171 | `LOCAL-TIME:*DEFAULT-TIMEZONE*`) . Support for different timezones is 172 | planned for a future release. 173 | 174 | The datetime object(s) returned by the parser are of type 175 | `LOCAL-TIME:TIMESTAMP`. Be aware of any limitations that may apply to 176 | them. 177 | 178 | Another problem is that parsing ordinals as words is supported except 179 | for `second`, which is ambiguous with second the unit of time. This 180 | should be fixed in a future release. 181 | -------------------------------------------------------------------------------- /test/datetime.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- 2 | ;;; datetime.lisp 3 | 4 | ;;; See the LICENSE file for licensing information. 5 | 6 | (cl:in-package #:chronicity-test) 7 | 8 | (define-test datetime-basics 9 | (let ((ts (make-datetime 2009 3 14 5 45 03))) 10 | (assert-eql 2009 (year-of ts)) 11 | (assert-eql 3 (month-of ts)) 12 | (assert-eql 14 (day-of ts)) 13 | (assert-eql 5 (hour-of ts)) 14 | (assert-eql 45 (minute-of ts)) 15 | (assert-eql 3 (sec-of ts)) 16 | (assert-eql 6 (dow-of ts))) 17 | (let ((ts (make-date 2009 3 14))) 18 | (assert-eql 2009 (year-of ts)) 19 | (assert-eql 3 (month-of ts)) 20 | (assert-eql 14 (day-of ts)) 21 | (assert-true (every #'zerop (list (hour-of ts) (minute-of ts) (sec-of ts)))) 22 | (assert-eql 6 (dow-of ts))) 23 | (let ((ts (make-time 5 45 03))) 24 | (assert-eql 5 (hour-of ts)) 25 | (assert-eql 45 (minute-of ts)) 26 | (assert-eql 3 (sec-of ts)))) 27 | 28 | (define-test datetime-universal-1 29 | (let* ((ts (now)) 30 | (universal (datetime-to-universal ts))) 31 | (multiple-value-bind (sec minute hour day month year) 32 | (decode-universal-time universal) 33 | (assert-eql (year-of ts) year) 34 | (assert-eql (month-of ts) month) 35 | (assert-eql (day-of ts) day) 36 | (assert-eql (hour-of ts) hour) 37 | (assert-eql (minute-of ts) minute) 38 | (assert-eql (sec-of ts) sec)))) 39 | 40 | (define-test datetime-universal-2 41 | (let* ((universal (get-universal-time)) 42 | (ts (universal-to-datetime universal))) 43 | (multiple-value-bind (sec minute hour day month year) 44 | (decode-universal-time universal) 45 | (assert-eql (year-of ts) year) 46 | (assert-eql (month-of ts) month) 47 | (assert-eql (day-of ts) day) 48 | (assert-eql (hour-of ts) hour) 49 | (assert-eql (minute-of ts) minute) 50 | (assert-eql (sec-of ts) sec)))) 51 | 52 | (define-test datetime-calc-and-comparisons-1 53 | (let* ((now (now)) 54 | (sec-ago (datetime-decr now :sec)) 55 | (sec-later (datetime-incr now :sec)) 56 | (minute-ago (datetime-decr now :minute)) 57 | (minute-later (datetime-incr now :minute)) 58 | (hour-ago (datetime-decr now :hour)) 59 | (hour-later (datetime-incr now :hour)) 60 | (day-ago (datetime-decr now :day)) 61 | (day-later (datetime-incr now :day)) 62 | (week-ago (datetime-decr now :week)) 63 | (week-later (datetime-incr now :week)) 64 | (month-ago (datetime-decr now :month)) 65 | (month-later (datetime-incr now :month)) 66 | (year-ago (datetime-decr now :year)) 67 | (year-later (datetime-incr now :year))) 68 | (assert-true (datetime< year-ago month-ago week-ago day-ago hour-ago minute-ago sec-ago 69 | now 70 | sec-later minute-later hour-later day-later week-later month-later year-later)) 71 | (assert-true (datetime> year-later month-later week-later day-later hour-later minute-later sec-later 72 | now 73 | sec-ago minute-ago hour-ago day-ago week-ago month-ago year-ago)) 74 | 75 | (assert-datetime= sec-later (datetime-incr sec-ago :sec 2)) 76 | (assert-datetime= minute-ago (datetime-decr minute-later :minute 2)) 77 | (assert-datetime= hour-later (datetime-incr hour-ago :hour 2)) 78 | (assert-datetime= day-ago (datetime-decr day-later :day 2)) 79 | (assert-datetime= week-later (datetime-incr week-ago :week 2)) 80 | (assert-datetime= month-ago (datetime-decr month-later :month 2)) 81 | (assert-datetime= year-later (datetime-incr year-ago :year 2)) 82 | 83 | (assert-true (datetime= now now)) 84 | (assert-true (datetime<= now now day-later)) 85 | (assert-true (datetime>= now now day-ago)) 86 | 87 | (assert-true (datetime/= day-ago now day-later)))) 88 | 89 | (define-test datetime-calc-and-comparisons-2 90 | (let ((ts1 (make-date 2009 3 14)) 91 | (ts2 (make-date 2009 3 15)) 92 | (ts3 (make-time 16 0 0)) 93 | (ts4 (make-time 5 0 0))) 94 | (assert-true (datetime< ts1 ts2)) 95 | (assert-true (datetime> ts2 ts1)) 96 | (assert-true (datetime< ts4 ts3)) 97 | (assert-true (datetime> ts3 ts4)))) 98 | 99 | (define-test datetime-overflow 100 | ;; next minute 101 | (assert-datetime= (make-datetime 2009 3 14 13 59 0) 102 | (datetime-incr (make-datetime 2009 3 14 13 58 59) :sec)) 103 | ;; next hour 104 | (assert-datetime= (make-datetime 2009 3 14 14 0 0) 105 | (datetime-incr (make-datetime 2009 3 14 13 59 0) :minute)) 106 | ;; next day 107 | (assert-datetime= (make-datetime 2009 3 15 0 0 0) 108 | (datetime-incr (make-datetime 2009 3 14 23 0 0) :hour)) 109 | ;; next month 110 | (assert-datetime= (make-datetime 2009 4 1 0 0 0) 111 | (datetime-incr (make-datetime 2009 3 31 0 0 0) :day)) 112 | ;; next year 113 | (assert-datetime= (make-datetime 2010 1 1 0 0 0) 114 | (datetime-incr (make-datetime 2009 12 1 0 0 0) :month))) 115 | 116 | (define-test datetime-month-calc 117 | ;; 'regular' cases 118 | (assert-datetime= (make-date 2009 5 24) 119 | (datetime-incr (make-date 2009 4 24) :month)) 120 | (assert-datetime= (make-date 2009 5 1) 121 | (datetime-incr (make-date 2009 4 1) :month)) 122 | 123 | ;; next/previous month if on current month ending 124 | (assert-datetime= (make-date 2009 5 30) 125 | (datetime-incr (make-date 2009 4 30) :month)) 126 | (assert-datetime= (make-date 2009 6 30) 127 | (datetime-incr (make-date 2009 5 31) :month)) 128 | (assert-datetime= (make-date 2009 4 30) 129 | (datetime-decr (make-date 2009 5 31) :month)) 130 | 131 | ;; february 132 | (assert-datetime= (make-date 2009 2 28) 133 | (datetime-decr (make-date 2009 3 31) :month)) 134 | (assert-datetime= (make-date 2009 2 28) 135 | (datetime-incr (make-date 2009 1 31) :month)) 136 | 137 | ;; year change 138 | (assert-datetime= (make-date 2009 1 31) 139 | (datetime-incr (make-date 2008 12 31) :month)) 140 | (assert-datetime= (make-date 2008 12 31) 141 | (datetime-decr (make-date 2009 1 31) :month))) 142 | 143 | 144 | 145 | -------------------------------------------------------------------------------- /src/numerize.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- 2 | ;;; numerize.lisp 3 | 4 | ;;; See the LICENSE file for licensing information. 5 | 6 | (cl:in-package #:cl-user) 7 | 8 | (defpackage #:chronicity-numerizer 9 | (:use #:cl) 10 | (:export #:numerize)) 11 | 12 | (in-package #:chronicity-numerizer) 13 | 14 | #.(cl-interpol:enable-interpol-syntax) 15 | 16 | (defvar *direct-nums* 17 | '(("(eleven|eleventh)" 11) 18 | ("(twelve|twelfth)" 12) 19 | ("(thirteen|thirteenth)" 13) 20 | ("(fourteen|fourteenth)" 14) 21 | ("(fifteen|fifteenth)" 15) 22 | ("(sixteen|sixteenth)" 16) 23 | ("(seventeen|seventeenth)" 17) 24 | ("(eighteen|eighteenth)" 18) 25 | ("(nineteen|ninteen|nineteenth)" 19) ; Common mis-spelling 26 | ("(zero|zeroth)" 0) 27 | ("(one|first)" 1) 28 | ("two" 2) ; Numerization for second is taken care of after 29 | ; processing tokens, see CHRONICITY::PRE-PROCESS-TOKENS 30 | ("(three|third)" 3) 31 | (#?r"(\bfour\b|fourth|forth)" 4) ; So that it matches four but not fourty 32 | ("(five|fifth)" 5) 33 | (#?r"(\bsix\b|sixth)" 6) 34 | (#?r"(\bseven\b|seventh)" 7) 35 | (#?r"(\beight\b|eighth)" 8) 36 | (#?r"(\bnine\b|ninth|nineth)" 9) 37 | ("(ten|tenth)" 10) 38 | ; (#?r"\ba[\b^$]" 1) ; doesn't make sense for an 'a' at the end to be a 1 39 | )) 40 | 41 | (defvar *ten-prefixes* 42 | '(("(twenty|twentieth)" 20) 43 | ("(thirty|thirtieth)" 30) 44 | ("(fourty|forty|fourtieth|fortieth)" 40) 45 | ("(fifty|fiftieth)" 50) 46 | ("(sixty|sixtieth)" 60) 47 | ("(seventy|seventieth)" 70) 48 | ("(eighty|eightieth)" 80) 49 | ("(ninety|ninetieth)" 90))) 50 | 51 | (defvar *big-prefixes* 52 | '(("(hundred|hundredth)" 100) 53 | ("(thousand|thousandth)" 1000) 54 | ("(lakh|lac)" 100000) 55 | ("(million|millionth)" 1000000) 56 | ("crore" 10000000) 57 | ("(billion|billionth)" 1000000000) 58 | ("(trillion|trillionth)" 1000000000000))) 59 | 60 | (defvar *big-detector-regex* 61 | (let ((big-or (format nil "(~{~A~^|~})" 62 | (mapcar #'first (append *direct-nums* 63 | *ten-prefixes* 64 | *big-prefixes*))))) 65 | #?r"${big-or}((\s|-)+${big-or})*")) 66 | 67 | (defun numerize (string) 68 | ;; Some normalization 69 | (setf string (cl-ppcre:regex-replace-all #?r"\band\b" string "")) 70 | (let ((start 0) 71 | (diff 0)) 72 | (loop 73 | (multiple-value-bind (start2 end2) 74 | (and (< start (length string)) 75 | (detect-numeral-sequence string :start start)) 76 | (unless start2 77 | (return)) 78 | (let ((number-string (numerize-aux (subseq string start2 end2)))) 79 | (when number-string 80 | (setf (values string diff) 81 | (replace-numeral-sequence string start2 end2 number-string))) 82 | (setf start (- end2 diff))))) 83 | string)) 84 | 85 | (defun detect-numeral-sequence (string &key (start 0)) 86 | (cl-ppcre:scan *big-detector-regex* string :start start)) 87 | 88 | (defun numerize-aux (string) 89 | (let ((tokens (reverse (cl-ppcre:split #?r"(\s|-)+" string)))) 90 | (setf tokens (remove-if-not #'numeric-token-p tokens)) 91 | (let* ((number (tokens-to-number tokens)) 92 | (number-string (format nil "~A" number))) 93 | ;; Check if the numeral was an ordinal. If so, append the 94 | ;; (st|nd|rd|th) to the end of the number 95 | (multiple-value-bind (match regs) 96 | (cl-ppcre:scan-to-strings "(fir(st)|seco(nd)|thi(rd)|\\w+(th)$)" 97 | (first tokens)) 98 | (if match 99 | (concatenate 'string number-string (find-if #'identity (subseq regs 1))) 100 | number-string))))) 101 | 102 | (defun replace-numeral-sequence (string start end number-string) 103 | (values 104 | (concatenate 'string 105 | (subseq string 0 start) 106 | number-string 107 | (subseq string end)) 108 | (- (- end start) (length number-string)))) 109 | 110 | (defun tokens-to-number (tokens) 111 | ;; TOKENS should be in reverse order i.e. the rightmost token in the 112 | ;; string should be first. 113 | (when (big-prefix-p (first (last tokens))) 114 | (setf tokens (append tokens (list "one")))) 115 | (let* ((sum 0) 116 | (multiplier 1) 117 | (tsum 0) 118 | (tokens* tokens)) 119 | (loop 120 | (unless tokens* (return)) 121 | (let ((token (first tokens*))) 122 | (cond 123 | ((and (big-prefix-p token) 124 | (> (token-numeric-value token) multiplier)) 125 | (incf sum (* tsum multiplier)) 126 | (setf tsum 0 127 | multiplier (token-numeric-value token))) 128 | ((big-prefix-p token) 129 | (let ((next-big-multiplier (or (position-if #'(lambda (x) 130 | (> (token-numeric-value x) multiplier)) 131 | tokens*) 132 | (length tokens*)))) 133 | (let ((new-sum (tokens-to-number (subseq tokens* 0 next-big-multiplier)))) 134 | (incf tsum new-sum) 135 | (setf tokens* (nthcdr (1- next-big-multiplier) tokens*))))) 136 | (t (incf tsum (token-numeric-value token))))) 137 | (setf tokens* (cdr tokens*))) 138 | (incf sum (* tsum multiplier)) 139 | sum)) 140 | 141 | (defun numeric-token-p (string) 142 | (dolist (list (list *direct-nums* *ten-prefixes* *big-prefixes*)) 143 | (dolist (numeral-pair list) 144 | (when (cl-ppcre:scan (first numeral-pair) string) 145 | (return-from numeric-token-p t))))) 146 | 147 | (defun token-numeric-value (string) 148 | (dolist (list (list *direct-nums* *ten-prefixes* *big-prefixes*)) 149 | (dolist (numeral-pair list) 150 | (when (cl-ppcre:scan (first numeral-pair) string) 151 | (return-from token-numeric-value (second numeral-pair)))))) 152 | 153 | (defun big-prefix-p (string) 154 | (dolist (numeral-pair *big-prefixes*) 155 | (when (cl-ppcre:scan (first numeral-pair) string) 156 | (return-from big-prefix-p t)))) 157 | 158 | ;;; Disable cl-interpol reader 159 | 160 | #.(cl-interpol:disable-interpol-syntax) 161 | 162 | 163 | 164 | 165 | 166 | 167 | 168 | 169 | 170 | -------------------------------------------------------------------------------- /src/chronicity.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- 2 | ;;; chronicity.lisp 3 | 4 | ;;; See the LICENSE file for licensing information. 5 | 6 | (cl:in-package #:chronicity) 7 | 8 | ;;; Some constants 9 | 10 | (defconstant +sec-seconds+ 1) 11 | (defconstant +minute-seconds+ 60) 12 | (defconstant +hour-seconds+ (* 60 60)) 13 | (defconstant +day-seconds+ (* 24 60 60)) 14 | (defconstant +weekend-seconds+ (* 2 24 60 60)) 15 | (defconstant +week-seconds+ (* 7 24 60 60)) 16 | (defconstant +fortnight-seconds+ (* 14 24 60 60)) 17 | (defconstant +month-seconds+ (* 30 24 60 60)) 18 | (defconstant +year-seconds+ (* 365 24 60 60)) 19 | (defconstant +year-months+ 12) 20 | 21 | ;;; Enable CL-INTERPOL's special reader syntax 22 | 23 | #.(cl-interpol:enable-interpol-syntax) 24 | 25 | (defvar *context* :future 26 | "The default value for :CONTEXT.") 27 | 28 | (defvar *now* nil 29 | "The default value for :NOW. If NIL, :NOW is assumed to be this 30 | instant.") 31 | 32 | (defvar *endian-preference* :little 33 | "The default value for :ENDIAN-PREFERENCE.") 34 | 35 | (defvar *guess* t 36 | "The default value for :GUESS.") 37 | 38 | (defvar *ambiguous-time-range* 6 39 | "The default value for :AMBIGUOUS-TIME-RANGE.") 40 | 41 | (defun parse (text &key 42 | ((:context *context*) *context*) 43 | ((:now *now*) (or *now* (now))) 44 | (guess *guess*) 45 | ((:ambiguous-time-range *ambiguous-time-range*) *ambiguous-time-range*) 46 | ((:endian-preference *endian-preference*) *endian-preference*)) 47 | "Parse the string in TEXT and return either a DATETIME or a SPAN 48 | object. Also returns a list of tokens as the second value. 49 | 50 | CONTEXT (default *CONTEXT*) can be either :PAST or :FUTURE. 51 | 52 | NOW (default *NOW* or this instant) should be a DATETIME instance, 53 | relative to which the date/time will be calculated. 54 | 55 | GUESS (default *GUESS*) if NIL, PARSE returns a SPAN object, otherwise 56 | returns the start, end or middle of the span if the it is :START, :END 57 | or :MIDDLE respectively. If it is T, it will return the default value 58 | of a span if it has one (SPAN-DEFAULT), otherwise it will return the 59 | start of span. 60 | 61 | For AMBIGUOUS-TIME-RANGE (default *AMBIGUOUS-TIME-RANGE*), if an 62 | integer is given, ambiguous times (like 5:00) will be assumed to be 63 | within the range of that time in the AM to that time in the PM. For 64 | example, if you set it to 7, then the parser will look for the time 65 | between 7am and 7pm. In the case of 5:00, it would assume that means 66 | 5:00pm. If NIL is given, no assumption will be made, and the first 67 | matching instance of that time will be used. 68 | 69 | Use ENDIAN-PREFERENCE (default *ENDIAN-PREFERENCE*) to specify whether to 70 | ambiguous dates as dd/mm (:LITTLE) or mm/dd (:MIDDLE)." 71 | (let ((tokens (tokenize-and-tag (pre-normalize text)))) 72 | (pre-process-tokens tokens) 73 | (values (guess-span (tokens-to-span tokens) guess) tokens))) 74 | 75 | (defun pre-normalize (text) 76 | (setf text (string-downcase text)) 77 | (setf text (chronicity-numerizer:numerize text)) 78 | (rr-all-f text #?/['\"\.]/ "") 79 | (rr-all-f text #?/([\/\-\,\@])/ " \\1 ") 80 | (rr-all-f text #?/\btoday\b/ "this day") 81 | (rr-all-f text #?/\btomm?orr?ow\b/ "next day") 82 | (rr-all-f text #?/\byesterday\b/ "last day") 83 | (rr-all-f text #?/\bnoon\b/ "12:00") 84 | (rr-all-f text #?/\bmidnight\b/ "24:00") 85 | (rr-all-f text #?/\bbefor now\b/ "past") 86 | (rr-all-f text #?/\bnow\b/ "this second") 87 | (rr-all-f text #?r"^a(\s+)" "1\\1") 88 | (rr-all-f text "\\b(ago|before)\\b" "past") 89 | (rr-all-f text #?/\bthi past\b/ "last") 90 | (rr-all-f text #?/\bthi last\b/ "last") 91 | (rr-all-f text "\\b(?:in|during) the (morning)\\b" "\\1") 92 | (rr-all-f text "\\b(?:in the|during the|at) (afternoon|evening|night)\\b" "\\1") 93 | (rr-all-f text #?/\btonight\b/ "this night") 94 | (rr-all-f text "(\\d)([ap]m|oclock)\\b" "\\1 \\2") 95 | (rr-all-f text "\\b(hence|after|from)\\b" "future") 96 | text) 97 | 98 | (defun tokenize (text) 99 | (mapcar #'create-token 100 | (cl-ppcre:split #?r"\s+" text))) 101 | 102 | (defun tokenize-and-tag (text) 103 | (let ((tokens (tokenize text))) 104 | (loop 105 | for type in (list 'repeater 'grabber 'pointer 'scalar 'ordinal 'separator) 106 | do (scan-tokens type tokens)) 107 | tokens)) 108 | 109 | (defun pre-process-tokens (tokens) 110 | (dotimes (i (length tokens)) 111 | (symbol-macrolet ((current (elt tokens i)) 112 | (next (elt tokens (1+ i)))) 113 | ;; Resolve ambiguity related to "second" 114 | (when (and (string-equal (token-word current) "second") 115 | (and (< (1+ i) (length tokens)) 116 | (find-tag 'repeater next))) 117 | (untag 'repeater-sec current) 118 | (tag (create-tag 'ordinal 2) current) 119 | (tag (create-tag 'ordinal-day 2) current))))) 120 | 121 | (defun guess-span (span guess) 122 | (when span 123 | (ecase guess 124 | ((t) (or (span-default span) 125 | (span-start span))) 126 | (:start (span-start span)) 127 | (:end (if (span-end-included-p span) 128 | (span-end span) 129 | (datetime-decr (span-end span) :sec))) 130 | (:middle (span-middle span)) 131 | ((nil) span)))) 132 | 133 | (defclass token () 134 | ((word :initarg :word 135 | :reader token-word) 136 | (tags :initarg :tags 137 | :initform nil 138 | :accessor token-tags))) 139 | 140 | (defmethod print-object ((x token) stream) 141 | (print-unreadable-object (x stream :type t :identity t) 142 | (format stream "~A~@[ [~{~A~^, ~}]~]" 143 | (token-word x) 144 | (mapcar #'type-of (token-tags x))))) 145 | 146 | (defun create-token (word &rest tags) 147 | (make-instance 'token 148 | :word word 149 | :tags tags)) 150 | 151 | (defclass tag () 152 | ((type :initarg :type 153 | :reader tag-type) 154 | (now :initarg :now 155 | :accessor tag-now 156 | :initform nil))) 157 | 158 | (defmethod print-object ((x tag) stream) 159 | (print-unreadable-object (x stream :type t) 160 | (when (slot-boundp x 'type) 161 | (princ (tag-type x) stream)) 162 | (when (tag-now x) 163 | (format stream " ~A" (tag-now x))))) 164 | 165 | (defun create-tag (class type &key now) 166 | (make-instance class :type type :now now)) 167 | 168 | (defmethod tag (tag token) 169 | (push tag (token-tags token))) 170 | 171 | (defmethod untag ((tag tag) (token token)) 172 | (setf (token-tags token) (remove tag (token-tags token)))) 173 | 174 | (defmethod untag ((x class) (token token)) 175 | (untag (class-name x) token)) 176 | 177 | (defmethod untag ((x symbol) token) 178 | (setf (token-tags token) (remove-if #'(lambda (tag) 179 | (typep tag x)) 180 | (token-tags token)))) 181 | 182 | (defun token-has-tag-p (token tag-name) 183 | (some #'(lambda (tag) (typep tag tag-name)) (token-tags token))) 184 | 185 | (defun find-tag (tag-name token) 186 | (find-if #'(lambda (x) 187 | (typep x tag-name)) 188 | (token-tags token))) 189 | 190 | (defun token-tag-type (tag-name token) 191 | (awhen (find-tag tag-name token) 192 | (tag-type it))) 193 | 194 | ;;; Generic token scanner 195 | 196 | (defgeneric scan-tokens (tag tokens) 197 | (:documentation "Scan the list of TOKENS and tag the appropriately.")) 198 | 199 | ;;; Disable CL-INTERPOL's special reader syntax 200 | 201 | #.(cl-interpol:disable-interpol-syntax) 202 | 203 | 204 | 205 | 206 | 207 | -------------------------------------------------------------------------------- /src/handlers.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- 2 | ;;; handlers.lisp 3 | 4 | ;;; See the LICENSE file for licensing information. 5 | 6 | (cl:in-package #:chronicity) 7 | 8 | (defun make-handler (class pattern fn) 9 | (list class pattern fn)) 10 | 11 | (defun handler-class (handler) 12 | (first handler)) 13 | 14 | (defun handler-pattern (handler) 15 | (second handler)) 16 | 17 | (defun handler-fn (handler) 18 | (third handler)) 19 | 20 | (defvar *handlers* nil) 21 | (defvar *handler-patterns*) 22 | 23 | (defun clear-handlers () 24 | (setf *handlers* nil)) 25 | 26 | (defun find-class-handlers (class) 27 | (remove class *handlers* :key #'handler-class :test (complement #'eql))) 28 | 29 | (defmacro define-handler ((class &optional (name (gentemp "HANDLE-" :chronicity))) 30 | lambda-list patterns 31 | &body body) 32 | `(progn 33 | (defun ,name ,lambda-list 34 | (let ((*handler-patterns* ',patterns)) 35 | ,@body)) 36 | (add-handler ',class ',patterns ',name) 37 | ',name)) 38 | 39 | (defun add-handler (class patterns fn) 40 | (let ((handlers (loop 41 | for pattern in patterns 42 | collect (make-handler class pattern fn)))) 43 | (setf *handlers* (nconc *handlers* handlers)))) 44 | 45 | ;;; Token matcher 46 | 47 | (defvar *handler* nil 48 | "Current handler -- The one which matched the token.") 49 | 50 | (defun match-tokens (handler tokens) 51 | (let ((tokens* tokens) 52 | (token-index 0) 53 | (pattern (handler-pattern handler))) 54 | (flet ((!next-token () 55 | (incf token-index) 56 | (setf tokens* (cdr tokens*)) 57 | (car tokens*)) 58 | (!optionalp (element) 59 | (unless (atom element) 60 | (member '? element)))) 61 | (loop 62 | for pattern* on pattern 63 | for element = (car pattern*) 64 | for token = (or (first tokens*) 65 | (if (every #'!optionalp pattern*) 66 | (return token-index) 67 | (return nil))) 68 | for name = (if (atom element) element (first (last element))) 69 | for optionalp = (!optionalp element) 70 | for sub-handler-p = (unless (atom element) 71 | (member 'p element)) 72 | ;; Make sure NAME is actually a defined class 73 | unless sub-handler-p do (find-class name t) 74 | if (not sub-handler-p) 75 | do (if (token-has-tag-p token name) 76 | (!next-token) 77 | (unless optionalp (return nil))) 78 | else do (let ((sub-handlers (find-class-handlers name))) 79 | (loop named inner-loop 80 | for sub-handler in sub-handlers 81 | thereis (awhen (match-tokens sub-handler tokens*) 82 | (return (+ token-index it))) 83 | finally (unless optionalp (return nil)))) 84 | finally (if tokens* 85 | (return nil) 86 | (return token-index)))))) 87 | 88 | (defun tokens-to-span (tokens) 89 | (flet ((!match (class tokens) 90 | (let ((handlers (find-class-handlers class))) 91 | (dolist (handler handlers) 92 | (when (match-tokens handler tokens) 93 | (let ((*handler* handler)) 94 | (return-from tokens-to-span (funcall (handler-fn handler) tokens)))))))) 95 | (!match 'date (remove-if #'(lambda (x) 96 | (and (find-tag 'separator x) 97 | (not (find-tag 'separator-slash-or-dash x)) 98 | (not (find-tag 'separator-at x)))) 99 | tokens)) 100 | (!match 'anchor (remove-if #'(lambda (x) 101 | (and (find-tag 'separator x) 102 | (not (find-tag 'separator-in x)))) 103 | tokens)) 104 | (!match 'arrow (remove-if #'(lambda (x) 105 | (or (find-tag 'separator-at x) 106 | (find-tag 'separator-slash-or-dash x) 107 | (find-tag 'separator-comma x))) 108 | tokens)) 109 | (!match 'narrow tokens) 110 | (!match 'time tokens))) 111 | 112 | (defun remove-separators (tokens) 113 | (remove-if #'(lambda (token) 114 | (and (= (length (token-tags token)) 1) 115 | (token-has-tag-p token 'separator))) 116 | tokens)) 117 | 118 | ;;; Helpers 119 | 120 | (defun get-anchor (tokens) 121 | (let ((grabber (create-tag 'grabber :this)) 122 | (pointer :future) 123 | (repeaters (get-repeaters tokens)) 124 | (head nil)) 125 | (setf tokens (remove-if #'(lambda (x) 126 | (token-has-tag-p x 'repeater)) 127 | tokens)) 128 | (when (and (first tokens) 129 | (token-has-tag-p (first tokens) 'grabber)) 130 | (setf grabber (find-tag 'grabber (first tokens)))) 131 | (setf head (pop repeaters)) 132 | (setf (tag-now head) *now*) 133 | (let ((outer-span nil)) 134 | (ecase (tag-type grabber) 135 | (:last (setf outer-span (r-next head :past))) 136 | (:this (if (plusp (length repeaters)) 137 | (setf outer-span (r-this head :none)) 138 | (setf outer-span (r-this head *context*)))) 139 | (:next (setf outer-span (r-next head :future)))) 140 | (find-within repeaters outer-span pointer)))) 141 | 142 | (defun get-repeaters (tokens) 143 | (let ((repeaters (loop 144 | for token in tokens 145 | when (find-tag 'repeater token) 146 | collect it))) 147 | (sort repeaters #'> :key #'r-width))) 148 | 149 | (defun find-within (tags span pointer) 150 | (when (zerop (length tags)) 151 | (return-from find-within span)) 152 | (destructuring-bind (head &rest rest) 153 | tags 154 | (setf (tag-now head) (ecase pointer 155 | (:future (span-start span)) 156 | (:past (span-end span)))) 157 | (let ((h (r-this head :none))) 158 | (if (or (span-includes-p span (span-start h)) 159 | (span-includes-p span (span-end h))) 160 | (find-within rest h pointer) 161 | nil)))) 162 | 163 | (defun merge-time-tokens-day (tokens date-start) 164 | (let ((time (awhen tokens 165 | (let ((*now* date-start)) 166 | (get-anchor (dealias-and-disambiguate-time tokens)))))) 167 | (or time 168 | (make-span date-start (datetime-incr date-start :day))))) 169 | 170 | (defun dealias-and-disambiguate-time (tokens) 171 | (let* ((time-token (find-if #'(lambda (x) 172 | (find-tag 'repeater-time x)) 173 | tokens)) 174 | (dp-token (find-if #'(lambda (x) 175 | (find-tag 'repeater-day-portion x)) 176 | tokens))) 177 | (when (and dp-token time-token) 178 | (let ((dp-tag (find-tag 'repeater-day-portion dp-token))) 179 | (case (tag-type dp-tag) 180 | (:morning 181 | (untag 'repeater-day-portion dp-token) 182 | (tag (create-tag 'repeater-day-portion :am) dp-token)) 183 | ((:afternoon :evening :night) 184 | (untag 'repeater-day-portion dp-token) 185 | (tag (create-tag 'repeater-day-portion :pm) dp-token))))) 186 | (when *ambiguous-time-range* 187 | (let ((time-tag (and time-token (find-tag 'repeater-time time-token)))) 188 | (when (and time-tag 189 | (tick-ambiguousp (tag-type time-tag)) 190 | (not dp-token)) 191 | (push (create-token "disambiguator" 192 | (create-tag 'repeater-day-portion *ambiguous-time-range*)) 193 | tokens)))) 194 | tokens)) 195 | -------------------------------------------------------------------------------- /src/datetime.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- 2 | ;;; datetime.lisp 3 | 4 | ;;; See the LICENSE file for licensing information. 5 | 6 | (cl:in-package #:chronicity) 7 | 8 | ;;; Date and Time constructors 9 | 10 | (deftype datetime () 11 | 'local-time:timestamp) 12 | 13 | (defun make-date (year &optional (month 1) (day 1)) 14 | (local-time:encode-timestamp 0 0 0 0 day month year)) 15 | 16 | (defun make-time (hour &optional (minute 0) (sec 0)) 17 | (local-time:adjust-timestamp 18 | (local-time:timestamp-minimize-part (local-time:make-timestamp) :hour) 19 | (offset :hour hour) 20 | (offset :minute minute) 21 | (offset :sec sec))) 22 | 23 | (defun make-datetime (year &optional (month 1) (day 1) (hour 0) (minute 0) (sec 0)) 24 | (local-time:encode-timestamp 0 sec minute hour day month year)) 25 | 26 | (defun copy-date (from &key 27 | (year (year-of from)) 28 | (month (month-of from)) 29 | (day (day-of from))) 30 | (make-date year month day)) 31 | 32 | (defun copy-time (from &key 33 | (hour (hour-of from)) 34 | (minute (minute-of from)) 35 | (sec (sec-of from))) 36 | (make-time hour minute sec)) 37 | 38 | (defun copy-datetime (from &key 39 | (year (year-of from)) 40 | (month (month-of from)) 41 | (day (day-of from)) 42 | (hour (hour-of from)) 43 | (minute (minute-of from)) 44 | (sec (sec-of from))) 45 | (make-datetime year month day hour minute sec)) 46 | 47 | (defun merge-datetime (date time) 48 | (let* ((epoch-time (make-time 0 0 0)) 49 | (diff-sec (local-time:timestamp-difference time epoch-time)) 50 | (diff-days (truncate diff-sec #.(* 24 60 60)))) 51 | (datetime-incr (make-datetime (year-of date) (month-of date) (day-of date) 52 | (hour-of time) (minute-of time) (sec-of time)) 53 | :day 54 | diff-days))) 55 | 56 | (defun now () 57 | (local-time:now)) 58 | 59 | (defun today () 60 | (local-time:today)) 61 | 62 | ;;; Date time Readers 63 | 64 | (defun year-of (datetime) 65 | (local-time:timestamp-year datetime)) 66 | 67 | (defun month-of (datetime) 68 | (local-time:timestamp-month datetime)) 69 | 70 | (defun day-of (datetime) 71 | (local-time:timestamp-day datetime)) 72 | 73 | (defun hour-of (datetime) 74 | (local-time:timestamp-hour datetime)) 75 | 76 | (defun minute-of (datetime) 77 | (local-time:timestamp-minute datetime)) 78 | 79 | (defun sec-of (datetime) 80 | (local-time:timestamp-second datetime)) 81 | 82 | (defun dow-of (datetime) 83 | (local-time:timestamp-day-of-week datetime)) 84 | 85 | (defun day-sec-of (datetime) 86 | "Returns the second of the day." 87 | (+ (* (hour-of datetime) 3600) 88 | (* (minute-of datetime) 60) 89 | (sec-of datetime))) 90 | 91 | ;;; Date time Calculations 92 | 93 | (defun datetime-incr (datetime unit &optional (amount 1)) 94 | (case unit 95 | (:week (datetime-incr datetime :day (* 7 amount))) 96 | (t (local-time:timestamp+ datetime amount unit)))) 97 | 98 | (defun datetime-decr (datetime unit &optional (amount 1)) 99 | (datetime-incr datetime unit (- amount))) 100 | 101 | (defun datetime-adjust (datetime part value) 102 | (case part 103 | (:day-of-week (local-time:adjust-timestamp datetime (offset part value))) 104 | (t (local-time:adjust-timestamp datetime (set part value))))) 105 | 106 | (defmacro datetime-incf (place unit &optional (amount 1)) 107 | `(setf ,place (datetime-incr ,place ,unit ,amount))) 108 | 109 | (defmacro datetime-decf (place unit &optional (amount 1)) 110 | `(setf ,place (datetime-decr ,place ,unit ,amount))) 111 | 112 | ;;; Date time comparisons 113 | 114 | (defun datetime< (&rest args) 115 | (apply #'local-time:timestamp< args)) 116 | 117 | (defun datetime<= (&rest args) 118 | (apply #'local-time:timestamp<= args)) 119 | 120 | (defun datetime> (&rest args) 121 | (apply #'local-time:timestamp> args)) 122 | 123 | (defun datetime>= (&rest args) 124 | (apply #'local-time:timestamp>= args)) 125 | 126 | (defun datetime= (&rest args) 127 | (apply #'local-time:timestamp= args)) 128 | 129 | (defun datetime/= (&rest args) 130 | (apply #'local-time:timestamp/= args)) 131 | 132 | (defun datetime-to-universal (datetime) 133 | (local-time:timestamp-to-universal datetime)) 134 | 135 | (defun universal-to-datetime (universal-time) 136 | (local-time:universal-to-timestamp universal-time)) 137 | 138 | ;;; Miscellaneous query operations on datetime objects 139 | 140 | (defun start-of-year (datetime) 141 | (local-time:timestamp-minimize-part datetime :month)) 142 | 143 | (defun end-of-year (datetime) 144 | (local-time:timestamp-maximize-part datetime :month)) 145 | 146 | (defun start-of-month (datetime) 147 | (local-time:timestamp-minimize-part datetime :day)) 148 | 149 | (defun end-of-month (datetime) 150 | (local-time:timestamp-maximize-part datetime :day)) 151 | 152 | (defun start-of-day (datetime) 153 | (local-time:timestamp-minimize-part datetime :hour)) 154 | 155 | (defun end-of-day (datetime) 156 | (local-time:timestamp-maximize-part datetime :hour)) 157 | 158 | (defun start-of-hour (datetime) 159 | (local-time:timestamp-minimize-part datetime :min)) 160 | 161 | (defun end-of-hour (datetime) 162 | (local-time:timestamp-maximize-part datetime :min)) 163 | 164 | (defun start-of-minute (datetime) 165 | (local-time:timestamp-minimize-part datetime :sec)) 166 | 167 | (defun end-of-minute (datetime) 168 | (local-time:timestamp-maximize-part datetime :sec)) 169 | 170 | (defun start-of-week (datetime) 171 | (start-of-day (datetime-adjust datetime :day-of-week :sunday))) 172 | 173 | (defun end-of-week (datetime) 174 | (end-of-day (datetime-adjust datetime :day-of-week :saturday))) 175 | 176 | ;;; Time span 177 | 178 | (defclass span () 179 | ((start :initarg :start 180 | :reader span-start) 181 | (end :initarg :end 182 | :reader span-end) 183 | (end-included-p :initarg :end-included-p 184 | :reader span-end-included-p 185 | :initform nil) 186 | (default :initarg :default 187 | :reader span-default 188 | :initform nil))) 189 | 190 | (defmethod print-object ((x span) stream) 191 | (flet ((!format-span () 192 | (format stream "~A~:[...~;..~]~A" 193 | (span-start x) 194 | (span-end-included-p x) 195 | (span-end x)))) 196 | (if *print-escape* 197 | (print-unreadable-object (x stream :type t) 198 | (!format-span)) 199 | (!format-span)))) 200 | 201 | (defun make-span (start end &optional end-included-p default) 202 | (make-instance 'span :start start :end end :end-included-p end-included-p :default default)) 203 | 204 | (defun span-width (span) 205 | (- (datetime-to-universal (span-end span)) 206 | (datetime-to-universal (span-start span)))) 207 | 208 | (defun span-middle (span) 209 | (universal-to-datetime 210 | (truncate (+ (datetime-to-universal (span-start span)) 211 | (datetime-to-universal (span-end span))) 212 | 2))) 213 | 214 | (defun span+ (span amount unit) 215 | (make-span (datetime-incr (span-start span) unit amount) 216 | (datetime-incr (span-end span) unit amount) 217 | (span-end-included-p span) 218 | (awhen (span-default span) 219 | (datetime-incr (span-default span) unit amount)))) 220 | 221 | (defun span- (span amount unit) 222 | (make-span (datetime-decr (span-start span) unit amount) 223 | (datetime-decr (span-end span) unit amount) 224 | (span-end-included-p span) 225 | (awhen (span-default span) 226 | (datetime-decr (span-default span) unit amount)))) 227 | 228 | (defun span-includes-p (span datetime) 229 | (if (span-end-included-p span) 230 | (datetime<= (span-start span) datetime (span-end span)) 231 | (and (datetime<= (span-start span) datetime) 232 | (datetime< datetime (span-end span))))) 233 | 234 | ;;; Miscellaneous data 235 | 236 | (defparameter *months* 237 | (list :JANUARY 238 | :FEBRUARY 239 | :MARCH 240 | :APRIL 241 | :MAY 242 | :JUNE 243 | :JULY 244 | :AUGUST 245 | :SEPTEMBER 246 | :OCTOBER 247 | :NOVEMBER 248 | :DECEMBER)) 249 | 250 | (defun month-name (index) 251 | (elt *months* (1- index))) 252 | 253 | (defun month-index (name) 254 | (1+ (position name *months*))) 255 | 256 | (defparameter *days-of-week* 257 | (list :SUNDAY 258 | :MONDAY 259 | :TUESDAY 260 | :WEDNESDAY 261 | :THURSDAY 262 | :FRIDAY 263 | :SATURDAY)) 264 | 265 | (defun dow-index (name) 266 | (position name *days-of-week*)) 267 | 268 | (defun dow-name (index) 269 | (elt *days-of-week* index)) 270 | 271 | -------------------------------------------------------------------------------- /src/handler-defs.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- 2 | ;;; handler-defs.lisp 3 | 4 | ;;; See the LICENSE file for licensing information. 5 | 6 | (cl:in-package #:chronicity) 7 | 8 | (clear-handlers) 9 | 10 | ;;; Date handlers 11 | 12 | (define-handler (date handle-rdn-sd-rmn-sy-rt) 13 | (tokens) 14 | ((repeater-day-name scalar-day repeater-month-name scalar-year repeater-time)) 15 | (setf tokens (remove-separators tokens)) 16 | (let* ((year-tag (find-tag 'scalar-year (fourth tokens))) 17 | (month-name-tag (find-tag 'repeater-month-name (third tokens))) 18 | (day-tag (find-tag 'scalar-day (second tokens))) 19 | (date-start (make-date (tag-type year-tag) 20 | (month-index (tag-type month-name-tag)) 21 | (tag-type day-tag)))) 22 | (merge-time-tokens-day (nthcdr 4 tokens) date-start))) 23 | 24 | (define-handler (date handle-rmn-sd-rt-sy) 25 | (tokens) 26 | ((repeater-month-name scalar-day repeater-time scalar-year)) 27 | (let* ((year-tag (find-tag 'scalar-year (fourth tokens))) 28 | (month-name-tag (find-tag 'repeater-month-name (first tokens))) 29 | (day-tag (find-tag 'scalar-day (second tokens))) 30 | (date-start (make-date (tag-type year-tag) 31 | (month-index (tag-type month-name-tag)) 32 | (tag-type day-tag)))) 33 | (merge-time-tokens-day (list (third tokens)) date-start))) 34 | 35 | (define-handler (date handle-rmn-sd-sy) 36 | (tokens) 37 | ((repeater-month-name scalar-day scalar-year) 38 | (repeater-month-name scalar-day scalar-year (? separator-at) (? p time))) 39 | (setf tokens (remove-separators tokens)) 40 | (let* ((year-tag (find-tag 'scalar-year (third tokens))) 41 | (month-name-tag (find-tag 'repeater-month-name (first tokens))) 42 | (day-tag (find-tag 'scalar-day (second tokens))) 43 | (date-start (make-date (tag-type year-tag) 44 | (month-index (tag-type month-name-tag)) 45 | (tag-type day-tag)))) 46 | (merge-time-tokens-day (nthcdr 3 tokens) date-start))) 47 | 48 | (defun guess-year (month day) 49 | (let* ((today (copy-date *now*)) 50 | (this-year (year-of *now*)) 51 | (this-year-date (make-date this-year month day))) 52 | (ecase *context* 53 | (:future (if (datetime< this-year-date today) (1+ this-year) this-year)) 54 | (:past (if (datetime> this-year-date today) (1- this-year) this-year))))) 55 | 56 | (define-handler (date handle-rmn-sd) 57 | (tokens) 58 | ((repeater-month-name scalar-day (? separator-at) (? p time))) 59 | (setf tokens (remove-separators tokens)) 60 | (let* ((month-name-tag (find-tag 'repeater-month-name (first tokens))) 61 | (day-tag (find-tag 'scalar-day (second tokens))) 62 | (month (month-index (tag-type month-name-tag))) 63 | (day (tag-type day-tag)) 64 | (year (guess-year month day)) 65 | (date-start (make-date year month day))) 66 | (merge-time-tokens-day (nthcdr 2 tokens) date-start))) 67 | 68 | (define-handler (date) 69 | (tokens) 70 | ((repeater-time (? repeater-day-portion) (? separator-on) repeater-month-name scalar-day)) 71 | (setf tokens (remove-separators tokens)) 72 | (cond 73 | ((= (length tokens) 3) 74 | (handle-rmn-sd (list (second tokens) (third tokens) (first tokens)))) 75 | ((= (length tokens) 4) 76 | (handle-rmn-sd (list (third tokens) (fourth tokens) (first tokens) (second tokens)))) 77 | (t 78 | (error "Wrong number of tokens passed to HANDLE-RMN-SD-ON.~%Tokens:~%~S" tokens)))) 79 | 80 | (define-handler (date handle-rmn-od-sy) 81 | (tokens) 82 | ((repeater-month-name ordinal-day scalar-year (? separator-at) (? p time))) 83 | (let* ((day-token (second tokens)) 84 | (day (token-tag-type 'ordinal-day day-token))) 85 | (tag (create-tag 'scalar-day day) day-token) 86 | (handle-rmn-sd-sy (list* (first tokens) day-token (third tokens) (nthcdr 3 tokens))))) 87 | 88 | (define-handler (date handle-rmn-od) 89 | (tokens) 90 | ((repeater-month-name ordinal-day (? separator-at) (? p time))) 91 | (let* ((day-token (second tokens)) 92 | (day (token-tag-type 'ordinal-day day-token))) 93 | (tag (create-tag 'scalar-day day) day-token) 94 | (handle-rmn-sd (list* (first tokens) day-token (nthcdr 2 tokens))))) 95 | 96 | (define-handler (date) 97 | (tokens) 98 | ((repeater-time (? repeater-day-portion) (? separator-on) repeater-month-name ordinal-day)) 99 | (setf tokens (remove-separators tokens)) 100 | (cond 101 | ((= (length tokens) 3) 102 | (handle-rmn-od (list (second tokens) (third tokens) (first tokens)))) 103 | ((= (length tokens) 4) 104 | (handle-rmn-od (list (third tokens) (fourth tokens) (first tokens) (second tokens)))) 105 | (t 106 | (error "Wrong number of tokens passed to HANDLE-RMN-OD-ON.~%Tokens:~%~S" tokens)))) 107 | 108 | (define-handler (date) 109 | (tokens) 110 | ((repeater-month-name scalar-year)) 111 | (let* ((month-name (token-tag-type 'repeater-month-name (first tokens))) 112 | (month (month-index month-name)) 113 | (year (token-tag-type 'scalar-year (second tokens))) 114 | (start (make-date year month))) 115 | (make-span start (datetime-incr start :month)))) 116 | 117 | (define-handler (date) 118 | (tokens) 119 | ((scalar-day repeater-month-name scalar-year (? separator-at) (? p time))) 120 | (handle-rmn-sd-sy (list* (second tokens) (first tokens) (nthcdr 2 tokens)))) 121 | 122 | (define-handler (date) 123 | (tokens) 124 | ((ordinal-day repeater-month-name scalar-year (? separator-at) (? p time))) 125 | (let* ((day-token (first tokens)) 126 | (day (token-tag-type 'ordinal-day day-token))) 127 | (tag (create-tag 'scalar-day day) day-token) 128 | (handle-rmn-sd-sy (list* (second tokens) day-token (nthcdr 2 tokens))))) 129 | 130 | (define-handler (date) 131 | (tokens) 132 | ((scalar-day repeater-month-name (? separator-at) (? p time))) 133 | (handle-rmn-sd (list* (second tokens) (first tokens) (nthcdr 2 tokens)))) 134 | 135 | (define-handler (date) 136 | (tokens) 137 | ((ordinal-day repeater-month-name (? separator-at) (? p time))) 138 | (handle-rmn-od (list* (second tokens) (first tokens) (nthcdr 2 tokens)))) 139 | 140 | (define-handler (date) 141 | (tokens) 142 | ((scalar-year separator-slash-or-dash scalar-month separator-slash-or-dash scalar-day (? separator-at) (? p time))) 143 | (setf tokens (remove-separators tokens)) 144 | (let* ((year (token-tag-type 'scalar-year (first tokens))) 145 | (month (token-tag-type 'scalar-month (second tokens))) 146 | (day (token-tag-type 'scalar-day (third tokens))) 147 | (date-start (make-date year month day))) 148 | (merge-time-tokens-day (nthcdr 3 tokens) date-start))) 149 | 150 | (define-handler (date handle-ambiguous-dmy) 151 | (original-tokens &aux tokens) 152 | ((scalar-month separator-slash-or-dash scalar-month separator-slash-or-dash scalar-year (? separator-at) (? p time)) 153 | (scalar-month separator-slash-or-dash scalar-month (? separator-at) (? p time))) 154 | (setf tokens (remove-separators original-tokens)) 155 | (destructuring-bind (day month) 156 | (ecase *endian-preference* 157 | (:little (list (token-tag-type 'scalar-day (first tokens)) 158 | (token-tag-type 'scalar-month (second tokens)))) 159 | (:middle (list (token-tag-type 'scalar-day (second tokens)) 160 | (token-tag-type 'scalar-month (first tokens))))) 161 | (let ((year (if (and (fourth original-tokens) 162 | (find-tag 'separator-slash-or-dash (fourth original-tokens))) 163 | (token-tag-type 'scalar-year (third tokens)) 164 | (guess-year month day)))) 165 | (merge-time-tokens-day (nthcdr 3 tokens) (make-date year month day))))) 166 | 167 | (define-handler (date) 168 | (tokens) 169 | ((scalar-day separator-slash-or-dash scalar-month separator-slash-or-dash scalar-year (? separator-at) (? p time)) 170 | (scalar-day separator-slash-or-dash scalar-month (? separator-at) (? p time)) 171 | (scalar-month separator-slash-or-dash scalar-day separator-slash-or-dash scalar-year (? separator-at) (? p time)) 172 | (scalar-month separator-slash-or-dash scalar-day (? separator-at) (? p time))) 173 | (let ((selected-pattern (handler-pattern *handler*))) 174 | (if (or (equalp selected-pattern (first *handler-patterns*)) 175 | (equalp selected-pattern (second *handler-patterns*))) 176 | (let ((*endian-preference* :little)) 177 | (handle-ambiguous-dmy tokens)) 178 | (let ((*endian-preference* :middle)) 179 | (handle-ambiguous-dmy tokens))))) 180 | 181 | (define-handler (date) 182 | (tokens) 183 | ((scalar-month separator-slash-or-dash scalar-year)) 184 | (setf tokens (remove-separators tokens)) 185 | (let ((month (token-tag-type 'scalar-month (first tokens))) 186 | (year (token-tag-type 'scalar-year (second tokens)))) 187 | (make-span (make-date year month) 188 | (datetime-incr (make-date year month) :month)))) 189 | 190 | ;;; Anchors 191 | 192 | (define-handler (anchor handle-r) 193 | (tokens) 194 | (((? grabber) repeater (? separator-at) (? repeater) (? repeater)) 195 | ((? grabber) repeater repeater (? separator-at) (? repeater) (? repeater)) 196 | (repeater (? repeater) grabber repeater)) 197 | (get-anchor (dealias-and-disambiguate-time tokens))) 198 | 199 | ;;; Arrows 200 | 201 | (defun r-rough-offset (repeater amount pointer) 202 | (if (zerop amount) 203 | (r-this repeater pointer) 204 | (let ((now (tag-now repeater)) 205 | (this-span (r-this repeater :none))) 206 | (cond ((datetime< now (span-start this-span)) 207 | (r-offset repeater 208 | (r-next repeater pointer) 209 | (if (eq pointer :past) amount (1- amount)) 210 | pointer)) 211 | ((datetime> now (span-end this-span)) 212 | (r-offset repeater 213 | this-span 214 | (if (eq pointer :future) amount (1- amount)) 215 | pointer)) 216 | (t (r-offset repeater this-span amount pointer)))))) 217 | 218 | (defun handle-srp (tokens &optional now) 219 | (let ((distance (tag-type (find-if #'(lambda (x) 220 | (eql (type-of x) 'scalar)) 221 | (token-tags (first tokens))))) 222 | (repeater (find-tag 'repeater (second tokens))) 223 | (pointer (token-tag-type 'pointer (third tokens)))) 224 | (setf (tag-now repeater) (or now *now*)) 225 | (r-rough-offset repeater distance pointer))) 226 | 227 | (define-handler (arrow handle-s-r-p) 228 | (tokens) 229 | (((? scalar) repeater pointer)) 230 | (when (= (length tokens) 2) 231 | (push (create-token "1" (create-tag 'scalar 1)) tokens)) 232 | (handle-srp tokens)) 233 | 234 | (define-handler (arrow handle-p-s-r) 235 | (tokens) 236 | ((pointer scalar repeater)) 237 | (handle-s-r-p (list (second tokens) (third tokens) (first tokens)))) 238 | 239 | (define-handler (arrow handle-s-r-p-a) 240 | (tokens) 241 | ((scalar repeater pointer (? p anchor))) 242 | (let ((anchor-span (awhen (nthcdr 3 tokens) 243 | (get-anchor it)))) 244 | (handle-srp tokens (or (span-default anchor-span) 245 | (span-start anchor-span))))) 246 | 247 | (define-handler (arrow) 248 | (tokens) 249 | ((repeater pointer (? p anchor))) 250 | (handle-s-r-p-a (cons (create-token "1" (create-tag 'scalar 1)) tokens))) 251 | 252 | ;;; Narrow 253 | 254 | (defun handle-orr (tokens outer-span) 255 | (let ((repeater (find-tag 'repeater (second tokens))) 256 | (ordinal (token-tag-type 'ordinal (first tokens)))) 257 | (setf (tag-now repeater) (datetime-decr (span-start outer-span) :sec)) 258 | (loop 259 | repeat ordinal 260 | for span = (r-next repeater :future) 261 | if (datetime> (span-start span) (span-end outer-span)) 262 | return nil 263 | finally (return span)))) 264 | 265 | (define-handler (narrow) 266 | (tokens) 267 | ((ordinal repeater separator-in scalar-year) 268 | (ordinal repeater separator-in repeater)) 269 | (let ((outer-span (aif (token-tag-type 'scalar-year (fourth tokens)) 270 | (make-span (make-date it) (make-date (1+ it))) 271 | (get-anchor (list (fourth tokens)))))) 272 | (handle-orr (list (first tokens) (second tokens)) outer-span))) 273 | 274 | (define-handler (narrow) 275 | (tokens) 276 | ((ordinal repeater grabber repeater)) 277 | (let ((outer-span (get-anchor (list (third tokens) (fourth tokens))))) 278 | (handle-orr tokens outer-span))) 279 | 280 | ;;; Time handlers 281 | 282 | (define-handler (time) 283 | (tokens) 284 | ((repeater-time (? repeater-day-portion))) 285 | (get-anchor (dealias-and-disambiguate-time tokens))) 286 | 287 | -------------------------------------------------------------------------------- /test/lisp-unit.lisp: -------------------------------------------------------------------------------- 1 | ;;;-*- Mode: Lisp; Package: LISP-UNIT -*- 2 | 3 | #| 4 | Copyright (c) 2004-2005 Christopher K. Riesbeck 5 | 6 | Permission is hereby granted, free of charge, to any person obtaining 7 | a copy of this software and associated documentation files (the "Software"), 8 | to deal in the Software without restriction, including without limitation 9 | the rights to use, copy, modify, merge, publish, distribute, sublicense, 10 | and/or sell copies of the Software, and to permit persons to whom the 11 | Software is furnished to do so, subject to the following conditions: 12 | 13 | The above copyright notice and this permission notice shall be included 14 | in all copies or substantial portions of the Software. 15 | 16 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS 17 | OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 18 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL 19 | THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR 20 | OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, 21 | ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 22 | OTHER DEALINGS IN THE SOFTWARE. 23 | |# 24 | 25 | 26 | ;;; A test suite package, modelled after JUnit. 27 | ;;; Author: Chris Riesbeck 28 | ;;; 29 | ;;; Update history: 30 | ;;; 31 | ;;; 04/07/06 added ~<...~> to remaining error output forms [CKR] 32 | ;;; 04/06/06 added ~<...~> to compact error output better [CKR] 33 | ;;; 04/06/06 fixed RUN-TESTS to get tests dynamically (bug reported 34 | ;;; by Daniel Edward Burke) [CKR] 35 | ;;; 02/08/06 added newlines to error output [CKR] 36 | ;;; 12/30/05 renamed ASSERT-PREDICATE to ASSERT-EQUALITY [CKR] 37 | ;;; 12/29/05 added ASSERT-EQ, ASSERT-EQL, ASSERT-EQUALP [CKR] 38 | ;;; 12/22/05 recoded use-debugger to use handler-bind, added option to prompt for debugger, 39 | ;;; 11/07/05 added *use-debugger* and assert-predicate [DFB] 40 | ;;; 09/18/05 replaced Academic Free License with MIT Licence [CKR] 41 | ;;; 08/30/05 added license notice [CKR] 42 | ;;; 06/28/05 changed RUN-TESTS to compile code at run time, not expand time [CKR] 43 | ;;; 02/21/05 removed length check from SET-EQUAL [CKR] 44 | ;;; 02/17/05 added RUN-ALL-TESTS [CKR] 45 | ;;; 01/18/05 added ASSERT-EQUAL back in [CKR] 46 | ;;; 01/17/05 much clean up, added WITH-TEST-LISTENER [CKR] 47 | ;;; 01/15/05 replaced ASSERT-EQUAL etc. with ASSERT-TRUE and ASSERT-FALSE [CKR] 48 | ;;; 01/04/05 changed COLLECT-RESULTS to echo output on *STANDARD-OUTPuT* [CKR] 49 | ;;; 01/04/05 added optional package argument to REMOVE-ALL-TESTS [CKR] 50 | ;;; 01/04/05 changed OUTPUT-OK-P to trim spaces and returns [CKR] 51 | ;;; 01/04/05 changed OUTPUT-OK-P to not check output except when asked to [CKR] 52 | ;;; 12/03/04 merged REMOVE-TEST into REMOVE-TESTS [CKR] 53 | ;;; 12/03/04 removed ability to pass forms to RUN-TESTS [CKR] 54 | ;;; 12/03/04 refactored RUN-TESTS expansion into RUN-TEST-THUNKS [CKR] 55 | ;;; 12/02/04 changed to group tests under packages [CKR] 56 | ;;; 11/30/04 changed assertions to put expected value first, like JUnit [CKR] 57 | ;;; 11/30/04 improved error handling and summarization [CKR] 58 | ;;; 11/30/04 generalized RUN-TESTS, removed RUN-TEST [CKR] 59 | ;;; 02/27/04 fixed ASSERT-PRINTS not ignoring value [CKR] 60 | ;;; 02/07/04 fixed ASSERT-EXPANDS failure message [CKR] 61 | ;;; 02/07/04 added ASSERT-NULL, ASSERT-NOT-NULL [CKR] 62 | ;;; 01/31/04 added error handling and totalling to RUN-TESTS [CKR] 63 | ;;; 01/31/04 made RUN-TEST/RUN-TESTS macros [CKR] 64 | ;;; 01/29/04 fixed ASSERT-EXPANDS quote bug [CKR] 65 | ;;; 01/28/04 major changes from BUG-FINDER to be more like JUnit [CKR] 66 | 67 | 68 | #| 69 | How to use 70 | ---------- 71 | 72 | 1. Read the documentation in lisp-unit.html. 73 | 74 | 2. Make a file of DEFINE-TEST's. See exercise-tests.lisp for many 75 | examples. If you want, start your test file with (REMOVE-TESTS) to 76 | clear any previously defined tests. 77 | 78 | 2. Load this file. 79 | 80 | 2. (use-package :lisp-unit) 81 | 82 | 3. Load your code file and your file of tests. 83 | 84 | 4. Test your code with (RUN-TESTS test-name1 test-name2 ...) -- no quotes! -- 85 | or simply (RUN-TESTS) to run all defined tests. 86 | 87 | A summary of how many tests passed and failed will be printed, 88 | with details on the failures. 89 | 90 | Note: Nothing is compiled until RUN-TESTS is expanded. Redefining 91 | functions or even macros does not require reloading any tests. 92 | 93 | For more information, see lisp-unit.html. 94 | 95 | |# 96 | 97 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 98 | ;;; Packages 99 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 100 | 101 | (cl:defpackage #:lisp-unit 102 | (:use #:common-lisp) 103 | (:export #:define-test #:run-all-tests #:run-tests 104 | #:assert-eq #:assert-eql #:assert-equal #:assert-equalp 105 | #:assert-error #:assert-expands #:assert-false 106 | #:assert-equality #:assert-prints #:assert-true 107 | #:get-test-code #:get-tests 108 | #:remove-all-tests #:remove-tests 109 | #:logically-equal #:set-equal 110 | #:use-debugger 111 | #:with-test-listener) 112 | ) 113 | 114 | (in-package #:lisp-unit) 115 | 116 | 117 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 118 | ;;; Globals 119 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 120 | 121 | (defparameter *test-listener* nil) 122 | 123 | (defparameter *tests* (make-hash-table)) 124 | 125 | ;;; Used by RUN-TESTS to collect summary statistics 126 | (defvar *test-count* 0) 127 | (defvar *pass-count* 0) 128 | 129 | ;;; Set by RUN-TESTS for use by SHOW-FAILURE 130 | (defvar *test-name* nil) 131 | 132 | ;;; If nil, errors in tests are caught and counted. 133 | ;;; If :ask, user is given option of entering debugger or not. 134 | ;;; If true and not :ask, debugger is entered. 135 | (defparameter *use-debugger* nil) 136 | 137 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 138 | ;;; Macros 139 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 140 | 141 | ;;; DEFINE-TEST 142 | 143 | (defmacro define-test (name &body body) 144 | `(progn 145 | (store-test-code ',name ',body) 146 | ',name)) 147 | 148 | ;;; ASSERT macros 149 | 150 | (defmacro assert-eq (expected form &rest extras) 151 | (expand-assert :equal form form expected extras :test #'eq)) 152 | 153 | (defmacro assert-eql (expected form &rest extras) 154 | (expand-assert :equal form form expected extras :test #'eql)) 155 | 156 | (defmacro assert-equal (expected form &rest extras) 157 | (expand-assert :equal form form expected extras :test #'equal)) 158 | 159 | (defmacro assert-equalp (expected form &rest extras) 160 | (expand-assert :equal form form expected extras :test #'equalp)) 161 | 162 | (defmacro assert-error (condition form &rest extras) 163 | (expand-assert :error form (expand-error-form form) 164 | condition extras)) 165 | 166 | (defmacro assert-expands (&environment env expansion form &rest extras) 167 | (expand-assert :macro form 168 | (expand-macro-form form #+lispworks nil #-lispworks env) 169 | expansion extras)) 170 | 171 | (defmacro assert-false (form &rest extras) 172 | (expand-assert :result form form nil extras)) 173 | 174 | (defmacro assert-equality (test expected form &rest extras) 175 | (expand-assert :equal form form expected extras :test test)) 176 | 177 | (defmacro assert-prints (output form &rest extras) 178 | (expand-assert :output form (expand-output-form form) 179 | output extras)) 180 | 181 | (defmacro assert-true (form &rest extras) 182 | (expand-assert :result form form t extras)) 183 | 184 | 185 | (defun expand-assert (type form body expected extras &key (test #'eql)) 186 | `(internal-assert 187 | ,type ',form #'(lambda () ,body) #'(lambda () ,expected) ,(expand-extras extras), test)) 188 | 189 | (defun expand-error-form (form) 190 | `(handler-case ,form 191 | (condition (error) error))) 192 | 193 | (defun expand-output-form (form) 194 | (let ((out (gensym))) 195 | `(let* ((,out (make-string-output-stream)) 196 | (*standard-output* (make-broadcast-stream *standard-output* ,out))) 197 | ,form 198 | (get-output-stream-string ,out)))) 199 | 200 | (defun expand-macro-form (form env) 201 | `(macroexpand-1 ',form ,env)) 202 | 203 | (defun expand-extras (extras) 204 | `#'(lambda () 205 | (list ,@(mapcan #'(lambda (form) (list `',form form)) extras)))) 206 | 207 | 208 | ;;; RUN-TESTS 209 | 210 | (defmacro run-all-tests (package &rest tests) 211 | `(let ((*package* (find-package ',package))) 212 | (run-tests 213 | ,@(mapcar #'(lambda (test) (find-symbol (symbol-name test) package)) 214 | tests)))) 215 | 216 | (defmacro run-tests (&rest names) 217 | `(run-test-thunks (get-test-thunks ,(if (null names) '(get-tests *package*) `',names)))) 218 | 219 | (defun get-test-thunks (names &optional (package *package*)) 220 | (mapcar #'(lambda (name) (get-test-thunk name package)) 221 | names)) 222 | 223 | (defun get-test-thunk (name package) 224 | (assert (get-test-code name package) (name package) 225 | "No test defined for ~S in package ~S" name package) 226 | (list name (coerce `(lambda () ,@(get-test-code name)) 'function))) 227 | 228 | (defun use-debugger (&optional (flag t)) 229 | (setq *use-debugger* flag)) 230 | 231 | ;;; WITH-TEST-LISTENER 232 | (defmacro with-test-listener (listener &body body) 233 | `(let ((*test-listener* #',listener)) ,@body)) 234 | 235 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 236 | ;;; Public functions 237 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 238 | 239 | (defun get-test-code (name &optional (package *package*)) 240 | (let ((table (get-package-table package))) 241 | (unless (null table) 242 | (gethash name table)))) 243 | 244 | (defun get-tests (&optional (package *package*)) 245 | (let ((l nil) 246 | (table (get-package-table package))) 247 | (cond ((null table) nil) 248 | (t 249 | (maphash #'(lambda (key val) 250 | (declare (ignore val)) 251 | (push key l)) 252 | table) 253 | (sort l #'string< :key #'string))))) 254 | 255 | 256 | (defun remove-tests (names &optional (package *package*)) 257 | (let ((table (get-package-table package))) 258 | (unless (null table) 259 | (if (null names) 260 | (clrhash table) 261 | (dolist (name names) 262 | (remhash name table)))))) 263 | 264 | (defun remove-all-tests (&optional (package *package*)) 265 | (if (null package) 266 | (clrhash *tests*) 267 | (remhash (find-package package) *tests*))) 268 | 269 | 270 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 271 | ;;; Private functions 272 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 273 | 274 | 275 | ;;; DEFINE-TEST support 276 | 277 | (defun get-package-table (package &key create) 278 | (let ((table (gethash (find-package package) *tests*))) 279 | (or table 280 | (and create 281 | (setf (gethash package *tests*) 282 | (make-hash-table)))))) 283 | 284 | (defun get-test-name (form) 285 | (if (atom form) form (cadr form))) 286 | 287 | (defun store-test-code (name code &optional (package *package*)) 288 | (setf (gethash name 289 | (get-package-table package :create t)) 290 | code)) 291 | 292 | 293 | ;;; ASSERTION support 294 | 295 | (defun internal-assert (type form code-thunk expected-thunk extras test) 296 | (let* ((expected (multiple-value-list (funcall expected-thunk))) 297 | (actual (multiple-value-list (funcall code-thunk))) 298 | (passed (test-passed-p type expected actual test))) 299 | 300 | (incf *test-count*) 301 | (when passed 302 | (incf *pass-count*)) 303 | 304 | (record-result passed type form expected actual extras) 305 | 306 | passed)) 307 | 308 | (defun record-result (passed type form expected actual extras) 309 | (funcall (or *test-listener* 'default-listener) 310 | passed type *test-name* form expected actual 311 | (and extras (funcall extras)) 312 | *test-count* *pass-count*)) 313 | 314 | (defun default-listener 315 | (passed type name form expected actual extras test-count pass-count) 316 | (declare (ignore test-count pass-count)) 317 | (unless passed 318 | (show-failure type (get-failure-message type) 319 | name form expected actual extras))) 320 | 321 | (defun test-passed-p (type expected actual test) 322 | (ecase type 323 | (:error 324 | (or (eql (car actual) (car expected)) 325 | (typep (car actual) (car expected)))) 326 | (:equal 327 | (and (<= (length expected) (length actual)) 328 | (every test expected actual))) 329 | (:macro 330 | (equal (car actual) (car expected))) 331 | (:output 332 | (string= (string-trim '(#\newline #\return #\space) 333 | (car actual)) 334 | (car expected))) 335 | (:result 336 | (logically-equal (car actual) (car expected))) 337 | )) 338 | 339 | 340 | ;;; RUN-TESTS support 341 | 342 | (defun run-test-thunks (test-thunks) 343 | (unless (null test-thunks) 344 | (let ((total-test-count 0) 345 | (total-pass-count 0) 346 | (total-error-count 0)) 347 | (dolist (test-thunk test-thunks) 348 | (multiple-value-bind (test-count pass-count error-count) 349 | (run-test-thunk (car test-thunk) (cadr test-thunk)) 350 | (incf total-test-count test-count) 351 | (incf total-pass-count pass-count) 352 | (incf total-error-count error-count))) 353 | (unless (null (cdr test-thunks)) 354 | (show-summary 'total total-test-count total-pass-count total-error-count)) 355 | (values)))) 356 | 357 | (defun run-test-thunk (*test-name* thunk) 358 | (if (null thunk) 359 | (format t "~& Test ~S not found" *test-name*) 360 | (prog ((*test-count* 0) 361 | (*pass-count* 0) 362 | (error-count 0)) 363 | (handler-bind 364 | ((error #'(lambda (e) 365 | (let ((*print-escape* nil)) 366 | (setq error-count 1) 367 | (format t "~& ~S: ~W" *test-name* e)) 368 | (if (use-debugger-p e) e (go exit))))) 369 | (funcall thunk) 370 | (show-summary *test-name* *test-count* *pass-count*)) 371 | exit 372 | (return (values *test-count* *pass-count* error-count))))) 373 | 374 | (defun use-debugger-p (e) 375 | (and *use-debugger* 376 | (or (not (eql *use-debugger* :ask)) 377 | (y-or-n-p "~A -- debug?" e)))) 378 | 379 | ;;; OUTPUT support 380 | 381 | (defun get-failure-message (type) 382 | (case type 383 | (:error "~&~@[Should have signalled ~{~S~^; ~} but saw~] ~{~S~^; ~}") 384 | (:macro "~&Should have expanded to ~{~S~^; ~} ~<~%~:;but saw ~{~S~^; ~}~>") 385 | (:output "~&Should have printed ~{~S~^; ~} ~<~%~:;but saw ~{~S~^; ~}~>") 386 | (t "~&Expected ~{~S~^; ~} ~<~%~:;but saw ~{~S~^; ~}~>") 387 | )) 388 | 389 | (defun show-failure (type msg name form expected actual extras) 390 | (format t "~&~@[~S: ~]~S failed: " name form) 391 | (format t msg expected actual) 392 | (format t "~{~& ~S => ~S~}~%" extras) 393 | type) 394 | 395 | (defun show-summary (name test-count pass-count &optional error-count) 396 | (format t "~&~A: ~S assertions passed, ~S failed~@[, ~S execution errors~]." 397 | name pass-count (- test-count pass-count) error-count)) 398 | 399 | (defun collect-form-values (form values) 400 | (mapcan #'(lambda (form-arg value) 401 | (if (constantp form-arg) 402 | nil 403 | (list form-arg value))) 404 | (cdr form) 405 | values)) 406 | 407 | 408 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 409 | ;;; Useful equality predicates for tests 410 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 411 | 412 | ;;; (LOGICALLY-EQUAL x y) => true or false 413 | ;;; Return true if x and y both false or both true 414 | 415 | (defun logically-equal (x y) 416 | (eql (not x) (not y))) 417 | 418 | ;;; (SET-EQUAL l1 l2 :test) => true or false 419 | ;;; Return true if every element of l1 is an element of l2 420 | ;;; and vice versa. 421 | 422 | (defun set-equal (l1 l2 &key (test #'equal)) 423 | (and (listp l1) 424 | (listp l2) 425 | (subsetp l1 l2 :test test) 426 | (subsetp l2 l1 :test test))) 427 | 428 | 429 | (provide "lisp-unit") 430 | -------------------------------------------------------------------------------- /test/parsing.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- 2 | ;;; parsing.lisp 3 | 4 | ;;; See the LICENSE file for licensing information. 5 | 6 | (cl:in-package #:chronicity-test) 7 | 8 | (define-test parse-guess-dates 9 | (let ((*now* (make-datetime 2006 8 16 14 0 0)) 10 | (*guess* :middle)) 11 | 12 | ;; rdn_sd_rmn_sy_rt 13 | 14 | (assert-datetime= (make-datetime 2012 10 02 0 2 20) 15 | (parse "Sun, 02 October 2012 00:02:20")) 16 | 17 | ;; rmn_sd_rt_sy 18 | 19 | (assert-datetime= (make-datetime 2014 10 20 2 30 56) 20 | (parse "Oct 20 02:30:56 2014")) 21 | 22 | ;; rm_sd 23 | 24 | (assert-datetime= (make-datetime 2007 5 27 12) (parse "may 27")) 25 | 26 | (assert-datetime= (make-datetime 2006 5 28 12) 27 | (parse "may 28" :context :past)) 28 | 29 | (assert-datetime= (make-datetime 2006 5 28 17) 30 | (parse "may 28 5pm" :context :past)) 31 | 32 | (assert-datetime= (make-datetime 2006 5 28 17) 33 | (parse "may 28 at 5pm" :context :past)) 34 | 35 | (assert-datetime= (make-datetime 2006 5 28 17 32 19) 36 | (parse "may 28 at 5:32.19pm" :context :past)) 37 | 38 | ;; rm_sd_on 39 | 40 | (assert-datetime= (make-datetime 2007 5 28 17) (parse "5pm on may 28")) 41 | 42 | (assert-datetime= (make-datetime 2007 5 28 17) (parse "5pm may 28")) 43 | 44 | (assert-datetime= (make-datetime 2007 5 28 05) 45 | (parse "5 on may 28" :ambiguous-time-range nil)) 46 | 47 | ;; rm_od 48 | 49 | (assert-datetime= (make-datetime 2007 5 27 12) (parse "may 27th")) 50 | 51 | (assert-datetime= (make-datetime 2006 5 27 12) 52 | (parse "may 27th" :context :past)) 53 | 54 | (assert-datetime= (make-datetime 2006 5 27 17) 55 | (parse "may 27th 5:00 pm" :context :past)) 56 | 57 | (assert-datetime= (make-datetime 2006 5 27 17) 58 | (parse "may 27th at 5pm" :context :past)) 59 | 60 | (assert-datetime= (make-datetime 2007 5 27 5) 61 | (parse "may 27th at 5" :ambiguous-time-range nil)) 62 | 63 | ;; rm_od_on 64 | 65 | (assert-datetime= (make-datetime 2006 5 27 17) 66 | (parse "5:00 pm may 27th" :context :past)) 67 | 68 | (assert-datetime= (make-datetime 2006 5 27 17) 69 | (parse "5pm on may 27th" :context :past)) 70 | 71 | (assert-datetime= (make-datetime 2007 5 27 5) 72 | (parse "5 on may 27th" :ambiguous-time-range nil)) 73 | 74 | ;; rm_sy 75 | 76 | (assert-datetime= (make-datetime 1979 6 16 0) (parse "June 1979")) 77 | 78 | (assert-datetime= (make-datetime 1979 12 16 12) (parse "dec 79")) 79 | 80 | ;; rm_sd_sy 81 | 82 | (assert-datetime= (make-datetime 2010 1 3 12) (parse "jan 3 2010")) 83 | 84 | (assert-datetime= (make-datetime 2010 1 4 0) (parse "jan 3 2010 midnight")) 85 | 86 | (assert-datetime= (make-datetime 2010 1 4 0) (parse "jan 3 2010 at midnight")) 87 | 88 | (assert-datetime= (make-datetime 2010 1 3 4) 89 | (parse "jan 3 2010 at 4" :ambiguous-time-range nil)) 90 | 91 | ;;time = parse_now("January 12, '00") 92 | ;;assert_equal Time.local(2000, 1, 12, 12), time 93 | 94 | (assert-datetime= (make-datetime 1979 5 27 12) (parse "may 27, 1979")) 95 | 96 | (assert-datetime= (make-datetime 1979 5 27 12) (parse "may 27 79")) 97 | 98 | (assert-datetime= (make-datetime 1979 5 27 12) (parse "may 27th, 1979")) 99 | 100 | (assert-datetime= (make-datetime 1979 5 27 16 30) (parse "may 27 79 4:30")) 101 | 102 | (assert-datetime= (make-datetime 1979 5 27 4 30) 103 | (parse "may 27 79 at 4:30" :ambiguous-time-range nil)) 104 | 105 | ;; sd_rm_sy 106 | 107 | (assert-datetime= (make-datetime 2010 1 3 12) (parse "3 jan 2010")) 108 | 109 | (assert-datetime= (make-datetime 2010 1 3 16) (parse "3 jan 2010 4pm")) 110 | 111 | (assert-datetime= (make-datetime 2006 10 27 19 30) (parse "27 Oct 2006 7:30pm")) 112 | 113 | ;; sm_sd_sy 114 | 115 | (assert-datetime= (make-datetime 1979 5 27 12) (parse "27/5/1979")) 116 | 117 | (assert-datetime= (make-datetime 1979 5 27 4) (parse "27/5/1979 4am")) 118 | 119 | ;; sd_sm_sy 120 | 121 | (assert-datetime= (make-datetime 1979 5 27 12) (parse "27/5/1979")) 122 | 123 | (assert-datetime= (make-datetime 1979 5 27 7) (parse "27/5/1979 @ 0700")) 124 | 125 | ;; sd_rm 126 | 127 | (assert-datetime= (make-datetime 2007 5 27 12) (parse "27 may")) 128 | 129 | (assert-datetime= (make-datetime 2006 5 28 12) 130 | (parse "28 may" :context :past)) 131 | 132 | (assert-datetime= (make-datetime 2006 5 28 17) 133 | (parse "28 may 5pm" :context :past)) 134 | 135 | (assert-datetime= (make-datetime 2006 5 28 17) 136 | (parse "28 may at 5pm" :context :past)) 137 | 138 | (assert-datetime= (make-datetime 2006 5 28 17 32 19) 139 | (parse "28 may at 5:32.19pm" :context :past)) 140 | 141 | ;; od_rm 142 | 143 | (assert-datetime= (make-datetime 2007 5 27 12) (parse "27th may")) 144 | 145 | (assert-datetime= (make-datetime 2006 5 27 12) 146 | (parse "27th may" :context :past)) 147 | 148 | (assert-datetime= (make-datetime 2006 5 27 17) 149 | (parse "27th may 5:00 pm" :context :past)) 150 | 151 | (assert-datetime= (make-datetime 2006 5 27 17) 152 | (parse "27th may at 5pm" :context :past)) 153 | 154 | (assert-datetime= (make-datetime 2007 5 27 5) 155 | (parse "27th may at 5" :ambiguous-time-range nil)) 156 | 157 | ;; sm_sd 158 | 159 | (assert-datetime= (make-datetime 2007 6 5 12) (parse "05/06")) 160 | 161 | (assert-datetime= (make-datetime 2007 6 12 12) (parse "12/06")) 162 | 163 | (assert-datetime= (make-datetime 2007 06 13 12) (parse "13/06")) 164 | 165 | ;; sy_sm_sd 166 | 167 | (assert-datetime= (make-datetime 2000 1 1 12) (parse "2000-1-1")) 168 | 169 | (assert-datetime= (make-datetime 2006 8 20 12) (parse "2006-08-20")) 170 | 171 | (assert-datetime= (make-datetime 2006 8 20 19) (parse "2006-08-20 7pm")) 172 | 173 | (assert-datetime= (make-datetime 2006 8 20 3) (parse "2006-08-20 03:00")) 174 | 175 | (assert-datetime= (make-datetime 2006 8 20 3 30 30) (parse "2006-08-20 03:30:30")) 176 | 177 | (assert-datetime= (make-datetime 2006 8 20 15 30 30) (parse "2006-08-20 15:30:30")) 178 | 179 | (assert-datetime= (make-datetime 2006 8 20 15 30 30) (parse "2006-08-20 15:30.30")) 180 | 181 | ;; rdn_rm_rd_rt_rtz_ry 182 | 183 | ;;; time = parse_now("Mon Apr 02 17:00:00 PDT 2007") 184 | ;;; assert_equal 1175558400, time.to_i 185 | 186 | ;;; now = Time.now 187 | ;;; time = parse_now(now.to_s) 188 | ;;; assert_equal now.to_s, time.to_s 189 | 190 | ;; rm_sd_rt 191 | 192 | ;;time = parse_now("jan 5 13:00") 193 | ;;assert_equal Time.local(2007, 1, 5, 13), time 194 | 195 | (assert-datetime= (make-datetime 2040 5 16 12) (parse "may 40")) 196 | 197 | (assert-datetime= (make-datetime 2040 5 27 12) (parse "may 27 40")) 198 | 199 | ;; Regression fixes 200 | (assert-datetime= (make-datetime 2006 8 16 23 35) 201 | (parse "today" :now (make-datetime 2006 8 16 23 10 0))))) 202 | 203 | (define-test parse-guess-r 204 | (let ((*now* (make-datetime 2006 8 16 14 0 0)) 205 | (*guess* :middle)) 206 | 207 | (assert-datetime= (make-datetime 2006 8 18 12) (parse "friday")) 208 | 209 | (assert-datetime= (make-datetime 2006 8 22 12) (parse "tue")) 210 | 211 | (assert-datetime= (make-datetime 2006 8 16 17) (parse "5")) 212 | 213 | (assert-datetime= (make-datetime 2006 8 16 5) 214 | (parse "5" :now (make-datetime 2006 8 16 3 0 0) :ambiguous-time-range nil)) 215 | 216 | (assert-datetime= (make-datetime 2006 8 17 13) (parse "13:00")) 217 | 218 | (assert-datetime= (make-datetime 2006 8 17 13 45) (parse "13:45")) 219 | 220 | (assert-datetime= (make-datetime 2006 11 16) (parse "november")) 221 | )) 222 | 223 | (define-test parse-guess-rr 224 | (let ((*now* (make-datetime 2006 8 16 14 0 0)) 225 | (*guess* :middle)) 226 | (assert-datetime= (make-datetime 2006 8 18 13) (parse "friday 13:00")) 227 | 228 | (assert-datetime= (make-datetime 2006 8 21 16) (parse "monday 4:00")) 229 | 230 | (assert-datetime= (make-datetime 2006 8 19 4) 231 | (parse "sat 4:00" :ambiguous-time-range nil)) 232 | 233 | (assert-datetime= (make-datetime 2006 8 20 4 20) 234 | (parse "sunday 4:20" :ambiguous-time-range nil)) 235 | 236 | (assert-datetime= (make-datetime 2006 8 16 16) (parse "4 pm")) 237 | 238 | (assert-datetime= (make-datetime 2006 8 16 4) 239 | (parse "4 am" :ambiguous-time-range nil)) 240 | 241 | (assert-datetime= (make-datetime 2006 8 16 12) (parse "12 pm")) 242 | 243 | (assert-datetime= (make-datetime 2006 8 16 12 1) (parse "12:01 pm")) 244 | 245 | (assert-datetime= (make-datetime 2006 8 16 0 1) (parse "12:01 am")) 246 | 247 | (assert-datetime= (make-datetime 2006 8 16) (parse "12 am")) 248 | 249 | (assert-datetime= (make-datetime 2006 8 16 4) (parse "4:00 in the morning")) 250 | 251 | (assert-datetime= (make-datetime 2006 11 4 12) (parse "november 4")) 252 | 253 | (assert-datetime= (make-datetime 2006 8 24 12) (parse "aug 24")) 254 | )) 255 | 256 | (define-test parse-guess-rrr 257 | (let ((*now* (make-datetime 2006 8 16 14 0 0))) 258 | (assert-datetime= (make-datetime 2006 8 18 13) (parse "friday 1 pm")) 259 | 260 | (assert-datetime= (make-datetime 2006 8 18 23) (parse "friday 11 at night")) 261 | 262 | (assert-datetime= (make-datetime 2006 8 18 23) (parse "friday 11 in the evening")) 263 | 264 | (assert-datetime= (make-datetime 2006 8 20 6) (parse "sunday 6am")) 265 | 266 | (assert-datetime= (make-datetime 2006 8 18 19) (parse "friday evening at 7")) 267 | )) 268 | 269 | (define-test parse-guess-gr 270 | (let ((*now* (make-datetime 2006 8 16 14 0 0)) 271 | (*guess* :middle)) 272 | ;; year 273 | 274 | (assert-datetime= (make-datetime 2006 10 24 7) (parse "this year")) 275 | 276 | (assert-datetime= (make-datetime 2006 4 24 19) 277 | (parse "this year" :context :past)) 278 | 279 | ;; month 280 | 281 | (assert-datetime= (make-datetime 2006 8 24 7) (parse "this month")) 282 | 283 | (assert-datetime= (make-datetime 2006 8 8 19) 284 | (parse "this month" :context :past)) 285 | 286 | (assert-datetime= (make-datetime 2006 12 16 12) 287 | (parse "next month" :now (make-datetime 2006 11 15))) 288 | 289 | ;; month name 290 | 291 | (assert-datetime= (make-datetime 2005 11 16) (parse "last november")) 292 | 293 | ;; fortnight 294 | 295 | (assert-datetime= (make-datetime 2006 8 21 19) (parse "this fortnight")) 296 | 297 | (assert-datetime= (make-datetime 2006 8 14 19) 298 | (parse "this fortnight" :context :past)) 299 | 300 | ;; week 301 | 302 | (assert-datetime= (make-datetime 2006 8 18 7) (parse "this week")) 303 | 304 | (assert-datetime= (make-datetime 2006 8 14 19) 305 | (parse "this week" :context :past)) 306 | 307 | ;; weekend 308 | 309 | (assert-datetime= (make-datetime 2006 8 20) (parse "this weekend")) 310 | 311 | (assert-datetime= (make-datetime 2006 8 13) 312 | (parse "this weekend" :context :past)) 313 | 314 | (assert-datetime= (make-datetime 2006 8 13) (parse "last weekend")) 315 | 316 | ;; day 317 | 318 | (assert-datetime= (make-datetime 2006 8 16 19) (parse "this day")) 319 | 320 | (assert-datetime= (make-datetime 2006 8 16 7) 321 | (parse "this day" :context :past)) 322 | 323 | (assert-datetime= (make-datetime 2006 8 16 19) (parse "today")) 324 | 325 | (assert-datetime= (make-datetime 2006 8 15 12) (parse "yesterday")) 326 | 327 | (assert-datetime= (make-datetime 2006 8 17 12) (parse "tomorrow")) 328 | 329 | ;; day name 330 | 331 | (assert-datetime= (make-datetime 2006 8 22 12) (parse "this tuesday")) 332 | 333 | (assert-datetime= (make-datetime 2006 8 22 12) (parse "next tuesday")) 334 | 335 | (assert-datetime= (make-datetime 2006 8 15 12) (parse "last tuesday")) 336 | 337 | (assert-datetime= (make-datetime 2006 8 23 12) (parse "this wed")) 338 | 339 | (assert-datetime= (make-datetime 2006 8 23 12) (parse "next wed")) 340 | 341 | (assert-datetime= (make-datetime 2006 8 9 12) (parse "last wed")) 342 | 343 | ;; day portion 344 | 345 | (assert-datetime= (make-datetime 2006 8 16 9) (parse "this morning")) 346 | 347 | (assert-datetime= (make-datetime 2006 8 16 22) (parse "tonight")) 348 | 349 | ;; minute 350 | 351 | (assert-datetime= (make-datetime 2006 8 16 14 1 30) (parse "next minute")) 352 | 353 | ;; second 354 | 355 | (assert-datetime= (make-datetime 2006 8 16 14) (parse "this second")) 356 | 357 | (assert-datetime= (make-datetime 2006 8 16 14) 358 | (parse "this second" :context :past)) 359 | 360 | (assert-datetime= (make-datetime 2006 8 16 14 0 1) (parse "next second")) 361 | 362 | (assert-datetime= (make-datetime 2006 8 16 13 59 59) (parse "last second")) 363 | )) 364 | 365 | (define-test parse-guess-grr 366 | (let ((*now* (make-datetime 2006 8 16 14 0 0)) 367 | (*guess* :middle)) 368 | 369 | (assert-datetime= (make-datetime 2006 8 15 16) (parse "yesterday at 4:00")) 370 | 371 | (assert-datetime= (make-datetime 2006 8 16 9) (parse "today at 9:00")) 372 | 373 | (assert-datetime= (make-datetime 2006 8 16 21) (parse "today at 2100")) 374 | 375 | (assert-datetime= (make-datetime 2006 8 16 9) (parse "this day at 0900")) 376 | 377 | (assert-datetime= (make-datetime 2006 8 17 9) (parse "tomorrow at 0900")) 378 | 379 | (assert-datetime= (make-datetime 2006 8 15 4) 380 | (parse "yesterday at 4:00" :ambiguous-time-range nil)) 381 | 382 | (assert-datetime= (make-datetime 2006 8 11 16) (parse "last friday at 4:00")) 383 | 384 | (assert-datetime= (make-datetime 2006 8 23 16) (parse "next wed 4:00")) 385 | 386 | (assert-datetime= (make-datetime 2006 8 15 15) (parse "yesterday afternoon")) 387 | 388 | (assert-datetime= (make-datetime 2006 8 8 12) (parse "last week tuesday")) 389 | 390 | (assert-datetime= (make-datetime 2006 8 16 19) (parse "tonight at 7")) 391 | 392 | (assert-datetime= (make-datetime 2006 8 16 19) (parse "tonight 7")) 393 | 394 | (assert-datetime= (make-datetime 2006 8 16 19) (parse "7 tonight")) 395 | )) 396 | 397 | (define-test parse-guess-grrr 398 | (let ((*now* (make-datetime 2006 8 16 14 0 0))) 399 | (assert-datetime= (make-datetime 2006 8 16 18) (parse "today at 6:00pm")) 400 | 401 | (assert-datetime= (make-datetime 2006 8 16 6) (parse "today at 6:00am")) 402 | 403 | (assert-datetime= (make-datetime 2006 8 16 18) (parse "this day 1800")) 404 | 405 | (assert-datetime= (make-datetime 2006 8 15 16) (parse "yesterday at 4:00pm")) 406 | 407 | (assert-datetime= (make-datetime 2006 8 17 19) (parse "tomorrow evening at 7")) 408 | 409 | (assert-datetime= (make-datetime 2006 8 17 5 30) (parse "tomorrow morning at 5:30")) 410 | 411 | (assert-datetime= (make-datetime 2006 8 21 00 1) (parse "next monday at 12:01 am")) 412 | 413 | (assert-datetime= (make-datetime 2006 8 21 12 1) (parse "next monday at 12:01 pm")) 414 | )) 415 | 416 | (define-test parse-guess-rgr 417 | (let ((*now* (make-datetime 2006 8 16 14 0 0)) 418 | (*guess* :middle)) 419 | (assert-datetime= (make-datetime 2006 8 15 15) (parse "afternoon yesterday")) 420 | 421 | (assert-datetime= (make-datetime 2006 8 15 14) (parse "2 PM yesterday")) 422 | 423 | (assert-datetime= (make-datetime 2006 8 15 14 30) (parse "2:30 yesterday")) 424 | 425 | (assert-datetime= (make-datetime 2006 8 8 12) (parse "tuesday last week")))) 426 | 427 | (define-test parse-guess-s-r-p 428 | (let ((*now* (make-datetime 2006 8 16 14 0 0)) 429 | (*guess* t)) 430 | ;; past 431 | 432 | (assert-datetime= (make-datetime 2006 8 15 14) (parse "a day ago")) 433 | 434 | (assert-datetime= (make-datetime 2003 8 16 14) (parse "3 years ago")) 435 | 436 | (assert-datetime= (make-datetime 2006 7 16 14) (parse "1 month ago")) 437 | 438 | (assert-datetime= (make-datetime 2006 8 2 14) (parse "1 fortnight ago")) 439 | 440 | (assert-datetime= (make-datetime 2006 7 19 14) (parse "2 fortnights ago")) 441 | 442 | (assert-datetime= (make-datetime 2006 7 26 14) (parse "3 weeks ago")) 443 | 444 | (assert-datetime= (make-datetime 2006 8 5) (parse "2 weekends ago")) 445 | 446 | (assert-datetime= (make-datetime 2006 8 13 14) (parse "3 days ago")) 447 | 448 | ;;time = parse_now("1 monday ago") 449 | ;;assert_equal Time.local(2006, 8, 14, 12), time 450 | 451 | (assert-datetime= (make-datetime 2006 8 12 6) (parse "5 mornings ago")) 452 | 453 | (assert-datetime= (make-datetime 2006 8 16 7) (parse "7 hours ago")) 454 | 455 | (assert-datetime= (make-datetime 2006 8 16 13 57) (parse "3 minutes ago")) 456 | 457 | (assert-datetime= (make-datetime 2006 8 16 13 59 40) (parse "20 seconds before now")) 458 | 459 | ;; future 460 | 461 | (assert-datetime= (make-datetime 2009 8 16 14 0 0) (parse "3 years from now")) 462 | 463 | (assert-datetime= (make-datetime 2007 2 16 14) (parse "6 months hence")) 464 | 465 | (assert-datetime= (make-datetime 2006 9 27 14) (parse "3 fortnights hence")) 466 | 467 | (assert-datetime= (make-datetime 2006 8 23 14 0 0) (parse "1 week from now")) 468 | 469 | (assert-datetime= (make-datetime 2006 8 19) (parse "1 weekend from now")) 470 | 471 | (assert-datetime= (make-datetime 2006 8 26) (parse "2 weekends from now")) 472 | 473 | (assert-datetime= (make-datetime 2006 8 17 14) (parse "1 day hence")) 474 | 475 | (assert-datetime= (make-datetime 2006 8 21 6) (parse "5 mornings hence")) 476 | 477 | (assert-datetime= (make-datetime 2006 8 16 15) (parse "1 hour from now")) 478 | 479 | (assert-datetime= (make-datetime 2006 8 16 14 20) (parse "20 minutes hence")) 480 | 481 | (assert-datetime= (make-datetime 2006 8 16 14 0 20) (parse "20 seconds from now")) 482 | 483 | (assert-datetime= (make-datetime 2007 1 7 23 30) 484 | (parse "2 months ago" :now (make-datetime 2007 3 7 23 30))) 485 | )) 486 | 487 | (define-test parse-guess-p-s-r 488 | (let ((*now* (make-datetime 2006 8 16 14 0 0))) 489 | (assert-datetime= (make-datetime 2006 8 16 17) (parse "in 3 hours")) 490 | )) 491 | 492 | (define-test parse-guess-s-r-p-a 493 | (let ((*now* (make-datetime 2006 8 16 14 0 0)) 494 | (*guess* t)) 495 | ;; past 496 | 497 | (assert-datetime= (make-datetime 2003 8 17 0) (parse "3 years ago tomorrow")) 498 | 499 | (assert-datetime= (make-datetime 2003 8 18 0) (parse "3 years ago this friday")) 500 | 501 | (assert-datetime= (make-datetime 2006 5 19 17) (parse "3 months ago saturday at 5:00 pm")) 502 | 503 | (assert-datetime= (make-datetime 2006 8 18 14) (parse "2 days from this second")) 504 | 505 | (assert-datetime= (make-datetime 2006 8 17 17) (parse "7 hours before tomorrow at midnight")) 506 | 507 | (assert-datetime= (make-datetime 2006 8 14 0) (parse "day before yesterday")) 508 | 509 | (assert-datetime= (make-datetime 2006 8 18 0) (parse "day after tomorrow")) 510 | 511 | ;; future 512 | )) 513 | 514 | (define-test parse-guess-o-r-s-r 515 | (let ((*now* (make-datetime 2006 8 16 14 0 0)) 516 | (*guess* :middle)) 517 | (assert-datetime= (make-datetime 2006 11 15 12) (parse "3rd wednesday in november")) 518 | 519 | (assert-equal nil (parse "10th wednesday in november")) 520 | 521 | (assert-datetime= (make-datetime 2007 1 17 12) (parse "3rd wednesday in 2007")))) 522 | 523 | (define-test parse-guess-o-r-g-r 524 | (let ((*now* (make-datetime 2006 8 16 14 0 0)) 525 | (*guess* :middle)) 526 | (assert-datetime= (make-datetime 2007 3 16 12) (parse "3rd month next year")) 527 | 528 | (assert-datetime= (make-datetime 2006 9 21 12) (parse "3rd thursday this september")) 529 | 530 | (assert-datetime= (make-datetime 2006 8 9 12) (parse "4th day last week")))) 531 | 532 | (define-test parse-guess-nonsense 533 | (let ((*now* (make-datetime 2006 8 16 14 0 0))) 534 | (assert-equal nil (parse "some stupid nonsense")) 535 | 536 | (assert-equal nil (parse "Ham Sandwich")))) 537 | 538 | (define-test parse-span 539 | (let ((*now* (make-datetime 2006 8 16 14 0 0)) 540 | (*guess* nil)) 541 | 542 | (let ((span (parse "friday"))) 543 | (assert-datetime= (make-date 2006 8 18) (span-start span)) 544 | (assert-datetime= (make-date 2006 8 19) (span-end span))) 545 | 546 | (let ((span (parse "november"))) 547 | (assert-datetime= (make-date 2006 11) (span-start span)) 548 | (assert-datetime= (make-date 2006 12) (span-end span))) 549 | 550 | (let ((span (parse "weekend"))) 551 | (assert-datetime= (make-date 2006 8 19) (span-start span)) 552 | (assert-datetime= (make-date 2006 8 21) (span-end span))))) 553 | 554 | (define-test parse-with-endian-precedence 555 | (let ((*guess* :start) 556 | (date-string "11/2/2007") 557 | (expect-little-endian (make-datetime 2007 2 11)) 558 | (expect-middle-endian (make-datetime 2007 11 2))) 559 | ;; Default: little endian 560 | (assert-datetime= expect-little-endian (parse date-string)) 561 | 562 | (assert-datetime= expect-little-endian (parse date-string :endian-preference :little)) 563 | 564 | (assert-datetime= expect-middle-endian (parse date-string :endian-preference :middle)))) 565 | 566 | (define-test parse-words 567 | (let ((*guess* :start) 568 | (*now* (make-datetime 2006 8 16 14 0 0))) 569 | (assert-datetime= (parse "33 days from now") (parse "thirty-three days from now")) 570 | (assert-datetime= (parse "2867532 seconds from now") (parse "two million eight hundred and sixty seven thousand five hundred and thirty two seconds from now")) 571 | (assert-datetime= (parse "may 10th") (parse "may tenth")) 572 | (assert-datetime= (make-datetime 2006 8 1) (parse "first day in august")) 573 | (assert-datetime= (make-datetime 2006 8 2) (parse "second day in august")) 574 | (assert-datetime= (make-datetime 2006 8 3) (parse "third day in august")))) 575 | 576 | ;; (define-test parse-only-complete-pointers 577 | ;; (let ((*now* (make-datetime 2006 8 16 14 0 0))) 578 | ;; assert_equal parse_now("eat pasty buns today at 2pm"), @time_2006_08_16_14_00_00 579 | ;; assert_equal parse_now("futuristically speaking today at 2pm"), @time_2006_08_16_14_00_00 580 | ;; assert_equal parse_now("meeting today at 2pm"), @time_2006_08_16_14_00_00 581 | ;; )) 582 | 583 | (define-test am-pm 584 | (let ((*now* (make-datetime 2006 8 16 14 0 0))) 585 | (assert-datetime= (make-date 2006 8 16) (parse "8/16/2006 at 12am")) 586 | (assert-datetime= (make-datetime 2006 8 16 12) (parse "8/16/2006 at 12pm")))) 587 | 588 | ;; (define-test a-p 589 | ;; (let ((*now* (make-datetime 2006 8 16 14 0 0))) 590 | ;; assert_equal Time.local(2006, 8, 16, 0, 15), parse_now("8/16/2006 at 12:15a") 591 | ;; assert_equal Time.local(2006, 8, 16, 18, 30), parse_now("8/16/2006 at 6:30p") 592 | ;; )) 593 | 594 | ;;; def test_argument_validation 595 | ;;; assert_raise(Chronic::InvalidArgumentException) do 596 | ;;; time = Chronic.parse("may 27", :foo => :bar) 597 | ;;; end 598 | 599 | ;;; assert_raise(Chronic::InvalidArgumentException) do 600 | ;;; time = Chronic.parse("may 27", :context => :bar) 601 | ;;; end 602 | ;;; end 603 | 604 | ;;; def test_seasons 605 | ;;; t = parse_now("this spring", :guess => false) 606 | ;;; assert_equal Time.local(2007, 3, 20), t.begin 607 | ;;; assert_equal Time.local(2007, 6, 20), t.end 608 | 609 | ;;; t = parse_now("this winter", :guess => false) 610 | ;;; assert_equal Time.local(2006, 12, 22, 23), t.begin 611 | ;;; assert_equal Time.local(2007, 3, 19), t.end 612 | 613 | ;;; t = parse_now("last spring", :guess => false) 614 | ;;; assert_equal Time.local(2006, 3, 20, 23), t.begin 615 | ;;; assert_equal Time.local(2006, 6, 20), t.end 616 | 617 | ;;; t = parse_now("last winter", :guess => false) 618 | ;;; assert_equal Time.local(2005, 12, 22, 23), t.begin 619 | ;;; assert_equal Time.local(2006, 3, 19, 23), t.end 620 | 621 | ;;; t = parse_now("next spring", :guess => false) 622 | ;;; assert_equal Time.local(2007, 3, 20), t.begin 623 | ;;; assert_equal Time.local(2007, 6, 20), t.end 624 | ;;; end 625 | 626 | ;; regression 627 | 628 | ;; def test_partial 629 | ;; assert_equal '', parse_now("2 hours") 630 | ;; end 631 | 632 | ;;; def test_days_in_november 633 | ;;; t1 = Chronic.parse('1st thursday in november', :now => Time.local(2007)) 634 | ;;; assert_equal Time.local(2007, 11, 1, 12), t1 635 | 636 | ;;; t1 = Chronic.parse('1st friday in november', :now => Time.local(2007)) 637 | ;;; assert_equal Time.local(2007, 11, 2, 12), t1 638 | 639 | ;;; t1 = Chronic.parse('1st saturday in november', :now => Time.local(2007)) 640 | ;;; assert_equal Time.local(2007, 11, 3, 12), t1 641 | 642 | ;;; t1 = Chronic.parse('1st sunday in november', :now => Time.local(2007)) 643 | ;;; assert_equal Time.local(2007, 11, 4, 11), t1 644 | 645 | ;;; ;; Chronic.debug = true 646 | ;;; ;; 647 | ;;; ;; t1 = Chronic.parse('1st monday in november', :now => Time.local(2007)) 648 | ;;; ;; assert_equal Time.local(2007, 11, 5, 11), t1 649 | ;;; end 650 | --------------------------------------------------------------------------------