Hi, Racket Discourse.
I thought I'd quickly share this little macro for defining paths originating from a single root (or home), which I've been using for easily referencing paths when writing scripts. Perhaps there is already a form which does exactly this, but I have not chanced upon it, yet.
The paths aren't realized, although it would probably be easy to adjust the macro to take care of this as well, or perhaps even incorporate "runtime-path" et al.
Interestingly, this was one of the very first macros I attempted, although it has evolved over time, as I have gained more experience.
#lang racket/base
(require
(for-syntax
racket/base
racket/syntax
syntax/parse))
(provide
define-paths)
(begin-for-syntax
(define-syntax-class
(path-name type)
#:attributes
([labl 0]
[path 0])
(pattern name:id
#:attr labl (case type [(file) #'("~a")] [(directory) #'("~a/")])
#:attr path #'(name)))
(define-syntax-class
file
#:attributes
([labl 0]
[path 0])
#:local-conventions
([name (path-name 'file)])
(pattern name
#:attr labl #'name.labl
#:attr path #'name.path))
(define-syntax-class
directory
#:attributes
([labls 1]
[paths 1])
#:local-conventions
([name (path-name 'directory)])
(pattern [name (~alt file:file sub:directory) ...]
#:with (labls ...) #'(("~a/" . file.labl) ... name.labl ("~a/" . sub.labls) ... ...)
#:with (paths ...) #'((name . file.path) ... name.path (name . sub.paths) ... ...)))
(define ((format-path-name stx) labl path)
(format-id stx labl #:subs? #true . apply . path))
(define (path-join names) (string-append . apply . names))
(define (format-paths-names stx labls-stx paths-stx)
(define paths* (map path-join (syntax->datum labls-stx)))
(map (format-path-name stx) paths* (map syntax->list (syntax->list paths-stx)))))
(define (norm-path path-symbol)
(define path-string (symbol->string path-symbol))
(case (system-path-convention-type)
[(unix) path-string]
[(windows) (regexp-replace* #rx"/" path-string "\\\\")]))
(define-syntax (define-paths stx)
(syntax-parse stx
[(_ #:home home:expr {~alt :file :directory} ...)
#:with once (generate-temporary #'once)
#:with (path-names ...)
(format-paths-names stx #'(labl ... labls ... ...) #'(path ... paths ... ...))
#'(define-values (path-names ...)
(let ([once home])
(values (build-path once (norm-path 'path-names)) ...)))]))
The usage then, looks something like this:
(define-paths
#:home temp/
[cmds
; command outputs
recon.txt
subdomains.txt
take-overs.txt
doppelgangers.json
load-balancing.txt
waf-signatures.json
dir-enumeration.txt
dir-traversal.txt
url-scan.json
wordpress.json]
[assm
; assessment data
assm.log
assm.json
info.json])
Directories appear at the head of a parens-group, as in [cmds ...] and files are the atoms in such a group, as in [cmds ... recon.txt ...].
Happy hacking!
Edit: Define Filesystem Paths Pithily · GitHub
3 Likes
Nice!
Tiny suggestion/idea: Maybe also check out the multi-in clause for require.
Although that can be used (AFAIK) only within require to make import module paths, and isn't a general-purpose path-maker like yours -- multi-in's Cartesian product syntax/approach might be interesting to consider for yours; it's a generalization of yours (IIUC)?
1 Like
Neat! Great reference.
Oh, man, this takes me back to a similar idea I came across from, I think, Norman Wildberger, which describes an operator, let's call it Π, that works like this:
#lang racket/base
(require
(only-in
racket/list append* cartesian-product))
(define (Π index)
(lambda msets
(let loop ([inner index]
[msets msets])
(if (zero? inner)
(append* msets)
(map (lambda (combination)
(loop (- inner 1) combination))
(apply cartesian-product msets))))))
{(Π 0)
'(0)
'(1)
'(0)}
#| produces
'(0 1 0)
|#
{(Π 1)
'((0))
'((1) (0))
'((0))}
#| produces
'((0 1 0)
(0 0 0))
|#
{(Π 2)
'(((0) (1))
((1) (0)))
'(((0) (1)))
'(((1)))}
#| produces
'(((0 0 1)
(0 1 1)
(1 0 1)
(1 1 1))
((1 0 1)
(1 1 1)
(0 0 1)
(0 1 1)))
|#
It is an interesting concept to apply to such paths, thanks for the suggestion.
Look at that! So cool.
#lang racket/base
(require
(for-syntax
racket/base
racket/syntax
syntax/parse))
(begin-for-syntax
(define-syntax-class
(path-name type)
#:attributes
([labl 0]
[path 0])
(pattern name:id
#:attr labl (case type [(file) #'("~a")] [(directory) #'("~a/")])
#:attr path #'(name)))
(define-syntax-class
file
#:attributes
([labl 0]
[path 0])
#:local-conventions
([name (path-name 'file)])
(pattern name
#:attr labl #'name.labl
#:attr path #'name.path))
(define-syntax-class
file*
#:attributes
([labl 1]
[path 1])
(pattern file:file
#:with (labl ...) #'(file.labl)
#:with (path ...) #'(file.path))
(pattern (file:file ...)
#:with (labl ...) #'(file.labl ...)
#:with (path ...) #'(file.path ...)))
(define-syntax-class
directory
#:attributes
([labls 1]
[paths 1])
#:local-conventions
([name (path-name 'directory)])
(pattern [name (~alt file:file* sub:directory*) ...]
#:with (labls ...) #'(("~a/" . file.labl) ... ... name.labl ("~a/" . sub.labls) ... ...)
#:with (paths ...) #'((name . file.path) ... ... name.path (name . sub.paths) ... ...)))
(define-syntax-class
directory*
#:attributes
([labls 1]
[paths 1])
#:local-conventions
([name (path-name 'directory)])
(pattern :directory)
(pattern [(name ...+) content ...]
#:with (dir:directory ...) #'([name content ...] ...)
#:with (labls ...) #'(dir.labls ... ...)
#:with (paths ...) #'(dir.paths ... ...)))
(define ((format-path-name stx) labl path)
(format-id stx labl #:subs? #true . apply . path))
(define (path-join names) (string-append . apply . names))
(define (format-paths-names stx labls-stx paths-stx)
(define paths* (map path-join (syntax->datum labls-stx)))
(map (format-path-name stx) paths* (map syntax->list (syntax->list paths-stx)))))
(define (norm-path path-symbol)
(define path-string (symbol->string path-symbol))
(case (system-path-convention-type)
[(unix) path-string]
[(windows) (regexp-replace* #rx"/" path-string "\\\\")]))
(define-syntax (define-paths stx)
(syntax-parse stx
[(_ #:home home:expr {~alt :file* :directory*} ...)
#:with once (generate-temporary #'once)
#:with (path-names ...)
(format-paths-names stx #'(labl ... ... labls ... ...) #'(path ... ... paths ... ...))
#'(define-values (path-names ...)
(let ([once home])
(values (build-path once (norm-path 'path-names)) ...)))]))
(define-paths
#:home (find-system-path 'home-dir)
[(Some some)
[path
[(To to) (Nowhere.txt nowhere.txt)]]])
Some/path/To/Nowhere.txt
Some/path/To/nowhere.txt
Some/path/to/Nowhere.txt
Some/path/to/nowhere.txt
some/path/To/Nowhere.txt
some/path/To/nowhere.txt
some/path/to/Nowhere.txt
some/path/to/nowhere.txt
;=>
#<path:C:\Users\CHRISTIAAN-BRAND\Some\path\To\Nowhere.txt>
#<path:C:\Users\CHRISTIAAN-BRAND\Some\path\To\nowhere.txt>
#<path:C:\Users\CHRISTIAAN-BRAND\Some\path\to\Nowhere.txt>
#<path:C:\Users\CHRISTIAAN-BRAND\Some\path\to\nowhere.txt>
#<path:C:\Users\CHRISTIAAN-BRAND\some\path\To\Nowhere.txt>
#<path:C:\Users\CHRISTIAAN-BRAND\some\path\To\nowhere.txt>
#<path:C:\Users\CHRISTIAAN-BRAND\some\path\to\Nowhere.txt>
#<path:C:\Users\CHRISTIAAN-BRAND\some\path\to\nowhere.txt>
Incidentally, what would one call these types of syntax-classes? That is, file* and directory* work by extending the base class of the pattern, i.e. file and directory, cool beans.
But, in the case of directory*, we introduce the recursive term into the base class, too. Mutually recursive syntax classes?
1 Like
