apropos/apropos-csi.scm

;;;; 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 (or #:prefix #:suffix #t)}}
;; ; {{SEARCH-MODE}} : {{(or #:prefix #:suffix #t)}} for contains. The default is {{#t}}.

(module apropos-csi ()

(import scheme)
(import (chicken base))
(import (chicken fixnum))
(import (chicken platform))
(import (chicken io))
(import (chicken port))
(import apropos-api)


;;(srfi 1)

(import (only (srfi 1) cons*))
#; ;UNUSED until no (srfi 1)
(define (cons* first . rest)
  (let recur ((x first) (rest rest))
    (if (pair? rest)
        (cons x (recur (car rest) (cdr rest)))
        x) ) )

;; Constants

;Some options only in full help. ex: "raw", "base [#]", "internal"
;Pad out to CSI-HELP-HEAD-WIDTH 18, No tabs
(define CSI-HELP #<<EOS
,a PATT OPT...    Apropos of PATT with OPT from help, mac, ci, imp, sort nam|mod|typ|#f, find nam|mod|#f
EOS
)

(define 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 (no sort order is implied):

  '(PATT . PATT)  performs as if `PATT+PATT find module+name` worked.
  '(PATT . _)     synonym for `PATT find module`.
  '(_ . PATT)     synonym for `PATT find name`.
  '(_ . _)        synonym for '.* | '".*" | (: (* any)) ;match any.

  '<atom>         interpret `<atom>` as an irregex.

  Best to present REGEX-style patterns as a string.
  Ex: '"^[a-zA-Z]$" vs. '^\[a-zA-Z\]$

Arguments:

 help              This message
 mac | macros      Include macro bound symbols
 ci | case-insensitive
                   Pattern has no capitals
 imp | imported    Only imported identifiers, otherwise global symbols
 sort name | module | type | #f
                   Order items; optional when last argument
 find name | module | #f
                   Pattern match component; optional when last argument
                   (also see the '(_ . _) pattern)
 all               Means `ci mac`
 krl               Means `all sort mod`
 base              For number valued pattern
 raw               No listing symbol interpretation (i.e. x123 ~> x)
 internal          Include internal modules
EOS
)

;;
;; REPL Integeration
;;

(define (interp-find-arg loc arg)
  (case arg
    ((n nam name)   #:name)
    ((m mod module) #:module)
    (else
      (and arg
           (error-apropos-find-key loc "unknown find key" arg)) ) ) )

(define (interp-sort-arg loc arg)
  (case arg
    ((n nam name)   #:name)
    ((m mod module) #:module)
    ((t typ type)   #:type)
    (else
      (and arg
           (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* ((patt (and (not (null? iargs)) (car iargs)))
         (args (if patt (cdr iargs) '())) )
    (let loop ((args args) (oargs `(,patt)))
      ;
      (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 #:macros? oargs)) )
              ;
              ((imp imported)
                (arg-next #:imported? #t) )
              ;
              ((mac macros)
                (arg-next #:macros? #t) )
              ;
              ((ci case-insensitive)
                (arg-next #:case-insensitive? #t) )
              ;
              ((internal)
                (arg-next #:internal? #t) )
              ;
              ((raw)
                (arg-next #:raw? #t) )
              ;
              ((base)
                (arg-next #:base (apropos-default-base) (cute check-apropos-number-base '|,a| <>)) )
              ;
              ((sort)
                (arg-next #:sort #:type (cute interp-sort-arg '|,a| <>)) )
              ;
              ((find split)
                (arg-next #:find #f (cute interp-find-arg '|,a| <>)) )
              ;
              ((help)
                (loop '() '()) )
              ;
              (else
                (loop (cdr args) (cons arg oargs)) ) ) ) ) ) ) )

(define (csi-apropos-command)
  (let* ((cmdlin (read-line))
         (csi-args (with-input-from-string cmdlin read-list))
         (apropos-args (parse-csi-apropos-arguments csi-args)) )
    ;NOTE will not dump the symbol-table unless explicit
    ;use '(: (* any)) | '(_ . _)
    (if (null? apropos-args)
        (display-apropos-help)
        (apply apropos apropos-args) ) ) )

;; Main

(when (feature? #:csi)
  ;; Load csi library at runtime here in Chicken 6 only after we confirm
  ;; csi is running. Otherwise chicken.csi load fails.
  (import (only (chicken csi) toplevel-command))
  (toplevel-command 'a csi-apropos-command CSI-HELP) )

) ;module apropos-csi