;;;; apropos-csi.scm  -*- Scheme -*-
;;;; Kon Lovett, Jul '18
;;;; Kon Lovett, Oct '17
;;;; Kon Lovett, Mar '09
;;;; From the Chicken 4 core, Version 4.0.0x5 - SVN rev. 13662

;; Issues
;;
;; - old csi option
;; ; {{search|mode pre[fix]|suff[ix]|#t}} : {{#:search-mode #:prefix|#:suffix|#t}}
;; ; {{SEARCH-MODE}} : Either {{#:prefix}}, {{#:suffix}}, or {{#t}} for contains. The default is {{#t}}.

(module apropos-csi ()

(import scheme
  (chicken base)
  (chicken fixnum)
  (chicken platform)
  (chicken io)
  (chicken port)
  (only (srfi 1) cons* reverse!)
  #; ;Warning: the following extensions are not currently installed: chicken.csi
  (only (chicken csi) toplevel-command)
  apropos-api)

(define-syntax apropos-toplevel-command
  (syntax-rules ()
    ((_ arg0 ...)
      (chicken.csi#toplevel-command arg0 ...) ) ) )

;;; Support

;; string extensions

(define (string-fixed-length x n #!optional (pad #\space) (tag "..."))
  (let ((rem (fx- n (string-length x))))
    (if (positive? rem)
      (string-append x (make-string rem pad))
      (string-append (substring x 0 (fx- n (string-length tag))) tag) ) ) )

;; Constants

(define-constant CSI-HELP-HEAD-WIDTH 18)

(define (csi-help-command-pad x)
  (string-fixed-length x CSI-HELP-HEAD-WIDTH) )

(define (csi-help cmd arg)
  (string-append (string-fixed-length cmd CSI-HELP-HEAD-WIDTH) arg) )

;rmvd ", raw, base [#]"
(define CSI-HELP
  (csi-help
    ",a PATT ARG..."
    "Apropos of PATT with ARG from ?, mac, qual, ci, sort nam|mod|typ|#f, split nam|mod|#f"))

(define-constant HELP-TEXT
#<<EOS
Pattern:

 The pattern PATT is a symbol, string, sre (see irregex), or quoted. Symbols &
 strings are interpreted as a substring match.

 The quoted PATT:

    '(PATT . PATT)  performs as if `PATT+PATT split module+name` worked.
    '(PATT . _)     synonym for `PATT split module`.
    '(_ . PATT)     synonym for `PATT split name`.
    '(_ . _)        synonym for `(: (* any))` or match any.

  '<atom>

    interpret `<atom>` as an irregex.

 Use "?" as a PATT to list symbols containing a `?`.

Arguments:

 macros            Include macro bound symbols
 qualified         Include "qualified" symbols
 ci | case-insensitive
                   Pattern has no capitals
 sort name | module | type | #f
                   Order items; optional when last argument
 split name | module | #f
                   Pattern match component; optional when last argument
                   (also see the '(_ . _) pattern)
 all               Means `ci qual mac`
 krl               Means `all sort mod`
 base              For number valued pattern
 raw               No listing symbol interpretation (i.e. x123 ~> x)
EOS
)

;;;
;;; REPL Integeration
;;;

(define (interp-split-arg loc arg)
  (case arg
    ((n nam name)     #:name )
    ((m mod module)   #:module )
    (else
      (if (not arg)
        #f
        (error-apropos-sort-key loc "unknown split key" arg) ) ) ) )

(define (interp-sort-arg loc arg)
  (case arg
    ((n nam name)     #:name )
    ((m mod module)   #:module )
    ((t typ type)     #:type )
    (else
      (if (not arg)
        #f
        (error-apropos-sort-key loc "unknown sort key" arg) ) ) ) )

(define (display-apropos-help)
  (print CSI-HELP)
  (print)
  (print HELP-TEXT) )

(define (parse-csi-apropos-arguments iargs)
  (let loop ((args iargs) (oargs '()))
    ;
    (define (restargs next optarg?)
      (cond
        ((null? next)
          '() )
        (optarg?
          (cdr next) )
        (else
          next ) ) )
    ;
    (define (arg-next kwd init #!optional optarg?)
      ;
      (define (thisargs next kwd init optarg?)
        (cond
          ((null? next)
            (cons* init kwd oargs) )
          (optarg?
            (cons* (optarg? (car next)) kwd oargs) )
          (else
            (cons* init kwd oargs) ) ) )
      ;
      (let* (
        (next (cdr args) )
        (args (restargs next optarg?) )
        (oargs (thisargs next kwd init optarg?) ) )
        ;
        (loop args oargs) ) )
    ;
    (if (null? args)
      ; original ordering
      (reverse! oargs)
      ;csi-apropos-syntax => keyword-apropos-syntax
      (let ((arg (car args)))
        (case arg
          ;
          ((krl)
            (loop
              (restargs (cons* 'all (cdr args)) #f)
              (cons* #:module #:sort oargs)) )
          ;
          ((all)
            (loop
              (restargs (cdr args) #f)
              (cons* #t #:case-insensitive? #t #:qualified? #t #:macros? oargs)) )
          ;
          ((mac macros)
            (arg-next #:macros? #t) )
          ;
          ((qual qualified)
            (arg-next #:qualified? #t) )
          ;
          ((ci case-insensitive)
            (arg-next #:case-insensitive? #t) )
          ;
          ((raw)
            (arg-next #:raw? #t) )
          ;
          ((base)
            (arg-next #:base (apropos-default-base) (cut check-apropos-number-base ',a <>)) )
          ;
          ((sort)
            (arg-next #:sort #:type (cut interp-sort-arg ',a <>)) )
          ;
          ((split)
            (arg-next #:split #f (cut interp-split-arg ',a <>)) )
          ;
          ((?)
            (loop '() '()) )
          ;
          (else
            (loop (cdr args) (cons arg oargs)) ) ) ) ) ) )

(define (csi-apropos-command)
  ;FIXME could be empty of args
  (let* (
    (cmdlin (read-line))
    (args (with-input-from-string cmdlin read-list))
    (apropos-args (parse-csi-apropos-arguments args)) )
    ;NOTE will not dump the symbol-table unless explicit ; use '(: (* any))
    (cond
      ((null? apropos-args)
        (display-apropos-help) )
      ((null? (cdr apropos-args))
        (apply apropos (car apropos-args) (apropos-default-options)) )
      (else
        (apply apropos apropos-args) ) ) ) )

;;; Main

(when (feature? csi:)
  (apropos-toplevel-command 'a csi-apropos-command CSI-HELP) )

) ;module apropos-csi