Changeset 15768 in project


Ignore:
Timestamp:
09/07/09 04:17:10 (10 years ago)
Author:
iraikov
Message:

switched neuromorpho to using getopt-long

Location:
release/4/neuromorpho
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • release/4/neuromorpho/neuromorpho.meta

    r14594 r15768  
    1818 ; A list of eggs sigma depends on.
    1919
    20  (needs eggdoc matchable html-parser sxml-transforms sxpath uri-generic args)
     20 (needs eggdoc matchable html-parser sxml-transforms sxpath uri-generic getopt-long)
    2121
    2222 (author "Ivan Raikov")
  • release/4/neuromorpho/neuromorpho.scm

    r15732 r15768  
    2222(require-extension
    2323 extras regex posix utils extras files data-structures tcp srfi-1 srfi-13
    24  matchable html-parser sxml-transforms sxpath uri-generic args)
    25 
     24 matchable html-parser sxml-transforms sxpath uri-generic getopt-long)
     25
     26
     27(define lookup-def
     28  (lambda (k lst . rest)
     29    (let-optionals rest ((default #f))
     30      (alist-ref k lst eq? default))))
    2631
    2732(define (quotewrapped? str)
     
    5358    (flush-output port) ) )
    5459
    55 (define data-dir                  (make-parameter #f))
    56 (define morphology-file           (make-parameter 'S))
    57 (define meta-filter               (make-parameter '(("Note" ""))))
    58 (define print-meta?               (make-parameter #f))
    59 (define make-index?               (make-parameter #f))
    60 (define index-fields              (make-parameter '("Neuron Name" "Note")))
     60(define opt-defaults
     61  `(
     62    (morphology-file . S)
     63    (meta-filter     . (("Note" "")))
     64    (index-fields    . ("Neuron Name" "Note"))
     65    ))
     66
     67(define (defopt x)
     68  (lookup-def x opt-defaults))
     69
     70(define (symbol-upcase str)
     71  (string->symbol (string-upcase str)))
     72
     73(define opt-grammar
     74  `(
     75    (data-dir
     76     "set download directory (default is a randomly generated name in /tmp)"
     77     (single-char #\d)
     78     (value (required DIR)))
     79
     80    (morphology-file
     81      "download morphology files (Original, Standard or None, default is standard)"
     82      (single-char #\m)
     83      (value (required "O, S, or N")
     84             (default ,(defopt 'morphology-file))
     85             (predicate ,(lambda (arg)
     86                           (case (symbol-upcase arg)
     87                             ((O S N ORIGINAL STANDARD)  #t)
     88                             (else     #f))))
     89             (transformer ,symbol-upcase)))
     90
     91    (meta-filter
     92     "filter pages based on metadata"
     93     (single-char #\f)
     94     (value   (required "NAME1=REGEXP1[,NAME2!=REGEXP2 ...]")   
     95              (default ,(defopt 'meta-filter))
     96              (transformer ,(lambda (arg)
     97                              (map
     98                               (lambda (x)
     99                                 (match (string-split x "!=")
     100                                        ((n v) `(!= . ,(map string-trim-both (list n v))))
     101                                        (else
     102                                         (match (string-split x "=")
     103                                                ((n v ) `(= . ,(map string-trim-both (list n v))))
     104                                                (else   `(= ,(string-trim-both x) ""))))))
     105                               (string-split arg ",")))
     106                           )))
     107
     108    (print-metadata
     109     "print metadata"
     110     (single-char #\p))
     111
     112    (i         "make index file")
     113
     114    (index-fields
     115     
     116     ,(begin
     117        (print "index-fields = " (defopt 'index-fields))
     118        (string-append "comma-separated list of index fields "
     119                       "(default is " (string-intersperse (defopt 'index-fields) ", ") ")")
     120        )
     121
     122     (value       (required "FIELD1,...")
     123                  (default  ,(defopt 'index-fields))
     124                  (transformer
     125                   ,(lambda (arg) (map string-trim-both (string-split (or arg "") ","))))))
     126
     127    (help  "Print help"
     128            (single-char #\h))
     129 
     130  ))
     131
     132
     133;; Use args:usage to generate a formatted list of options (from OPTS),
     134;; suitable for embedding into help text.
     135(define (neuromorpho:usage)
     136  (print "Usage: " (car (argv)) " [options...] operands ")
     137  (newline)
     138  (print "Where operands are HTML files that contain search results from NeuroMorpho: ")
     139  (print "e.g. " (car (argv)) " neuromorpho_searchresults.html")
     140  (newline)
     141  (print "The following options are recognized: ")
     142  (newline)
     143  (width 35)
     144  (print (parameterize ((indent 5)) (usage opt-grammar)))
     145  (exit 1))
     146
     147
     148;; Process arguments and collate options and arguments into OPTIONS
     149;; alist, and operands (filenames) into OPERANDS.  You can handle
     150;; options as they are processed, or afterwards.
     151
     152(define opts    (getopt-long (command-line-arguments) opt-grammar))
     153(define opt     (make-option-dispatch opts opt-grammar))
    61154
    62155(define (get-data-dir)
    63   (or (data-dir)
     156  (or (opt 'data-dir)
    64157      (let ([dir (create-temporary-directory)])
    65158        (data-dir dir)
     
    302395      ,@universal-conversion-rules))))
    303396
    304  
    305                  
    306 (define opts
    307   `(
    308     ,(args:make-option (d)       (required: "DIR")   
    309                        "set download directory (default is a randomly generated name in /tmp)"
    310                        (data-dir arg))
    311     ,(args:make-option (m)       (required: "O, S, or N")   
    312                        "download morphology files (Original, Standard or None, default is standard)"
    313                        (morphology-file (string->symbol (string-upcase arg))))
    314     ,(args:make-option (fm)       (required: "NAME1=REGEXP1[,NAME2!=REGEXP2 ...]")   
    315                        "filter pages based on metadata"
    316                        (meta-filter
    317                         (map
    318                          (lambda (x)
    319                            (match (string-split x "!=")
    320                                   ((n v) `(!= . ,(map string-trim-both (list n v))))
    321                                   (else
    322                                    (match (string-split x "=")
    323                                     ((n v ) `(= . ,(map string-trim-both (list n v))))
    324                                     (else   `(= ,(string-trim-both x) ""))))))
    325                          (string-split arg ","))))
    326     ,(args:make-option (pm)       #:none
    327                        "print metadata"
    328                        (print-meta? #t))
    329     ,(args:make-option (i)       #:none
    330                        "make index file"
    331                        (make-index? #t))
    332     ,(args:make-option (if)       (required: "FIELD1,...")
    333                        (string-append "comma-separated list of index fields "
    334                                       "(default is " (string-intersperse (index-fields) ", ") ")")
    335                        (index-fields (map string-trim-both (string-split (or arg "") ","))))
    336     ,(args:make-option (h help)  #:none               "Print help"
    337                        (usage))))
    338 
    339 
    340 ;; Use args:usage to generate a formatted list of options (from OPTS),
    341 ;; suitable for embedding into help text.
    342 (define (usage)
    343   (print "Usage: " (car (argv)) " [options...] operands ")
    344   (newline)
    345   (print "Where operands are HTML files that contain search results from NeuroMorpho: ")
    346   (print "e.g. " (car (argv)) " neuromorpho_searchresults.html")
    347   (newline)
    348   (print "The following options are recognized: ")
    349   (newline)
    350   (print (parameterize ((args:indent 5)) (args:usage opts)))
    351   (exit 1))
    352 
    353 
    354 ;; Process arguments and collate options and arguments into OPTIONS
    355 ;; alist, and operands (filenames) into OPERANDS.  You can handle
    356 ;; options as they are processed, or afterwards.
    357 (define args    (command-line-arguments))
    358 
    359 (let-values (((options operands)  (args:parse args opts)))
    360    (if (null? operands) (usage))           
    361    (d "download directory is ~s~%" (get-data-dir))
    362    (if (meta-filter) (d "metadata filter is ~s~%" (meta-filter)))
    363    (let* ((data-list
    364            (concatenate
    365             (map (lambda (p)
    366                    (let* ((search-results  (parse-sxml p))
    367                           (page-list       (extract-pages-from-search-results search-results))
    368                           (file-list       (map fetch-file page-list))
    369                           (sxml-list       (map parse-sxml file-list))
    370                           (meta-list       (map extract-metadata sxml-list))
    371                           (links-list      (map (lambda (sxml) `(links . ,(extract-info-links sxml))) sxml-list)))
    372                      (map (lambda (f m l) `(,f ,@m ,l))  file-list meta-list links-list)))
    373                  operands)))
    374           (meta-filtered-list
    375            (begin
    376              (if (and (meta-filter) (pair? (meta-filter)))
    377                (let ((ops (map first (meta-filter)))
    378                      (ks  (map second (meta-filter)))
    379                      (rxs (map (lambda (x) (regexp (third x) #t))
    380                                (meta-filter))))
    381                  (filter (lambda (x)
    382                            (let ((detail  (alist-ref 'detail (cdr x))))
    383                              (every (lambda (op k rx)
    384                                       (let* ((propval (alist-ref k detail string-ci=?))
    385                                              (propval (or (and (string? propval) propval) ""))
    386                                              (m       (string-match rx propval)))
    387                                         (case op
    388                                           ((=)   m)
    389                                           ((!=)  (not m))
    390                                           (else  m))))
    391                                     ops ks rxs)))
    392                          data-list))
    393                data-list)))
    394           )
    395      (if (print-meta?) (for-each print meta-filtered-list))
    396      (let ((morphology-files
    397             (case (morphology-file)
    398               ((O S ORIGINAL STANDARD)
    399                (let* ((rx (regexp (regexp-escape (case (morphology-file)
    400                                                    ((O ORIGINAL) "Morphology File (Original)")
    401                                                    ((S STANDARD) "Morphology File (Standardized)")
    402                                                    (else "")))))
    403                       (download-url? (lambda (x) (string-match rx (caddr x)))))
    404                  (map (lambda (x)
    405                         (let* ((links           (alist-ref 'links (cdr x)))
    406                                (morphology-url  (find download-url? links)))
    407                           (fetch-file morphology-url)))
    408                       meta-filtered-list)))
    409               (else (list)))))
    410        (if (and (make-index?) (not (null? morphology-files)))
    411            (let ((index-file (make-pathname (make-absolute-pathname (current-directory) (get-data-dir)) "index.html")))
    412            (d "creating index file ~s...~%" index-file)
    413            (with-output-to-file index-file
    414              (lambda () (make-index-page meta-filtered-list morphology-files))))))))
    415 
     397
     398(define (main)
     399  (let ((operands          (opt '@))
     400        (meta-filter       (opt 'meta-filter))
     401        (morphology-file   (opt 'morphology-file)))
     402    (if (null? operands) (neuromorpho:usage))
     403    (d "download directory is ~s~%" (get-data-dir))
     404    (if meta-filter (d "metadata filter is ~s~%" meta-filter))
     405    (let* ((data-list
     406            (concatenate
     407             (map (lambda (p)
     408                    (let* ((search-results  (parse-sxml p))
     409                           (page-list       (extract-pages-from-search-results search-results))
     410                           (file-list       (map fetch-file page-list))
     411                           (sxml-list       (map parse-sxml file-list))
     412                           (meta-list       (map extract-metadata sxml-list))
     413                           (links-list      (map (lambda (sxml) `(links . ,(extract-info-links sxml))) sxml-list)))
     414                      (map (lambda (f m l) `(,f ,@m ,l))  file-list meta-list links-list)))
     415                  operands)))
     416           (meta-filtered-list
     417            (begin
     418              (if (and meta-filter (pair? meta-filter))
     419                  (let ((ops (map first   meta-filter))
     420                        (ks  (map second  meta-filter))
     421                        (rxs (map (lambda (x) (regexp (third x) #t))
     422                                  meta-filter)))
     423                    (filter (lambda (x)
     424                              (let ((detail  (alist-ref 'detail (cdr x))))
     425                                (every (lambda (op k rx)
     426                                         (let* ((propval (alist-ref k detail string-ci=?))
     427                                                (propval (or (and (string? propval) propval) ""))
     428                                                (m       (string-match rx propval)))
     429                                           (case op
     430                                             ((=)   m)
     431                                             ((!=)  (not m))
     432                                             (else  m))))
     433                                       ops ks rxs)))
     434                            data-list))
     435                  data-list)))
     436           )
     437      (if (opt 'print-metadata) (for-each print meta-filtered-list))
     438      (let ((morphology-files
     439             (case morphology-file
     440               ((O S ORIGINAL STANDARD)
     441                (let* ((rx (regexp (regexp-escape (case morphology-file
     442                                                    ((O ORIGINAL) "Morphology File (Original)")
     443                                                    ((S STANDARD) "Morphology File (Standardized)")
     444                                                    (else "")))))
     445                       (download-url? (lambda (x) (string-match rx (caddr x)))))
     446                  (map (lambda (x)
     447                         (let* ((links           (alist-ref 'links (cdr x)))
     448                                (morphology-url  (find download-url? links)))
     449                           (fetch-file morphology-url)))
     450                       meta-filtered-list)))
     451               (else (list)))))
     452        (if (and (opt 'i) (not (null? morphology-files)))
     453            (let ((index-file (make-pathname (make-absolute-pathname (current-directory) (get-data-dir)) "index.html")))
     454              (d "creating index file ~s...~%" index-file)
     455              (with-output-to-file index-file
     456                (lambda () (make-index-page meta-filtered-list morphology-files))))))))
     457  )
     458
     459(main)
     460
  • release/4/neuromorpho/neuromorpho.setup

    r15732 r15768  
    1010
    1111  ; Assoc list with properties for the program:
    12   '((version 1.6)))
     12  '((version 1.7)))
    1313;    (documentation "neuromorpho.html")))
Note: See TracChangeset for help on using the changeset viewer.