dds/utils.rkt

#lang typed/racket

(require (for-syntax syntax/parse racket/list))

(provide Variable VariableMapping GeneralPair
         eval-with eval1-with
         extract-symbols
         any->string stringify-variable-mapping string->any map-sexp
         read-org-sexp unorg unstringify-pairs compose-n compose-3 compose-4
         multi-compose read-org-variable-mapping unorgv
         ;; Syntax
         auto-hash-ref/explicit auto-hash-ref/:)

(module+ test
  (require typed/rackunit))

;;; ===================
;;; HashTable injection
;;; ===================

(define-type Variable Symbol)
(define-type (VariableMapping A) (Immutable-HashTable Variable A))

(: eval-with (-> (VariableMapping Any) Any AnyValues))
(define (eval-with ht expr)
  (parameterize ([current-namespace (make-base-namespace)])
    (for ([(x val) (in-hash ht)]) (namespace-set-variable-value! x val))
    (eval expr)))

(: eval1-with (-> (VariableMapping Any) Any Any))
(define (eval1-with ht expr)
  (call-with-values (λ () (eval-with ht expr))
                    (λ args (car args))))

(module+ test
  (test-case "eval-with"
    (check-equal? (eval1-with (hash 'a 1 'b 2) '(+ a b 1))
                  4)
    (define ht : (VariableMapping Integer) (hash 'a 1 'b 2))
    (define expr : Any '(+ a b 1))
    (check-equal? (eval1-with ht expr)
                  4)))

(define-syntax (auto-hash-ref/explicit stx)
  (syntax-parse stx
    [(_ (ht:id xs:id ...) body:expr)
     #`(let #,(for/list ([x (syntax->list #'(xs ...))])
                #`[#,x (hash-ref ht '#,x)])
         body)]))

(module+ test
  (test-case "auto-hash-ref/explicit"
    (define mytable #hash((a . 3) (b . 4)))
    (check-equal? (auto-hash-ref/explicit (mytable b a)
                                          (* a b))
                  12)
    (define ht #hash((a . #t) (b . #f)))
    (check-equal? (auto-hash-ref/explicit (ht a b)
                                          (and (not a) b))
                  #f)))

(define-syntax (auto-hash-ref/: stx)
  (syntax-parse stx
    [(_ ht:id body)
     (let* ([names/: (collect-colons (syntax->datum #'body))])
       #`(let #,(for/list ([x names/:])
                  ;; put x in the same context as body
                  #`[#,(datum->syntax #'body x)
                     (hash-ref ht '#,(strip-colon x))])
           body))]))

;;; The helper functions for auto-hash-ref/:.
(begin-for-syntax
  ;; Collect all the symbols starting with a colon in datum.
  (define (collect-colons datum)
    (remove-duplicates
     (flatten
      (for/list ([token datum])
        (cond
          [(symbol? token)
           (let ([name (symbol->string token)])
             (if (eq? #\: (string-ref name 0))
                 token
                 '()))]
          [(list? token)
           (collect-colons token)]
          [else '()])))))

  ;; Strip the leading colon off x.
  (define (strip-colon x)
    (let ([x-str (symbol->string x)])
      (if (eq? #\: (string-ref x-str 0))
          (string->symbol (substring x-str 1))
          x))))

(module+ test
  (test-case "auto-hash-ref/:"
    (define ht1 #hash((x . #t) (y . #t) (t . #f)))
    (define z #t)
    (check-equal? (auto-hash-ref/: ht1
                                   (and :x (not :y) z (or (and :t) :x)))
                  #f)
    (define ht2 #hash((a . 1) (b . 2)))
    (check-equal? (auto-hash-ref/: ht2 (+ :a (* 2 :b)))
                  5)))

;;; ==============================
;;; Analysis of quoted expressions
;;; ==============================

;;; Produces a list of symbols appearing in the quoted expression
;;; passed in the first argument.
(: extract-symbols (-> Any (Listof Symbol)))
(define (extract-symbols form)
  (: extract-rec (-> Any (Listof Any)))
  (define (extract-rec form)
    (match form
      [(? symbol?) (list form)]
      [(? list?)
       (flatten (for/list : (Listof Any)
                    ([x form])
                  (extract-symbols x)))]
      [else '()]))
  (cast (extract-rec form) (Listof Symbol)))

(module+ test
  (test-case "extract-symbols"
    (check-equal? (extract-symbols '(1 (2 3) x (y z 3)))
                  '(x y z))))


;;; =========================
;;; Composing typed functions
;;; =========================

(: compose-n (All (a) (-> (-> a a) * (-> a a))))
(define (compose-n . funcs)
  (λ (x)
    (for/foldr ([x x]) ([f funcs])
      (f x))))

(: compose-3 (All (a b c d) (-> (-> c d) (-> b c) (-> a b) (-> a d))))
(define (compose-3 f1 f2 f3)
  (λ (x) (f1 (f2 (f3 x)))))
(: compose-4 (All (a b c d e) (-> (-> d e) (-> c d) (-> b c) (-> a b) (-> a e))))
(define (compose-4 f1 f2 f3 f4)
  (λ (x) (f1 (f2 (f3 (f4 x))))))

(define-syntax (multi-compose stx)
  ;; Implementation by Sorawee Porncharoenwase.
  (syntax-parse stx
    [(_ f:expr g:expr)
     #'(compose f g)]
    [(_ f:expr funcs:expr ...)
     #'(compose f (multi-compose funcs ...))]))

(module+ test
  (check-equal? ((multi-compose add1
                                (λ ([x : Number]) (* x 3))
                                add1
                                (λ ([x : Number]) (+ x 2)))
                 3)
                19))


;;; =========================
;;; Org-mode interoperability
;;; =========================

(: any->string (-> Any String))
(define (any->string x)
  (with-output-to-string (λ () (display x))))

(module+ test
  (test-case "any->string"
   (check-equal? (any->string 'a) "a")
   (check-equal? (any->string '(a 1 (x y))) "(a 1 (x y))")
   (check-equal? (any->string "hello") "hello")))

(: stringify-variable-mapping (-> (VariableMapping Any) (VariableMapping String)))
(define (stringify-variable-mapping ht)
  (for/hash : (VariableMapping String)
      ([(key val) (in-hash ht)]) (values key (any->string val))))

(module+ test
  (test-case "stringify-variable-mapping"
    (define mp (stringify-variable-mapping #hash((a . (and a b)) (b . (not b)))))
    (check-equal? (hash-ref mp 'a) "(and a b)")
    (check-equal? (hash-ref mp 'b) "(not b)")))

(: string->any (-> String Any))
(define (string->any str)
  (with-input-from-string str (λ () (read))))

(module+ test
  (test-case "string->any"
    (check-equal? (string->any "(or b (not a))") '(or b (not a)))
    (check-equal? (string->any "14") 14)))

;;; Given a sexp, converts all "#f" to #f and "#t" to #t.
;;;
;;; When I read Org-mode tables, I pump them through a call to the
;;; prin1 because the elisp sexp seems incompatible with Racket.  On
;;; the other hand, Racket Booleans seem to upset elisp a little, so
;;; prin1 wraps them in additional double quotes.  This function
;;; removes those quotes.
(: handle-org-booleans (-> Any Any))
(define/match (handle-org-booleans datum)
  [("#t") #t]
  [("#f") #f]
  [((? list?)) (map handle-org-booleans datum)]
  [ (_) datum])

(: map-sexp (-> (-> Any Any) Any Any))
(define (map-sexp func sexp)
  (match sexp
    [(? list?) (map ((curry map-sexp) func) sexp)]
    [datum (func datum)]))

(module+ test
  (test-case "map-sexp"
    (check-equal? (map-sexp (λ (x) (add1 (cast x Number))) '(1 2 (4 10) 3))
                  '(2 3 (5 11) 4))))

(: read-org-sexp (-> String Any))
(define read-org-sexp
  (compose ((curry map-sexp) (match-lambda
                               [(and (? string?) str) (string->any str)]
                               [x x]))
           string->any))
(define unorg read-org-sexp)

(module+ test
  (test-case "read-org-sexp"
    (check-equal? (read-org-sexp "((\"a\" \"(and a b)\") (\"b\" \"(or b (not a))\"))")
                  '((a (and a b)) (b (or b (not a)))))
    (check-equal? (unorg "(#t \"#t\" \"#t \" '(1 2 \"#f\"))")
                  '(#t #t #t '(1 2 #f)))))

(define-type (GeneralPair A B) (U (Pair A B) (List A B)))

(: unstringify-pairs (-> (Listof (GeneralPair String Any))
                         (Listof (GeneralPair Symbol Any))))
(define (unstringify-pairs pairs)
  (for/list ([p pairs])
    (match p
      [(list key val)
       (cons (string->symbol key) (if (string? val)
                                      (string->any val)
                                      val))]
      [(cons key val)
       (cons (string->symbol key) (if (string? val)
                                      (string->any val)
                                      val))])))

(module+ test
  (test-case "unstringify-pairs"
    (check-equal? (unstringify-pairs '(("a" . "1") ("b" . "(and a (not b))")))
                  '((a . 1) (b . (and a (not b)))))
    (check-equal? (unstringify-pairs '(("a" . 1) ("b" . "(and a (not b))")))
                  '((a . 1) (b . (and a (not b)))))))

(: read-org-variable-mapping (-> String (VariableMapping Any)))
(define read-org-variable-mapping
  (compose-3
   (λ ([pairs : (Listof (Pair Symbol Any))])
     (make-immutable-hash pairs))
   (λ (sexp)
     (unstringify-pairs (cast sexp (Listof (GeneralPair String Any)))))
   string->any))

;;; A synonym for read-org-variable-mapping.
(define unorgv read-org-variable-mapping)

(module+ test
  (test-case "read-org-variable-mapping"
    (define m1 (read-org-variable-mapping "((\"a\" \"(and a b)\") (\"b\" \"(or b (not a))\"))"))
    (define m2 (read-org-variable-mapping "((\"a\" . \"(and a b)\") (\"b\" . \"(or b (not a))\"))"))
    (define m3 (unorgv "((\"a\" . \"(and a b)\") (\"b\" . \"(or b (not a))\"))"))
    (check-equal? (hash-ref m1 'a) '(and a b))
    (check-equal? (hash-ref m2 'a) '(and a b))
    (check-equal? (hash-ref m3 'a) '(and a b))
    (check-equal? (hash-ref m1 'b) '(or b (not a)))
    (check-equal? (hash-ref m2 'b) '(or b (not a)))
    (check-equal? (hash-ref m3 'b) '(or b (not a)))))