snarl.factor
| @@ -1,4 +1,4 @@ | |||
| 1 | - | ! Copyright (C) 2023 CapitalEx | |
| 1 | + | ! Copyright (C) 2023 and Null | |
| 2 | 2 | ! This mine and only mine all rights reserved >:3c | |
| 3 | 3 | USING: accessors assocs assocs.extras combinators | |
| 4 | 4 | combinators.short-circuit command-line continuations debugger | |
snarl.factor(файл создан)
| @@ -0,0 +1,214 @@ | |||
| 1 | + | ! Copyright (C) 2023 CapitalEx | |
| 2 | + | ! This mine and only mine all rights reserved >:3c | |
| 3 | + | USING: accessors assocs assocs.extras combinators | |
| 4 | + | combinators.short-circuit command-line continuations debugger | |
| 5 | + | html.elements io io.directories io.encodings.utf8 io.files | |
| 6 | + | io.files.info io.pathnames io.streams.string kernel literals | |
| 7 | + | namespaces sbufs sequences sequences.deep sets sorting splitting | |
| 8 | + | strings unicode xml xml.data xml.state xml.traversal xml.writer | |
| 9 | + | ; | |
| 10 | + | FROM: namespaces => set ; | |
| 11 | + | IN: snarl | |
| 12 | + | <PRIVATE | |
| 13 | + | M: xml write-xml | |
| 14 | + | [ before>> write-xml ] | |
| 15 | + | [ body>> write-xml ] | |
| 16 | + | [ after>> write-xml ] tri ; | |
| 17 | + | ||
| 18 | + | SYMBOLS: @current-page @public-path @template @pages @titles | |
| 19 | + | @inbound @headers @hidden-from-sitemap ; | |
| 20 | + | ||
| 21 | + | CONSTANT: HEADERS $[ | |
| 22 | + | { "h1" "h2" "h3" "h4" "h5" "h6" } [ <null-name> ] map! | |
| 23 | + | ] | |
| 24 | + | ||
| 25 | + | : set-html-escape-codes ( -- ) | |
| 26 | + | H{ | |
| 27 | + | { "emsp" { 8195 } } | |
| 28 | + | { "nbsp" { 160 } } | |
| 29 | + | { "amp" { 38 } } | |
| 30 | + | { "mdash" { 8212 } } | |
| 31 | + | } extra-entities set ; | |
| 32 | + | ||
| 33 | + | : current-page ( -- current-page ) @current-page get ; inline | |
| 34 | + | : inbound ( -- inbound ) @inbound get ; inline | |
| 35 | + | : titles ( -- titles ) @titles get ; inline | |
| 36 | + | : pages ( -- pages ) @pages get ; inline | |
| 37 | + | : template ( -- template ) @template get ; inline | |
| 38 | + | : headers ( -- headers ) @headers get ; inline | |
| 39 | + | ||
| 40 | + | : <section ( -- ) "<section" write-html ; | |
| 41 | + | : section> ( -- ) ">" write-html ; | |
| 42 | + | : </section> ( -- ) "</section>" write-html ; | |
| 43 | + | ||
| 44 | + | : set-main-article ( xml -- xml ) | |
| 45 | + | dup "main-article" "id" set-attr ; | |
| 46 | + | ||
| 47 | + | : article? ( string -- string ) | |
| 48 | + | >lower { [ "the" = ] [ "a" = ] [ "an" = ] } 1|| ; | |
| 49 | + | ||
| 50 | + | : leading-letter ( words -- words ) | |
| 51 | + | split-words [ article? ] reject first 1 head >upper ; | |
| 52 | + | ||
| 53 | + | : group-pages-alphbetically ( -- pages ) | |
| 54 | + | pages keys [ titles at leading-letter ] collect-by | |
| 55 | + | [ [ titles at split-words dup first article? [ rest ] when " " join ] sort-by ] assoc-map | |
| 56 | + | sort-keys ; | |
| 57 | + | ||
| 58 | + | : find-headers ( tag -- headers ) | |
| 59 | + | [ HEADERS swap '[ _ tag-named? ] any? ] { } deep-filter-as ; | |
| 60 | + | ||
| 61 | + | : backlink ( links -- ) | |
| 62 | + | current-page inbound '[ _ _ swapd adjoin-at ] each ; | |
| 63 | + | ||
| 64 | + | : bad-link? ( link -- ? ) | |
| 65 | + | { [ empty? ] [ "http" head? ] | |
| 66 | + | [ "sitemap.html" = ] [ current-page = ] } 1|| ; | |
| 67 | + | ||
| 68 | + | : links ( xml -- links ) | |
| 69 | + | "a" deep-tags-named [ "href" attr ] map! ; | |
| 70 | + | ||
| 71 | + | : link-outbound ( xml -- xml ) | |
| 72 | + | dup links [ bad-link? ] reject [ "#" split first ] map backlink ; | |
| 73 | + | ||
| 74 | + | : find-title ( xml -- title ) | |
| 75 | + | "h1" deep-tag-named deep-children>string ; | |
| 76 | + | ||
| 77 | + | : load-templates ( wiki-path -- ) | |
| 78 | + | "_templates/page.html" append-path utf8 file-contents >sbuf | |
| 79 | + | @template set ; | |
| 80 | + | ||
| 81 | + | : save-headers ( xml -- xml ) | |
| 82 | + | dup find-headers current-page headers set-at ; | |
| 83 | + | ||
| 84 | + | : save-title ( xml -- xml ) | |
| 85 | + | dup current-page titles [ drop find-title ] change-at ; | |
| 86 | + | ||
| 87 | + | : save-page ( xml -- xml ) | |
| 88 | + | dup current-page @pages get set-at ; | |
| 89 | + | ||
| 90 | + | : ?hide-from-sitemap ( xml -- xml ) | |
| 91 | + | dup "sitemap" attr [ | |
| 92 | + | current-page @hidden-from-sitemap get adjoin | |
| 93 | + | ] when ; | |
| 94 | + | ||
| 95 | + | : write-article ( template page xml -- template ) | |
| 96 | + | nip set-main-article xml>string "{{article}}" swap replace ; | |
| 97 | + | ||
| 98 | + | : list-inbound ( inbound -- ) | |
| 99 | + | [ <li> <a dup =href a> titles at write </a> </li> ] each ; | |
| 100 | + | ||
| 101 | + | : write-inbound ( template page xml -- template ) | |
| 102 | + | drop inbound at members [ titles at leading-letter ] sort-by [ | |
| 103 | + | <h4 "inbound-links" =id h4> "In Bound Links" write </h4> | |
| 104 | + | <ul "link-list" =id ul> list-inbound </ul> | |
| 105 | + | ] with-string-writer "{{backlinks}}" swap replace ; | |
| 106 | + | ||
| 107 | + | : list-headers ( headers -- ) | |
| 108 | + | [ | |
| 109 | + | <li> <a dup "id" attr "#" prepend =href a> | |
| 110 | + | deep-children>string write | |
| 111 | + | </a> </li> | |
| 112 | + | ] each ; | |
| 113 | + | ||
| 114 | + | : write-headers ( template page xml -- template ) | |
| 115 | + | drop headers at [ "id" attr ] filter [ | |
| 116 | + | <h4> "Headers" write </h4> | |
| 117 | + | <ul "header-list" =id ul> list-headers </ul> | |
| 118 | + | ] with-string-writer "{{headings}}" swap replace ; | |
| 119 | + | ||
| 120 | + | : write-title ( template page xml -- template ) | |
| 121 | + | drop titles at "{{title}}" swap replace ; | |
| 122 | + | ||
| 123 | + | : write-locations ( pages -- ) | |
| 124 | + | [ <li> <a dup =href a> titles at write </a> </li> ] each ; | |
| 125 | + | ||
| 126 | + | : reject-hidden-pages ( pages -- pages ) | |
| 127 | + | [ @hidden-from-sitemap get in? ] reject ; | |
| 128 | + | ||
| 129 | + | : remove-hidden-pages ( sitemap -- sitemap ) | |
| 130 | + | [ reject-hidden-pages ] map-values harvest-values ; | |
| 131 | + | ||
| 132 | + | : render-sitemap ( -- string ) | |
| 133 | + | group-pages-alphbetically remove-hidden-pages [ | |
| 134 | + | <section "sitemap" =id section> | |
| 135 | + | <h1> "Site Map" write </h1> | |
| 136 | + | [ | |
| 137 | + | <section "listing" =class section> | |
| 138 | + | <h3> swap write </h3> | |
| 139 | + | <ul> write-locations </ul> | |
| 140 | + | </section> | |
| 141 | + | ] assoc-each | |
| 142 | + | </section> | |
| 143 | + | ] with-string-writer ; | |
| 144 | + | ||
| 145 | + | : render-page ( page xml -- string ) | |
| 146 | + | [ dup @current-page set ] dip [ template ] 2dip { | |
| 147 | + | [ write-title ] [ write-headers ] | |
| 148 | + | [ write-inbound ] [ write-article ] | |
| 149 | + | } 2cleave ; | |
| 150 | + | ||
| 151 | + | : process-page ( xml -- ) | |
| 152 | + | save-page save-title save-headers | |
| 153 | + | ?hide-from-sitemap link-outbound drop ; | |
| 154 | + | ||
| 155 | + | : load-page ( file-path -- ) | |
| 156 | + | dup file-name @current-page set file>xml process-page ; | |
| 157 | + | ||
| 158 | + | : should-write? ( to-write path -- ? ) | |
| 159 | + | dup file-exists? [ utf8 file-contents swap >string = not ] [ 2drop t ] if ; | |
| 160 | + | ||
| 161 | + | : write-page ( file string -- ) | |
| 162 | + | swap @public-path get prepend-path | |
| 163 | + | 2dup should-write? [ utf8 set-file-contents ] [ 2drop ] if ; | |
| 164 | + | ||
| 165 | + | : write-pages ( vec -- ) | |
| 166 | + | [ write-page ] assoc-each ; | |
| 167 | + | ||
| 168 | + | : generate-sitemap ( vec -- vec ) | |
| 169 | + | template | |
| 170 | + | "Site Map" "{{title}}" swap replace | |
| 171 | + | "" "{{headings}}" swap replace | |
| 172 | + | "" "{{backlinks}}" swap replace | |
| 173 | + | render-sitemap "{{article}}" swap replace | |
| 174 | + | "sitemap.html" swap set-of ; | |
| 175 | + | ||
| 176 | + | : generate-pages ( -- vec ) | |
| 177 | + | pages [ [ render-page ] keepd swap ] assoc-map ; | |
| 178 | + | ||
| 179 | + | : load-articles ( pages-path -- ) | |
| 180 | + | qualified-directory-files | |
| 181 | + | [ directory? ] reject | |
| 182 | + | [ load-page ] each ; | |
| 183 | + | ||
| 184 | + | : initialize-paths ( args -- pages-path ) | |
| 185 | + | { | |
| 186 | + | [ "public" append-path @public-path set ] | |
| 187 | + | [ load-templates ] | |
| 188 | + | [ "pages" append-path ] | |
| 189 | + | } cleave ; | |
| 190 | + | ||
| 191 | + | : initialize-state ( -- ) | |
| 192 | + | H{ } clone @titles set H{ } clone @headers set | |
| 193 | + | H{ } clone @inbound set H{ } clone @pages set | |
| 194 | + | HS{ } clone @hidden-from-sitemap set ; | |
| 195 | + | ||
| 196 | + | : build-failed ( _ error -- ) | |
| 197 | + | nip print-error | |
| 198 | + | "Failed to build: " write current-page print ; | |
| 199 | + | ||
| 200 | + | PRIVATE> | |
| 201 | + | ||
| 202 | + | : build-wiki ( args -- ) | |
| 203 | + | [ set-html-escape-codes | |
| 204 | + | initialize-state | |
| 205 | + | initialize-paths | |
| 206 | + | load-articles | |
| 207 | + | generate-pages | |
| 208 | + | generate-sitemap | |
| 209 | + | write-pages ] [ build-failed ] recover ; | |
| 210 | + | ||
| 211 | + | MAIN: [ | |
| 212 | + | command-line get ?first | |
| 213 | + | [ build-wiki ] [ "Usage: snarl DIR" print ] if* | |
| 214 | + | ] | |
Новее
Позже