From 2cd09108c9b316c9c8aa1c1b87b85a1c32cef089 Mon Sep 17 00:00:00 2001
From: Nikita Karetnikov <nikita@karetnikov.org>
Date: Thu, 19 Sep 2013 11:07:39 +0000
Subject: guix package: Add '--list-generations'.

* guix/scripts/package.scm: Import (srfi srfi-19).
  (generation-time, matching-generations): New functions.
  (show-help): Add '--list-generations'.
  (%options): Likewise.
  (guix-package)[process-query]: Add support for '--list-generations'.
* guix/ui.scm: Import (srfi srfi-19) and (ice-9 regex).
  (string->generations, string->duration): New functions.
* tests/guix-package.sh: Test '--list-generations'.
* tests/ui.scm: Import (srfi srfi-19).
  Test 'string->generations' and 'string->duration'.
* doc/guix.texi (Invoking guix-package): Document '--list-generations'.
---
 guix/ui.scm | 68 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 68 insertions(+)

(limited to 'guix/ui.scm')

diff --git a/guix/ui.scm b/guix/ui.scm
index 293730308e..4415997252 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -28,12 +28,14 @@ (define-module (guix ui)
   #:use-module ((guix licenses) #:select (license? license-name))
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-37)
   #:autoload   (ice-9 ftw)  (scandir)
   #:use-module (ice-9 match)
   #:use-module (ice-9 format)
+  #:use-module (ice-9 regex)
   #:export (_
             N_
             leave
@@ -50,6 +52,8 @@ (define-module (guix ui)
             fill-paragraph
             string->recutils
             package->recutils
+            string->generations
+            string->duration
             args-fold*
             run-guix-command
             program-name
@@ -404,6 +408,70 @@ (define (description->recutils str)
           (and=> (package-description p) description->recutils))
   (newline port))
 
+(define (string->generations str)
+  "Return the list of generations matching a pattern in STR.  This function
+accepts the following patterns: \"1\", \"1,2,3\", \"1..9\", \"1..\", \"..9\"."
+  (define (maybe-integer)
+    (let ((x (string->number str)))
+      (and (integer? x)
+           x)))
+
+  (define (maybe-comma-separated-integers)
+    (let ((lst (delete-duplicates
+                (map string->number
+                     (string-split str #\,)))))
+      (and (every integer? lst)
+           lst)))
+
+  (cond ((maybe-integer)
+         =>
+         list)
+        ((maybe-comma-separated-integers)
+         =>
+         identity)
+        ((string-match "^([0-9]+)\\.\\.([0-9]+)$" str)
+         =>
+         (lambda (match)
+           (let ((s (string->number (match:substring match 1)))
+                 (e (string->number (match:substring match 2))))
+             (and (every integer? (list s e))
+                  (<= s e)
+                  (iota (1+ (- e s)) s)))))
+        ((string-match "^([0-9]+)\\.\\.$" str)
+         =>
+         (lambda (match)
+           (let ((s (string->number (match:substring match 1))))
+             (and (integer? s)
+                  `(>= ,s)))))
+        ((string-match "^\\.\\.([0-9]+)$" str)
+         =>
+         (lambda (match)
+           (let ((e (string->number (match:substring match 1))))
+             (and (integer? e)
+                  `(<= ,e)))))
+        (else #f)))
+
+(define (string->duration str)
+  "Return the duration matching a pattern in STR.  This function accepts the
+following patterns: \"1d\", \"1w\", \"1m\"."
+  (define (hours->duration hours match)
+    (make-time time-duration 0
+               (* 3600 hours (string->number (match:substring match 1)))))
+
+  (cond ((string-match "^([0-9]+)d$" str)
+         =>
+         (lambda (match)
+           (hours->duration 24 match)))
+        ((string-match "^([0-9]+)w$" str)
+         =>
+         (lambda (match)
+           (hours->duration (* 24 7) match)))
+        ((string-match "^([0-9]+)m$" str)
+         =>
+         (lambda (match)
+           (hours->duration (* 24 30) match)))
+        (else #f)))
+
 (define (args-fold* options unrecognized-option-proc operand-proc . seeds)
   "A wrapper on top of `args-fold' that does proper user-facing error
 reporting."
-- 
cgit v1.2.3