Initial import

private/aliases.rkt

@@ -0,0 +1,135 @@
+#lang racket/base
+
+(require rash
+         "dispatcher.rkt"
+         "env-support.rkt"
+         "help.rkt"
+         "racket-tools.rkt"
+         (for-syntax racket/base))
+
+(provide pwd ls mkdir rmdir rm cp mv cat touch echo which
+         head tail wc sort uniq cut tee tr basename dirname realpath readlink
+         stat du df mktemp printenv env date help raco)
+
+(define (make-command-procedure name)
+  (λ args
+    (apply dispatch-coreutils-command name args)))
+
+(define pwd-command (make-command-procedure 'pwd))
+(define ls-command (make-command-procedure 'ls))
+(define mkdir-command (make-command-procedure 'mkdir))
+(define rmdir-command (make-command-procedure 'rmdir))
+(define rm-command (make-command-procedure 'rm))
+(define cp-command (make-command-procedure 'cp))
+(define mv-command (make-command-procedure 'mv))
+(define cat-command (make-command-procedure 'cat))
+(define touch-command (make-command-procedure 'touch))
+(define echo-command (make-command-procedure 'echo))
+(define which-command (make-command-procedure 'which))
+(define head-command (make-command-procedure 'head))
+(define tail-command (make-command-procedure 'tail))
+(define wc-command (make-command-procedure 'wc))
+(define sort-command (make-command-procedure 'sort))
+(define uniq-command (make-command-procedure 'uniq))
+(define cut-command (make-command-procedure 'cut))
+(define tee-command (make-command-procedure 'tee))
+(define tr-command (make-command-procedure 'tr))
+(define basename-command (make-command-procedure 'basename))
+(define dirname-command (make-command-procedure 'dirname))
+(define realpath-command (make-command-procedure 'realpath))
+(define readlink-command (make-command-procedure 'readlink))
+(define stat-command (make-command-procedure 'stat))
+(define du-command (make-command-procedure 'du))
+(define df-command (make-command-procedure 'df))
+(define mktemp-command (make-command-procedure 'mktemp))
+(define printenv-command (make-command-procedure 'printenv))
+(define env-command (make-command-procedure 'env))
+(define date-command (make-command-procedure 'date))
+(define raco-command coreutils-raco)
+
+(define (help-command . args)
+  (apply coreutils-help args))
+
+(begin-for-syntax
+  (define (assignment-prefix-name stx)
+    (define datum (syntax-e stx))
+    (define text
+      (cond
+        [(symbol? datum) (symbol->string datum)]
+        [(string? datum) datum]
+        [else #f]))
+    (and text
+         (regexp-match? #px"^[^=]+=$" text)
+         (substring text 0 (sub1 (string-length text)))))
+
+  (define (racket-expression? stx)
+    (pair? (syntax-e stx)))
+
+  (define (prepare-env-arguments arguments)
+    (let loop ([rest arguments] [result '()])
+      (cond
+        [(null? rest)
+         (reverse result)]
+        [(and (pair? (cdr rest))
+              (assignment-prefix-name (car rest))
+              (racket-expression? (cadr rest)))
+         (define name (assignment-prefix-name (car rest)))
+         (define expression (cadr rest))
+         (loop (cddr rest)
+               (cons #`(environment-assignment #,name #,expression)
+                     result))]
+        [else
+         (loop (cdr rest)
+               (cons (car rest) result))])))
+
+  (define (make-env-alias procedure-id)
+    (λ (stx)
+      (syntax-case stx ()
+        [(_ argument ...)
+         (let ([prepared
+                (prepare-env-arguments
+                 (syntax->list #'(argument ...)))])
+           (with-syntax ([(prepared-argument ...) prepared]
+                         [command-procedure procedure-id])
+             #'(=unix-pipe= (values command-procedure)
+                            prepared-argument ...)))])))
+
+  (define (make-coreutils-alias procedure-id)
+    (λ (stx)
+      (syntax-case stx ()
+        [(_ argument ...)
+         (with-syntax ([command-procedure procedure-id])
+           #'(=unix-pipe= (values command-procedure) argument ...))]))))
+
+(define-pipeline-alias pwd      (make-coreutils-alias #'pwd-command))
+(define-pipeline-alias ls       (make-coreutils-alias #'ls-command))
+(define-pipeline-alias mkdir    (make-coreutils-alias #'mkdir-command))
+(define-pipeline-alias rmdir    (make-coreutils-alias #'rmdir-command))
+(define-pipeline-alias rm       (make-coreutils-alias #'rm-command))
+(define-pipeline-alias cp       (make-coreutils-alias #'cp-command))
+(define-pipeline-alias mv       (make-coreutils-alias #'mv-command))
+(define-pipeline-alias cat      (make-coreutils-alias #'cat-command))
+(define-pipeline-alias touch    (make-coreutils-alias #'touch-command))
+(define-pipeline-alias echo     (make-coreutils-alias #'echo-command))
+(define-pipeline-alias which    (make-coreutils-alias #'which-command))
+(define-pipeline-alias head     (make-coreutils-alias #'head-command))
+(define-pipeline-alias tail     (make-coreutils-alias #'tail-command))
+(define-pipeline-alias wc       (make-coreutils-alias #'wc-command))
+(define-pipeline-alias sort     (make-coreutils-alias #'sort-command))
+(define-pipeline-alias uniq     (make-coreutils-alias #'uniq-command))
+(define-pipeline-alias cut      (make-coreutils-alias #'cut-command))
+(define-pipeline-alias tee      (make-coreutils-alias #'tee-command))
+(define-pipeline-alias tr       (make-coreutils-alias #'tr-command))
+(define-pipeline-alias basename (make-coreutils-alias #'basename-command))
+(define-pipeline-alias dirname  (make-coreutils-alias #'dirname-command))
+(define-pipeline-alias realpath (make-coreutils-alias #'realpath-command))
+(define-pipeline-alias readlink (make-coreutils-alias #'readlink-command))
+(define-pipeline-alias stat     (make-coreutils-alias #'stat-command))
+(define-pipeline-alias du       (make-coreutils-alias #'du-command))
+(define-pipeline-alias df       (make-coreutils-alias #'df-command))
+(define-pipeline-alias mktemp   (make-coreutils-alias #'mktemp-command))
+(define-pipeline-alias printenv (make-coreutils-alias #'printenv-command))
+(define-pipeline-alias env      (make-env-alias #'env-command))
+(define-pipeline-alias date     (make-coreutils-alias #'date-command))
+(define-pipeline-alias help     (make-coreutils-alias #'help-command))
+(define-pipeline-alias raco     (make-coreutils-alias #'raco-command))

private/commands.rkt

@@ -0,0 +1,50 @@
+#lang racket/base
+
+(require "coreutils.rkt"
+         "extended.rkt"
+         "racket-tools.rkt")
+
+(provide (struct-out coreutils-command)
+         coreutils-commands
+         find-coreutils-command)
+
+(struct coreutils-command (name procedure documentation-term) #:transparent)
+
+(define coreutils-commands
+  (list
+   (coreutils-command 'pwd coreutils-pwd 'rash-coreutils-pwd)
+   (coreutils-command 'ls coreutils-ls 'rash-coreutils-ls)
+   (coreutils-command 'mkdir coreutils-mkdir 'rash-coreutils-mkdir)
+   (coreutils-command 'rmdir coreutils-rmdir 'rash-coreutils-rmdir)
+   (coreutils-command 'rm coreutils-rm 'rash-coreutils-rm)
+   (coreutils-command 'cp coreutils-cp 'rash-coreutils-cp)
+   (coreutils-command 'mv coreutils-mv 'rash-coreutils-mv)
+   (coreutils-command 'cat coreutils-cat 'rash-coreutils-cat)
+   (coreutils-command 'touch coreutils-touch 'rash-coreutils-touch)
+   (coreutils-command 'echo coreutils-echo 'rash-coreutils-echo)
+   (coreutils-command 'which coreutils-which 'rash-coreutils-which)
+   (coreutils-command 'head coreutils-head 'rash-coreutils-head)
+   (coreutils-command 'tail coreutils-tail 'rash-coreutils-tail)
+   (coreutils-command 'wc coreutils-wc 'rash-coreutils-wc)
+   (coreutils-command 'sort coreutils-sort 'rash-coreutils-sort)
+   (coreutils-command 'uniq coreutils-uniq 'rash-coreutils-uniq)
+   (coreutils-command 'cut coreutils-cut 'rash-coreutils-cut)
+   (coreutils-command 'tee coreutils-tee 'rash-coreutils-tee)
+   (coreutils-command 'tr coreutils-tr 'rash-coreutils-tr)
+   (coreutils-command 'basename coreutils-basename 'rash-coreutils-basename)
+   (coreutils-command 'dirname coreutils-dirname 'rash-coreutils-dirname)
+   (coreutils-command 'realpath coreutils-realpath 'rash-coreutils-realpath)
+   (coreutils-command 'readlink coreutils-readlink 'rash-coreutils-readlink)
+   (coreutils-command 'stat coreutils-stat 'rash-coreutils-stat)
+   (coreutils-command 'du coreutils-du 'rash-coreutils-du)
+   (coreutils-command 'df coreutils-df 'rash-coreutils-df)
+   (coreutils-command 'mktemp coreutils-mktemp 'rash-coreutils-mktemp)
+   (coreutils-command 'printenv coreutils-printenv 'rash-coreutils-printenv)
+   (coreutils-command 'env coreutils-env 'rash-coreutils-env)
+   (coreutils-command 'date coreutils-date 'rash-coreutils-date)
+   (coreutils-command 'raco coreutils-raco 'rash-coreutils-raco)))
+
+(define (find-coreutils-command name)
+  (for/first ([command (in-list coreutils-commands)]
+              #:when (eq? name (coreutils-command-name command)))
+    command))

private/coreutils.rkt

@@ -0,0 +1,272 @@
+#lang racket/base
+
+(require racket/file
+         racket/format
+         racket/list
+         racket/path
+         racket/port
+         racket/string
+         racket/system
+         "path-output.rkt")
+
+(provide coreutils-pwd
+         coreutils-ls
+         coreutils-mkdir
+         coreutils-rmdir
+         coreutils-rm
+         coreutils-cp
+         coreutils-mv
+         coreutils-cat
+         coreutils-touch
+         coreutils-echo
+         coreutils-which)
+
+(define (arg->string arg)
+  (cond
+    [(path? arg) (path->string arg)]
+    [(symbol? arg) (symbol->string arg)]
+    [(string? arg) arg]
+    [else (~a arg)]))
+
+(define (arg->path arg)
+  (string->path (arg->string arg)))
+
+(define (option? arg option)
+  (string=? (arg->string arg) option))
+
+(define (hidden-name? path)
+  (define name (path->string (file-name-from-path path)))
+  (and (positive? (string-length name))
+       (char=? (string-ref name 0) #\.)))
+
+(define (path-display-name path)
+  (path->string (file-name-from-path path)))
+
+(define (directory-entry-type path)
+  (cond
+    [(directory-exists? path) "d"]
+    [(link-exists? path) "l"]
+    [else "-"]))
+
+(define (directory-entry-size path)
+  (if (file-exists? path)
+      (file-size path)
+      0))
+
+(define (write-ls-entry path long?)
+  (if long?
+      (printf "~a ~a ~a\n"
+              (directory-entry-type path)
+              (~a (directory-entry-size path)
+                  #:min-width 10
+                  #:align 'right)
+              (path-display-name path))
+      (printf "~a\n" (path-display-name path))))
+
+(define (write-directory-listing directory all? long?)
+  (define entries
+    (sort (directory-list directory #:build? #t)
+          string<?
+          #:key path-display-name))
+  (for ([entry (in-list entries)])
+    (when (or all? (not (hidden-name? entry)))
+      (write-ls-entry entry long?))))
+
+(define (coreutils-pwd . args)
+  (unless (null? args)
+    (raise-arguments-error 'pwd "does not accept arguments" "arguments" args))
+  (displayln (path->rash-string (current-directory))))
+
+(define (coreutils-ls . args)
+  (define all? #f)
+  (define long? #f)
+  (define paths '())
+  (for ([arg (in-list args)])
+    (define text (arg->string arg))
+    (cond
+      [(or (string=? text "-a") (string=? text "--all"))
+       (set! all? #t)]
+      [(or (string=? text "-l") (string=? text "--long"))
+       (set! long? #t)]
+      [(or (string=? text "-la") (string=? text "-al"))
+       (set! all? #t)
+       (set! long? #t)]
+      [(string-prefix? text "-")
+       (raise-arguments-error 'ls "unsupported option" "option" text)]
+      [else
+       (set! paths (append paths (list (arg->path arg))))]))
+  (when (null? paths)
+    (set! paths (list (current-directory))))
+  (define file-paths
+    (filter
+     (λ (path)
+       (or (file-exists? path) (link-exists? path)))
+     paths))
+  (define directory-paths
+    (filter directory-exists? paths))
+  (for ([path (in-list paths)])
+    (unless (or (file-exists? path)
+                (link-exists? path)
+                (directory-exists? path))
+      (raise-arguments-error 'ls "path does not exist" "path" path)))
+  (for ([path (in-list file-paths)])
+    (write-ls-entry path long?))
+  (for ([path (in-list directory-paths)]
+        [index (in-naturals)])
+    (when (or (pair? file-paths) (> index 0))
+      (newline))
+    (when (> (length paths) 1)
+      (printf "~a:\n" (path->rash-string path)))
+    (write-directory-listing path all? long?)))
+
+(define (coreutils-mkdir . args)
+  (define parents? #f)
+  (define paths '())
+  (for ([arg (in-list args)])
+    (define text (arg->string arg))
+    (cond
+      [(or (string=? text "-p") (string=? text "--parents"))
+       (set! parents? #t)]
+      [(string-prefix? text "-")
+       (raise-arguments-error 'mkdir "unsupported option" "option" text)]
+      [else
+       (set! paths (append paths (list (arg->path arg))))]))
+  (when (null? paths)
+    (raise-arguments-error 'mkdir "expected at least one directory" "arguments" args))
+  (for ([path (in-list paths)])
+    (if parents?
+        (make-directory* path)
+        (make-directory path))))
+
+(define (coreutils-rmdir . args)
+  (when (null? args)
+    (raise-arguments-error 'rmdir "expected at least one directory" "arguments" args))
+  (for ([arg (in-list args)])
+    (define text (arg->string arg))
+    (when (string-prefix? text "-")
+      (raise-arguments-error 'rmdir "unsupported option" "option" text))
+    (delete-directory (arg->path arg))))
+
+(define (delete-path path recursive? force?)
+  (cond
+    [(directory-exists? path)
+     (if recursive?
+         (delete-directory/files path)
+         (raise-arguments-error 'rm
+                                "cannot remove a directory without -r"
+                                "path" path))]
+    [(or (file-exists? path) (link-exists? path))
+     (delete-file path)]
+    [force? (void)]
+    [else
+     (raise-arguments-error 'rm "path does not exist" "path" path)]))
+
+(define (coreutils-rm . args)
+  (define recursive? #f)
+  (define force? #f)
+  (define paths '())
+  (for ([arg (in-list args)])
+    (define text (arg->string arg))
+    (cond
+      [(or (string=? text "-r")
+           (string=? text "-R")
+           (string=? text "--recursive"))
+       (set! recursive? #t)]
+      [(or (string=? text "-f") (string=? text "--force"))
+       (set! force? #t)]
+      [(or (string=? text "-rf")
+           (string=? text "-fr")
+           (string=? text "-Rf")
+           (string=? text "-fR"))
+       (set! recursive? #t)
+       (set! force? #t)]
+      [(string-prefix? text "-")
+       (raise-arguments-error 'rm "unsupported option" "option" text)]
+      [else
+       (set! paths (append paths (list (arg->path arg))))]))
+  (when (null? paths)
+    (raise-arguments-error 'rm "expected at least one path" "arguments" args))
+  (for ([path (in-list paths)])
+    (delete-path path recursive? force?)))
+
+(define (copy-directory source destination)
+  (copy-directory/files source destination))
+
+(define (coreutils-cp . args)
+  (define recursive? #f)
+  (define paths '())
+  (for ([arg (in-list args)])
+    (define text (arg->string arg))
+    (cond
+      [(or (string=? text "-r")
+           (string=? text "-R")
+           (string=? text "--recursive"))
+       (set! recursive? #t)]
+      [(string-prefix? text "-")
+       (raise-arguments-error 'cp "unsupported option" "option" text)]
+      [else
+       (set! paths (append paths (list (arg->path arg))))]))
+  (unless (= (length paths) 2)
+    (raise-arguments-error 'cp
+                           "this version expects exactly source and destination"
+                           "arguments" args))
+  (define source (first paths))
+  (define destination (second paths))
+  (cond
+    [(directory-exists? source)
+     (unless recursive?
+       (raise-arguments-error 'cp
+                              "source is a directory; use -r"
+                              "source" source))
+     (copy-directory source destination)]
+    [(file-exists? source)
+     (copy-file source destination)]
+    [else
+     (raise-arguments-error 'cp "source does not exist" "source" source)]))
+
+(define (coreutils-mv . args)
+  (unless (= (length args) 2)
+    (raise-arguments-error 'mv
+                           "expected source and destination"
+                           "arguments" args))
+  (define source (arg->path (first args)))
+  (define destination (arg->path (second args)))
+  (rename-file-or-directory source destination))
+
+(define (coreutils-cat . args)
+  (when (null? args)
+    (copy-port (current-input-port) (current-output-port)))
+  (for ([arg (in-list args)])
+    (define text (arg->string arg))
+    (when (string-prefix? text "-")
+      (raise-arguments-error 'cat "unsupported option" "option" text))
+    (call-with-input-file* (arg->path arg)
+      (λ (in)
+        (copy-port in (current-output-port))))))
+
+(define (coreutils-touch . args)
+  (when (null? args)
+    (raise-arguments-error 'touch "expected at least one file" "arguments" args))
+  (for ([arg (in-list args)])
+    (define text (arg->string arg))
+    (when (string-prefix? text "-")
+      (raise-arguments-error 'touch "unsupported option" "option" text))
+    (define path (arg->path arg))
+    (if (file-exists? path)
+        (file-or-directory-modify-seconds path (current-seconds))
+        (call-with-output-file* path
+          (λ (out) (void))))))
+
+(define (coreutils-echo . args)
+  (displayln (string-join (map arg->string args) " ")))
+
+(define (coreutils-which . args)
+  (when (null? args)
+    (raise-arguments-error 'which "expected at least one command" "arguments" args))
+  (for ([arg (in-list args)])
+    (define executable (find-executable-path (arg->string arg)))
+    (if executable
+        (displayln (path->rash-string executable))
+        (raise-arguments-error 'which
+                               "command was not found on PATH"
+                               "command" (arg->string arg)))))

private/dispatcher.rkt

@@ -0,0 +1,83 @@
+#lang racket/base
+
+(require racket/list
+         racket/path
+         "commands.rkt"
+         "env-support.rkt"
+         "help.rkt")
+
+(provide dispatch-coreutils-command
+         expand-coreutils-arguments)
+
+(define (regexp-paths pattern)
+  (define entries
+    (directory-list (current-directory) #:build? #t))
+  (define matching-entries
+    (filter
+     (λ (entry)
+       (define name (file-name-from-path entry))
+       (and name
+            (regexp-match? pattern (path->string name))))
+     entries))
+  (sort matching-entries
+        string<?
+        #:key
+        (λ (entry)
+          (path->string (file-name-from-path entry)))))
+
+(define (expand-coreutils-argument arg)
+  (cond
+    [(list? arg)
+     (append-map expand-coreutils-argument arg)]
+    [(regexp? arg)
+     (define matches (regexp-paths arg))
+     (when (null? matches)
+       (raise-arguments-error
+        'dispatch-coreutils-command
+        "regular expression matched no paths"
+        "pattern" arg))
+     matches]
+    [else
+     (list arg)]))
+
+(define (expand-coreutils-arguments args)
+  (append-map expand-coreutils-argument args))
+
+(define (help-option? arg)
+  (or (equal? arg '--help)
+      (equal? arg "--help")))
+
+(define (argument->command-name arg)
+  (cond
+    [(symbol? arg) arg]
+    [(string? arg) (string->symbol arg)]
+    [(path? arg) (string->symbol (path->string arg))]
+    [else #f]))
+
+(define (run-coreutils-command-if-known command)
+  (define command-name
+    (and (pair? command)
+         (argument->command-name (car command))))
+  (define known-command
+    (and command-name
+         (find-coreutils-command command-name)))
+  (if known-command
+      (begin
+        (apply dispatch-coreutils-command command-name (cdr command))
+        #t)
+      #f))
+
+(define (dispatch-coreutils-command command-name . args)
+  (unless (symbol? command-name)
+    (raise-argument-error 'dispatch-coreutils-command "symbol?" command-name))
+  (define command (find-coreutils-command command-name))
+  (unless command
+    (raise-arguments-error 'dispatch-coreutils-command
+                           "unknown coreutils command"
+                           "command" command-name))
+  (if (ormap help-option? args)
+      (coreutils-help command-name)
+      (parameterize ([current-coreutils-command-runner
+                      run-coreutils-command-if-known])
+        (apply (coreutils-command-procedure command)
+               (expand-coreutils-arguments args)))))

private/env-support.rkt

@@ -0,0 +1,9 @@
+#lang racket/base
+
+(provide (struct-out environment-assignment)
+         current-coreutils-command-runner)
+
+(struct environment-assignment (name value) #:transparent)
+
+(define current-coreutils-command-runner
+  (make-parameter #f))

private/extended.rkt

@@ -0,0 +1,541 @@
+#lang racket/base
+
+(require gregor
+         racket/file
+         racket/format
+         racket/list
+         racket/path
+         racket/port
+         racket/set
+         racket/string
+         racket/system
+         "env-support.rkt"
+         "path-output.rkt")
+
+(provide coreutils-head
+         coreutils-tail
+         coreutils-wc
+         coreutils-sort
+         coreutils-uniq
+         coreutils-cut
+         coreutils-tee
+         coreutils-tr
+         coreutils-basename
+         coreutils-dirname
+         coreutils-realpath
+         coreutils-readlink
+         coreutils-stat
+         coreutils-du
+         coreutils-df
+         coreutils-mktemp
+         coreutils-printenv
+         coreutils-env
+         coreutils-date)
+
+(define (arg->string arg)
+  (cond
+    [(path? arg) (path->string arg)]
+    [(symbol? arg) (symbol->string arg)]
+    [(string? arg) arg]
+    [else (~a arg)]))
+
+(define (arg->path arg)
+  (string->path (arg->string arg)))
+
+(define (read-lines-from-arguments args)
+  (if (null? args)
+      (port->lines (current-input-port))
+      (append-map
+       (λ (arg)
+         (call-with-input-file* (arg->path arg) port->lines))
+       args)))
+
+(define (parse-n-option who args default)
+  (cond
+    [(and (pair? args)
+          (member (arg->string (car args)) '("-n" "--lines")))
+     (unless (pair? (cdr args))
+       (raise-arguments-error who "missing line count" "arguments" args))
+     (define n (string->number (arg->string (cadr args))))
+     (unless (and (exact-integer? n) (>= n 0))
+       (raise-arguments-error who "line count must be a non-negative integer"
+                              "count" (cadr args)))
+     (values n (cddr args))]
+    [else
+     (values default args)]))
+
+(define (coreutils-head . args)
+  (define-values (n files) (parse-n-option 'head args 10))
+  (define lines (read-lines-from-arguments files))
+  (for ([line (in-list (take lines (min n (length lines))))])
+    (displayln line)))
+
+(define (coreutils-tail . args)
+  (define-values (n files) (parse-n-option 'tail args 10))
+  (define lines (read-lines-from-arguments files))
+  (define count (length lines))
+  (for ([line (in-list (drop lines (max 0 (- count n))))])
+    (displayln line)))
+
+(define (bytes-for-arguments args)
+  (if (null? args)
+      (port->bytes (current-input-port))
+      (apply bytes-append
+             (for/list ([arg (in-list args)])
+               (file->bytes (arg->path arg))))))
+
+(define (coreutils-wc . args)
+  (define lines? #f)
+  (define words? #f)
+  (define bytes? #f)
+  (define files '())
+  (for ([arg (in-list args)])
+    (define text (arg->string arg))
+    (cond
+      [(string=? text "-l") (set! lines? #t)]
+      [(string=? text "-w") (set! words? #t)]
+      [(or (string=? text "-c") (string=? text "--bytes")) (set! bytes? #t)]
+      [(string-prefix? text "-")
+       (raise-arguments-error 'wc "unsupported option" "option" text)]
+      [else (set! files (append files (list arg)))]))
+  (when (not (or lines? words? bytes?))
+    (set! lines? #t)
+    (set! words? #t)
+    (set! bytes? #t))
+  (define bs (bytes-for-arguments files))
+  (define text (bytes->string/utf-8 bs #\?))
+  (define results
+    (filter (λ (x) x)
+            (list (if lines? (number->string (length (regexp-match* #rx"\n" text))) #f)
+                  (if words? (number->string (length (regexp-match* #px"\\S+" text))) #f)
+                  (if bytes? (number->string (bytes-length bs)) #f))))
+  (displayln (string-join results " ")))
+
+(define (coreutils-sort . args)
+  (define reverse? #f)
+  (define numeric? #f)
+  (define files '())
+  (for ([arg (in-list args)])
+    (define text (arg->string arg))
+    (cond
+      [(or (string=? text "-r") (string=? text "--reverse")) (set! reverse? #t)]
+      [(or (string=? text "-n") (string=? text "--numeric-sort")) (set! numeric? #t)]
+      [(string-prefix? text "-")
+       (raise-arguments-error 'sort "unsupported option" "option" text)]
+      [else (set! files (append files (list arg)))]))
+  (define (less? a b)
+    (if numeric?
+        (< (or (string->number a) +inf.0)
+           (or (string->number b) +inf.0))
+        (string<? a b)))
+  (define sorted (sort (read-lines-from-arguments files) less?))
+  (for ([line (in-list (if reverse? (reverse sorted) sorted))])
+    (displayln line)))
+
+(define (run-lengths lines)
+  (let loop ([rest lines] [current #f] [count 0] [result '()])
+    (cond
+      [(null? rest)
+       (reverse (if current (cons (cons current count) result) result))]
+      [(and current (string=? current (car rest)))
+       (loop (cdr rest) current (add1 count) result)]
+      [else
+       (loop (cdr rest)
+             (car rest)
+             1
+             (if current (cons (cons current count) result) result))])))
+
+(define (coreutils-uniq . args)
+  (define count? #f)
+  (define files '())
+  (for ([arg (in-list args)])
+    (define text (arg->string arg))
+    (cond
+      [(or (string=? text "-c") (string=? text "--count")) (set! count? #t)]
+      [(string-prefix? text "-")
+       (raise-arguments-error 'uniq "unsupported option" "option" text)]
+      [else (set! files (append files (list arg)))]))
+  (for ([entry (in-list (run-lengths (read-lines-from-arguments files)))])
+    (if count?
+        (printf "~a ~a\n" (~a (cdr entry) #:min-width 7 #:align 'right) (car entry))
+        (displayln (car entry)))))
+
+(define (parse-field-spec text)
+  (define n (string->number text))
+  (unless (and (exact-positive-integer? n))
+    (raise-arguments-error 'cut "only one positive field number is supported"
+                           "field" text))
+  n)
+
+(define (coreutils-cut . args)
+  (define delimiter "\t")
+  (define field #f)
+  (define files '())
+  (let loop ([rest args])
+    (cond
+      [(null? rest) (void)]
+      [(member (arg->string (car rest)) '("-d" "--delimiter"))
+       (unless (pair? (cdr rest))
+         (raise-arguments-error 'cut "missing delimiter" "arguments" args))
+       (set! delimiter (arg->string (cadr rest)))
+       (loop (cddr rest))]
+      [(member (arg->string (car rest)) '("-f" "--fields"))
+       (unless (pair? (cdr rest))
+         (raise-arguments-error 'cut "missing field" "arguments" args))
+       (set! field (parse-field-spec (arg->string (cadr rest))))
+       (loop (cddr rest))]
+      [(string-prefix? (arg->string (car rest)) "-")
+       (raise-arguments-error 'cut "unsupported option" "option" (car rest))]
+      [else
+       (set! files (append files (list (car rest))))
+       (loop (cdr rest))]))
+  (unless field
+    (raise-arguments-error 'cut "expected -f FIELD" "arguments" args))
+  (for ([line (in-list (read-lines-from-arguments files))])
+    (define parts (string-split line delimiter #:trim? #f #:repeat? #f))
+    (when (<= field (length parts))
+      (displayln (list-ref parts (sub1 field))))))
+
+(define (coreutils-tee . args)
+  (define append? #f)
+  (define files '())
+  (for ([arg (in-list args)])
+    (define text (arg->string arg))
+    (cond
+      [(or (string=? text "-a") (string=? text "--append")) (set! append? #t)]
+      [(string-prefix? text "-")
+       (raise-arguments-error 'tee "unsupported option" "option" text)]
+      [else (set! files (append files (list (arg->path arg))))]))
+  (define outputs
+    (for/list ([path (in-list files)])
+      (open-output-file path #:exists (if append? 'append 'truncate/replace))))
+  (dynamic-wind
+    void
+    (λ ()
+      (let loop ()
+        (define bs (read-bytes 4096 (current-input-port)))
+        (unless (eof-object? bs)
+          (write-bytes bs (current-output-port))
+          (for ([out (in-list outputs)]) (write-bytes bs out))
+          (loop))))
+    (λ ()
+      (for ([out (in-list outputs)]) (close-output-port out)))))
+
+(define (expand-character-set text)
+  (define chars (string->list text))
+  (let loop ([rest chars] [result '()])
+    (cond
+      [(null? rest)
+       (reverse result)]
+      [(and (pair? (cdr rest))
+            (pair? (cddr rest))
+            (char=? (cadr rest) #\-)
+            (char<=? (car rest) (caddr rest)))
+       (define start (char->integer (car rest)))
+       (define end (char->integer (caddr rest)))
+       (define expanded
+         (for/list ([code (in-range start (add1 end))])
+           (integer->char code)))
+       (loop (cdddr rest) (append (reverse expanded) result))]
+      [else
+       (loop (cdr rest) (cons (car rest) result))])))
+
+(define (squeeze-characters text chars)
+  (define squeeze? (list->seteq chars))
+  (list->string
+   (let loop ([rest (string->list text)] [previous #f] [result '()])
+     (cond
+       [(null? rest) (reverse result)]
+       [else
+        (define ch (car rest))
+        (if (and previous
+                 (char=? ch previous)
+                 (set-member? squeeze? ch))
+            (loop (cdr rest) previous result)
+            (loop (cdr rest) ch (cons ch result)))]))))
+
+(define (translate-characters text from to)
+  (when (null? to)
+    (raise-arguments-error 'tr "SET2 must not be empty" "SET2" to))
+  (define last-to (last to))
+  (define mapping
+    (for/hash ([ch (in-list from)] [i (in-naturals)])
+      (values ch (if (< i (length to)) (list-ref to i) last-to))))
+  (list->string
+   (for/list ([ch (in-string text)])
+     (hash-ref mapping ch ch))))
+
+(define (delete-characters text chars)
+  (define delete-set (list->seteq chars))
+  (list->string
+   (for/list ([ch (in-string text)]
+              #:unless (set-member? delete-set ch))
+     ch)))
+
+(define (coreutils-tr . args)
+  (define delete? #f)
+  (define squeeze? #f)
+  (define sets '())
+  (for ([arg (in-list args)])
+    (define text (arg->string arg))
+    (cond
+      [(or (string=? text "-d") (string=? text "--delete"))
+       (set! delete? #t)]
+      [(or (string=? text "-s") (string=? text "--squeeze-repeats"))
+       (set! squeeze? #t)]
+      [(or (string=? text "-ds") (string=? text "-sd"))
+       (set! delete? #t)
+       (set! squeeze? #t)]
+      [(string-prefix? text "-")
+       (raise-arguments-error 'tr "unsupported option" "option" text)]
+      [else
+       (set! sets (append sets (list text)))]))
+  (define text (port->string (current-input-port)))
+  (cond
+    [(and delete? squeeze?)
+     (unless (= (length sets) 2)
+       (raise-arguments-error 'tr "expected SET1 SET2 with -ds" "arguments" args))
+     (define deleted
+       (delete-characters text (expand-character-set (first sets))))
+     (display
+      (squeeze-characters deleted (expand-character-set (second sets))))]
+    [delete?
+     (unless (= (length sets) 1)
+       (raise-arguments-error 'tr "expected one character set with -d" "arguments" args))
+     (display
+      (delete-characters text (expand-character-set (first sets))))]
+    [(and squeeze? (= (length sets) 1))
+     (display
+      (squeeze-characters text (expand-character-set (first sets))))]
+    [else
+     (unless (= (length sets) 2)
+       (raise-arguments-error 'tr "expected SET1 SET2" "arguments" args))
+     (define to (expand-character-set (second sets)))
+     (define translated
+       (translate-characters text
+                             (expand-character-set (first sets))
+                             to))
+     (display
+      (if squeeze?
+          (squeeze-characters translated to)
+          translated))]))
+
+(define (coreutils-basename . args)
+  (unless (= (length args) 1)
+    (raise-arguments-error 'basename "expected one path" "arguments" args))
+  (define name (file-name-from-path (arg->path (car args))))
+  (displayln (if name (path->string name) "")))
+
+(define (coreutils-dirname . args)
+  (unless (= (length args) 1)
+    (raise-arguments-error 'dirname "expected one path" "arguments" args))
+  (define-values (base name dir?) (split-path (arg->path (car args))))
+  (displayln
+   (cond
+     [(path? base) (path->rash-string base)]
+     [(eq? base 'relative) "."]
+     [else (path->rash-string (arg->path (car args)))])))
+
+(define (coreutils-realpath . args)
+  (unless (= (length args) 1)
+    (raise-arguments-error 'realpath "expected one path" "arguments" args))
+  (displayln (path->rash-string (simplify-path (path->complete-path (arg->path (car args))) #t))))
+
+(define (coreutils-readlink . args)
+  (unless (= (length args) 1)
+    (raise-arguments-error 'readlink "expected one path" "arguments" args))
+  (define path (arg->path (car args)))
+  (unless (link-exists? path)
+    (raise-arguments-error 'readlink "path is not a symbolic link" "path" path))
+  (displayln (path->rash-string (resolve-path path))))
+
+(define (coreutils-stat . args)
+  (when (null? args)
+    (raise-arguments-error 'stat "expected at least one path" "arguments" args))
+  (for ([arg (in-list args)])
+    (define path (arg->path arg))
+    (unless (or (file-exists? path) (directory-exists? path) (link-exists? path))
+      (raise-arguments-error 'stat "path does not exist" "path" path))
+    (printf "Path: ~a\n" (path->rash-string (path->complete-path path)))
+    (printf "Type: ~a\n"
+            (cond [(link-exists? path) "link"]
+                  [(directory-exists? path) "directory"]
+                  [else "file"]))
+    (when (file-exists? path) (printf "Size: ~a\n" (file-size path)))
+    (printf "Modified: ~a\n" (file-or-directory-modify-seconds path))))
+
+(define (path-size path)
+  (cond
+    [(file-exists? path) (file-size path)]
+    [(directory-exists? path)
+     (for/sum ([entry (in-list (directory-list path #:build? #t))])
+       (path-size entry))]
+    [else 0]))
+
+(define (human-size n)
+  (cond
+    [(>= n (* 1024 1024 1024)) (format "~aG" (~r (/ n (* 1024.0 1024 1024)) #:precision '(= 1)))]
+    [(>= n (* 1024 1024)) (format "~aM" (~r (/ n (* 1024.0 1024)) #:precision '(= 1)))]
+    [(>= n 1024) (format "~aK" (~r (/ n 1024.0) #:precision '(= 1)))]
+    [else (format "~aB" n)]))
+
+(define (coreutils-du . args)
+  (define human? #f)
+  (define paths '())
+  (for ([arg (in-list args)])
+    (define text (arg->string arg))
+    (cond
+      [(or (string=? text "-h") (string=? text "--human-readable")) (set! human? #t)]
+      [(string-prefix? text "-")
+       (raise-arguments-error 'du "unsupported option" "option" text)]
+      [else (set! paths (append paths (list (arg->path arg))))]))
+  (when (null? paths) (set! paths (list (current-directory))))
+  (for ([path (in-list paths)])
+    (define size (path-size path))
+    (printf "~a\t~a\n" (if human? (human-size size) size) (path->rash-string path))))
+
+(define (coreutils-df . args)
+  (unless (null? args)
+    (raise-arguments-error 'df "this portable implementation does not accept arguments yet"
+                           "arguments" args))
+  (displayln "Filesystem")
+  (for ([root (in-list (filesystem-root-list))])
+    (displayln (path->rash-string root))))
+
+(define (coreutils-mktemp . args)
+  (define directory? #f)
+  (define template "tmp~a")
+  (for ([arg (in-list args)])
+    (define text (arg->string arg))
+    (cond
+      [(or (string=? text "-d") (string=? text "--directory")) (set! directory? #t)]
+      [(string-prefix? text "-")
+       (raise-arguments-error 'mktemp "unsupported option" "option" text)]
+      [else (set! template text)]))
+  (define result (make-temporary-file template (if directory? 'directory #f)))
+  (displayln (path->rash-string result)))
+
+(define (environment-name->string name)
+  (bytes->string/locale name))
+
+(define (environment-value->string value)
+  (bytes->string/locale value))
+
+(define (write-environment env)
+  (define names
+    (sort (environment-variables-names env)
+          string<?
+          #:key environment-name->string))
+  (for ([name (in-list names)])
+    (define value (environment-variables-ref env name))
+    (when value
+      (printf "~a=~a\n" (environment-name->string name) (environment-value->string value)))))
+
+(define (coreutils-printenv . args)
+  (define env (current-environment-variables))
+  (if (null? args)
+      (write-environment env)
+      (for ([arg (in-list args)])
+        (define name (string->bytes/locale (arg->string arg)))
+        (define value (environment-variables-ref env name))
+        (when value (displayln (environment-value->string value))))))
+
+(define assignment-rx #px"^([^=]+)=(.*)$")
+
+(define (value->environment-string value)
+  (cond
+    [(string? value) value]
+    [(path? value) (path->string value)]
+    [(symbol? value) (symbol->string value)]
+    [(bytes? value) (bytes->string/locale value)]
+    [else (~a value)]))
+
+(define (split-environment-arguments args)
+  (let loop ([rest args] [assignments '()])
+    (cond
+      [(null? rest)
+       (values (reverse assignments) '())]
+      [(environment-assignment? (car rest))
+       (define assignment (car rest))
+       (loop (cdr rest)
+             (cons (cons (environment-assignment-name assignment)
+                         (environment-assignment-value assignment))
+                   assignments))]
+      [else
+       (define text (arg->string (car rest)))
+       (define match (regexp-match assignment-rx text))
+       (if match
+           (loop (cdr rest)
+                 (cons (cons (list-ref match 1)
+                             (list-ref match 2))
+                       assignments))
+           (values (reverse assignments) rest))])))
+
+(define (run-external-environment-command command)
+  (define executable
+    (find-executable-path (arg->string (car command))))
+  (unless executable
+    (raise-arguments-error 'env "command was not found on PATH"
+                           "command" (car command)))
+  (define ok?
+    (apply system* executable (map arg->string (cdr command))))
+  (unless ok?
+    (raise-arguments-error 'env "command returned a non-zero exit status"
+                           "command" (car command))))
+
+(define (coreutils-env . args)
+  (define-values (assignments command)
+    (split-environment-arguments args))
+  (define env
+    (environment-variables-copy (current-environment-variables)))
+  (for ([assignment (in-list assignments)])
+    (environment-variables-set!
+     env
+     (string->bytes/locale (car assignment))
+     (string->bytes/locale
+      (value->environment-string (cdr assignment)))))
+  (if (null? command)
+      (write-environment env)
+      (parameterize ([current-environment-variables env])
+        (define runner (current-coreutils-command-runner))
+        (define handled?
+          (and runner (runner command)))
+        (unless handled?
+          (run-external-environment-command command)))))
+
+(define (coreutils-date . args)
+  (define utc? #f)
+  (define iso? #f)
+  (define timezone #f)
+  (define pattern #f)
+  (let loop ([rest args])
+    (cond
+      [(null? rest) (void)]
+      [(member (arg->string (car rest)) '("-u" "--utc"))
+       (set! utc? #t)
+       (loop (cdr rest))]
+      [(member (arg->string (car rest)) '("-I" "--iso" "--iso-8601"))
+       (set! iso? #t)
+       (loop (cdr rest))]
+      [(string=? (arg->string (car rest)) "--tz")
+       (unless (pair? (cdr rest))
+         (raise-arguments-error 'date "missing time zone" "arguments" args))
+       (set! timezone (arg->string (cadr rest)))
+       (loop (cddr rest))]
+      [(string=? (arg->string (car rest)) "--format")
+       (unless (pair? (cdr rest))
+         (raise-arguments-error 'date "missing CLDR format" "arguments" args))
+       (set! pattern (arg->string (cadr rest)))
+       (loop (cddr rest))]
+      [else
+       (raise-arguments-error 'date "unsupported argument" "argument" (car rest))]))
+  (define m
+    (cond
+      [utc? (now/moment/utc)]
+      [timezone (now/moment #:tz timezone)]
+      [else (now/moment)]))
+  (displayln
+   (cond
+     [pattern (~t m pattern)]
+     [iso? (moment->iso8601 m)]
+     [else (~t m "EEE MMM dd HH:mm:ss xxx yyyy")])))

private/help.rkt

@@ -0,0 +1,63 @@
+#lang racket/base
+
+(require racket/format
+         racket/system
+         "commands.rkt"
+         "racket-tools.rkt")
+
+(provide coreutils-help
+         coreutils-help-search-term
+         raco-executable)
+
+(define (arg->string arg)
+  (cond
+    [(string? arg) arg]
+    [(symbol? arg) (symbol->string arg)]
+    [else (~a arg)]))
+
+(define (arg->symbol arg)
+  (cond
+    [(symbol? arg) arg]
+    [(string? arg) (string->symbol arg)]
+    [else #f]))
+
+(define (coreutils-help-search-term value)
+  (define name (arg->symbol value))
+  (define command (and name (find-coreutils-command name)))
+  (if command
+      (symbol->string (coreutils-command-documentation-term command))
+      (arg->string value)))
+
+(define (raco-executable)
+  (find-raco-executable))
+
+(define (open-racket-documentation search-term)
+  (define ok?
+    (system* (raco-executable)
+             "docs"
+             "--"
+             search-term))
+  (unless ok?
+    (raise-arguments-error 'help
+                           "raco docs failed"
+                           "search term" search-term)))
+
+(define (write-command-list)
+  (displayln "rash-coreutils commands:")
+  (for ([command (in-list coreutils-commands)])
+    (printf "  ~a\n" (coreutils-command-name command)))
+  (newline)
+  (displayln "Use: help <command> or <command> --help")
+  (displayln "Other terms are passed to Racket's documentation search."))
+
+(define (coreutils-help . args)
+  (cond
+    [(null? args)
+     (write-command-list)]
+    [(= (length args) 1)
+     (open-racket-documentation
+      (coreutils-help-search-term (car args)))]
+    [else
+     (raise-arguments-error 'help
+                            "expected zero or one search term"
+                            "arguments" args)]))

private/path-output.rkt

@@ -0,0 +1,17 @@
+#lang racket/base
+
+(require racket/format
+         racket/path
+         racket/string)
+
+(provide path->rash-string)
+
+(define (path->rash-string path)
+  (define text
+    (cond
+      [(path? path) (path->string path)]
+      [(string? path) path]
+      [else (path->string (string->path (~a path)))]))
+  (if (eq? (system-type 'os) 'windows)
+      (string-replace text "\\" "/")
+      text))

private/racket-tools.rkt

@@ -0,0 +1,75 @@
+#lang racket/base
+
+(require racket/format
+         racket/list
+         racket/path
+         racket/string
+         racket/system
+         setup/dirs)
+
+(provide coreutils-raco
+         find-raco-executable)
+
+(define (raco-executable-name)
+  (if (eq? (system-type 'os) 'windows)
+      "raco.exe"
+      "raco"))
+
+(define (existing-raco-in directory)
+  (and directory
+       (let ([path (build-path directory (raco-executable-name))])
+         (and (file-exists? path) path))))
+
+(define (find-raco-executable)
+  ;; Prefer the console executable directory of the current Racket
+  ;; installation. This avoids accidentally using raco from another Racket
+  ;; installation on PATH.
+  (define console-bin
+    (with-handlers ([exn:fail? (λ (_) #f)])
+      (find-console-bin-dir)))
+  (define from-console-bin
+    (existing-raco-in console-bin))
+
+  ;; Portable and non-standard installations commonly put raco next to the
+  ;; currently running Racket executable.
+  (define exec-file
+    (with-handlers ([exn:fail? (λ (_) #f)])
+      (find-system-path 'exec-file)))
+  (define from-exec-dir
+    (and exec-file
+         (existing-raco-in (path-only exec-file))))
+
+  ;; PATH is deliberately last because it may point to another installation.
+  (or from-console-bin
+      from-exec-dir
+      (find-executable-path (raco-executable-name))
+      (error 'raco "cannot find raco for the current Racket installation")))
+
+(define (command-item->strings value)
+  (cond
+    [(symbol? value) (list (symbol->string value))]
+    [(path? value) (list (path->string value))]
+    [(string? value) (list value)]
+    [(number? value) (list (~a value))]
+    [(list? value) (append-map command-item->strings value)]
+    [else
+     (raise-argument-error
+      'raco
+      "command item (string, symbol, path, number, or list)"
+      value)]))
+
+(define (coreutils-raco . command)
+  (define arguments
+    (append-map command-item->strings command))
+  (define executable (find-raco-executable))
+  (printf "> ~a ~a\n"
+          (path->string executable)
+          (string-join arguments " "))
+
+  (unless (apply system* executable arguments)
+    (error 'raco
+           "command failed~a"
+           (if (null? arguments)
+               ""
+               (format ": ~a" (car arguments)))))
+  (void))