Revision of snarl.factor

1

+

2

+

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 ] sort-by ] assoc-map sort-keys ;

56

+

57

+

: find-headers ( tag -- headers )

58

+

[ HEADERS swap '[ _ tag-named? ] any? ] { } deep-filter-as ;

59

+

60

+

: backlink ( links -- )

61

+

current-page inbound '[ _ _ swapd adjoin-at ] each ;

62

+

63

+

: bad-link? ( link -- ? )

64

+

{ [ empty? ] [ "http" head? ]

65

+

[ "sitemap.html" = ] [ current-page = ] } 1|| ;

66

+

67

+

: links ( xml -- links )

68

+

"a" deep-tags-named [ "href" attr ] map! ;

69

+

70

+

: link-outbound ( xml -- xml )

71

+

dup links [ bad-link? ] reject [ "#" split first ] map backlink ;

72

+

73

+

: find-title ( xml -- title )

74

+

"h1" deep-tag-named deep-children>string ;

75

+

76

+

: load-templates ( wiki-path -- )

77

+

"_templates/page.html" append-path utf8 file-contents >sbuf

78

+

@template set ;

79

+

80

+

: save-headers ( xml -- xml )

81

+

dup find-headers current-page headers set-at ;

82

+

83

+

: save-title ( xml -- xml )

84

+

dup current-page titles [ drop find-title ] change-at ;

85

+

86

+

: save-page ( xml -- xml )

87

+

dup current-page @pages get set-at ;

88

+

89

+

: ?hide-from-sitemap ( xml -- xml )

90

+

dup "sitemap" attr [

91

+

current-page @hidden-from-sitemap get adjoin

92

+

] when ;

93

+

94

+

: write-article ( template page xml -- template )

95

+

nip set-main-article xml>string "{{article}}" swap replace ;

96

+

97

+

: list-inbound ( inbound -- )

98

+

[ <li> <a dup =href a> titles at write </a> </li> ] each ;

99

+

100

+

: write-inbound ( template page xml -- template )

101

+

drop inbound at members [ titles at leading-letter ] sort-by [

102

+

<h4 "inbound-links" =id h4> "In Bound Links" write </h4>

103

+

<ul "link-list" =id ul> list-inbound </ul>

104

+

] with-string-writer "{{backlinks}}" swap replace ;

105

+

106

+

: list-headers ( headers -- )

107

+

[

108

+

109

+

deep-children>string write

110

+

</a> </li>

111

+

] each ;

112

+

113

+

: write-headers ( template page xml -- template )

114

+

drop headers at [ "id" attr ] filter [

115

+

<h4> "Headers" write </h4>

116

+

<ul "header-list" =id ul> list-headers </ul>

117

+

] with-string-writer "{{headings}}" swap replace ;

118

+

119

+

: write-title ( template page xml -- template )

120

+

drop titles at "{{title}}" swap replace ;

121

+

122

+

: write-locations ( pages -- )

123

+

[ <li> <a dup =href a> titles at write </a> </li> ] each ;

124

+

125

+

: reject-hidden-pages ( pages -- pages )

126

+

[ @hidden-from-sitemap get in? ] reject ;

127

+

128

+

: remove-hidden-pages ( sitemap -- sitemap )

129

+

[ reject-hidden-pages ] map-values harvest-values ;

130

+

131

+

: render-sitemap ( -- string )

132

+

group-pages-alphbetically remove-hidden-pages [

133

+

134

+

<h1> "Site Map" write </h1>

135

+

[

136

+

137

+

<h3> swap write </h3>

138

+

<ul> write-locations </ul>

139

+

</section>

140

+

] assoc-each

141

+

</section>

142

+

] with-string-writer ;

143

+

144

+

: render-page ( page xml -- string )

145

+

[ dup @current-page set ] dip [ template ] 2dip {

146

+

[ write-title ] [ write-headers ]

147

+

[ write-inbound ] [ write-article ]

148

+

} 2cleave ;

149

+

150

+

: process-page ( xml -- )

151

+

save-page save-title save-headers

152

+

?hide-from-sitemap link-outbound drop ;

153

+

154

+

: load-page ( file-path -- )

155

+

dup file-name @current-page set file>xml process-page ;

156

+

157

+

: should-write? ( to-write path -- ? )

158

+

dup file-exists? [ utf8 file-contents swap >string = not ] [ 2drop t ] if ;

159

+

160

+

: write-page ( file string -- )

161

+

swap @public-path get prepend-path

162

+

2dup should-write? [ utf8 set-file-contents ] [ 2drop ] if ;

163

+

164

+

: write-pages ( vec -- )

165

+

[ write-page ] assoc-each ;

166

+

167

+

: generate-sitemap ( vec -- vec )

168

+

template

169

+

"Site Map" "{{title}}" swap replace

170

+

"" "{{headings}}" swap replace

171

+

"" "{{backlinks}}" swap replace

172

+

render-sitemap "{{article}}" swap replace

173

+

"sitemap.html" swap set-of ;

174

+

175

+

: generate-pages ( -- vec )

176

+

pages [ [ render-page ] keepd swap ] assoc-map ;

177

+

178

+

: load-articles ( pages-path -- )

179

+

qualified-directory-files

180

+

[ directory? ] reject

181

+

[ load-page ] each ;

182

+

183

+

: initialize-paths ( args -- pages-path )

184

+

{

185

+

[ "public" append-path @public-path set ]

186

+

[ load-templates ]

187

+

[ "pages" append-path ]

188

+

} cleave ;

189

+

190

+

: initialize-state ( -- )

191

+

H{ } clone @titles set H{ } clone @headers set

192

+

H{ } clone @inbound set H{ } clone @pages set

193

+

HS{ } clone @hidden-from-sitemap set ;

194

+

195

+

: build-failed ( _ error -- )

196

+

nip print-error

197

+

"Failed to build: " write current-page print ;

198

+

199

+

PRIVATE>

200

+

201

+

: build-wiki ( args -- )

202

+

[ set-html-escape-codes

203

+

initialize-state

204

+

initialize-paths

205

+

load-articles

206

+

generate-pages

207

+

generate-sitemap

208

+

write-pages ] [ build-failed ] recover ;

209

+

210

+

MAIN: [

211

+

command-line get ?first

212

+

[ build-wiki ] [ "Usage: snarl DIR" print ] if*

213

+

]

capitalex / snarl.factor

capitalex revidoval tento gist 19 hours ago. Přejít na revizi

		@@ -0,0 +1,213 @@
1	+	! Copyright (C) 2026 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 ] sort-by ] assoc-map sort-keys ;
56	+
57	+	: find-headers ( tag -- headers )
58	+	[ HEADERS swap '[ _ tag-named? ] any? ] { } deep-filter-as ;
59	+
60	+	: backlink ( links -- )
61	+	current-page inbound '[ _ _ swapd adjoin-at ] each ;
62	+
63	+	: bad-link? ( link -- ? )
64	+	{ [ empty? ] [ "http" head? ]
65	+	[ "sitemap.html" = ] [ current-page = ] } 1\|\| ;
66	+
67	+	: links ( xml -- links )
68	+	"a" deep-tags-named [ "href" attr ] map! ;
69	+
70	+	: link-outbound ( xml -- xml )
71	+	dup links [ bad-link? ] reject [ "#" split first ] map backlink ;
72	+
73	+	: find-title ( xml -- title )
74	+	"h1" deep-tag-named deep-children>string ;
75	+
76	+	: load-templates ( wiki-path -- )
77	+	"_templates/page.html" append-path utf8 file-contents >sbuf
78	+	@template set ;
79	+
80	+	: save-headers ( xml -- xml )
81	+	dup find-headers current-page headers set-at ;
82	+
83	+	: save-title ( xml -- xml )
84	+	dup current-page titles [ drop find-title ] change-at ;
85	+
86	+	: save-page ( xml -- xml )
87	+	dup current-page @pages get set-at ;
88	+
89	+	: ?hide-from-sitemap ( xml -- xml )
90	+	dup "sitemap" attr [
91	+	current-page @hidden-from-sitemap get adjoin
92	+	] when ;
93	+
94	+	: write-article ( template page xml -- template )
95	+	nip set-main-article xml>string "{{article}}" swap replace ;
96	+
97	+	: list-inbound ( inbound -- )
98	+	[ <li> <a dup =href a> titles at write </a> </li> ] each ;
99	+
100	+	: write-inbound ( template page xml -- template )
101	+	drop inbound at members [ titles at leading-letter ] sort-by [
102	+	<h4 "inbound-links" =id h4> "In Bound Links" write </h4>
103	+	<ul "link-list" =id ul> list-inbound </ul>
104	+	] with-string-writer "{{backlinks}}" swap replace ;
105	+
106	+	: list-headers ( headers -- )
107	+	[
108	+	<li> <a dup "id" attr "#" prepend =href a>
109	+	deep-children>string write
110	+	</a> </li>
111	+	] each ;
112	+
113	+	: write-headers ( template page xml -- template )
114	+	drop headers at [ "id" attr ] filter [
115	+	<h4> "Headers" write </h4>
116	+	<ul "header-list" =id ul> list-headers </ul>
117	+	] with-string-writer "{{headings}}" swap replace ;
118	+
119	+	: write-title ( template page xml -- template )
120	+	drop titles at "{{title}}" swap replace ;
121	+
122	+	: write-locations ( pages -- )
123	+	[ <li> <a dup =href a> titles at write </a> </li> ] each ;
124	+
125	+	: reject-hidden-pages ( pages -- pages )
126	+	[ @hidden-from-sitemap get in? ] reject ;
127	+
128	+	: remove-hidden-pages ( sitemap -- sitemap )
129	+	[ reject-hidden-pages ] map-values harvest-values ;
130	+
131	+	: render-sitemap ( -- string )
132	+	group-pages-alphbetically remove-hidden-pages [
133	+	<section "sitemap" =id section>
134	+	<h1> "Site Map" write </h1>
135	+	[
136	+	<section "listing" =class section>
137	+	<h3> swap write </h3>
138	+	<ul> write-locations </ul>
139	+	</section>
140	+	] assoc-each
141	+	</section>
142	+	] with-string-writer ;
143	+
144	+	: render-page ( page xml -- string )
145	+	[ dup @current-page set ] dip [ template ] 2dip {
146	+	[ write-title ] [ write-headers ]
147	+	[ write-inbound ] [ write-article ]
148	+	} 2cleave ;
149	+
150	+	: process-page ( xml -- )
151	+	save-page save-title save-headers
152	+	?hide-from-sitemap link-outbound drop ;
153	+
154	+	: load-page ( file-path -- )
155	+	dup file-name @current-page set file>xml process-page ;
156	+
157	+	: should-write? ( to-write path -- ? )
158	+	dup file-exists? [ utf8 file-contents swap >string = not ] [ 2drop t ] if ;
159	+
160	+	: write-page ( file string -- )
161	+	swap @public-path get prepend-path
162	+	2dup should-write? [ utf8 set-file-contents ] [ 2drop ] if ;
163	+
164	+	: write-pages ( vec -- )
165	+	[ write-page ] assoc-each ;
166	+
167	+	: generate-sitemap ( vec -- vec )
168	+	template
169	+	"Site Map" "{{title}}" swap replace
170	+	"" "{{headings}}" swap replace
171	+	"" "{{backlinks}}" swap replace
172	+	render-sitemap "{{article}}" swap replace
173	+	"sitemap.html" swap set-of ;
174	+
175	+	: generate-pages ( -- vec )
176	+	pages [ [ render-page ] keepd swap ] assoc-map ;
177	+
178	+	: load-articles ( pages-path -- )
179	+	qualified-directory-files
180	+	[ directory? ] reject
181	+	[ load-page ] each ;
182	+
183	+	: initialize-paths ( args -- pages-path )
184	+	{
185	+	[ "public" append-path @public-path set ]
186	+	[ load-templates ]
187	+	[ "pages" append-path ]
188	+	} cleave ;
189	+
190	+	: initialize-state ( -- )
191	+	H{ } clone @titles set H{ } clone @headers set
192	+	H{ } clone @inbound set H{ } clone @pages set
193	+	HS{ } clone @hidden-from-sitemap set ;
194	+
195	+	: build-failed ( _ error -- )
196	+	nip print-error
197	+	"Failed to build: " write current-page print ;
198	+
199	+	PRIVATE>
200	+
201	+	: build-wiki ( args -- )
202	+	[ set-html-escape-codes
203	+	initialize-state
204	+	initialize-paths
205	+	load-articles
206	+	generate-pages
207	+	generate-sitemap
208	+	write-pages ] [ build-failed ] recover ;
209	+
210	+	MAIN: [
211	+	command-line get ?first
212	+	[ build-wiki ] [ "Usage: snarl DIR" print ] if*
213	+	]