(define-module (mecab mecab)

  #:use-module (bytestructures guile)

  #:use-module (ice-9 match)

  #:use-module (mecab configuration)

  #:use-module (rnrs bytevectors)

  #:use-module ((system foreign) #:select

                                 (pointer->procedure pointer->string string->pointer

                                  bytevector->pointer pointer->bytevector

                                  pointer-address make-pointer

                                  sizeof %null-pointer))

  #:use-module ((system foreign) #:prefix foreign:)

  #:export (mecab-version

            mecab-new-tagger

            mecab-error

            mecab-parse

            mecab-parse-to-str

            mecab-destroy

            node-next

            node-prev

            node-feature

            node-surface

            node-stat

            MECAB_NOR_NODE MECAB_UNK_NODE MECAB_BOS_NODE MECAB_EOS_NODE MECAB_EON_NODE

            mecab-split

            mecab-features

            mecab-words))

(define (make-double-pointer)

  (bytevector->pointer (make-bytevector (sizeof '*))))

(define (mecab->procedure return name params)

  (let ((ptr (dynamic-func name (dynamic-link %libmecab))))

    (pointer->procedure return ptr params)))

(define mecab-version

  (let ((proc (mecab->procedure '* "mecab_version" '())))

    (lambda ()

      (pointer->string (proc)))))

(define mecab-new-tagger

  (let ((proc (mecab->procedure '* "mecab_new" `(,foreign:int *))))

    (lambda (options)

      (let* ((options (map string->utf8 (cons "mecab" options)))

             (bv (make-bytevector (* (sizeof '*) (+ (length options) 1)) 0)))

        (cond

          ((= (sizeof '*) 4)

           (let loop ((i 0) (options options))

             (match options

               (() #t)

               ((option options ...)

                (bytevector-u32-set! bv (* 4 i) (pointer-address (bytevector->pointer option)) (native-endianness))

                (loop (+ i 1) options)))))

          ((= (sizeof '*) 8)

           (let loop ((i 0) (options options))

             (match options

               (() #t)

               ((option options ...)

                (bytevector-u64-set! bv (* 8 i) (pointer-address (bytevector->pointer option)) (native-endianness))

                (loop (+ i 1) options)))))

          (else (throw 'unsupported-pointer-size (sizeof '*))))

        (proc (length options)

              (bytevector->pointer bv))))))

(define mecab-error

  (let ((proc (mecab->procedure '* "mecab_strerror" '(*))))

    (lambda (tagger)

      (pointer->string (proc tagger)))))

(define %mecab-path

  (bs:pointer

    (delay (bs:struct

             `((rnode ,%mecab-node)

               (rnext ,%mecab-path)

               (lnode ,%mecab-node)

               (lnext ,%mecab-path)

               (cost ,int)

               (prob ,float))))))

(define %mecab-node

  (bs:pointer

    (delay (bs:struct

             `((prev ,%mecab-node)

               (next ,%mecab-node)

               (enext ,%mecab-node)

               (bnext ,%mecab-node)

               (rpath ,%mecab-path)

               (lpath ,%mecab-path)

               (surface ,(bs:pointer uint8)); char *, not 0-terminated, use length

               (feature ,cstring-pointer)

               (id ,unsigned-int)

               (length ,unsigned-short)

               (rlength ,unsigned-short)

               (rcattr ,unsigned-short)

               (lcattr ,unsigned-short)

               (posid ,unsigned-short)

               (chartype ,uint8)

               (stat ,uint8)

               (isbest ,uint8)

               (alpha ,float)

               (beta ,float)

               (prob ,float)

               (wcost ,short)

               (cost ,long))))))

(define mecab-parse

  (let ((proc (mecab->procedure '* "mecab_sparse_tonode" '(* *))))

    (lambda (tagger str)

      (bytestructure-ref

        (bytestructure

          %mecab-node

          (pointer-address (proc tagger (string->pointer str))))

        '*))))

(define mecab-parse-to-str

  (let ((proc (mecab->procedure '* "mecab_sparse_tostr" '(* *))))

    (lambda (tagger str)

      (pointer->string (proc tagger (string->pointer str))))))

(define mecab-destroy

  (let ((proc (mecab->procedure foreign:void "mecab_destroy" '(*))))

    (lambda (tagger)

      (proc tagger))))

(define MECAB_NOR_NODE 0)

(define MECAB_UNK_NODE 1)

(define MECAB_BOS_NODE 2)

(define MECAB_EOS_NODE 3)

(define MECAB_EON_NODE 4)

(define (node-feature node)

  (bytestructure-ref node 'feature))

(define (node-surface node)

  (let* ((surface (bytestructure-ref node 'surface))

         (len (bytestructure-ref node 'length))

         (pointer (make-pointer surface))

         (bv (pointer->bytevector pointer len))

         (str (make-bytevector (+ (bytevector-length bv) 1))))

    (bytevector-copy! bv 0 str 0 (bytevector-length bv))

    (bytevector-u8-set! str (bytevector-length bv) 0)

    (pointer->string (bytevector->pointer str))))

(define (node-next node)

  (bytestructure-ref node 'next '*))

(define (node-prev node)

  (bytestructure-ref node 'prev '*))

(define (node-stat node)

  (bytestructure-ref node 'stat))

(define (mecab-split tagger str)

  (let ((bos-node (mecab-parse tagger str)))

    (let loop ((node (node-next bos-node)) (surfaces '()))

      (if (= (node-stat node) MECAB_EOS_NODE)

          (reverse surfaces)

          (loop (node-next node) (cons (node-surface node) surfaces))))))

(define (mecab-features tagger str)

  (let ((bos-node (mecab-parse tagger str)))

    (let loop ((node (node-next bos-node)) (surfaces '()))

      (if (= (node-stat node) MECAB_EOS_NODE)

          (reverse surfaces)

          (loop (node-next node) (cons (node-feature node) surfaces))))))

(define (mecab-words tagger str)

  (let ((bos-node (mecab-parse tagger str)))

    (let loop ((node (node-next bos-node)) (words '()))

      (cond

        ((= (node-stat node) MECAB_EOS_NODE) words)

        ((= (node-stat node) MECAB_NOR_NODE)

         ;; 動詞,自立,*,*,五段・ラ行,連用タ接続,当たる,アタッ,アタッ

         (match (string-split (node-feature node) #\,)

           ((gram1 gram2 gram3 gram4 gram5 gram6 dictionary read1 read2)

            (match gram1

              ("助動詞" (loop (node-next node) words))

              ("記号" (loop (node-next node) words))

              (_ (loop (node-next node) (cons dictionary words)))))))

        (else (loop (node-next node) words))))))