diff --git a/hierarchical-cmdline/hierarchical-cmdline-test.rkt b/hierarchical-cmdline/hierarchical-cmdline-test.rkt new file mode 100644 index 0000000..95e532a --- /dev/null +++ b/hierarchical-cmdline/hierarchical-cmdline-test.rkt @@ -0,0 +1,64 @@ +#lang racket/base +(module+ test + (require rackunit racket/cmdline racket/port syntax-parse-example/hierarchical-cmdline/hierarchical-cmdline) + + (test-begin + (define prog "my-prog") + + (define (parse-relative) + (parameterize-help-if-empty-ccla + (command-line + #:program (string-append prog " --relative") + #:once-each + [("--left") => (shift-command-line-arguments + (displayln "You're going left!") + (parse-main)) + '("Go to the left")] + [("--right") => (shift-command-line-arguments + (displayln "You're going right!") + (parse-main)) + '("Go to the right")]))) + + (define (parse-absolute) + (parameterize-help-if-empty-ccla + (command-line + #:program (string-append prog " --absolute") + #:once-each + [("--north") => (shift-command-line-arguments + (displayln "You're going north!") + (parse-main)) + '("Go to the north")] + [("--south") => (shift-command-line-arguments + (displayln "You're going south!") + (parse-main)) + '("Go to the south")]))) + + (define (parse-move) + (parameterize-help-if-empty-ccla + (command-line + #:program (string-append prog " --move") + #:once-each + [("--relative") => (shift-command-line-arguments (parse-relative)) + '("Specify a relative direction")] + [("--absolute") => (shift-command-line-arguments (parse-absolute)) + '("Specify an absolute direction")]))) + + (define (parse-main) + (command-line + #:program prog + #:once-each + [("--move") => (shift-command-line-arguments (parse-move)) + '("Specify directions")] + [("--jump") => (shift-command-line-arguments + (displayln "You're jumping!") + (parse-main)) + '("jump")])) + + (test-case "ex1" + (check-equal? + (with-output-to-string + (lambda () + (parameterize ([current-command-line-arguments (vector "--move" "--relative" "--left" "--jump" "--jump" "--move" "--absolute" "--south" "--jump")]) + (parse-main)))) + "You're going left!\nYou're jumping!\nYou're jumping!\nYou're going south!\nYou're jumping!\n"))) +) diff --git a/hierarchical-cmdline/hierarchical-cmdline.rkt b/hierarchical-cmdline/hierarchical-cmdline.rkt new file mode 100644 index 0000000..ab9bb12 --- /dev/null +++ b/hierarchical-cmdline/hierarchical-cmdline.rkt @@ -0,0 +1,20 @@ +#lang racket/base +(provide shift-command-line-arguments parameterize-help-if-empty-ccla) +(require syntax/parse/define racket/vector) + +;; Remove the first argument of the command line arguments +(define-syntax-parse-rule (shift-command-line-arguments body ...) + (λ args + (parameterize ([current-command-line-arguments (vector-copy (current-command-line-arguments) 1)]) + body ...))) + +;; If the command line arguments are empty, re-parameterize it to +;; default to #("--help") +(define-syntax-parse-rule (parameterize-help-if-empty-ccla body ...) + (let ([ccla (current-command-line-arguments)]) + (parameterize ([current-command-line-arguments + (if (vector-empty? ccla) + #("--help") + ccla)]) + body ...))) + diff --git a/hierarchical-cmdline/hierarchical-cmdline.scrbl b/hierarchical-cmdline/hierarchical-cmdline.scrbl new file mode 100644 index 0000000..7246d2b --- /dev/null +++ b/hierarchical-cmdline/hierarchical-cmdline.scrbl @@ -0,0 +1,89 @@ +#lang syntax-parse-example +@require[ + (for-label racket/base racket/cmdline syntax/parse syntax-parse-example/hierarchical-cmdline/hierarchical-cmdline)] + +@(define hierarchical-cmdline-eval + (make-base-eval '(require racket/cmdline syntax-parse-example/hierarchical-cmdline/hierarchical-cmdline))) + +@title{Hierarchical parsing of command-line arguments} +@stxbee2021["Metaxal" 16] +@nested[#:style 'inset @emph{Adapted from a @hyperlink["https://github.com/jackfirth/resyntax/pull/147/files" @elem{PR to @tt{resyntax}}]}] + +@; ============================================================================= + +@defmodule[syntax-parse-example/hierarchical-cmdline/hierarchical-cmdline]{} + +@defform[(shift-command-line-arguments body ...)]{ +} + +@defform[(parameterize-help-if-empty-ccla body ...)]{ +} + +The purpose of the first macro is to make it easy to parse command line +arguments in a hierarchical way using the built-in @racket[command-line] form. The +second macro is an additional helper that displays the help message +automatically when no command-line argument is specified at this level, which +avoids the case where the user tries one argument is then has no information +about what to do next. + +@examples[#:eval hierarchical-cmdline-eval + (define prog "my-prog") + + (define (parse-relative) + (parameterize-help-if-empty-ccla + (command-line + #:program (string-append prog " --relative") + #:once-each + [("--left") => (shift-command-line-arguments + (displayln "You're going left!") + (parse-main)) + '("Go to the left")] + [("--right") => (shift-command-line-arguments + (displayln "You're going right!") + (parse-main)) + '("Go to the right")]))) + + (define (parse-absolute) + (parameterize-help-if-empty-ccla + (command-line + #:program (string-append prog " --absolute") + #:once-each + [("--north") => (shift-command-line-arguments + (displayln "You're going north!") + (parse-main)) + '("Go to the north")] + [("--south") => (shift-command-line-arguments + (displayln "You're going south!") + (parse-main)) + '("Go to the south")]))) + + (define (parse-move) + (parameterize-help-if-empty-ccla + (command-line + #:program (string-append prog " --move") + #:once-each + [("--relative") => (shift-command-line-arguments (parse-relative)) + '("Specify a relative direction")] + [("--absolute") => (shift-command-line-arguments (parse-absolute)) + '("Specify an absolute direction")]))) + + (define (parse-main) + (command-line + #:program prog + #:once-each + [("--move") => (shift-command-line-arguments (parse-move)) + '("Specify directions")] + [("--jump") => (shift-command-line-arguments + (displayln "You're jumping!") + (parse-main)) + '("jump")])) + + (code:comment "$ racket syntax-bee.rkt --move --relative --left --jump --jump --move --absolute --south --jump") + (parameterize ([current-command-line-arguments (vector "--move" "--relative" "--left" "--jump" "--jump" "--move" "--absolute" "--south" "--jump")]) + (parse-main)) +] + +Implementation: + +@racketfile{hierarchical-cmdline.rkt} + diff --git a/index.scrbl b/index.scrbl index e184da9..89360a0 100644 --- a/index.scrbl +++ b/index.scrbl @@ -40,6 +40,7 @@ @include-example{try-catch-finally} @include-example{kw-ctc} @include-example{pyret-for} +@include-example{hierarchical-cmdline} @include-example{flaggable-app} @include-example{js-dict} @include-example{define-freevar}