136 lines
6.0 KiB
Racket
136 lines
6.0 KiB
Racket
#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))
|