#lang s-exp "../lang.ss"

(require "../../collects/moby/runtime/stx.ss")

;; lift information (linfo) contains
;;    - return : stx (used as (list-of stx) when folding)
;;               that is the new expression
;;    - raise : (list-of stx)
;;              representing spliced out (or new) expressions
;;              to be raised to a higher level
(define-struct linfo (return raise))

;; stateful gensym operations including a counter,
;; a thunk that adds 1 and returns the old value,
;; and a thunk to reset to 0
;; only the thunks are exported
(define gensym-counter 0)
(define (gensym)
  (begin (set! gensym-counter (add1 gensym-counter))
         (sub1 gensym-counter)))
(define (reset-gensym)
  (set! gensym-counter 0))

;; list-of: (any -> boolean) -> (any -> boolean)
;; consumes a predicate and returns a new predicate that checks
;;    if its input is a list such that each element satisfies the original predicate
(define (list-of pred)
  (lambda (dat)
    (and (list? dat)
         (andmap pred dat))))

;; s-expr?: datum -> boolean
;; consumes anything and returns true if it is an s-expression, false otherwise
(define (sexp? expr)
  (or (string? expr)
      (symbol? expr)
      (number? expr)
      (boolean? expr)
      (char? expr)
      ((list-of sexp?) expr)))

#|
;; symb-prepend: string symbol -> symbol
;; consumes a prepend string and an original symbol
;; returns a new symbol with the prepend string prepended to the original
(define (symb-prepend prepend symb)
  (string->symbol (string-append prepend (symbol->string symb))))
|#

;; ensugar: stx -> stx
;; takes a define statement as a syntax object
;; produces a semantically equivalent define statement that is guaranteed to use
;;    syntactic sugar if defining a procedure
(define (ensugar a-def)
  (if (stx-begins-with? a-def 'define)
      (let ([stx-list (stx-e a-def)])
        (if (and (stx:atom? (second stx-list))
                 (stx-begins-with? (third stx-list) 'lambda))
            (datum->stx false
                        (list (first stx-list)
                              (cons (second stx-list)
                                    (stx-e (second (stx-e (third stx-list)))))
                              (third (stx-e (third stx-list))))
                        (stx-loc a-def))
            a-def))
      (error 'ensugar (format "expected definition as syntax, found: ~a" a-def))))



;; get-struct-procs: s-expr -> (list-of symbol)
;; consumes a struct definition in abstract syntax
;; returns a list of procs generated by defining that struct
(define (get-struct-procs struct-def)
  (list* (string->symbol (format "make-~a" (second struct-def)))
         (string->symbol (format "~a?" (second struct-def)))
         (foldl (lambda (elt rest-procs)
                  (list* (string->symbol (format "~a-~a" (second struct-def) elt))
                         (string->symbol (format "set-~a-~a!"
                                                 (second struct-def)
                                                 elt))
                         rest-procs))
                empty
                (third struct-def))))


(provide/contract
 [struct linfo ([return (or/c stx? (list-of stx?))]
                [raise list?])]
 [gensym ( -> number?)]
 [reset-gensym ( -> void?)]
 [sexp? (any/c . -> . boolean?)]
 [ensugar (stx? . -> . stx?)]
 [get-struct-procs (sexp? . -> . (list-of symbol?))])