extra/faq/faq.factor

   1 ! Copyright (C) 2007 Daniel Ehrenberg
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: xml kernel sequences xml.utilities combinators.lib
   4 math xml.data arrays assocs xml.generator xml.writer namespaces
   5 make math.parser io accessors ;
   6 IN: faq
   7
   8 : find-after ( seq quot -- elem after )
   9     over >r find r> rot 1+ tail ; inline
  10
  11 : tag-named*? ( tag name -- ? )
  12     assure-name swap tag-named? ;
  13
  14 ! Questions
  15 TUPLE: q/a question answer ;
  16 C: <q/a> q/a
  17
  18 : li>q/a ( li -- q/a )
  19     [ "br" tag-named*? not ] filter
  20     [ "strong" tag-named*? ] find-after
  21     >r children>> r> <q/a> ;
  22
  23 : q/a>li ( q/a -- li )
  24     [ question>> "strong" build-tag* f "br" build-tag* 2array ] keep
  25     answer>> append "li" build-tag* ;
  26
  27 : xml>q/a ( xml -- q/a )
  28     [ "question" tag-named children>> ] keep
  29     "answer" tag-named children>> <q/a> ;
  30
  31 : q/a>xml ( q/a -- xml )
  32     [ question>> "question" build-tag* ] keep
  33     answer>> "answer" build-tag*
  34     "\n" swap 3array "qa" build-tag* ;
  35
  36 ! Lists of questions
  37 TUPLE: question-list title seq ;
  38 C: <question-list> question-list
  39
  40 : xml>question-list ( list -- question-list )
  41     [ "title" swap at ] keep
  42     children>> [ tag? ] filter [ xml>q/a ] map
  43     <question-list> ;
  44
  45 : question-list>xml ( question-list -- list )
  46     [ seq>> [ q/a>xml "\n" swap 2array ]
  47       map concat "list" build-tag* ] keep
  48     title>> [ "title" pick set-at ] when* ;
  49
  50 : html>question-list ( h3 ol -- question-list )
  51     >r [ children>string ] [ f ] if* r>
  52     children-tags [ li>q/a ] map <question-list> ;
  53
  54 : question-list>h3 ( id question-list -- h3 )
  55     title>> [
  56         "h3" build-tag
  57         swap number>string "id" pick set-at
  58     ] [ drop f ] if* ;
  59
  60 : question-list>html ( question-list start id -- h3/f ol )
  61     -rot >r [ question-list>h3 ] keep
  62     seq>> [ q/a>li ] map "ol" build-tag* r>
  63     number>string "start" pick set-at
  64     "margin-left: 5em" "style" pick set-at ;
  65
  66 ! Overall everything
  67 TUPLE: faq header lists ;
  68 C: <faq> faq
  69
  70 : html>faq ( div -- faq )
  71     unclip swap { "h3" "ol" } [ tags-named ] with map
  72     first2 >r f prefix r> [ html>question-list ] 2map <faq> ;
  73
  74 : header, ( faq -- )
  75     dup header>> ,
  76     lists>> first 1 -1 question-list>html nip , ;
  77
  78 : br, ( -- )
  79     "br" contained, nl, ;
  80
  81 : toc-link, ( question-list number -- )
  82     number>string "#" prepend "href" swap 2array 1array
  83     "a" swap [ title>> , ] tag*, br, ;
  84
  85 : toc, ( faq -- )
  86     "div" { { "style" "background-color: #eee; margin-left: 30%; margin-right: 30%; width: auto; padding: 5px; margin-top: 1em; margin-bottom: 1em" } } [
  87         "strong" [ "The big questions" , ] tag, br,
  88         lists>> rest dup length [ toc-link, ] 2each
  89     ] tag*, ;
  90
  91 : faq-sections, ( question-lists -- )
  92     unclip seq>> length 1+ dupd
  93     [ seq>> length + ] accumulate nip
  94     0 -rot [ pick question-list>html [ , nl, ] bi@ 1+ ] 2each drop ;
  95
  96 : faq>html ( faq -- div )
  97     "div" [
  98         dup header,
  99         dup toc,
 100         lists>> faq-sections,
 101     ] make-xml ;
 102
 103 : xml>faq ( xml -- faq )
 104     [ "header" tag-named children>string ] keep
 105     "list" tags-named [ xml>question-list ] map <faq> ;
 106
 107 : faq>xml ( faq -- xml )
 108     "faq" [
 109         "header" [ dup header>> , ] tag,
 110         lists>> [ question-list>xml , nl, ] each
 111     ] make-xml ;
 112
 113 : read-write-faq ( xml-stream -- )
 114     read-xml xml>faq faq>html write-xml ;