outils.sls

(library (outils)
  (export lookup
          lookup-spine
          
          ;; read/write utilities
          read-all
          write-expression-to-file
          write-r6rs-expression-to-file
          save-fasl
          load-config
          fasl-load

          ;; config utilities
          persist-track-configs
          processed-config
          load-track-configs

          ;; configlet utilities
          configlet-uuid)
  (import (chezscheme)
          (json))

  ;;; Assoc lists

  (define lookup
    (case-lambda
      ((symbol)
       (lambda (thing)
         (lookup symbol thing)))
      ((symbol thing)
       (cond ((assoc symbol thing) => cdr)
             (else (error 'lookup "key not in alist" symbol thing))))
      ((default symbol thing)
       (cond ((assoc symbol thing) => cdr)
             (else default)))))

  (define (lookup-spine keys alist)
    (fold-left (lambda (alist key)
                 (lookup key alist))
               alist
               keys))

  ;;; i/o
  (define (read-all)
    (let loop ((sexp (read)) (config '()))
      (if (eof-object? sexp)
          (reverse config)
          (loop (read) (cons sexp config)))))

  (define (write-expression-to-file code file)
    (when (file-exists? file)
      (delete-file file))
    (with-output-to-file file
      (lambda ()
        (for-each (lambda (line)
                    (pretty-print line) (newline))
                  code))))

  (define (write-r6rs-expression-to-file code file)
    (when (file-exists? file)
      (delete-file file))
    (with-output-to-file file
      (lambda ()
        (format #t "#!r6rs~%~%")
        (for-each (lambda (line)
                    (pretty-print line) (newline))
                  code))))

  (define (save-fasl obj file)
    (when (file-exists? file)
      (delete-file file))
    (let ((out (open-file-output-port file)))
      (fasl-write obj out)
      (close-output-port out)))

  (define (fasl-load file)
    (let ((in (open-file-input-port file)))
      (let ((obj (fasl-read in)))
        (close-input-port in)
        obj)))

  ;;; Config
  
  (define config-file "config/track.ss")
  (define track-configs "closet/tracks.txt")
  (define track-configs-fasl "closet/track-configs.fasl")

  (define (load-config)
    (with-input-from-file config-file read-all))

  (define (download-config track)
    (let ((config.json (format "closet/json/~a.json" track)))
      (system (format "mkdir -p closet/json && wget https://raw.githubusercontent.com/exercism/~a/master/config.json -O ~a"
                      track
                      config.json))))

  (define (load-track-config track)
    (let ((config.json (format "closet/json/~a.json" track)))
      (unless (file-exists? config.json)
        (download-config track))
      (with-input-from-file config.json json-read)))

  (define (persist-track-configs)
    (let ((tracks (with-input-from-file track-configs read-all)))
      (save-fasl (map load-track-config tracks) track-configs-fasl)))

  (define (load-track-configs)
    (fasl-load track-configs-fasl))

  (define (processed-config)
    (map (lambda (config)
           (if (not (eq? (car config) 'exercises))
               config
               `(exercises . ,(map (lambda (exercise)
                                     (map prepare-for-configlet exercise))
                                   (remp (lambda (exercise)
                                           (memq 'wip (map car exercise)))
                                         (cdr config))))))
         (load-config)))


  ;;; UUID
  ;; wrapper to read uuid generated by configlet from scheme
  (define (configlet-uuid)
    (let ((from-to-pid (process "./bin/configlet uuid")))
      (let ((fresh-uuid (read (car from-to-pid))))
        (close-port (car from-to-pid))
        (close-port (cadr from-to-pid))
        (symbol->string fresh-uuid))))
  
  ;;; Configlet formatting
  (define (kebab->snake str)
    (list->string
     (map (lambda (c)
            (if (char=? c #\-) #\_ c))
          (string->list str))))

  (define (prepare-snake-case symbol)
    (kebab->snake (symbol->string symbol)))

  ;; to make exercism/configlet happy
  (define (prepare-for-configlet pair)
    (let ((snake-key (prepare-snake-case (car pair))))
      (if (null? (cdr pair))
          `(,snake-key)
          (if (eq? 'topics (car pair))
              `(,snake-key ,@(map prepare-snake-case (cdr pair)))
              `(,snake-key . ,(cdr pair))))))

  )