! Copyright (C) 2026 CapitalEx
! 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 ] 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*
]