#!/usr/bin/env guile
!#

(use-modules (srfi srfi-1) (sph)
  (srfi srfi-41) (sph stream)
  (ice-9 match) (sph lang sc)
  (srfi srfi-2) (sph lang scheme)
  ((sph filesystem) #:select (path->full-path ensure-trailing-slash)) (sph alist)
  (sph list) (sph cli) (sph list other) (sph string) (rnrs sorting))

(define sph-sc-documentor-cli-description
  "extracts declarations from sc files and displays an overview in markdown format")

(define sph-sc-documentor-description
  "command-line interface: sc-documentor --help.
   identifiers created through preprocessor concatenatation are not included.
   it is possible to add them using a configuration file with --config.
   # data structures
   sc-doc-elements: (sc-doc-element ...)
   sc-doc-element: (symbol:type any ...)
   # extractors
   extractors match sc expression list-prefixes and return an sc-doc-element,
   for example \"('function' name parameters output-type input-type)\".
   there is no user extension mechanism yet. new extractors must be added to \"extractors\".
   new sc-doc-element types can be used but sc-format-group would
   have to be extended to recognise them")

(define (extract-enum a) (list (pair (q enum) a)))

(define (extract-define-body-docstring a)
  (if (or (null? a) (not (string? (first a)))) #f (first a)))

(define (extract-pre-define-value-docstring a)
  (match a ((begin (? string? docstring) value _ ...) docstring) (_ #f)))

(define (extract-define a) "-> ('function' name parameters output-type input-type docstring)"
  (match a
    ( ( ( (? sc-not-preprocessor-keyword? name) parameter ...)
        ((? sc-not-function-pointer-symbol? return-type) types ...) body ...)
      (list
        (list (q function) name parameter return-type types (extract-define-body-docstring body))))
    ( ( ( (? sc-not-preprocessor-keyword? name)) return-type body ...)
      (list (list (q function) name null return-type null (extract-define-body-docstring body))))
    (((? symbol? name) type value) (list (list (q variable) name type))) (else #f)))

(define (extract-declare-type a) "-> (type symbol:other/struct/union/function name [value])"
  (match a
    ((name ((quote function-pointer) body ...)) (list (q type) (q function) name (second a)))
    ((name ((quote struct) body ...)) (list (q type) (q struct) name (second a)))
    ((name ((quote union) body ...)) (list (q type) (q union) name (second a)))
    ((name _ ...) (list (q type) (q other) name (second a)))))

(define (extract-declare-array a) "-> (array name type (integer ...))"
  (match a
    ((name type size values ...) (let (size (any->list size)) (list (q array) name type size)))))

(define (extract-declare-variable id type) (if (symbol? id) (list (q variable) id type) #f))

(define (extract-declare a)
  "-> sc-doc-elements
   sc-doc-elements contains any of the following sc-doc-element types
     function, type, (variable name output-type), (enum names ...),
     (struct name fields), (union name fields)"
  (compact
    (map-slice 2
      (l (id type)
        (match type (((quote array) a ...) (extract-declare-array (pair id a)))
          (((quote enum) a ...) (first (extract-enum a)))
          ( ( (or (quote struct) (quote union)) (not (? symbol?)) _ ...)
            (list (first type) id (second type)))
          (((quote type) type) (extract-declare-type (list id type)))
          ((quote struct) (list (q struct) id #f))
          (_
            (let (b (extract-define (list id type)))
              (if b (first b) (extract-declare-variable id type))))))
      a)))

(define (extract-pre-define a) "-> ((macro name list:parameters) ...)"
  (if (= 1 (length a)) (list (list (q macro) (first a) null #f))
    (map-slice 2
      (l (name value)
        (let (docstring (extract-pre-define-value-docstring value))
          (match name ((name parameter ...) (list (q macro) name parameter docstring))
            (_ (list (q macro) name null docstring)))))
      a)))

"commenting them here removes them from output"

(define extractors
  (alist-q enum extract-enum
    pre-define extract-pre-define
    pre-define-if-not-defined extract-pre-define define extract-define declare extract-declare))

(define (extract-one a)
  "list -> sc-doc-elements
   take an sc expression and try to extract documentation relevant information
   using prefixes and procedures defined in \"extractors\""
  (any
    (l (extractor)
      (and (not (null? a)) (eq? (first extractor) (first a)) ((tail extractor) (tail a))))
    extractors))

(define (remove-begin a) (match a (((quote begin) a ...) a) (else (list a))))

(define (extract-from-file path) "string -> sc-doc-elements"
  (stream-fold
    (l (result a)
      (let
        (a
          (match a
            ( ( (quote sc-include) paths ...)
              (let
                (load-paths
                  (pair (ensure-trailing-slash (dirname (path->full-path path)))
                    (sc-default-load-paths)))
                (append-map (l (b) (extract-from-file (sc-path->full-path load-paths b))) paths)))
            (else (let (matched (extract-one a)) (or matched null)))))
        (append result a)))
    null (file->stream path read)))

(define (extract-from-files-combined paths)
  "extract from multiple files and display a merged result" (append-map extract-from-file paths))

(define group-order (q (function macro variable type enum)))

(define (group-title id md-level)
  (string-append (if (< 0 md-level) (string-append (string-multiply "#" md-level) " ") "")
    (case id
      ((type) "types")
      ((enum) "enum")
      ((function) "functions")
      ((macro) "macros")
      ((variable) "variables"))))

(define (format-docstring a)
  (string-append (string-join (map string-trim (string-split a #\newline)) "\n  " (q prefix)) "\n"))

(define (format-group-element id a with-docstrings)
  (case id
    ( (macro)
      (apply
        (l (name parameters docstring)
          (string-append (sc-identifier name)
            (if (null? parameters) ""
              (string-append "(" (string-join (map sc-identifier parameters) ", ") ")"))
            (if (and with-docstrings docstring) (format-docstring docstring) "")))
        (tail a)))
    ( (function)
      (apply
        (l (name parameters type-out type-in docstring)
          (string-append (sc-identifier name) " ::"
            (if (null? parameters) ""
              (string-join
                (map
                  (l (arg-type arg-name)
                    (string-append (sc-identifier arg-type) ":" (sc-identifier arg-name)))
                  type-in parameters)
                " " (q prefix)))
            " -> " (sc-identifier type-out)
            (if (and with-docstrings docstring) (format-docstring docstring) "")))
        (tail a)))
    ((variable) (apply (l (name type) (string-append (sc->c type) " " (sc->c name))) (tail a)))
    ( (enum)
      (let*
        ( (a (tail a)) (name (and (symbol? (first a)) (symbol->string (first a))))
          (fields (if (symbol? (first a)) (second a) (first a))))
        (string-append (if name (string-append name ": ") "")
          (string-join (map-slice 3 (l a (string-join (map sc-identifier a) " ")) fields) "\n  "))))
    ( (function-pointer)
      (match (tail a)
        ( (output-type input-types ...)
          (string-append (string-join (map sc-identifier input-types) " ") " -> "
            (sc-identifier output-type)))))
    ( (struct union)
      (let*
        ( (name-and-fields
            (match (tail a) (((? symbol? name) field ...) (pair name field)) (a (pair #f a))))
          (name (first name-and-fields)) (fields (tail name-and-fields)))
        (apply string-append (symbol->string id)
          (if name (string-append " " (sc-identifier name)) "")
          (map-apply
            (l (field-name field-type)
              (string-append "\n  " (sc-identifier field-name) ": " (sc-identifier field-type)))
            fields))))
    (else "")))

(define (format-group-type a with-docstrings) "format an sc-doc-element group for declared c types"
  (apply append
    (filter-map
      (l (sub-type)
        (and-let* ((sub-group (alist-ref a sub-type)))
          (map
            (l (a)
              (let (id-string (sc-identifier (first a)))
                (case sub-type
                  ( (struct union)
                    (string-append id-string ": "
                      (format-group-element sub-type (second a) with-docstrings)))
                  ( (function)
                    (string-append id-string ": "
                      (format-group-element (q function-pointer) (second a) with-docstrings)))
                  ((other) (string-append id-string ": " (sc-identifier (second a))))
                  (else id-string))))
            (list-sort-with-accessor string<? (compose symbol->string first)
              (map (compose tail tail) sub-group)))))
      (q (other function union struct)))))

(define (format-group id a with-docstrings)
  (case id
    ((type) (format-group-type a with-docstrings))
    ( (function)
      (map (l (a) (format-group-element id a with-docstrings))
        (list-sort-with-accessor string<? (compose symbol->string second) a)))
    (else (list-sort string<? (map (l (a) (format-group-element id a with-docstrings)) a)))))

(define (extracted-identifier-replace a identifier-replacements)
  "(string:regexppattern string:replacement [string:pattern string:replacement] ...)
   replace any identifier by regexp"
  (let
    (replace
      (let
        (b
          (map (l (a) (pair (make-regexp (first a)) (tail a)))
            (list->alist identifier-replacements)))
        (l (a)
          (if (symbol? a)
            (string->symbol
              (fold (l (b result) (regexp-replace result (first b) (tail b))) (symbol->string a) b))
            a))))
    (map
      (l (a)
        (case (first a)
          ( (macro)
            (apply
              (l (name parameters docstring)
                (list (q macro) (replace name) (map replace parameters)))
              (tail a)))
          ( (function)
            (apply
              (l (name parameters type-out type-in docstring)
                (list (q function) (replace name)
                  (map replace parameters) (replace type-out) (map replace type-in)))
              (tail a)))
          ( (variable)
            (apply (l (name type-out) (list (q variable) (replace name) (replace type-out)))
              (tail a)))
          ( (type)
            (let (sub-type (second a))
              (pair (q type)
                (case sub-type
                  ( (struct)
                    (match (tail a)
                      ( ( (quote struct) name ((quote struct) struct-body ...))
                        (list (q struct) name
                          (pair (q struct)
                            (map
                              (l (a)
                                (if (symbol? a) (replace a)
                                  (pairs (first a) (replace (second a)) (tail (tail a)))))
                              struct-body))))
                      (else a)))
                  ((other) (apply list sub-type (map replace (tail (tail a)))))
                  (else (tail a))))))
          (else a)))
      a)))

(define (extracted-exclude a exclusions) "(string:regexp-pattern)"
  (let
    (exclusions?
      (let (exclusions (map make-regexp exclusions))
        (l (a) "string -> booloean" (any (l (b) (regexp-exec b a)) exclusions))))
    (filter
      (l (a)
        (let
          (name
            (case (first a)
              ((macro variable function) (symbol->string (second a)))
              ((type) (symbol->string (list-ref a 2)))
              (else #f)))
          (not (and name (exclusions? name)))))
      a)))

(define (get-config path) "string -> alist" (if path (file->datums path) null))

(define (apply-config-add extracted config)
  (let (a (alist-ref config (q add)))
    (if a (append extracted (apply append (filter-map extract-one a))) extracted)))

(define (apply-config-remove extracted config)
  (let (a (alist-ref config (q remove))) (if a (extracted-exclude extracted a) extracted)))

(define (apply-config-replace extracted config)
  (let (a (alist-ref config (q replace)))
    (if a (extracted-identifier-replace extracted a) extracted)))

(define (display-markdown grouped md-level with-docstrings)
  (display-line
    (string-join
      (filter-map
        (l (group-id)
          (and-let*
            ((a (alist-ref grouped group-id)) (a (if (eq? (q type) group-id) (group a second) a)))
            (string-append (group-title group-id md-level) "\n"
              "~~~\n" (string-join (format-group group-id a with-docstrings) "\n") "\n~~~")))
        group-order)
      "\n\n")))

(define (sc-documentor-cli)
  (let*
    ( (options
        ( (cli-create #:options
            (q
              ( ( (sc-file-path ...) #:required? #t #:value-required? #t)
                (config #:value-required? #t)
                (md-level #:value-required? #t #:description "markdown heading level, 1..n")
                (with-docstrings)))
            #:description sph-sc-documentor-cli-description)))
      (config (get-config (alist-ref options (q config))))
      (extracted (extract-from-files-combined (alist-ref options (q sc-file-path))))
      (extracted
        (apply-config-replace (apply-config-remove (apply-config-add extracted config) config)
          config))
      (grouped (group extracted first)) (with-docstrings (alist-ref options (q with-docstrings)))
      (md-level (let (a (alist-ref options (q md-level))) (if a (string->number a) 1))))
    (display-markdown grouped md-level with-docstrings)))

(sc-documentor-cli)