basis/help/html/html.factor

   1 ! Copyright (C) 2008, 2009 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 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 html xml.syntax xml.writer ;
   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 url-of topic>filename ;
  55
  56 : help-stylesheet ( -- string )
  57     "vocab:help/html/stylesheet.css" ascii file-contents
  58     [XML <style><-></style> XML] ;
  59
  60 : help>html ( topic -- xml )
  61     [ article-title ]
  62     [ drop help-stylesheet ]
  63     [ [ help ] with-html-writer ]
  64     tri simple-page ;
  65
  66 : generate-help-file ( topic -- )
  67     dup topic>filename utf8 [ help>html write-xml ] with-file-writer ;
  68
  69 : all-vocabs-really ( -- seq )
  70     #! Hack.
  71     all-vocabs values concat
  72     vocabs [ find-vocab-root not ] filter [ vocab ] map append ;
  73
  74 : all-topics ( -- topics )
  75     [
  76         articles get keys [ >link ] map %
  77         all-words [ >link ] map %
  78         all-authors [ <vocab-author> ] map %
  79         all-tags [ <vocab-tag> ] map %
  80         all-vocabs-really %
  81     ] { } make ;
  82
  83 : serialize-index ( index file -- )
  84     [ [ [ topic>filename ] dip ] { } assoc-map-as object>bytes ] dip
  85     binary set-file-contents ;
  86
  87 : generate-indices ( -- )
  88     articles get keys [ [ >link ] [ article-title ] bi ] { } map>assoc "articles.idx" serialize-index
  89     all-words [ dup name>> ] { } map>assoc "words.idx" serialize-index
  90     all-vocabs-really [ dup vocab-name ] { } map>assoc "vocabs.idx" serialize-index ;
  91
  92 : generate-help-files ( -- )
  93     all-topics [ '[ _ generate-help-file ] try ] each ;
  94
  95 : generate-help ( -- )
  96     "docs" temp-file
  97     [ make-directories ]
  98     [
  99         [
 100             generate-indices
 101             generate-help-files
 102         ] with-directory
 103     ] bi ;
 104
 105 MEMO: load-index ( name -- index )
 106     binary file-contents bytes>object ;
 107
 108 TUPLE: result title href ;
 109
 110 : offline-apropos ( string index -- results )
 111     load-index swap >lower
 112     '[ [ drop _ ] dip >lower subseq? ] assoc-filter
 113     [ swap result boa ] { } assoc>map
 114     [ [ title>> ] compare ] sort ;
 115
 116 : article-apropos ( string -- results )
 117     "articles.idx" offline-apropos ;
 118
 119 : word-apropos ( string -- results )
 120     "words.idx" offline-apropos ;
 121
 122 : vocab-apropos ( string -- results )
 123     "vocabs.idx" offline-apropos ;