Finishing moves: jsonic

#lang br/quicklang
(module reader br
  (require "reader.rkt")
  (provide read-syntax get-info)
  (define (get-info port mod line col pos)
    (define (handle-query key default)
      (case key
        [(color-lexer)
         (dynamic-require 'jsonic/colorer 'color-jsonic)]
        [(drracket:indentation)
         (dynamic-require 'jsonic/indenter 'indent-jsonic)]
        [(drracket:toolbar-buttons)
         (dynamic-require 'jsonic/buttons 'button-list)]
        [else default]))
    handle-query))

#lang br/quicklang
(require "tokenizer.rkt" "parser.rkt" racket/contract)

(define (read-syntax path port)
  (define parse-tree (parse path (make-tokenizer port)))
  (define module-datum `(module jsonic-module jsonic/expander
                          ,parse-tree))
  (datum->syntax #f module-datum))
(provide (contract-out
          [read-syntax (any/c input-port? . -> . syntax?)]))

#lang br/quicklang
(require brag/support racket/contract)

(module+ test
  (require rackunit))

(define (token? x)
  (or (eof-object? x) (token-struct? x)))

(module+ test
  (check-true (token? eof))
  (check-true (token? (token 'A-TOKEN-STRUCT "hi")))
  (check-false (token? 42)))

(define (make-tokenizer port)
  (port-count-lines! port)
  (define (next-token)
    (define jsonic-lexer
      (lexer
       [(from/to "//" "\n") (next-token)]
       [(from/to "@$" "$@")
        (token 'SEXP-TOK (trim-ends "@$" lexeme "$@")
               #:position (+ (pos lexeme-start) 2)
               #:line (line lexeme-start)
               #:column (+ (col lexeme-start) 2)
               #:span (- (pos lexeme-end)
                         (pos lexeme-start) 4))]
       [any-char (token 'CHAR-TOK lexeme
                        #:position (pos lexeme-start)
                        #:line (line lexeme-start)
                        #:column (col lexeme-start)
                        #:span (- (pos lexeme-end)
                                  (pos lexeme-start)))]))
    (jsonic-lexer port))
  next-token)
(provide (contract-out
          [make-tokenizer (input-port? . -> . (-> token?))]))

(module+ test
  (check-equal?
   (apply-tokenizer-maker make-tokenizer "// comment\n")
   empty)
  (check-equal?
   (apply-tokenizer-maker make-tokenizer "@$ (+ 6 7) $@")
   (list (token 'SEXP-TOK " (+ 6 7) "
                #:position 3
                #:line 1
                #:column 2
                #:span 9)))
  (check-equal?
   (apply-tokenizer-maker make-tokenizer "hi")
   (list (token 'CHAR-TOK "h"
                #:position 1
                #:line 1
                #:column 0
                #:span 1)
         (token 'CHAR-TOK "i"
                #:position 2
                #:line 1
                #:column 1
                #:span 1))))

#lang brag
jsonic-program : (jsonic-char | jsonic-sexp)*
jsonic-char    : CHAR-TOK
jsonic-sexp    : SEXP-TOK

#lang br/quicklang
(require json)

(define-macro (jsonic-mb PARSE-TREE)
  #'(#%module-begin
     (define result-string PARSE-TREE)
     (define validated-jsexpr (string->jsexpr result-string))
     (display result-string)))
(provide (rename-out [jsonic-mb #%module-begin]))

(define-macro (jsonic-char CHAR-TOK-VALUE)
  #'CHAR-TOK-VALUE)
(provide jsonic-char)

(define-macro (jsonic-program SEXP-OR-JSON-STR ...)
  #'(string-trim (string-append SEXP-OR-JSON-STR ...)))
(provide jsonic-program)

(define-macro (jsonic-sexp SEXP-STR)
  (with-pattern ([SEXP-DATUM (format-datum '~a #'SEXP-STR)])
    #'(jsexpr->string SEXP-DATUM)))
(provide jsonic-sexp)

#lang br
(require "parser.rkt" "tokenizer.rkt" brag/support rackunit)

(check-equal?
 (parse-to-datum
  (apply-tokenizer-maker make-tokenizer "// line commment\n"))
 '(jsonic-program))
(check-equal?
 (parse-to-datum
  (apply-tokenizer-maker make-tokenizer "@$ 42 $@"))
 '(jsonic-program (jsonic-sexp " 42 ")))
(check-equal?
 (parse-to-datum
  (apply-tokenizer-maker make-tokenizer "hi"))
 '(jsonic-program
   (jsonic-char "h")
   (jsonic-char "i")))
(check-equal?
 (parse-to-datum
  (apply-tokenizer-maker make-tokenizer
                         "hi\n// comment\n@$ 42 $@"))
 '(jsonic-program
   (jsonic-char "h")
   (jsonic-char "i")
   (jsonic-char "\n")
   (jsonic-sexp " 42 ")))

#lang br
(require brag/support syntax-color/racket-lexer racket/contract)

(define in-racket-expr? #f)

(define (color-jsonic port)
  (define jsonic-lexer
    (lexer
     [(eof) (values lexeme 'eof #f #f #f)]
     ["@$" (begin
             (set! in-racket-expr? #t)
             (values lexeme 'parenthesis '|(|
                     (pos lexeme-start) (pos lexeme-end)))]
     ["$@" (begin
             (set! in-racket-expr? #f)
             (values lexeme 'parenthesis '|)|
                     (pos lexeme-start) (pos lexeme-end)))]
     [(from/to "//" "\n")
      (values lexeme 'comment #f
              (pos lexeme-start) (pos lexeme-end))]
     [any-char
      (values lexeme 'string #f
              (pos lexeme-start) (pos lexeme-end))]))
  (if (and in-racket-expr?
           (not (equal? (peek-string 2 0 port) "$@")))
      (racket-lexer port)
      (jsonic-lexer port)))
(provide
 (contract-out
  [color-jsonic
   (input-port? . -> . (values
                        (or/c string? eof-object?)
                        symbol?
                        (or/c symbol? #f)
                        (or/c exact-positive-integer? #f)
                        (or/c exact-positive-integer? #f)))]))

(module+ test
  (require rackunit)
  (check-equal? (values->list
                 (color-jsonic (open-input-string "x")))
                (list "x" 'string #f 1 2)))

#lang br
(require br/indent racket/contract racket/gui/base)

(define indent-width 2)
(define (left-bracket? c) (member c (list #\{ #\[)))
(define (right-bracket? c) (member c (list #\} #\])))

(define (indent-jsonic tbox [posn 0])
  (define prev-line (previous-line tbox posn))
  (define current-line (line tbox posn))
  (cond
    [(not prev-line) 0]
    [else
     (define prev-indent (line-indent tbox prev-line))
     (cond
       [(left-bracket?
         (line-first-visible-char tbox prev-line))
        (+ prev-indent indent-width)]
       [(right-bracket?
         (line-first-visible-char tbox current-line))
        (- prev-indent indent-width)]
       [else prev-indent])]))
(provide
 (contract-out
  [indent-jsonic (((is-a?/c text%)) 
                  (exact-nonnegative-integer?) . ->* .
                  exact-nonnegative-integer?)]))

(module+ test
  (require rackunit)
  (define test-str #<<HERE
#lang jsonic
{
"value": 42,
"string":
[
{
"array": @$(range 5)$@,
"object": @$(hash 'k1 "valstring")$@
}
]
// "bar"
}
HERE
    )
  (check-equal?
   (string-indents (apply-indenter indent-jsonic test-str))
   '(0 0 2 2 2 4 6 6 4 2 2 0)))

#lang br
(require racket/draw)

(define (button-func drr-window)
  (define expr-string "@$  $@")
  (define editor (send drr-window get-definitions-text))
  (send editor insert expr-string)
  (define pos (send editor get-start-position))
  (send editor set-position (- pos 3)))

(define our-jsonic-button
  (list
   "Insert expression"
   (make-object bitmap% 16 16)
   button-func
   #f))

(provide button-list)
(define button-list (list our-jsonic-button))         

#lang jsonic
// a line comment
[
  @$ 'null $@,
  @$ (* 6 7) $@,
  @$ (= 2 (+ 1 1)) $@,
  @$ (list "array" "of" "strings") $@,
  @$ (hash 'key-1 'null
           'key-2 (even? 3)
           'key-3 (hash 'subkey 21)) $@
]

#lang scribble/manual
@(require (for-label json))

@title{jsonic: because JSON is boring}
@author{Roxy Lexington}

@defmodulelang[jsonic]

@section{Introduction}

This is a domain-specific language
that relies on the @racketmodname[json] library.

In particular, the @racket[jsexpr->string] function.

If we start with this:

@verbatim|{
#lang jsonic
[
  @$ 'null $@,
  @$ (* 6 7) $@,
  @$ (= 2 (+ 1 1)) $@
]
}|

We'll end up with this:

@verbatim{
[
  null,
  42,
  true
]
}

#lang info
(define collection "jsonic")
(define version "1.0")
(define scribblings '(("scribblings/jsonic.scrbl")))
(define test-omit-paths '("jsonic-test.rkt"))
(define deps '("base"
               "beautiful-racket-lib"
               "brag"
               "draw-lib"
               "gui-lib"
               "br-parser-tools-lib"
               "rackunit-lib"
               "syntax-color-lib"))
(define build-deps '("scribble-lib"))