#lang racket
(provide (rename-out [app #%app])
         string:
         dot)

(require racket/syntax)


(define (referable? s)
  (or (string? s)
      (vector? s)
      (list? s)
      (hash? s)
      (sequence? s)))

(define (ref s i)
  (cond
    [(string? s)   (string-ref s i)]
    [(vector? s)   (vector-ref s i)]
    [(list? s)     (list-ref s i)]
    [(hash? s)     (hash-ref s i)]    
    [(sequence? s) (sequence-ref s i)]
    [else          (error)]))

; sequence-take : sequence? index? -> list
(define (sequence-take s j)
  (for/list ([n (in-range j)] [x s]) x))


(define-for-syntax (curly? stx)
  (let ([ps (syntax-property stx 'paren-shape)])
    (and ps (eqv? ps #\{))))

(define-for-syntax (begins-with-dot? id-stx)
  (and (identifier? id-stx)
       (eqv? #\. (string-ref (symbol->string (syntax->datum id-stx)) 0))))


(define-syntax (app stx)
  (syntax-case stx (_)
    [(? struct-expr .name)
     (begins-with-dot? #'.name)
     (with-syntax ([name (let ([n (symbol->string (syntax->datum #'.name))]) (substring n 1 (string-length n)))])
       #'(let ([s struct-expr])
           (unless (struct? s)
             (error 'app "expected a structure instance before the dot name, got ~a " s))
           (dot s name)))]
    [(? proc-expr arg-expr)
     (curly? stx)
     (syntax/loc stx
       (let* ([s proc-expr]
              [i  arg-expr])
         (cond
           [(string? s)   (string-ref s i)]
           [(vector? s)   (vector-ref s i)]
           [(list? s)     (list-ref s i)]
           [(hash? s)     (hash-ref s i)]
           [(sequence? s) (sequence-ref s i)]
           [else          (s i)])))]
    [(? proc-expr arg1-expr _)
     (curly? stx)
     (quasisyntax/loc stx
       (let ([s proc-expr]
             [i arg1-expr])
         (cond
           [(string? s)   (substring s i (string-length s))]
           [(vector? s)   (vector-copy s i (vector-length s))]
           [(list? s)     (list-tail s i)]
           [(hash? s)     #,(syntax/loc stx (error 'ref-app "the (h i _) syntax is not supported for hash tables"))]
           [(sequence? s) (sequence-tail s i)]
           [else #,(syntax/loc stx (#%app proc-expr arg1-expr #\_))])))]
    [(? proc-expr _ arg2-expr)
     (curly? stx)
     (quasisyntax/loc stx
       (let ([s proc-expr]
             [j arg2-expr])
         (cond
           [(string? s)   (substring s 0 j)]
           [(vector? s)   (vector-copy s 0 j)]
           [(list? s)     (take s j)]
           [(hash? s)     #,(syntax/loc stx (error 'ref-app "the (h _ i) syntax is not supported for hash tables"))]
           [(sequence? s) (sequence-take s j)]
           [else #,(syntax/loc stx (#%app proc-expr #\_ arg2-expr))])))]
    [(? proc-expr arg1-expr arg2-expr)
     (curly? stx)
     (syntax/loc stx
       (let ([s proc-expr]
             [i arg1-expr]
             [j arg2-expr])
         (cond
           [(string? s)   (substring s i j)]
           [(vector? s)   (vector-copy s i j)]
           [(list? s)     (take (drop s i) j)]
           [(hash? s)     (hash-ref s i j)]
           [(sequence? s) (sequence-take (sequence-tail s i) (- j i))]
           [else (s i j)])))]           
    [(? . more)
     (syntax/loc stx (#%app . more))]))

(define (->string v)
  (cond
    [(char? v)   (string v)]
    [(symbol? v) (symbol->string v)]
    [(number? v) (number->string v)]
    [else v]))

(define-syntax (string: stx)
  (syntax-case stx ()
    [(_ expr ...)
     #'(string-append (->string expr) ...)]))

(define-syntax (list: stx)
  (syntax-case stx ()
    [(_ expr ...)
     #'(string-append (->string expr) ...)]))


(define-syntax (dot stx)
  (syntax-case stx ()
    [(_ s f)
     #`(let-values ([(i _) (struct-info s)])
         (let-values ([(name _2 accessor _4 _5 _6 _7 _8) (struct-type-info i)])
           (let ([s.f (format-id #,(syntax/loc stx #'foo) "~a-~a" name 'f)])
             ((eval s.f) s))))]
    [else (error 'dot "expected  (dot <struct> <field-name>)")]))