haskal
/
capybara
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

make relative xrefs work

This commit is contained in:
xenia 2021-06-11 01:12:39 -04:00
parent 9408f67b01
commit 86bb36fe49
1 changed files with 23 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

35
render.rkt
View File

@ -1,7 +1,7 @@
#lang racket/base #lang racket/base
(require racket/fasl racket/list racket/match racket/port racket/path racket/set racket/string (require racket/fasl racket/list racket/match racket/port racket/path racket/set racket/string
racket/runtime-path racket/runtime-path net/url-string
markdown markdown/display-xexpr markdown/toc markdown markdown/display-xexpr markdown/toc
"compiler.rkt" "defs.rkt" "fetch.rkt" "compiler.rkt" "defs.rkt" "fetch.rkt"
threading threading
@ -17,6 +17,8 @@
(define *index.md* (build-path "index.md")) (define *index.md* (build-path "index.md"))
(define *reserved-slugs* (set (build-path "hashtag") (build-path "user") (build-path "tech")))
(define (read-input-doc xref-name [port (current-input-port)]) (define (read-input-doc xref-name [port (current-input-port)])
(define metadata (read port)) (define metadata (read port))
(unless (metadata? metadata) (unless (metadata? metadata)
@ -74,19 +76,25 @@
(define (extract-prefixed-links/many xexprs start-char tag-name) (define (extract-prefixed-links/many xexprs start-char tag-name)
(map (λ (xexpr) (extract-prefixed-links xexpr start-char tag-name)) xexprs)) (map (λ (xexpr) (extract-prefixed-links xexpr start-char tag-name)) xexprs))
(define (check-xrefs xexprs xrefs-repo) (define (check-xrefs xexprs xrefs-repo base-xref)
(define (check-xrefs-help xexpr) (define (check-xrefs-help xexpr)
(match xexpr (match xexpr
[(list 'xref (list (list 'target target)) body ...) [(list 'xref (list (list 'target target)) body ...)
(define target-path (explode-path (build-path "/" target))) (define abs-target
(unless (set-member? xrefs-repo target-path) (simplify-path
(url->path
(combine-url/relative
(path->url base-xref)
target))
#f))
(unless (set-member? xrefs-repo (explode-path abs-target))
(error "invalid xref!" target)) (error "invalid xref!" target))
(map check-xrefs-help body)] (apply list 'xref (list (list 'target (path->string abs-target)))
(map check-xrefs-help body))]
[(list tag attrs body ...) [(list tag attrs body ...)
(map check-xrefs-help body)] (cons tag (cons attrs (map check-xrefs-help body)))]
[(? string?) (void)])) [(? string?) xexpr]))
(map check-xrefs-help xexprs) (map check-xrefs-help xexprs))
xexprs)
(define (input-doc->ir-doc doc xrefs-repo) (define (input-doc->ir-doc doc xrefs-repo)
(match-define (input-doc md xref-name text) doc) (match-define (input-doc md xref-name text) doc)
@ -97,7 +105,7 @@
(extract-text-starting-with/many *user-char* 'user) (extract-text-starting-with/many *user-char* 'user)
(extract-prefixed-links/many *xref-char* 'xref) (extract-prefixed-links/many *xref-char* 'xref)
(extract-prefixed-links/many *user-char* 'user) (extract-prefixed-links/many *user-char* 'user)
(check-xrefs xrefs-repo))) (check-xrefs xrefs-repo xref-name)))
(ir-doc md xref-name output-cooked)) (ir-doc md xref-name output-cooked))
;; lowers pseudo-tags into their final form ;; lowers pseudo-tags into their final form
@ -110,7 +118,7 @@
,@(map lower-specials* body))] ,@(map lower-specials* body))]
;; xrefs ;; xrefs
[(list 'xref (list (list 'target target)) body ...) [(list 'xref (list (list 'target target)) body ...)
`(a ([class "xref"] [href ,(format "~a/xref/~a" base-url target)]) `(a ([class "xref"] [href ,(format "~a~a" base-url target)])
,@(map lower-specials* body))] ,@(map lower-specials* body))]
;; users ;; users
[(list 'user (list (list 'target target)) body ...) [(list 'user (list (list 'target target)) body ...)
@ -182,7 +190,10 @@
(define xrefs-repo (define xrefs-repo
(for/set ([spec (in-list rule-specs)]) (for/set ([spec (in-list rule-specs)])
(explode-path (rule-spec-xref-name spec)))) (define exploded (explode-path (rule-spec-xref-name spec)))
(when (and (> (length exploded) 1)
(set-member? *reserved-slugs* (second exploded)))
(error "file is using a reserved slug" (rule-spec-src spec)))))
(define intermediate-rules (define intermediate-rules
(for/list ([spec (in-list rule-specs)]) (for/list ([spec (in-list rule-specs)])