capitalex / snarl.factor

! Copyright (C) 2023 and Null ! This mine and only mine all rights reserved >:3c USING: accessors assocs assocs.extras combinators combinators.short-circuit command-line continuations debugger html.elements io io.directories io.encodings.utf8 io.files io.files.info io.pathnames io.streams.string kernel literals namespaces sbufs sequences sequences.deep sets sorting splitting strings unicode xml xml.data xml.state xml.traversal xml.writer ; FROM: namespaces => set ; IN: snarl <PRIVATE M: xml write-xml [ before>> write-xml ] [ body>> write-xml ] [ after>> write-xml ] tri ; SYMBOLS: @current-page @public-path @template @pages @titles @inbound @headers @hidden-from-sitemap ; CONSTANT: HEADERS $[ { "h1" "h2" "h3" "h4" "h5" "h6" } [ <null-name> ] map! ] : set-html-escape-codes ( -- ) H{ { "emsp" { 8195 } } { "nbsp" { 160 } } { "amp" { 38 } } { "mdash" { 8212 } } } extra-entities set ; : current-page ( -- current-page ) @current-page get ; inline : inbound ( -- inbound ) @inbound get ; inline : titles ( -- titles ) @titles get ; inline : pages ( -- pages ) @pages get ; inline : template ( -- template ) @template get ; inline : headers ( -- headers ) @headers get ; inline : <section ( -- ) "<section" write-html ; : section> ( -- ) ">" write-html ; : </section> ( -- ) "</section>" write-html ; : set-main-article ( xml -- xml ) dup "main-article" "id" set-attr ; : article? ( string -- string ) >lower { [ "the" = ] [ "a" = ] [ "an" = ] } 1|| ; : leading-letter ( words -- words ) split-words [ article? ] reject first 1 head >upper ; : group-pages-alphbetically ( -- pages ) pages keys [ titles at leading-letter ] collect-by [ [ titles at split-words dup first article? [ rest ] when " " join ] sort-by ] assoc-map sort-keys ; : find-headers ( tag -- headers ) [ HEADERS swap '[ _ tag-named? ] any? ] { } deep-filter-as ; : backlink ( links -- ) current-page inbound '[ _ _ swapd adjoin-at ] each ; : bad-link? ( link -- ? ) { [ empty? ] [ "http" head? ] [ "sitemap.html" = ] [ current-page = ] } 1|| ; : links ( xml -- links ) "a" deep-tags-named [ "href" attr ] map! ; : link-outbound ( xml -- xml ) dup links [ bad-link? ] reject [ "#" split first ] map backlink ; : find-title ( xml -- title ) "h1" deep-tag-named deep-children>string ; : load-templates ( wiki-path -- ) "_templates/page.html" append-path utf8 file-contents >sbuf @template set ; : save-headers ( xml -- xml ) dup find-headers current-page headers set-at ; : save-title ( xml -- xml ) dup current-page titles [ drop find-title ] change-at ; : save-page ( xml -- xml ) dup current-page @pages get set-at ; : ?hide-from-sitemap ( xml -- xml ) dup "sitemap" attr [ current-page @hidden-from-sitemap get adjoin ] when ; : write-article ( template page xml -- template ) nip set-main-article xml>string "{{article}}" swap replace ; : list-inbound ( inbound -- ) [ <li> <a dup =href a> titles at write </a> </li> ] each ; : write-inbound ( template page xml -- template ) drop inbound at members [ titles at leading-letter ] sort-by [ <h4 "inbound-links" =id h4> "In Bound Links" write </h4> <ul "link-list" =id ul> list-inbound </ul> ] with-string-writer "{{backlinks}}" swap replace ; : list-headers ( headers -- ) [ <li> <a dup "id" attr "#" prepend =href a> deep-children>string write </a> </li> ] each ; : write-headers ( template page xml -- template ) drop headers at [ "id" attr ] filter [ <h4> "Headers" write </h4> <ul "header-list" =id ul> list-headers </ul> ] with-string-writer "{{headings}}" swap replace ; : write-title ( template page xml -- template ) drop titles at "{{title}}" swap replace ; : write-locations ( pages -- ) [ <li> <a dup =href a> titles at write </a> </li> ] each ; : reject-hidden-pages ( pages -- pages ) [ @hidden-from-sitemap get in? ] reject ; : remove-hidden-pages ( sitemap -- sitemap ) [ reject-hidden-pages ] map-values harvest-values ; : render-sitemap ( -- string ) group-pages-alphbetically remove-hidden-pages [ <section "sitemap" =id section> <h1> "Site Map" write </h1> [ <section "listing" =class section> <h3> swap write </h3> <ul> write-locations </ul> </section> ] assoc-each </section> ] with-string-writer ; : render-page ( page xml -- string ) [ dup @current-page set ] dip [ template ] 2dip { [ write-title ] [ write-headers ] [ write-inbound ] [ write-article ] } 2cleave ; : process-page ( xml -- ) save-page save-title save-headers ?hide-from-sitemap link-outbound drop ; : load-page ( file-path -- ) dup file-name @current-page set file>xml process-page ; : should-write? ( to-write path -- ? ) dup file-exists? [ utf8 file-contents swap >string = not ] [ 2drop t ] if ; : write-page ( file string -- ) swap @public-path get prepend-path 2dup should-write? [ utf8 set-file-contents ] [ 2drop ] if ; : write-pages ( vec -- ) [ write-page ] assoc-each ; : generate-sitemap ( vec -- vec ) template "Site Map" "{{title}}" swap replace "" "{{headings}}" swap replace "" "{{backlinks}}" swap replace render-sitemap "{{article}}" swap replace "sitemap.html" swap set-of ; : generate-pages ( -- vec ) pages [ [ render-page ] keepd swap ] assoc-map ; : load-articles ( pages-path -- ) qualified-directory-files [ directory? ] reject [ load-page ] each ; : initialize-paths ( args -- pages-path ) { [ "public" append-path @public-path set ] [ load-templates ] [ "pages" append-path ] } cleave ; : initialize-state ( -- ) H{ } clone @titles set H{ } clone @headers set H{ } clone @inbound set H{ } clone @pages set HS{ } clone @hidden-from-sitemap set ; : build-failed ( _ error -- ) nip print-error "Failed to build: " write current-page print ; PRIVATE> : build-wiki ( args -- ) [ set-html-escape-codes initialize-state initialize-paths load-articles generate-pages generate-sitemap write-pages ] [ build-failed ] recover ; MAIN: [ command-line get ?first [ build-wiki ] [ "Usage: snarl DIR" print ] if* ]