#!/usr/bin/guile
!#

(use-modules (ice-9 ftw) (sph cli)
  (sph list) (sph hashtable)
  (srfi srfi-1)
  (sph) (sph alist)
  (sph string) (sph io)
  (rnrs sorting)
  (sph other) (sph list other) (sph lang itpn) (ice-9 match) (sph lang indent-syntax))

(define program-description "indent packet notation filter and transformer")

(define command-line-interface
  (cli-create #:help program-description
    #:options
    (q (((file-paths ...))
        (search #:names #\s
          #:value-required? #t
          #:description
          "search in the prefix part of itpn packets. conditions like word,word.~word.word are supported, where comma is \"or\", period is \"and\" and tilde is \"not\"")
        (search-suffix #:value-required? #t) (search-all #:names #\a #:value-required? #t)
        (sort-tags)
        (replace-tag #:value-required? #t
          #:description "value format: \"tags-to-replace replacements\" \"tag[.tag] tag[.tag]\"")
        (replace-tags-from-file #:value-required? #t
          #:description
          "takes a path to a file that contains lines in the format \"tag replacement ...\"")
        (add-file-name-tags)
        (split #:description
          "split into matches and non-matches. output-file-1 receives matches, output-file-2 non-matches, and if any of those is not specified output is written to standard output")
        (output-to-source #:description
          "overwrite source files when output would otherwise be written to standard-output")
        (output-file-1 #:value-required? #t #:description "path for a file to write matches to")
        (output-file-2 #:value-required? #t #:description "path for a file to write non-matches to")
        (format #:value-required? #t
          #:description
          "prefix/suffix/filename. comma-separated names of block parts to display. default: prefix,suffix")
        (exclude #:names #\e) (syntax-check #:names #\c)
        (list-unique-tags) (sort-packets) (deduplicate) (count)))))

(define (create-indent size) (list->string (make-list (* size 2) #\space)))

(define (rw-port->port read write port port-2)
  (let loop ((e (read port))) (if (eof-object? e) e (begin (write e port-2) (loop (read port))))))

(define (ht-associate-words! hashtable string)
  "hashtable string ->
   creates a hashtable entry from a string in format \"key value ...\".
   create hashtable entry from space separated words in string"
  (let (string (string-split string #\space)) (ht-set! hashtable (first string) (tail string))))

(define (key-values-table-merge-from-port! port ht)
  "port hashtable -> hashtable
   see key-values-table-from-port"
  (port-lines-each (l (line) (ht-associate-words! ht line)) port))

(define (key-values-table-from-port port)
  "port [hashtable] -> hashtable
   read from port to create a hashtable from a string with lines in the format \"key value ...\"
   example use case: configuration files for string pattern replacements"
  (let (r (ht-create-string)) (port-lines-each (l (line) (ht-associate-words! r line)) port) r))

(define (key-values-table-from-file path)
  (call-with-input-file path (l (a) (key-values-table-from-port a))))

(define (key-values-table-merge-from-file! path ht)
  (call-with-input-file path (l (a) (key-values-table-merge-from-port! a ht))))

(define (rw-file->port read write path port)
  (call-with-input-file path (l (file-port) (rw-port->port read write file-port port))))

(define* (rw-file-indirect->file read write path-1 #:optional (path-2 path-1))
  "like rw-port->file but takes a path for reading from an input file"
  (temp-file-port->file (l (port-output) (rw-file->port read write path-1 port-output)) path-2))

(define (cli-parse-replace-tag a) "string:\"tag[,tag ...] tag[,tag ...]\" -> (old new)"
  (apply
    (l* (tags #:optional replacements)
      (pair (string-split tags #\,) (if replacements (string-split replacements #\,) null)))
    (string-split a #\space)))

(define (itpn-packet-map-tag-list proc packet)
  (map-first (l (a) (string-join (proc (string-split a #\space)) " ")) packet))

(define (itpn-packet-map-tags proc packet) (itpn-packet-map-tag-list (l (a) (map proc a)) packet))

(define (create-parsed-itpn-processors arguments) "alist -> (procedure ...)"
  (alist-bind arguments
    (search search-all search-suffix
      sort-tags exclude
      sort-packets add-file-name-tags replace-tag replace-tags-from-file split extract deduplicate)
    (compact
      (list
        (and add-file-name-tags
          (l (a path)
            (if (string? path)
              (let
                (file-name-prefix (string-join (string-split (basename path) #\.) " " (q suffix)))
                (map (l (a) (pair (string-append file-name-prefix (first a)) (tail a))) a))
              a)))
        (and replace-tag
          (apply
            (l (old . new)
              (l (a path)
                (map
                  (l (packet)
                    (itpn-packet-map-tag-list
                      (l (a)
                        (let
                          (a
                            (if (contains-some? a old)
                              (delete-duplicates (append (complement a old) new)) a))
                          (if (null? a) (list "other") a)))
                      packet))
                  a)))
            (cli-parse-replace-tag replace-tag)))
        (and (string? replace-tags-from-file)
          (let (table (key-values-table-from-file replace-tags-from-file))
            (l (a path)
              (map
                (l (packet)
                  (itpn-packet-map-tag-list
                    (l (a) (delete-duplicates (flatten (list-replace-from-hashtable a table))))
                    packet))
                a))))
        (and sort-tags (l (a path) (itfpn-tags-sort a string<?)))
        (and deduplicate (l (a path) (delete-duplicates a)))
        ; an optimisation could be possible here by evaluating the search before other processors. questions are
        ; if the search should run after replace and what happens when the list is split into matches and non-matches
        (and (or search search-suffix search-all split)
          (let
            ( (matchers
                (map (l (a) (and a (parse-search a))) (list search search-suffix search-all))))
            (l (parsed-itpn path)
              (let
                (partition-select (if exclude (if split reverse second) (if split identity first)))
                (partition-select (apply itpn-search parsed-itpn matchers))))))))))

(define (list-logical-string-contains? a condition)
  (list-logical-match (l (b) (string-contains a b)) condition))

(define (itpn-search parsed-itpn prefix suffix all)
  "list list:list-logical-match-condition ... -> (matches non-matches)
   filter itpn-packets by list-logical-match conditions"
  (apply-values list
    (partition
      (l (a)
        (and (or (not prefix) (list-logical-string-contains? (first a) prefix))
          (or (not suffix)
            (list-logical-string-contains? (string-join (flatten (tail a)) " ") suffix))
          (or (not all) (list-logical-string-contains? (string-join (flatten a) " ") all))))
      parsed-itpn)))

(define parse-search
  (letrec
    ( (split-words
        (l (a char)
          "string character -> list
          split by char and replace multiple occurences of char with a single occurence so that
          escaping and using the char in any of the words is still possible"
          (map (l (a) (if (string-null? a) (string-append (string char) a) a))
            (string-split a char))))
      (parse-words
        (l (words names chars unary)
          (if (null? names) words
            (fold-right
              (l (a result)
                (let
                  (words
                    (parse-words (split-words a (first chars)) (tail names)
                      (tail chars) (tail unary)))
                  (if (< 1 (length words))
                    (if (first unary)
                      (pairs (first words) (pair (first names) (tail words)) result)
                      (pair (pair (first names) words) result))
                    (append words result))))
              null words)))))
    (l (a)
      "string -> list-logical-condition
      parse search expressions into a list-logical-match condition.
      words can be separated by any of the characters \",.~\".
      comma: or, period: and, tilde: not.
      priority is or, and, not.
      a.b.c,d~f~g,h
      ->
      (and (or (and \"a\" \"b\" \"c\") (and \"d\" (not \"f\" \"g\")) \"h\"))"
      (pair (q and)
        (parse-words (list a) (q (or and not)) (q (#\, #\. #\~)) (q (#f #f #t)))))))

(define (get-all-itpn-from-standard-input) (read-indent-tree->prefix-tree (current-input-port)))

(define (get-all-itpn-from-file-path path)
  (call-with-input-file path (l (port) (read-indent-tree->prefix-tree port))))

(define (itpn-contains-empty-line? parsed-itpn) (contains? parsed-itpn ""))
(define (itpn-empty-line-first-index parsed-itpn) (list-index-value parsed-itpn ""))

(define (create-error-data file-name packet-number other)
  (compact
    (list "empty-line" (and file-name (string-append "file: " (string-quote file-name)))
      (and packet-number (string-append "packet: " (number->string packet-number))) (and other))))

(define (check-for-parse-errors& parsed-itpn path c)
  (if (string? parsed-itpn)
    (raise (list (q syntax-invalid) (create-error-data path #f parsed-itpn)))
    (let (empty-line-index (itpn-empty-line-first-index parsed-itpn))
      (if empty-line-index
        (raise (list (q syntax-invalid) (create-error-data path empty-line-index #f))) (c)))))

(define (format-error-data a) (if (list? a) a (any->string a)))

(define (file-system-fold-error name stat errno result)
  (format (current-error-port) "warning: ~a: ~a~%" name (strerror errno)))

(define (file-system-fold-identity name stat result) result)

(define (file-system-fold* enter? leaf down up skip error init paths)
  "procedure procedure procedure procedure procedure procedure any (string ...) -> any
   maps paths with calls to file-system-fold. stops on error"
  (first
    (fold-multiple-c
      (l (path continue r)
        (let (r-new (file-system-fold enter? leaf down up skip error r path)) (continue r-new)))
      paths init)))

(define (input-handler-proc arguments)
  (alist-bind arguments (list-unique-tags split syntax-check)
    (let*
      ( (parsed-itpn-processors (create-parsed-itpn-processors arguments))
        (apply-processors
          (l (parsed-itpn path)
            (fold (l (processor r) (processor r path)) parsed-itpn parsed-itpn-processors)))
        (with-type-and-result-creator
          (l (c)
            (cond
              (syntax-check (c (q syntax-check) (l (parsed-itpn path) (list #t))))
              (list-unique-tags (c (q unique-tags) (l (parsed-itpn path) (itfpn-tags parsed-itpn))))
              (split (c (q split) apply-processors))
              (else (c (q parsed-itpn) apply-processors))))))
      (l (paths process-one)
        "(string ...) procedure:{parsed-itpn -> any} -> any
        manages and accesses input resources and processing"
        (with-type-and-result-creator
          (l (type create-result)
            (if paths
              (let (inaccessible-path (find (negate file-exists?) paths))
                (if inaccessible-path
                  (raise (list (q inaccessible-path) (q itpn) (pair "path" inaccessible-path)))
                  (pair type
                    (file-system-fold* (l (path stat r) #t)
                      (l (path stat r)
                        (let
                          (r-one
                            (process-one (get-all-itpn-from-file-path path) path create-result))
                          (pair r-one r)))
                      file-system-fold-identity file-system-fold-identity
                      file-system-fold-identity file-system-fold-error (list) paths))))
              (list type
                (process-one (get-all-itpn-from-standard-input) "standard-input" create-result)))))))))

(define (arguments->formats& arguments c)
  "list {show-file? show-prefix? show-suffix? -> any} -> any"
  (let (format (alist-ref-q arguments format))
    (if format
      (let (format (string-split format #\,))
        (apply c (map (l (a) (contains? format a)) (list "filename" "prefix" "suffix"))))
      (c #f #t #t))))

(define (process-one-proc arguments)
  "alist -> any
   creates a result for one list of parsed-itpn packets (for example read from the contents of a file or standard-input)"
  (l (parsed-itpn path create-result)
    "list string/symbol -> (symbol:mode-prefix string/symbol:path result-data ...)"
    (check-for-parse-errors& parsed-itpn path
      (nullary (pair path (create-result parsed-itpn path))))))

(define (result-map-data proc a) "procedure list -> list"
  (pair (first a) (map-apply (l (filename . data) (pair filename (proc data))) (tail a))))

(define (result? a) (match a (((? symbol? type) ((? string? path) data ...) ...) #t) (_ #f)))
(define (result->data a) (apply append (map (l (a) (tail a)) (tail a))))

(define (process-after-proc arguments)
  (let
    ( (list-unique-tags? (alist-ref-q arguments list-unique-tags))
      (sort-packets? (alist-ref-q arguments sort-packets)))
    (l (result) "list -> list"
      (let (type (first result))
        (cond
          ( (eq? (q unique-tags) type)
            (pair type (list-sort string<? (delete-duplicates (result->data result)))))
          (sort-packets?
            (case type
              ((parsed-itpn) (result-map-data (l (a) (itpn-packets-sort a string<?)) result))
              ( (split)
                (result-map-data (l (a) (map (l (packets) (itpn-packets-sort packets string<?)) a))
                  result))))
          (else result))))))

(define (display-parsed-itpn-one port path a show-file? show-prefix? show-suffix?)
  (let*
    ( (indent-level 0)
      (indent-level
        (if (and show-file? (not (null? a)) (string? path))
          (begin (display-line path port) (+ 1 indent-level)) indent-level))
      (indent-1 (create-indent indent-level)) (indent-2 (create-indent (+ 1 indent-level))))
    (each
      (l (packet)
        (let
          (indent-level
            (if show-prefix?
              (begin (display-line (string-append indent-1 (first packet)) port) (+ 1 indent-level))
              indent-level))
          (if show-suffix?
            (display-line (prefix-tree->indent-tree (tail packet) indent-level) port))))
      a)))

(define (output-handler-proc arguments) "list list ->"
  (alist-bind arguments (output-file-1 output-file-2 output-to-source count)
    (let*
      ( (call-with-output-port
          (l (file indirect? c)
            (if indirect?
              (if file (rw-file-indirect->file port->string c file) (c (current-output-port)))
              (if file (call-with-output-file file c) (c (current-output-port))))))
        (call-with-output-ports
          (l (data proc)
            (if output-to-source
              (call-with-output-port (or output-file-1 output-file-2) #f
                (l (port-other)
                  (map-apply
                    (l (path . a)
                      (call-with-output-port path #t
                        (l (port-source)
                          ; output-file-1 is mapped to take matches, output-file-2 takes non-matches
                          (if output-file-1 (apply proc port-other port-source path a)
                            (apply proc port-source port-other path a)))))
                    data)))
              (call-with-output-port output-file-1 #f
                (l (port-1)
                  (call-with-output-port output-file-2 #f
                    (l (port-2) (map-apply (l a (apply proc port-1 port-2 a)) data)))))))))
      (arguments->formats& arguments
        (l (show-file? show-prefix? show-suffix?)
          (l (result)
            (apply
              (l (type . data)
                (case type
                  ( (parsed-itpn)
                    (if count (display-line (length (apply append data)))
                      (if output-to-source
                        (map-apply
                          (l (path . data)
                            (call-with-output-port path #t
                              (l (port)
                                (display-parsed-itpn-one port path
                                  data show-file? show-prefix? show-suffix?))))
                          data)
                        (call-with-output-port output-file-1 #f
                          (l (port)
                            (map-apply
                              (l (path . data)
                                (display-parsed-itpn-one port path
                                  data show-file? show-prefix? show-suffix?))
                              data))))))
                  ( (split)
                    (call-with-output-ports data
                      (l (port-matches port-non-matches path packets-matching packets-not-matching)
                        (display-parsed-itpn-one port-matches path
                          packets-matching show-file? show-prefix? show-suffix?)
                        (display-parsed-itpn-one port-non-matches path
                          packets-not-matching show-file? show-prefix? show-suffix?))))
                  ((unique-tags) (if count (display-line (length data)) (each display-line data)))
                  (else (display-line result))))
              result)))))))

(define (result-handler arguments a process-after output-handler) "list list -> [list]"
  (cond
    ((null? a) (exit 0))
    ( (result? a)
      (case (first a)
        ((syntax-check) (exit (if (every identity (tail (tail a))) 0 1)))
        ((parsed-itpn split unique-tags) (output-handler (process-after a)))))
    (else (raise (q invalid-internal-result-format)))))

(define (itpn-filter-cli)
  (let (arguments (command-line-interface))
    (result-handler arguments
      ( (input-handler-proc arguments) (alist-ref-q arguments file-paths)
        (process-one-proc arguments))
      (process-after-proc arguments) (output-handler-proc arguments))))

(itpn-filter-cli)