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))