racket-webview/private/utils.rkt

#lang racket/base

(require racket/string
         racket/port
         racket/contract
         json
         (prefix-in g: gregor)
         (prefix-in g: gregor/time)
         gregor-utils
         racket-sprintf
         )

(provide while
       until
       get-lib-path
       do-for
       esc-quote
       esc-double-quote
       fromJson
       mk-js-array
       js-code
       kv-1
       kv-2
       make-kv
       kv?
       list-of-kv?
       list-of-symbol?
       list-of?
       string->time
       time->string
       string->date
       date->string
       string->datetime
       datetime->string
       )

(define-syntax while
(syntax-rules ()
  ((_ cond body ...)
   (letrec ((while-f (lambda (last-result)
                       (if cond
                           (let ((last-result (begin
                                                body
                                                ...)))
                             (while-f last-result))
                           last-result))))
     (while-f #f))
   )
  ))

(define-syntax until
(syntax-rules ()
  ((_ cond body ...)
   (letrec ((until-f (lambda (last-result)
                       (if cond
                           last-result
                           (let ((last-reult (begin
                                               body
                                               ...)))
                             (until-f last-result))))))
     (until-f #f)))))

(define-syntax do-for
(syntax-rules ()
  ((_ (init cond next) body ...)
   (begin
     init
     (letrec ((do-for-f (lamba ()
                               (if cond
                                   (begin
                                     (begin
                                       body
                                       ...)
                                     next
                                     (do-for-f))))))
       (do-for-f))))))

(define (get-lib-path lib)
(let ((platform (system-type)))
  (cond
    [(eq? platform 'windows) 
     (let ((try1 (build-path (current-directory) ".." "lib" "dll" lib))
           (try2 (build-path (current-directory) "lib" "dll" lib)))
       (if (file-exists? try1)
           try1
           try2)
       )]
    [else
     (error (format "Install the shared library: ~a" lib))]
    )))

(define (esc-quote str)
  (string-replace str "'" "\\'"))

(define (esc-double-quote str)
  (string-replace str "\"" "\\\""))
               
(define (fromJson str)
  (with-input-from-string str read-json))

(define (mk-js-array l)
  (if (list-of-kv? l)
      (string-append "[ " (string-join (map (λ (e) (mk-js-array e)) l) ", ") " ]")
      (if (list? l)
          (string-append "[ " (string-join (map (λ (e) (format "'~a'"
                                                               (esc-quote (format "~a" e)))) l) ", ") " ]")
          (if (pair? l)
              (format "[ '~a', '~a' ]" (car l) (cdr l))
              (format "[ '~a' ]" (esc-quote (format "~a" l)))))))

(define (js-code . a)
  (define (code* l)
    (if (null? l)
        ""
        (string-append (car l) "\n" (code* (cdr l)))
        )
    )
  (code* a))

(define (kv? e)
  (or 
   (and (list? e) (= (length e) 2) (symbol? (car e)))
   (and (pair? e) (symbol? (car e)))))

(define/contract (kv-1 e)
  (-> kv? symbol?)
  (car e))

(define/contract (kv-2 e)
  (-> kv? any/c)
  (if (list? e)
      (cadr e)
      (cdr e)))

(define/contract (make-kv k v)
  (-> symbol? any/c kv?)
  (if (list? v)
      (list k v)
      (cons k v)))

(define (list-of? pred? l)
  (define (all-pred? l)
    (if (null? l)
        #t
        (if (pred? (car l))
            (all-pred? (cdr l))
            #f)))
  (if (list? l)
      (all-pred? l)
      #f))

(define (list-of-kv? l)
  (list-of? kv? l))

(define (list-of-symbol? l)
  (list-of? symbol? l))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Date / Time conversion
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (string->time s)
  (with-handlers ([exn:fail?
                   (λ (e) (g:parse-time s "HH:mm"))])
    (g:parse-time s "HH:mm:ss")))

(define (time->string t)
  (unless (or (g:time? t) (g:datetime? t) (g:moment? t))
    (error "set! - gregor time?, moment? or datetime? expected"))
  (sprintf "%02d:%02d:%02d" (g:->hours t) (g:->minutes t) (g:->seconds t)))

(define (string->datetime s)
  (with-handlers ([exn:fail?
                   (λ (e) (g:parse-moment s "yyyy-MM-dd'T'HH:mm:ss"))])
    (g:parse-moment s "yyyy-MM-dd'T'HH:mm")))

(define (datetime->string dt)
  (when (racket-date? dt)
    (datetime->string date->moment dt))
  (unless (or (g:datetime? dt) (g:moment? dt) (g:date? dt) (g:time? dt))
    (error "set! - gregor time? , date?, datetime? or moment? expected"))
  (sprintf "%04d:%02d:%02dT%02d:%02d:%02d"
           (g:->year dt) (g:->month dt) (g:->day dt)
           (g:->hours dt) (g:->minutes dt) (g:->seconds dt))
  )

(define (string->date d)
  (g:parse-date d "yyyy-MM-dd"))

(define (date->string d)
  (when (racket-date? d)
    (date->string (date->moment d)))
  (unless (or (g:date? d) (g:moment? d) (g:datetime? d))
    (error "set! - gregor date expected"))
  (sprintf "%04d-%02d-%02d" (g:->year d) (g:->month d) (g:->day d)))