Define Filesystem Paths Pithily

define-paths.rkt

#lang racket/base

(require
  (for-syntax
   racket/base
   racket/syntax
   syntax/parse
   syntax/id-set
   (only-in
    racket/list append*)
   (only-in
    racket/string string-join)))

;--------------
; PATHS-SYNTAX
(begin-for-syntax
  ;------------
  ; PATH-NAMES
  (define (labl-of type)
    (case type [(file) #'("~a")] [(directory) #'("~a/")]))

  (define :face (gensym))
  
  (define-splicing-syntax-class
    (path-name type)
    #:description
    "the name of a file or a directory, with an optional from-clause"
    #:attributes
    ([name 0] [mask 0] [labl 0] [path 0] [term 0] [mask* 0])

    (pattern {~seq name:id #:is from:expr}
      #:attr mask  (syntax-property (generate-temporary 'mask) :face #'from)
      #:attr labl  (labl-of type)
      #:attr path  #'(name)
      #:attr term  #'(mask)
      #:attr mask* #'(mask))
    
    (pattern {~seq name:id}
      #:attr mask  #`#,(symbol->string (syntax-e #'name))
      #:attr labl  (labl-of type)
      #:attr path  #'(name)
      #:attr term  #'(mask)
      #:attr mask* #'()))

  ;------------
  ; FILE-NAMES
  (define-splicing-syntax-class
    file
    #:description
    "the name of a file"
    #:attributes
    ([labl 0] [path 0] [term 0] [mask* 0])
    #:local-conventions
    ([name (path-name 'file)])
    
    (pattern name
      #:with labl  #'name.labl
      #:with path  #'name.path
      #:with term  #'name.term
      #:attr mask* #'name.mask*))

  ;-------------------
  ; DIRECTORY-CONTENT
  (define-splicing-syntax-class
    dir-content
    #:description
    "the contents of a directory"
    #:attributes
    ([labls 1] [paths 1] [terms 1] [mask* 0])
    
    (pattern {~seq (~alt file:file dir:directory) ...}
      #:with (labls ...) #'(file.labl ... dir.labls ... ...)
      #:with (paths ...) #'(file.path ... dir.paths ... ...)
      #:with (terms ...) #'(file.term ... dir.terms ... ...)
      #:attr  mask*      #'((~@ . file.mask*) ... (~@ . dir.mask*) ...)))

  ;-------------
  ; DIRECTORIES
  ;-------------------------------------------------------------------------
  ; this seems fishy to me, but I can't get the ellipses to match up nicely
  ; in the class itself--specifically, the variadic names-case
  (define (extend-content labls paths terms labl* path* name* term* mask*)
    (define labls-list (syntax->list labls))
    (define paths-list (syntax->list paths))
    (define terms-list (syntax->list terms))
    (for/lists
     (labls* paths* terms*
      #:result
      (list (append* labls*)
            (append* paths*)
            (append* terms*)))
               
     ([labl (in-list (syntax->list labl*))]
      [path (in-list (syntax->list path*))]
      [name (in-list (syntax->list name*))]
      [term (in-list (syntax->list term*))]
      [mask (in-list (syntax->list mask*))])
      
      (values
       (cons labl (map (lambda (labl) #`("~a/"  . #,labl)) labls-list))
       (cons path (map (lambda (path) #`(#,name . #,path)) paths-list))
       (cons term (map (lambda (term) #`(#,mask . #,term)) terms-list)))))
  
  (define-syntax-class
    directory
    #:description
    "the names and contents of one or more directories"
    #:attributes
    ([labls 1] [paths 1] [terms 1] [mask* 0])
    #:local-conventions
    ([name (path-name 'directory)])
    
    (pattern [name content:dir-content]
      #:with ((labls ...) (paths ...) (terms ...))
      (extend-content
       #'(content.labls ...)
       #'(content.paths ...)
       #'(content.terms ...)
       #'(name.labl)
       #'(name.path) #'(name.name)
       #'(name.term) #'(name.mask))
      #:attr mask*
      #'((~@ . name.mask*) (~@ . content.mask*)))
    
    (pattern [(name ...+) content:dir-content]
      #:with ((labls ...) (paths ...) (terms ...))
      (extend-content
       #'(content.labls ...)
       #'(content.paths ...)
       #'(content.terms ...)
       #'(name.labl ...)
       #'(name.path ...) #'(name.name ...)
       #'(name.term ...) #'(name.mask ...))
      #:attr mask*
      #'((~@ . name.mask*) ... (~@ . content.mask*))))

  ;--------------
  ; PATH-ALIASES
  (define (unmask term) (syntax-property term :face))

  (define (masklets terms)
    (define mask-set (immutable-free-id-set (syntax->list terms)))
    (for/list ([mask (in-free-id-set mask-set)])
      #`[#,mask #,(unmask mask)]))
  
  ;-------------------
  ; PATH-CONSTRUCTORS
  (define ((format-path-name stx) labl path)
    (format-id stx labl #:subs? #true . apply . path))
  
  (define (labl-join labels) (string-join labels ""))
  (define (format-paths-names stx labls-stx paths-stx)
    (define labels (map labl-join    (syntax->datum labls-stx)))
    (define paths* (map syntax->list (syntax->list paths-stx)))
    (map (format-path-name stx) labels paths*)))

;--------------
; PATHS-MACROS
(define-syntax (define-paths stx)
  (syntax-parse stx
    [(_ #:relative-to root:expr :dir-content)
     #:attr  basis (generate-temporary 'root)
     #:with  masks (masklets #'mask*)
     #:with (names ...)
     (format-paths-names stx #'(labls ...) #'(paths ...))
     #'(define-values (names ...)
         (let ([basis root] . masks)
           (values (build-path basis . terms) ...)))]

    [(_ :dir-content)
     #:with  masks (masklets #'mask*)
     #:with (names ...)
     (format-paths-names stx #'(labls ...) #'(paths ...))
     #'(define-values (names ...)
         (let masks (values (build-path . terms) ...)))]))

;-------------
; MACRO-USAGE
(define some-dir     "something")
(define other-dir    "different")
(define nowhere-file "here.txt")

(define-paths
  [{Some #:is some-dir
    some #:is other-dir}
   [path
    [{To to}
     Nowhere.txt
     nowhere.txt #:is nowhere-file]]]
  
  [{Other #:is some-dir
    other #:is other-dir}
   [path
    [{To to}
     Nowhere.txt
     nowhere.txt #:is nowhere-file]]])

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\something\path\To\Nowhere.txt>
 #<path:C:\Users\CHRISTIAAN-BRAND\something\path\To\here.txt>
 #<path:C:\Users\CHRISTIAAN-BRAND\something\path\to\Nowhere.txt>
 #<path:C:\Users\CHRISTIAAN-BRAND\something\path\to\here.txt>
 #<path:C:\Users\CHRISTIAAN-BRAND\different\path\To\Nowhere.txt>
 #<path:C:\Users\CHRISTIAAN-BRAND\different\path\To\here.txt>
 #<path:C:\Users\CHRISTIAAN-BRAND\different\path\to\Nowhere.txt>
 #<path:C:\Users\CHRISTIAAN-BRAND\different\path\to\here.txt>
|#