racket git parser

gistfile1.txt

https://gist.github.com/anonymous/1d97377be54fd02da8b050783cfbf2ad


#+BEGIN_SRC
#lang racket
(define (run-gs-command repo)
  (with-output-to-string
   (thunk
    (system
     (format "cd ~s; git status -s" repo)))))
(define (parse-gs-output output)
  (define split-into-lines
    (string-split output
                #px"\n"))
  (map parse-git-status-short-line
       split-into-lines))
(struct untracked-file (name) #:transparent)
(struct modified-file (name)  #:transparent)
(define (parse-git-status-short-line line)
    #|
In the short-format, the status of each path is shown as
XY PATH1 -> PATH2
where PATH1 is the path in the HEAD, and the " -> PATH2" part is shown only
when PATH1 corresponds to a different path in the index/worktree (i.e. the file is renamed).
The XY is a two-letter status code.
The fields (including the ->) are separated from each other by a single space.
If a filename contains whitespace or other nonprintable characters, that field will be quoted
in the manner of a C string literal: surrounded by ASCII double quote (34) characters, and with
interior special characters backslash-escaped.
For paths with merge conflicts, X and Y show the modification states of each side of the merge. For paths that
do not have merge conflicts, X shows the status of the index, and Y shows the status of the work tree.
For untracked paths, XY are ??. Other status codes can be interpreted as follows:
    ' ' = unmodified
    M = modified
    A = added
    D = deleted
    R = renamed
    C = copied
    U = updated but unmerged
Ignored files are not listed, unless --ignored option is in effect, in which case XY are !!.
X          Y     Meaning
-------------------------------------------------
          [MD]   not updated
M        [ MD]   updated in index
A        [ MD]   added to index
D         [ M]   deleted from index
R        [ MD]   renamed in index
C        [ MD]   copied in index
[MARC]           index and work tree matches
[ MARC]     M    work tree changed since index
[ MARC]     D    deleted in work tree
-------------------------------------------------
D           D    unmerged, both deleted
A           U    unmerged, added by us
U           D    unmerged, deleted by them
U           A    unmerged, added by them
D           U    unmerged, deleted by us
A           A    unmerged, both added
U           U    unmerged, both modified
-------------------------------------------------
?           ?    untracked
!           !    ignored
-------------------------------------------------
|#
  (define components (regexp-match #px"^(.)(.) (.*)$" line))
  (define X (second components))
  (define Y (third components))
  (define filename (fourth components))
  (cond ((and (string=? X "?")
              (string=? Y "?"))
         (untracked-file filename))
        ((and (string=? X " ")
              (string=? Y "M"))
         (modified-file filename))
        (else (error (format "unhandled git status '~a~a'" X Y)))))
(define (main data)
  (main data))
(define (timer-thread-loop config data)
  (for ([i config])
    (run-config config))
  (timer-thread-loop config))
(struct timer-data (initial-time run-log))
(define (start-timer-thread [config (config-schedule configuration)])
  (thread (lambda ()
            (timer-thread-loop config
                               ))))
(module* main #f
  (pretty-print (parse-gs-output
                 (run-gs-command "/Users/joel/emacs"))))
(module+ test
  (require rackunit))
(module+ test
  (define was-run #f)
  (define (foobar)
    (set! was-run #t))
  (define timer-thread
    (start-timer-thread
     '(every (seconds 1)
             (run foobar))))
  (kill-thread timer-thread)
  (check-eq? was-run #t)
  )
(define (config-schedule config)
  (cdr (assoc 'schedule config)))
(define configuration
  '(
    (data-dir . "~/var/racket-helper-data.rktd")
    (schedule
     (every (seconds 30)
            (run dirty-checker)))
    (dirty-checker
     ((git
       "~/dotfiles"
       "~/emacs")
      (simple-files
       "~/Inbox")
      )
     )))
#+END_SRC
** space adventure
#+BEGIN_SRC
#lang racket
(module code racket
  (require racket/gui/base)
  (define clicks 0)
  (struct game
    (cards
     adventure-count))
  (struct ui
    (frame
     message
     adventure-button))
  (define cards '())
  (define (have-adventure)
    (set! cards (cons 'ore cards)))
  (define (start-game)
    (define frame (new frame%
                       [label "Space Adventure!"]
                       [width 300]
                       [height 300]))
    ; Make a static text message in the frame
    (define adventure-results
      (new message% [parent frame]
           [label "No adventures so far..."]
           [auto-resize #t]))
    (define (button-click-callback btn event)
      (set! clicks (add1 clicks))
      (send adventure-results set-label
            (format "~s adventure(s)!" clicks)))
    ; Make a button in the frame
    (new button% [parent frame]
         [label "Adventure!"]
         [callback button-click-callback])
    (send frame show #t))
  (define (render)
    10
    )
  (provide render
           start-game))
(require 'code)
(module tests racket
  (module unit racket
    (require rackunit)
    (require (submod ".." ".." code))
    (check-eq? (render) 10)
    ))
(require (submod 'tests unit))
#+END_SRC