basis/help/html/html.factor

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: io.encodings.utf8 io.encodings.ascii io.encodings.binary
   4 io.files io.files.temp io.directories html.streams html.elements help kernel
   5 assocs sequences make words accessors arrays help.topics vocabs
   6 tools.vocabs tools.vocabs.browser namespaces prettyprint io
   7 vocabs.loader serialize fry memoize unicode.case math.order
   8 sorting debugger ;
   9 IN: help.html
  10
  11 : escape-char ( ch -- )
  12     dup H{
  13         { CHAR: " "__quo__" }
  14         { CHAR: * "__star__" }
  15         { CHAR: : "__colon__" }
  16         { CHAR: < "__lt__" }
  17         { CHAR: > "__gt__" }
  18         { CHAR: ? "__que__" }
  19         { CHAR: \\ "__back__" }
  20         { CHAR: | "__pipe__" }
  21         { CHAR: / "__slash__" }
  22         { CHAR: , "__comma__" }
  23         { CHAR: @ "__at__" }
  24     } at [ % ] [ , ] ?if ;
  25
  26 : escape-filename ( string -- filename )
  27     [ [ escape-char ] each ] "" make ;
  28
  29 GENERIC: topic>filename* ( topic -- name prefix )
  30
  31 M: word topic>filename*
  32     dup vocabulary>> [
  33         [ name>> ] [ vocabulary>> ] bi 2array "word"
  34     ] [ drop f f ] if ;
  35
  36 M: link topic>filename* name>> dup [ "article" ] [ topic>filename* ] if ;
  37 M: word-link topic>filename* name>> topic>filename* ;
  38 M: vocab-spec topic>filename* vocab-name "vocab" ;
  39 M: vocab-tag topic>filename* name>> "tag" ;
  40 M: vocab-author topic>filename* name>> "author" ;
  41 M: f topic>filename* drop \ f topic>filename* ;
  42
  43 : topic>filename ( topic -- filename )
  44     topic>filename* dup [
  45         [
  46             % "-" %
  47             dup array?
  48             [ [ escape-filename ] map "," join ]
  49             [ escape-filename ]
  50             if % ".html" %
  51         ] "" make
  52     ] [ 2drop f ] if ;
  53
  54 M: topic browser-link-href topic>filename ;
  55
  56 : help-stylesheet ( -- )
  57     "resource:basis/help/html/stylesheet.css" ascii file-contents write ;
  58
  59 : help>html ( topic -- )
  60     dup topic>filename utf8 [
  61         dup article-title
  62         [ <style> help-stylesheet </style> ]
  63         [ [ help ] with-html-writer ] simple-page
  64     ] with-file-writer ;
  65
  66 : all-vocabs-really ( -- seq )
  67     #! Hack.
  68     all-vocabs values concat
  69     vocabs [ find-vocab-root not ] filter [ vocab ] map append ;
  70
  71 : all-topics ( -- topics )
  72     [
  73         articles get keys [ >link ] map %
  74         all-words [ >link ] map %
  75         all-authors [ <vocab-author> ] map %
  76         all-tags [ <vocab-tag> ] map %
  77         all-vocabs-really %
  78     ] { } make ;
  79
  80 : serialize-index ( index file -- )
  81     [ [ [ topic>filename ] dip ] { } assoc-map-as object>bytes ] dip
  82     binary set-file-contents ;
  83
  84 : generate-indices ( -- )
  85     articles get keys [ [ >link ] [ article-title ] bi ] { } map>assoc "articles.idx" serialize-index
  86     all-words [ dup name>> ] { } map>assoc "words.idx" serialize-index
  87     all-vocabs-really [ dup vocab-name ] { } map>assoc "vocabs.idx" serialize-index ;
  88
  89 : generate-help-files ( -- )
  90     all-topics [ '[ _ help>html ] try ] each ;
  91
  92 : generate-help ( -- )
  93     "docs" temp-file
  94     [ make-directories ]
  95     [
  96         [
  97             generate-indices
  98             generate-help-files
  99         ] with-directory
 100     ] bi ;
 101
 102 MEMO: load-index ( name -- index )
 103     binary file-contents bytes>object ;
 104
 105 TUPLE: result title href ;
 106
 107 : offline-apropos ( string index -- results )
 108     load-index swap >lower
 109     '[ [ drop _ ] dip >lower subseq? ] assoc-filter
 110     [ swap result boa ] { } assoc>map
 111     [ [ title>> ] compare ] sort ;
 112
 113 : article-apropos ( string -- results )
 114     "articles.idx" offline-apropos ;
 115
 116 : word-apropos ( string -- results )
 117     "words.idx" offline-apropos ;
 118
 119 : vocab-apropos ( string -- results )
 120     "vocabs.idx" offline-apropos ;