]> gitweb.factorcode.org Git - factor.git/blobdiff - basis/help/html/html.factor
webapps: better style
[factor.git] / basis / help / html / html.factor
index e4a30319493d7552feaed9e7d85102d2f5e0471c..c0d0677ddeb51946d2a5fe771b99f9be2a42c56f 100644 (file)
@@ -1,12 +1,14 @@
 ! Copyright (C) 2008, 2011 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: io.encodings.utf8 io.encodings.binary io.files
-io.files.temp io.directories html.streams help help.home kernel
-assocs sequences make words accessors arrays help.topics vocabs
-vocabs.hierarchy help.vocabs namespaces prettyprint io
-vocabs.loader serialize fry memoize unicode.case math.order
-sorting debugger html xml.syntax xml.writer math.parser
-sets hashtables ;
+USING: accessors arrays ascii assocs colors
+combinators.short-circuit debugger formatting help help.home
+help.topics help.vocabs html html.streams io.directories
+io.encodings.ascii io.encodings.binary io.encodings.utf8
+io.files io.files.temp io.pathnames kernel make math math.parser
+namespaces regexp sequences sequences.deep serialize sets
+sorting splitting strings system tools.completion vocabs
+vocabs.hierarchy words xml.data xml.syntax xml.traversal
+xml.writer ;
 FROM: io.encodings.ascii => ascii ;
 FROM: ascii => ascii? ;
 IN: help.html
@@ -14,7 +16,7 @@ IN: help.html
 : escape-char ( ch -- )
     dup ascii? [
         dup H{
-            { CHAR: " "__quo__" }
+            { CHAR: \" "__quo__" }
             { CHAR: * "__star__" }
             { CHAR: : "__colon__" }
             { CHAR: < "__lt__" }
@@ -48,7 +50,7 @@ M: vocab-author topic>filename* name>> "author" ;
 M: f topic>filename* drop \ f topic>filename* ;
 
 : topic>filename ( topic -- filename )
-    topic>filename* dup [
+    topic>filename* [
         [
             % "-" %
             dup array?
@@ -56,45 +58,208 @@ M: f topic>filename* drop \ f topic>filename* ;
             [ escape-filename ]
             if % ".html" %
         ] "" make
-    ] [ 2drop f ] if ;
+    ] [ drop f ] if* ;
 
 M: topic url-of topic>filename ;
 
-: help-stylesheet ( -- xml )
+M: pathname url-of
+    string>> "resource:" ?head [
+        "https://github.com/factor/factor/blob/master/"
+        prepend
+    ] [ drop f ] if ;
+
+: help-stylesheet ( stylesheet -- xml )
     "vocab:help/html/stylesheet.css" ascii file-contents
-    [XML <style><-></style> XML] ;
+    swap "\n" glue [XML <style><-></style> XML] ;
+
+: help-meta ( -- xml )
+    [XML
+        <meta
+            name="viewport"
+            content="width=device-width, initial-scale=1"
+            charset="utf-8"
+        />
+        <meta
+            name="theme-color"
+            content="#f5f5f5"
+            media="(prefers-color-scheme: light)"
+        />
+        <meta
+            name="theme-color"
+            content="#373e48"
+            media="(prefers-color-scheme: dark)"
+        />
+    XML] ;
 
-: help-navbar ( -- xml )
+: help-nav ( -- xml )
     "conventions" >link topic>filename
     [XML
-        <div class="navbar">
-        <b> Factor Documentation </b> |
-        <a href="/">Home</a> |
-        <a href=<->>Glossary</a> |
-        <form method="get" action="/search" style="display:inline;">
-            <input name="search" type="text"/>
-            <button type="submit">Search</button>
-        </form>
-        <a href="http://factorcode.org" style="float:right; padding: 4px;">factorcode.org</a>
-        </div>
+        <nav>
+            <a href="https://factorcode.org">
+            <img src="favicon.ico" width="24" height="24" />
+            </a>
+            <a href="/">Handbook</a>
+            <a href=<->>Glossary</a>
+            <form method="get" action="/search" style="float: right;">
+                <input placeholder="Search" name="search" type="text"/>
+                <input type="submit" value="Go"/>
+            </form>
+        </nav>
      XML] ;
 
+: help-footer ( -- xml )
+    version-info "\n" split1 drop
+    [XML
+        <footer>
+        <p>
+        This documentation was generated offline from a
+        <code>load-all</code> image.  If you want, you can also
+        browse the documentation from within the <a
+        href="article-ui-tools.html">UI developer tools</a>. See
+        the <a href="https://factorcode.org">Factor website</a>
+        for more information.
+        </p>
+        <p><-></p>
+        </footer>
+    XML] ;
+
+: bijective-base26 ( n -- name )
+    [ dup 0 > ] [ 1 - 26 /mod CHAR: a + ] "" produce-as nip reverse! ;
+
+: css-class ( style classes -- name )
+    dup '[ drop _ assoc-size 1 + bijective-base26 ] cache ;
+
+: fix-css-style ( style -- style' )
+    R/ font-size: \d+pt;/ [
+        "font-size: " ?head drop "pt;" ?tail drop
+        string>number 2 -
+        "font-size: %dpt;" sprintf
+    ] re-replace-with
+
+    R/ padding: \d+px;/ [
+        "padding: " ?head drop "px;" ?tail drop
+        string>number dup even? [ 2 * 1 + ] [ 2 * ] if
+        number>string "padding: " "px;" surround
+    ] re-replace-with
+
+    R/ width: \d+px;/ [
+       drop ""
+    ] re-replace-with
+
+    R/ font-family: monospace;/ [
+        " white-space: pre-wrap; line-height: 125%;" append
+    ] re-replace-with
+
+    dup { "font-family: monospace;" "background-color:" } [ subseq-of? ] with all? [
+        " margin: 10px 0px;" append
+    ] when
+
+    dup { "border:" "background-color:" } [ subseq-of? ] with all? [
+        " border-radius: 5px;" append
+    ] when ;
+
+: fix-help-header ( classes -- classes )
+    dup [
+        [ ".a" head? ] [ "#f4efd9;" subseq-of? ] bi and
+    ] find [
+        "padding: 10px;" "padding: 0px;" replace
+        "background-color: #f4efd9;" "background-color: white;" replace
+        "}" ?tail drop
+        " border-bottom: 1px dashed #d5d5d5 width: 100%; padding-top: 15px; padding-bottom: 10px; }"
+        append swap pick set-nth {
+            ".a a { color: black; font-size: 24pt; line-height: 100%; }"
+            ".a * a { color: #2a5db0; font-size: 12pt; }"
+            ".a td { border: none; }"
+            ".a tr:hover { background-color: white; }"
+        } prepend
+    ] [ drop ] if* ;
+
+: dark-mode-css ( classes -- classes' )
+    { "" "/* Dark mode */" "@media (prefers-color-scheme:dark) {" }
+    swap [
+        R/ {[^}]+}/ [
+            "{" ?head drop "}" ?tail drop ";" split
+            [ [ blank? ] trim ] map harvest [ ";" append ] map
+            [ R/ (#[0-9a-fA-F]+|white|black);/ re-contains? ] filter
+            [
+                R/ (#[0-9a-fA-F]+|white|black);/ [
+                    >string H{
+                        { "#000000;" "#bdc1c6;" }
+                        { "#2a5db0;" "#8ab4f8;" }
+                        { "#333333;" "#d5d5d5;" }
+                        { "#373e48;" "#ffffff;" }
+                        { "#8b4500;" "orange;" }
+                        { "#e3e2db;" "#444444;" }
+                        { "white;" "#202124;" }
+                        { "black;" "white;" }
+                    } ?at [
+                        but-last parse-color inverse-color color>hex ";" append
+                    ] unless
+                ] re-replace-with
+            ] map " " join "{ " " }" surround
+        ] re-replace-with "    " prepend
+        dup "{  }" subseq-of? [ drop f ] when
+    ] map harvest append "}" suffix ;
+
+: css-classes ( classes -- stylesheet )
+    [
+        [ fix-css-style " { " "}" surround ] [ "." prepend ] bi* prepend
+    ] { } assoc>map fix-help-header dup dark-mode-css append join-lines ;
+
+:: css-styles-to-classes ( body -- stylesheet body )
+    H{ } clone :> classes
+    body [
+        dup xml-chunk? [
+            seq>> [
+                dup {
+                    [ tag? ]
+                    [ "style" attr ]
+                    [ "class" attr not ]
+                } 1&& [
+                    [ clone [ V{ } like ] change-alist ] change-attrs
+                    "style" over delete-at* drop classes css-class
+                    "class" rot set-at
+                ] [ drop ] if
+            ] deep-each
+        ] [ drop ] if
+    ] each classes sort-values css-classes body ;
+
+: retina-image ( path -- path' )
+    dup "@2x" subseq-of? [ "." split1-last "@2x." glue ] unless ;
+
+: ?copy-file ( from to -- )
+    dup file-exists? [ 2drop ] [ copy-file ] if ;
+
+: cache-images ( body -- body' )
+    dup [
+        dup xml-chunk? [
+            seq>> [
+                T{ name { main "img" } } over tag-named? [
+                    dup "src" attr
+                    retina-image dup file-name
+                    [ ?copy-file ] keep
+                    "src" set-attr
+                ] [ drop ] if
+            ] deep-each
+        ] [ drop ] if
+    ] each ;
+
 : help>html ( topic -- xml )
     [ article-title " - Factor Documentation" append ]
-    [ drop help-stylesheet ]
     [
-        [ help-navbar ]
-        [ [ print-topic ] with-html-writer ]
-        bi* append
-    ] tri
-    simple-page ;
+        [ print-topic ] with-html-writer
+        css-styles-to-classes cache-images
+        "resource:extra/websites/factorcode/favicon.ico" dup file-name ?copy-file
+        [ help-stylesheet help-meta prepend help-nav ] dip help-footer
+        [XML <-><div class="page"><-><-></div> XML]
+    ] bi simple-page ;
 
 : generate-help-file ( topic -- )
     dup topic>filename utf8 [ help>html write-xml ] with-file-writer ;
 
 : all-vocabs-really ( -- seq )
-    all-vocabs-recursive >hashtable no-roots remove-redundant-prefixes
-    [ vocab-name "scratchpad" = not ] filter ;
+    all-disk-vocabs-recursive filter-vocabs
+    [ vocab-name "scratchpad" = ] reject ;
 
 : all-topics ( -- topics )
     [
@@ -106,25 +271,36 @@ M: topic url-of topic>filename ;
     ] { } make ;
 
 : serialize-index ( index file -- )
-    [ [ [ topic>filename ] dip ] { } assoc-map-as object>bytes ] dip
-    binary set-file-contents ;
+    binary [
+        [ [ topic>filename ] dip ] { } assoc-map-as serialize
+    ] with-file-writer ;
 
-: generate-indices ( -- )
-    articles get keys [ [ >link ] [ article-title ] bi ] { } map>assoc "articles.idx" serialize-index
-    all-words [ dup name>> ] { } map>assoc "words.idx" serialize-index
-    all-vocabs-really [ dup vocab-name ] { } map>assoc "vocabs.idx" serialize-index ;
+: generate-article-index ( -- )
+    articles get [ [ >link ] [ article-title ] bi* ] assoc-map
+    "articles.idx" serialize-index ;
 
-: (generate-help-files) ( -- )
-    all-topics [ '[ _ generate-help-file ] try ] each ;
+: generate-word-index ( -- )
+    all-words [ dup name>> ] { } map>assoc
+    "words.idx" serialize-index ;
+
+: generate-vocab-index ( -- )
+    all-vocabs-really [ dup vocab-name ] { } map>assoc
+    "vocabs.idx" serialize-index ;
+
+: generate-indices ( -- )
+    generate-article-index
+    generate-word-index
+    generate-vocab-index ;
 
 : generate-help-files ( -- )
-    [
-        recent-searches off
-        recent-words off
-        recent-articles off
-        recent-vocabs off
-        (generate-help-files)
-    ] with-scope ;
+    H{
+        { recent-searches f }
+        { recent-words f }
+        { recent-articles f }
+        { recent-vocabs f }
+    } [
+        all-topics [ '[ _ generate-help-file ] try ] each
+    ] with-variables ;
 
 : generate-help ( -- )
     "docs" cache-file
@@ -139,23 +315,30 @@ M: topic url-of topic>filename ;
 MEMO: load-index ( name -- index )
     binary file-contents bytes>object ;
 
-TUPLE: result title href ;
-
-: partition-exact ( string results -- results' )
-    [ title>> = ] with partition append ;
-
 : offline-apropos ( string index -- results )
-    load-index over >lower
-    '[ [ drop _ ] dip >lower subseq? ] assoc-filter
-    [ swap result boa ] { } assoc>map
-    [ title>> ] sort-with
-    partition-exact ;
+    load-index completions ;
 
 : article-apropos ( string -- results )
     "articles.idx" offline-apropos ;
 
-: word-apropos ( string -- results )
-    "words.idx" offline-apropos ;
-
 : vocab-apropos ( string -- results )
     "vocabs.idx" offline-apropos ;
+
+: generate-qualified-index ( index -- )
+    H{ } clone [
+        '[
+            over "," split1 nip ".html" ?tail drop
+            [ swap ":" glue 2array ] [ _ push-at ] bi
+        ] assoc-each
+    ] keep [ swap ] { } assoc-map-as
+    "qualified.idx" binary [ serialize ] with-file-writer ;
+
+: qualified-index ( str index -- str index' )
+    over ":" split1 [
+        "qualified.idx"
+        dup file-exists? [ pick generate-qualified-index ] unless
+        load-index completions keys concat
+    ] [ drop f ] if [ append ] unless-empty ;
+
+: word-apropos ( string -- results )
+    "words.idx" load-index qualified-index completions ;