www

Unnamed repository; edit this file 'description' to name the repository.
Log | Files | Refs

mpi.rkt (7297B)

      1 #lang racket/base
      2 (require racket/match
      3          racket/string)
      4 
      5 (provide mpi->list
      6          mpi->string
      7          self-mpi?)
      8 
      9 ;; mpi->list : module-path-index -> list
     10 (define (mpi->list mpi)
     11   (cond [(module-path-index? mpi)
     12          (let-values ([(path relto) (module-path-index-split mpi)])
     13            (cond [(not path) #| relto = #f |# null]
     14                  [(not relto) (list path)]
     15                  [else (cons path (mpi->list relto))]))]
     16         [else (list mpi)]))
     17 
     18 ;; mpi->string : module-path-index -> string
     19 (define (mpi->string mpi)
     20   (if (module-path-index? mpi)
     21       (let ([mps (mpi->list mpi)])
     22         (cond [(pair? mps)
     23                (string-join (map (lambda (x) (format "~s" x)) mps)
     24                             " <= ")]
     25               [(null? mps) "this module"]))
     26       (format "~s" mpi)))
     27 
     28 ;; self-mpi? : module-path-index -> bool
     29 (define (self-mpi? mpi)
     30   (let-values ([(path relto) (module-path-index-split mpi)])
     31     (eq? path #f)))
     32 
     33 ;; --
     34 
     35 (provide mpi->mpi-sexpr
     36          mpi-sexpr->mpi)
     37 
     38 ;; mp = module-path
     39 ;; mpi = module-path-index
     40 ;; rmp = resolved-module-path
     41 
     42 ;; An mpi-sexpr is one of
     43 ;;   (cons mp-sexpr mpi-sexpr)
     44 ;;   (list rmp-sexpr)
     45 ;;   (list #f)  ;; "self" module
     46 ;;   null
     47 
     48 ;; An rmp-sexpr is
     49 ;;   (list 'resolved path/symbol)
     50 
     51 ;; mpi->mpi-sexpr : mpi -> mpi-sexpr
     52 (define (mpi->mpi-sexpr mpi)
     53   (cond [(module-path-index? mpi)
     54          (let-values ([(mod next) (module-path-index-split mpi)])
     55            (cons (mp->mp-sexpr mod) (mpi->mpi-sexpr next)))]
     56         [(resolved-module-path? mpi)
     57          (list (rmp->rmp-sexpr mpi))]
     58         [else null]))
     59 
     60 ;; mp->mp-sexpr : mp -> mp-sexpr
     61 (define (mp->mp-sexpr mp)
     62   (if (path? mp)
     63       (if (absolute-path? mp)
     64           `(file ,(path->string mp))
     65           (path->string mp))
     66       mp))
     67 
     68 ;; mpi-sexpr->mpi : mpi-sexpr -> mpi
     69 (define (mpi-sexpr->mpi sexpr)
     70   (match sexpr
     71     ['() #f]
     72     [(list (list 'resolved path))
     73      (rmp-sexpr->rmp path)]
     74     [(cons first rest)
     75      (module-path-index-join first (mpi-sexpr->mpi rest))]))
     76 
     77 ;; rmp->rmp-sexpr : rmp -> rmp-sexpr
     78 (define (rmp->rmp-sexpr rmp)
     79   (list 'resolved (resolved-module-path-name rmp)))
     80 
     81 ;; rmp-sexpr->rmp : rmp-sexpr -> rmp
     82 (define (rmp-sexpr->rmp sexpr)
     83   (make-resolved-module-path (cadr sexpr)))
     84 
     85 ;; ----
     86 
     87 (provide mpi-sexpr->expanded-mpi-sexpr
     88          expanded-mpi-sexpr->library)
     89 
     90 ;; An expanded-mpi-sexpr is (listof expanded-mpi-frame)
     91 
     92 ;; An expanded-mpi-frame is one of:
     93 ;;   (list 'LIB (listof string))
     94 ;;   (list 'PLANET (listof string) PackageSpec)
     95 ;;   (list 'FILE string)
     96 ;;      absolute file path (not relative)
     97 ;;   (list 'QUOTE symbol)
     98 ;;   (list 'SELF)
     99 ;;   (list 'REL (listof string))
    100 ;;   (list 'SUBMOD (U module-path ".") (listof (U ".." symbol)))
    101 ;; The first 5 variants are considered "absolute" frames.
    102 ;; The first 2 variants are consider "library" frames.
    103 
    104 ;; mpi-sexpr->expanded-mpi-sexpr
    105 (define (mpi-sexpr->expanded-mpi-sexpr sexpr)
    106   (map mpi-frame->expanded-mpi-frame sexpr))
    107 
    108 ;; mpi-frame->expanded-mpi-frame
    109 (define (mpi-frame->expanded-mpi-frame sexpr)
    110   (match sexpr
    111     [#f
    112      `(SELF)]
    113     [`(quote ,mod)
    114      `(QUOTE ,mod)]
    115     [`(lib ,path)
    116      (cond [(symbol? path)
    117             (mpi-frame->expanded-mpi-frame path)]
    118            [(regexp-match? #rx"/" path)
    119             `(LIB ,(split-mods path))]
    120            [else
    121             `(LIB ,(list "mzlib" path))])]
    122     [`(lib ,path . ,more)
    123      `(LIB ,(split-mods path more))]
    124     [`(planet ,(? symbol? spec))
    125      (mpi-frame->expanded-mpi-frame (parse-planet-spec spec))]
    126     [`(planet ,path ,package . ,more)
    127      `(PLANET ,(split-mods path more) ,package)]
    128     [(? symbol? mod)
    129      `(LIB ,(split-mods* (symbol->string mod)))]
    130     [`(file ,path)
    131      (cond [(absolute-path? path)
    132             `(FILE ,path)]
    133            [else
    134             `(REL (split-mods path))])]
    135     [(? string? path)
    136      `(REL ,(split-mods path))]
    137     [`(resolved ,(? path? path))
    138      `(FILE ,path)]
    139     [`(resolved ,(? symbol? symbol))
    140      `(QUOTE ,symbol)]
    141     [`(submod ,base . ,elems)
    142      (cond [(equal? base "..")
    143             `(SUBMOD "." ,(cons ".." elems))]
    144            [else
    145             `(SUBMOD ,base ,@elems)])]
    146     ))
    147 
    148 ;; expanded-mpi-sexpr->mpi-sexpr
    149 (define (expanded-mpi-sexpr->mpi-sexpr sexpr)
    150   (map expanded-mpi-frame->mpi-frame sexpr))
    151 
    152 ;; expanded-mpi-frame->mpi-frame
    153 (define (expanded-mpi-frame->mpi-frame sexpr)
    154   (match sexpr
    155     [`(SELF)
    156      #f]
    157     [`(QUOTE ,mod)
    158      `(quote ,mod)]
    159     [`(LIB ,paths)
    160      `(lib ,(apply string-append (intersperse "/" paths)))]
    161     [`(PLANET ,paths ,package)
    162      `(planet ,(apply string-append (intersperse "/" paths)) ,package)]
    163     [`(FILE ,path)
    164      `(file ,path)]
    165     [`(REL ,paths)
    166      (apply string-append (intersperse "/" paths))]
    167     [`(SUBMOD ,base ,elems)
    168      `(submod ,base ,@elems)]))
    169 
    170 (define (parse-planet-spec spec-sym)
    171   (define spec (symbol->string spec-sym))
    172   (let ([m (regexp-match #rx"([^/]*)/([^:/]*)(?:[:]([^/]*))?(?:/(.*))?" spec)])
    173     (unless m (error "bad planet symbol" spec-sym))
    174     (let ([owner (cadr m)]
    175           [package (string-append (caddr m) ".plt")]
    176           [version (and (cadddr m) (parse-version (cadddr m)))]
    177           [path (list-ref m 4)])
    178       `(planet ,(string-append (or path "main") ".rkt")
    179                (,owner ,package . ,version)))))
    180 
    181 (define (parse-version str)
    182   ;; FIXME!!!
    183   '())
    184 
    185 (define (split-mods* path)
    186   (let ([mods (split-mods path)])
    187     (if (and (pair? mods) (null? (cdr mods)))
    188         (append mods (list "main.rkt"))
    189         mods)))
    190 
    191 (define (split-mods path [more null])
    192   (append (apply append (map split-mods more))
    193           (regexp-split #rx"/" path)))
    194 
    195 (define (flatten-mods more path)
    196   (path->string (apply build-path (append more (list path)))))
    197 
    198 ;; expanded-mpi-sexpr->library : expanded-mpi-sexpr -> expanded-mpi-frame
    199 (define (expanded-mpi-sexpr->library sexpr0)
    200   (define (abs? link)
    201     (and (pair? link) (memq (car link) '(LIB PLANET))))
    202   (define (loop stack stacks)
    203     (cond [(pair? (cdr stack))
    204            (cons (car stack) (loop (cdr stack) stacks))]
    205           [(pair? stacks)
    206            (unless (eq? 'REL (car (car stacks)))
    207              (error 'expanded-mpi-sexpr->library
    208                     "internal error: absolute frame"))
    209            (loop (cadr (car stacks)) (cdr stacks))]
    210           [else stack]))
    211   (define sexpr1 (reverse (cut-to-absolute sexpr0)))
    212   (and (library-expanded-mpi-frame? (car sexpr1))
    213        `(,(car (car sexpr1))
    214          ,(loop (cadr (car sexpr1)) (cdr sexpr1))
    215          . ,(cddr (car sexpr1)))))
    216 
    217 ;; cut-to-absolute : expanded-mpi-sexpr -> expanded-mpi-sexpr
    218 (define (cut-to-absolute sexpr)
    219   (cond [(and (pair? sexpr)
    220               (absolute-expanded-mpi-frame? (car sexpr)))
    221          (list (car sexpr))]
    222         [(pair? sexpr)
    223          (cons (car sexpr) (cut-to-absolute (cdr sexpr)))]))
    224 
    225 ;; absolute-expanded-mpi-frame? : expanded-mpi-frame -> boolean
    226 (define (absolute-expanded-mpi-frame? sexpr)
    227   (not (memq (car sexpr) '(REL))))
    228 
    229 ;; library-expanded-mpi-frame? : expanded-mpi-frame -> boolean
    230 (define (library-expanded-mpi-frame? sexpr)
    231   (memq (car sexpr) '(LIB PLANET)))
    232 
    233 ;; intersperse : X (listof X) -> (listof X)
    234 (define (intersperse sep items)
    235   (cond [(and (pair? items) (pair? (cdr items)))
    236          (cons (car items) (cons sep (intersperse sep (cdr items))))]
    237         [else items]))