simply.scm) gauche module to write code simply

json.scm

(define-module simply.json
  (use simply)
  (export make-json)
  )
(select-module simply.json)

(define (collect-data start end data)
  (string-append
    start
    (string-join data ",")
    end
    )
  )

(define (hash->json hs)
  (collect-data
    "{" "}"
    (hash-table-fold
      hs (lambda (key value res)
           (cons
             (string-append (data->json key) ":" (data->json value))
             res)
           ) '())
    )
  )

(define (list->json ls)
  (collect-data
    "[" "]"
    (r fold (lambda (data res)
              (cons (data->json data) res)
              ) '() ls)
    )
  )

(define (data->json data)
  (cond
    [(list? data) (list->json data)]
    [(hash-table? data) (hash->json data)]
    [(hash-table*? data) (hash->json (data))]
    [(boolean? data) (if data "true" "false")]
    [(number? data) (number->string data)]
    [(string? data) (string-append "\"" (to-utf8 data) "\"")]
    [(symbol? data) (data->json (symbol->string data))]
    [(keyword? data) (data->json (keyword->string data))]
    [else data]
    )
  )

(define (make-json data . options)
  (let-keywords options ((callback '()))
    (let1 res (data->json data)
      (if (null? callback) res (string-append callback "(" res ")"))
      )
    )
  )

(provide "simply/json")

notify.scm

(define-module simply.notify
  (use simply)
  (export-all)
  )
(select-module simply.notify)

(define (notify-send title text . options)
  (let-keywords options ((icon '())
                         (time '())
                         (level '())
                         (category '())
                         )
    (execute
      (string-join
        (append (list "notify-send" #`"\",title\"" #`"\",text\"")
                (if (null? icon) '() (list #`"-i ,icon"))
                (if (null? time) '() (list #`"-t ,time"))
                (if (null? level) '() (list #`"-u ,level"))
                (if (null? category) '() (list #`"-c ,category"))
                )
        " "
        )
      )
    )
  )

(provide "simply/notify")

simply.scm

; gauche module to write code simply

(define-module simply
  (use srfi-1)
  (use srfi-13)
  (use rfc.http) (use rfc.uri) (use rfc.base64) (use file.util)
  (use gauche.charconv) (use gauche.process)
  (export-all)
  )
(select-module simply)

(define *simply-version* "0.17")
(define *get-lambda-tag* '__get-lambda-tag)

; #r
; ------------------------------------------
(define-syntax r
  (syntax-rules ()
    [(_ ls) (reverse ls) ]
    [(_ fn ...) (reverse (fn ...))]
    )
  )

; #!
; ------------------------------------------
(define-syntax !
  (syntax-rules ()
    [(_ bool) (not bool) ]
    [(_ fn ...) (not (fn ...))]
    )
  )

; #p
; ------------------------------------------
(define-syntax p
  (syntax-rules ()
    [(_ str) (print str)]
    [(_ expr ...) (print (expr ...))]
    )
  )

; #list-receive
; ------------------------------------------
(define-syntax list-receive
  (syntax-rules ()
    [(_ vals ls e ...)
     (receive vals (apply values ls) e ...)
     ]
    )
  )

; #block
; ------------------------------------------
(define-syntax block
  (syntax-rules ()
    [(_ tag e ...)
     (call/cc (lambda (tag) e ...))
     ]
    )
  )

; #cache-function
; ------------------------------------------
(define-syntax cache-function
  (syntax-rules ()
    [(_ (fn expr ...))
     (let ((cached-result '()) (is-cached? #f))
       (lambda ()
         (cond
           [is-cached? (cached-result)]
           [else
             (receive tmp (fn expr ...)
               (set! is-cached? #t)
               (case (length tmp)
                 ; normal variable
                 [(1) (set! cached-result (lambda () (car tmp)))
                      tmp]
                 ; values
                 [else (set! cached-result (lambda () (apply values tmp)))
                   (apply values tmp)]
                 )
               )
             ]
           )
         )
       )
     ]
    )
  )

; #cl (connect list)
; ------------------------------------------
(define-syntax cl
  (syntax-rules (_res)
    [(_ expr1 expr2)
     (let1 _res expr1
       (eval (append 'expr2
                     (list (if (list? _res) (cons 'list _res) _res))
                     )
             (interaction-environment))
       )
     ]
    [(_ expr1 expr2 expr3 ...)
     (cl (cl expr1 expr2) expr3 ...)
     ]
    )
  )

; #uses
; ------------------------------------------
(define-syntax uses
  (syntax-rules ()
    [(_ m) (use m)]
    [(_ m1 m2 ...)
     (begin (use m1) (uses m2 ...))
     ]
    )
  )

; #lambda/tag
;    make lambda which has TAG
; ------------------------------------------
(define-syntax lambda/tag
  (syntax-rules ()
    [(_ tag args expr ...)
     (lambda _args_
       (cond
         [(and (= (length _args_) 1)
            (symbol? (car _args_))
            (eq? (car _args_) *get-lambda-tag*))
          (values #t tag)
          ] 
         [else
           (receive args (apply values _args_)
             expr ...
             )
           ]
         )
       )
     ]
    )
  )

; =lambda/tag?
; ------------------------------------------
(define (lambda/tag? obj)
  (guard (e (else #f))
    (receive (flag tag) (obj *get-lambda-tag*)
      (if flag #t #f)
      )
    )
  )
; =get-lambda-tag
; ------------------------------------------
(define (get-lambda-tag obj)
  (if (lambda/tag? obj)
    (receive (flag tag) (obj *get-lambda-tag*) tag)
    #f
    )
  )

; =to-s
; ------------------------------------------
(define-method to-s ((a <string>)) a)
(define-method to-s ((a <char>)) (string a))
(define-method to-s ((a <number>)) (number->string a))
(define-method to-s ((a <symbol>)) (symbol->string a))
(define-method to-s ((a <symbol>)) (symbol->string a))
(define-method to-s ((a <keyword>)) (keyword->string a))
(define-method to-s ((a <list>)) (list->string a))

; =+
; ------------------------------------------
(define-method + ((a <char>) . b)
  (apply + (cons (string a) b))
  )
(define-method + ((a <string>) . b)
  (string-append a (fold (lambda (x res) (string-append res (to-s x))) "" b))
  )
(define-method + ((a <list>) . b)
  (append a
          (fold (lambda (x res)
                  (let1 c (class-of x)
                    (if (or (eq? <pair> c) (eq? <list> c))
                      (append x res)
                      res
                      )
                    )
                  ) '() b)
          )
  )

; =/
; ------------------------------------------
(define-method / ((base <string>) del)
  (string-split base del)
  )
(define-method / ((base <list>) del-con)
  (list-split base del-con)
  )

; ===?
; ------------------------------------------
(define-method ==? ((a <integer>) (b <integer>)) (= a b))
(define-method ==? ((a <rational>) (b <rational>)) (= a b))
(define-method ==? ((a <real>) (b <real>)) (= a b))
(define-method ==? ((a <list>) (b <list>)) (equal? a b))
(define-method ==? ((a <string>) (b <string>)) (string=? a b))
(define-method ==? ((a <char>) (b <char>)) (char=? a b))
(define-method ==? ((a <string>) (b <char>))
  (if (= 1 (string-length a)) (char=? (string-ref a 0) b) #f))
(define-method ==? ((a <char>) (b <string>))
  (if (= 1 (string-length b)) (char=? (string-ref b 0) a) #f))
(define-method ==? ((a <boolean>) (b <boolean>)) (eq? a b))
(define-method ==? ((a <symbol>) (b <symbol>)) (eq? a b))
(define-method ==? ((a <keyword>) (b <keyword>)) (eq? a b))


; =len
; ------------------------------------------
(define-method len ((str <string>)) (string-length str))
(define-method len ((ls <list>)) (length ls))
(define-method len ((ht <hash-table>)) (hash-table-num-entries ht))

; =trim
;   faster than string-trim-both in srfi-13
; ------------------------------------------
(define (trim original-str)
  (if (string=? original-str "") original-str
    (let1 tmp (let loop((str original-str))
                (case (string-ref str 0)
                  [(#\space #\tab #\newline #\return)
                   (loop (substring str 1 (string-length str)))]
                  [else
                    str
                    ]
                  )
                )
      (let loop((str tmp))
        (let1 len (- (string-length str) 1)
          (case (string-ref str len)
            [(#\space #\tab #\newline #\return)
             (loop (substring str 0 len))
             ]
            [else str]
            )
          )
        )
      )
    )
  )

; =to-lower
; ------------------------------------------
(define to-lower string-downcase)
; =to-upper
; ------------------------------------------
(define to-upper string-upcase)

; =puts
; ------------------------------------------
(define (puts . strs)
  (for-each print strs)
  )

; =index-of
; ------------------------------------------
(define (index-of ls obj)
  (list-index (cut ==? <> obj) ls)
  )

; =hash-table-wrap {{{
; ------------------------------------------
(define (hash-table-wrap hs)
  (lambda args
    (let1 len (length args)
      (cond
        [(= len 0) hs ]
        [(= len 1)
         (if (hash-table-exists? hs (car args))
           (hash-table-get hs (car args))
           '()
           )
         ]
        [(= len 2)
         (hash-table-put! hs (car args) (cadr args))
         ]
        [(= len 3)
         (let1 comm (cadr args)
           (cond
             [(eq? comm 'delete)
              (hash-table-delete! hs (caddr args))
              ]
             [(eq? comm 'exists?)
              (hash-table-exists? hs (caddr args))
              ]
             [else
               (error 'unknown_command)
               ]
             )
           )
         ]
        [(= len 4) #t] ;hash-table-wrap check
        )
      )
    )
  )
; =make-hash-table-wrap
; ------------------------------------------
(define (make-hash-table-wrap)
  (hash-table-wrap (make-hash-table))
  )
; =hash-table-wrap?
; ------------------------------------------
(define (hash-table-wrap? obj)
  (if (and (procedure? obj) (! eq? obj print))
    (guard (e (else #f))
      (hash-table? (obj))
      )
    #f
    )
  )
; =list->hash-table-wrap
; ------------------------------------------
(define (list->hash-table-wrap ls)
  (hash-table-wrap (list->hash-table ls))
  )
; }}}

; =list->hash-table
; ------------------------------------------
(define (list->hash-table original-ls)
  (let1 hs (make-hash-table)
    (let loop((ls original-ls))
      (when (> (length ls) 1)
        (let ((key (car ls)) (value (cadr ls)))
          (hash-table-put!
            hs key
            (if (and (list? value) (eq? (car value) '@hash))
              (list->hash-table (cadr value)) value)
            )
          (loop (cddr ls))
          )
        )
      )
    hs
    )
  )

; =hash-table*
;   new version of hash-table-wrap
; ------------------------------------------
(define (hash-table* . init)
  (let1 ht (cond
             [(and (= (length init) 1) (hash-table? (car init))) (car init)]
             [(> (length init) 1)
              (list->hash-table init)
              ]
             [else (make-hash-table)]
             )
    (lambda/tag
      'hash-table* args
      (case (length args)
        [(0) ht]
        [(1)
         (let1 cmd (car args)
           (cond
             [(symbol? cmd)
              ; get
              (let1 res (hash-table-get ht cmd)
                (if (hash-table? res) (hash-table* res) res)
                )
              ]
             [(string? cmd)
              ; get
              (let1 res (hash-table-get ht (string->symbol cmd))
                (if (hash-table? res) (hash-table* res) res)
                )
              ]
             [(and (keyword? cmd) (eq? cmd :length))
              ; length
              (hash-table-num-entries ht)
              ]
             [(and (keyword? cmd) (eq? cmd :clear))
              ; clear
              (hash-table-clear! ht)
              ]
             )
           )
         ]
        [(2)
         (let ((key (car args)) (value (cadr args)))
           (cond
             [(symbol? key)
              ; put
              (hash-table-put! ht key
                               (if (hash-table? value) (hash-table* value) value))
              ]
             [(string? key)
              ; put
              (hash-table-put! ht (string->symbol key)
                               (if (hash-table? value) (hash-table* value) value))
              ]
             [(and (keyword? key) (eq? key :delete))
              ; delete
              (hash-table-delete! ht value)
              ]
             [(and (keyword? key) (eq? key :exists?))
              ; exists?
              (hash-table-exists? ht value)
              ]
             [(and (keyword? key) (eq? key :each))
              ; each
              (hash-table-for-each ht value)
              ]
             )
           )
         ]
        )
      )
    )
  )

; =make-hash-table*
;   new version of make-hash-table-wrap
; ------------------------------------------
(define (make-hash-table* . init)
  (hash-table* (if (null? init) (list (make-hash-table)) init))
  )

; =hash-table*?
; ------------------------------------------
(define (hash-table*? obj)
  (if (and (lambda/tag? obj) (eq? (get-lambda-tag obj) 'hash-table*)) #t #f)
  )

; =list-replace
; ------------------------------------------
(define (list-replace ls comp to)
  (map (lambda (from)
         (cond
           [(list? from)
            (list-replace from comp to)
            ]
           [else
             (if (comp from) to from)
             ]
           )
         ) ls)
  )

; =list-replace-all
; ------------------------------------------
(define (list-replace-all ls . args)
  (cond
    [(= 0 (modulo (length args) 2))
     (let loop((rules args) (result ls))
       (cond
         [(null? rules)
          result
          ]
         [else
           (loop (cddr rules) (list-replace result (car rules) (cadr rules)))
           ]
         )
       )
     ]
    [else ls]
    )
  )

; =list-split
; ------------------------------------------
(define (list-split original-ls con)
  (let loop((ls original-ls) (tmp '()) (res '()))
    (cond
      [(null? ls)
       (r if (! null? tmp)
          (cons (r tmp) res)
          res
          )
       ]
      [(con (car ls))
       (loop (cdr ls) '() (cons (r tmp) res))
       ]
      [else
        (loop (cdr ls) (cons (car ls) tmp) res)
        ]
      )
    )
  )

; =regexp-match
; ------------------------------------------
(define (regexp-match reg-str target-str)
  (let1 r (string->regexp reg-str)
    (values (r target-str) r)
    )
  )

; =file-each
; ------------------------------------------
(define (file-each filename . fn)
  (define (original-file-each input-fn expr-fn)
    (with-input-from-file
      filename
      (lambda ()
        (let loop((_line (input-fn)))
          (when (! eof-object? _line)
            (expr-fn _line)
            (loop (input-fn))
            )
          )
        )
      )
    )

  (cond
    [(and (= 1 (length fn)) (procedure? (car fn)))
     (original-file-each read-line (car fn))
     ]
    [(and (= 2 (length fn)) (procedure? (car fn)) (procedure? (cadr fn)))
     (original-file-each (car fn) (cadr fn))
     ]
    )
  )

; =http-get
; ------------------------------------------
(define _http-get http-get)
(define (http-get uri . options)
  ; ----
  (define (make-auth-list user pass)
    (cond
      [(and (string? user) (string? pass))
       (list :Authorization
             (string-append
               "Basic "
               (base64-encode-string
                 (string-append user ":" pass))))
       ]
      [else '()]
      )
    )
  ; /---

  (let-keywords options ((user '())
                         (password '()))
    (let1 basic-auth (make-auth-list user password)
      (receive (scheme user-info hostname port path query fragment)
        (uri-parse uri)
        (let ((server (string-append hostname (if port #`":,port" "")))
              (path (string-append (if path path "/") (if query #`"?,query" "")))
              )
          (receive (status header body) (apply _http-get (append (list server path) basic-auth))
            (values body status header)
            )
          )
        )
      )
    )
  )

; =file->list
; ------------------------------------------
(define-method file->list ((filename <string>) . options)
  (define (_delete-comment ls comment-str)
    (r fold (lambda (line res)
              (let1 index (string-scan line comment-str)
                (if (and (number? index) (= 0 index)) res (cons line res)))
              ) '() ls)
    )
  (define (_split-line ls del)
    (r fold (lambda (line res)
              (cons (string-split line del) res)
              ) '() ls)
    )
  (let1 ls (file->list read-line filename)
    (let-keywords options ((split #f)
                           (comment #f)
                           )
      (let1 tmp (if comment (_delete-comment ls comment) ls)
        (if split (_split-line tmp split) tmp)
        )
      )
    )
  )
; =file->string
; ------------------------------------------
(define file->string file->string)

(define (file->list-each filename fn)
  ;(cl (file->list filename) (for-each fn))
  (for-each fn (file->list filename))
  )

; =charconv
; ------------------------------------------
; =to-utf8
(define (to-utf8 str) (ces-convert str '*JP 'UTF8))
; =to-sjis
(define (to-sjis str) (ces-convert str '*JP 'SJIS))
; =to-euc
(define (to-euc str) (ces-convert str '*JP 'EUCJP))

; =char->symbol
; ------------------------------------------
(define (char->symbol c) (string->symbol (string c)))
; =sysmbol->char
; ------------------------------------------
(define (symbol->char s) (string-ref (symbol->string s) 0))

; =args->hash
; usage: (args->hash (cdr args) '(a (b 1 "default") c))
; ------------------------------------------
(define (args->hash args rules)
  (define (parse-args)
    (let loop((ls args) (options '()))
      (cond
        [(null? ls) (values (r options) '())]
        [(! string? (car ls)) (values (r options) ls)]
        [(char=? (string-ref (car ls) 0) #\-)
         (loop (cdr ls)
               (fold (lambda (x res)
                       (cons (char->symbol x) res)
                       ) options (string->list (string-drop (car ls) 1)))
               )
         ]
        [else (values (r options) ls)]
        )
      )
    )

  ; body ----
  (receive (options rest-args) (parse-args)
    (let1 hs (make-hash-table-wrap)
      (let loop((ls rules) (param rest-args))
        (cond
          [(null? ls) (values hs param)]
          [(symbol? (car ls))
           ; booleanの場合
           (let1 r (car ls)
             (hs r (if (list-index (lambda (o) (eq? o r)) options) #t #f))
             (loop (cdr ls) param)
             )
           ]
          [(list? (car ls))
           ; 引数を取る場合
           (let* ((x (car ls))
                  (r (car x))
                  (num (cadr x))
                  (default (if (> (length x) 2) (caddr x) '()))
                  )
             (cond
               [(and (list-index (lambda (o) (eq? o r)) options) (>= (length param) num))
                ; 2つ以上ならリストで返す
                (hs r (if (= num 1) (list-ref (take param num) 0) (take param num)))
                (loop (cdr ls) (drop param num))
                ]
               [else
                 ; 必要な引数がない場合はデフォルト値
                 (hs r default)
                 (loop (cdr ls) param)
                 ]
               )
             )
           ]
          )
        )
      )
    )
  )

; =has-args?
; ------------------------------------------
(define (has-args? args)
  (>= (length args) 2)
  )

; =standard-input?
; ------------------------------------------
(define (standard-input?)
  (char-ready? (standard-input-port))
  )

; =with-standard-input
; ------------------------------------------
(define (with-standard-input fn)
  (when (standard-input?)
    (fn (port->string (standard-input-port)))
    )
  )

; =execute
; ------------------------------------------
(define (execute command)
  (call-with-input-process command port->string)
  )

; =map*
; ------------------------------------------
(define (map* fn ls)
  (map (lambda (x)
         (cond
           [(pair? x) (map* fn x)]
           [else (fn x)]
           )
         ) ls)
  )

; =inc dec
; ------------------------------------------
(define (++ i) (+ i 1))
(define (-- i) (- i 1))

(provide "simply")

stack.scm

(define-module simply.stack
  (use srfi-1)
  (use simply)
  (export-all)
  )
(select-module simply.stack)

; =_stack-pop
; -------------------------------
(define (_stack-pop ls)
  (if (> (length ls) 0)
    (let1 res (last ls)
      (values res (take ls (- (length ls) 1)))
      )
    (values #f ls)
    )
  )

; =_stack-shift
; -------------------------------
(define (_stack-shift ls)
  (if (> (length ls) 0)
    (let1 res (car ls)
      (values res (drop ls 1))
      )
    (values #f ls)
    )
  )

; =make-stack
; -------------------------------
(define (make-stack . init-ls)
  (let1 ls (if (null? init-ls) '() (car init-ls))
    (lambda/tag 'stack arg
      (case (length arg)
        [(1)
         (case (car arg)
           [(pop shift)
            (receive (res new-ls) ((if (eq? (car arg) 'pop)
                                     _stack-pop
                                     _stack-shift) ls)
              (set! ls new-ls) res
              )
            ]
           [else
             (when (number? (car arg))
               (list-ref ls (car arg))
               )
             ]
           )
         ]
        [(2)
         (case (car arg)
           [(push unshift)
            (set! ls (if (eq? (car arg) 'push)
                       (append ls (list (cadr arg)))
                       (cons (cadr arg) ls)
                       ))
            (cadr arg)
            ]
           )
         ]
        [else ls]
        )
      )
    )
  )

; =stack?
; -------------------------------
(define (stack? obj)
  (if (and (lambda/tag? obj) (eq? (get-lambda-tag obj) 'stack)) #t #f)
  )

(provide "simply/stack")

style.scm

(define-module simply.style
  (use simply)
  (use srfi-13)
  (use binary.pack)
  (export-all)
  )
(select-module simply.style)

; style color maps {{{
(define style-color-map
  (hash-table*
    'bold "[1m" 'underline "[4m"
    'fg-black "[30m" 'fg-red "[31m"
    'fg-green "[32m" 'fg-yellow "[33m"
    'fg-blue "[34m" 'fg-purple "[35m"
    'fg-aqua "[36m" 'fg-white "[37m"
    'bg-black "[40m" 'bg-red "[41m"
    'bg-green "[42m" 'bg-yellow "[43m"
    'bg-blue "[44m" 'bg-purple "[45m"
    'bg-aqua "[46m" 'bg-white "[47m"
    'normal "[0m"
    )) ; }}}

(define (_mypack val) (pack "a" (list val) :to-string? #t))
(define (_make-escape str) (list (_mypack "\x1B") str))

(define (make-style-list str . options)
  (fold (lambda (key res)
          (if (style-color-map :exists? key)
            (append (_make-escape (style-color-map key)) res)
            res
            )
          )
        (cons str (_make-escape (style-color-map 'normal))) options
        )
  )

(define (display/style str . options)
  (for-each display (apply make-style-list (cons str options)))
  )

(define (make-style-list/regexp str . rules)
  (define (make-result-list match-obj styles) ; {{{
    (append (if (string=? (match-obj 'before) "") '() (list (match-obj 'before)))
            (apply make-style-list (cons (match-obj 0) styles))
            )
    ) ; }}}
  (define (rule-matched? s) ; {{{
    (block
      break
      (let loop((ls rules))
        (cond
          [(null? ls) (list #f '() '())]
          [(>= (length ls) 2)
           (let* ((regexp (car ls)) (styles (cadr ls))
                  (m (if (regexp? regexp)
                       ((string->regexp (string-append "^" (regexp->string regexp))) s)
                       #f)))
             (if m (break (list #t m styles)) (loop (cddr ls)))
             )
           ]
          [else
            (list #f '() '())
            ]
          )
        )
      )
    ) ; }}}
  ; body ----------------------------
  (define (make-style-list/regexp-body s res)
    (cond
      [(string=? s "") res]
      [else 
        (list-receive (result matched-obj styles) (rule-matched? s)
          (cond
            [result
              (make-style-list/regexp-body
                (matched-obj 'after)
                (append res (make-result-list matched-obj styles))
                )
              ]
            [else
              (make-style-list/regexp-body
                (string-drop s 1) (append res (list (string-take s 1))))
              ]
            )
          )
        ]
      )
    )
  ; main ----------------------------
  (make-style-list/regexp-body str '())
  )

(define (screen-clear)
  (for-each display (_make-escape "[2J"))
  (screen-goto 0 0)
  )

(define (screen-clear-below)
  (for-each display (_make-escape "[0J"))
  )

(define (screen-goto y x)
  (let ((x2 (+ x 1)) (y2 (+ y 1)))
    (for-each display (_make-escape #`"\[,|x2|;,|y2|H"))
    )
  )

(provide "simply/style")

sxml.scm

(define-module simply.sxml
  (use sxml.ssax) (use sxml.sxpath)
  (use sxml.tools) (use sxml.serializer)
  (use sxml.tree-trans)
  (use srfi-1) (use srfi-13)
  (use simply)
  (export-all)
  )
(select-module simply.sxml)

; =sxml class
; ---------------------------------
(define-class <sxml> ()
  [
   (body :init-keyword :body :init-value '()
         :getter sxml:body)
   (namespace :init-keyword :namespace :init-value '()
              :getter sxml:namespace
              )
   (ignore-case :init-keyword :ignore-case :init-value #t)
   (delete-ns-prefix :init-keyword :delete-ns-prefix :init-value #t)

   ; input
   (file :init-keyword :file :init-value #f)
   (uri :init-keyword :uri :init-value #f)
   (string :init-keyword :string :init-value #f)
   (port :init-keyword :port :init-value #f)
   ]
  )


; =constructor
; ---------------------------------
(define-method initialize ((self <sxml>) init-args)
  (next-method)

  ; set body
  (when (null? (sxml:body self))
    (set!
      (slot-ref self'body)
      (cond
        ; from uri
        [(slot-ref self'uri)
         (ssax:xml->sxml (open-input-string
                           (to-utf8 (http-get (slot-ref self'uri)))) '())
         ]
        ; from file
        [(slot-ref self'file)
         (call-with-input-file
           (slot-ref self'file)
           (lambda (port)
             (if port (ssax:xml->sxml port '()) '())
             )
           :if-does-not-exist #f
           )
         ]
        ; from string
        [(slot-ref self'string)
         (ssax:xml->sxml (open-input-string (to-utf8 (slot-ref self'string))) '())
         ]
        ; from port
        [(slot-ref self'port)
         (ssax:xml->sxml (slot-ref self'port) '())
         ]
        [else '()]
        )
      )
    )

  ; get namespace
  (when (null? (slot-ref self'namespace))
    (let1 root (sxml:root self :no-wrap #t)
      (cond
        [(null? root)
         (set! (slot-ref self'namespace) '())
         ]
        [else
          (let1 tmp (string-split (symbol->string (car root)) #\:)
            (set! (slot-ref self'namespace)
              (string->symbol
                (string-join (take tmp (- (length tmp) 1)) ":")
                )
              )
            )
          ]
        )
      )
    )

  ; delete namespace prefix
  (when (and (slot-ref self'delete-ns-prefix) (! null? (sxml:body self)))
    (set!
      (slot-ref self'body)
      (delete-sxml-namespace (sxml:body self))
      )
    )
  )

; =sxml:root
; ---------------------------------
(define-method sxml:root ((sxml <sxml>) . options)
  (cond
    [(null? (sxml:body sxml)) '()
                              ]
    [else
      (let1 root (block _break
                        (for-each
                          (lambda (elem)
                            (if (and (list? elem) (! eq? (car elem) '*PI*))
                              (_break elem)
                              )
                            )
                          (cdr (sxml:body sxml))
                          )
                        '()
                        )
        (let-keywords options ((no-wrap #f) (contain-root #t))
          (let1 data (if contain-root root (cdr root))
            (if no-wrap data
              (begin
                (make <sxml> :namespace (slot-ref sxml'namespace)
                      :body data :delete-ns-prefix #f)
                )
              )
            )
          )
        )
      ]
    )
  )

; =change-symbol
; ---------------------------------
(define (change-symbol fn . syms)
  (case (length syms)
    [(0)
     '()
     ]
    [(1)
     (string->symbol (fn (symbol->string (car syms))))
     ]
    [else
      (map (lambda (x) (string->symbol
                         (fn (symbol->string x))))
           syms)
      ]
    )
  )

; =sxpath
; ---------------------------------
(define-method sxpath ((sxml <sxml>) (path <pair>))
  (let1 ls ((sxpath path) (sxml:body sxml))
    (r fold
       (lambda (x res)
         (cons (make <sxml> :body x :ignore-case (slot-ref sxml'ignore-case)) res)
         ) '() ls)
    )
  )

; =sxml:name
; ---------------------------------
(define-method sxml:name ((sxml <sxml>) . options)
  (let-keywords options ((ignore-case #t))
    (if (list? (sxml:body sxml))
      (if ignore-case (change-symbol string-downcase (car (sxml:body sxml))) (car (sxml:body sxml)))
      #f
      )
    )
  )
(define-method sxml:name ((sxml <pair>) . options)
  (apply sxml:name (cons (car sxml) options))
  )

; =sxml:value
; ---------------------------------
(define-method sxml:value ((sxml <sxml>))
  (if (>= (length (sxml:body sxml)) 2)
    (cadr (sxml:body sxml))
    #f
    )
  )
(define-method sxml:value ((sxml <pair>))
  (sxml:value (car sxml))
  )

; =sxml:attr-names
; ---------------------------------
(define-method sxml:attr-names ((sxml <sxml>))
  (let1 attrs (sxml:attr-list-node (sxml:body sxml))
    (r fold (lambda (att res)
              (cons (car att) res)
              ) '() (cdr attrs))
    )
  )
(define-method sxml:attr-names ((sxml <pair>))
  (sxml:attr-names (car sxml))
  )

; =sxml:attr-hash*
; ---------------------------------
(define-method sxml:attr-hash* ((sxml <sxml>))
  (let ((attrs (sxml:attr-list-node (sxml:body sxml)))
        (hs (make-hash-table*))
        )
    (for-each (lambda (att)
                (when (= 2 (length att))
                  (hs (first att) (second att))
                  )
                ) (cdr attrs))
    hs
    )
  )
(define-method sxml:attr-hash* ((sxml <pair>))
  (sxml:attr-hash* (car sxml))
  )

; =sxml:attr
; ---------------------------------
(define-method sxml:attr ((sxml <sxml>) (name <symbol>) . options)
  (let-keywords options ((ignore-case #t))
    (let1 res (sxml:attr (sxml:body sxml) name)
      (cond
        [ignore-case
          (if res res (sxml:attr (sxml:body sxml) (change-symbol string-downcase name)))
          ]
        [else
          res
          ]
        )
      )
    )
  )
(define-method sxml:attr ((sxml <pair>))
  (sxml:attr (car sxml))
  )

; =delete-sxml-namespace
; ---------------------------------
(define (delete-sxml-namespace sxml)
  (pre-post-order
    sxml
    `((*text* . ,(lambda (trigger x) x))
      (*default* . ,(lambda x
                      (rxmatch-cond
                        ((rxmatch #/http\:\/\/\S+:(.+)/ (symbol->string (car x)))
                         (#f name)
                         (sxml:change-name x (string->symbol (string-downcase name)))
                         )
                        (else x)
                        )
                      )
                 )
      )
    )
  )


; =file->sxml
; ---------------------------------
(define (file->sxml filename)
  (make <sxml> :file filename)
  )

; =string->sxml
; ---------------------------------
(define (string->sxml str)
  (make <sxml> :string str)
  )

; =port->sxml
; ---------------------------------
(define (port->sxml port)
  (make <sxml> :port port)
  )

; =uri->sxml
; ---------------------------------
(define (uri->sxml uri)
  (make <sxml> :uri uri)
  )

; =sxml?
; ---------------------------------
(define (sxml? obj)
  (eq? (class-of obj) <sxml>)
  )

(provide "simply/sxml")