path: root/genman.txr

@# This requires a hacked version of man2html
@# See here: http://www.kylheku.com/cgit/man
@(bind closedtxt " <TT>[+]</TT>")
@(bind opentxt " <TT>[-]</TT>")
@(bind xpnall "[expand all]")
@(bind clpsall "[collapse all]")
@(bind closed t)
@(do
   (defvarl symhash (hash))
   (defvarl tagmap (hash))
   (defvarl tochash (hash))
   (defvarl dupe-hashes (hash))
   (defvarl dupe-titles (hash))
   (defvarl direct (hash))
   (defvarl disamb (hash))
   (defvarl dist-counter 0)
   (defvarl colli (hash-props))

   (defun hash-title (title)
     (let* ((ti title)
            (cntr 0)
            (defs (build (while-match `@nil<tt>@ttitem</tt>@rest` ti
                           (add ttitem)
                           (set ti rest)))))
       (set title (if defs
                    (car defs)
                    (downcase-str title))
            ti title)
       (while* [dupe-titles title]
         (set title `T-@(inc cntr)-@ti`))
       (set [dupe-titles title] t)
       (let* ((h (crc32 title))
              (h (+ h (or [colli title] 0)))
              (existing [dupe-hashes h]))
         (when existing
           (unless (equal title existing)
             (error "~a ~a hash collision!" existing title)))
         (set [dupe-hashes h] title)
         (format nil "N-~,08X" h))))

   (defun toc-tag (sec)
     `TOC-@sec`)

   (defun process-ambiguities (hash)
     (let ((rhash (hash)))
       (dohash (sym tags hash)
         (let ((shash (fmt "S-~,08X" (crc32 sym))))
           (if [rhash shash]
             (error "~a ~a hash collision" sym [rhash shash])
             (set [rhash shash] sym))
           (set [hash sym] shash)
           (if (null (cdr tags))
             (push shash [direct (car tags)])
             (set [disamb shash] (reverse tags))))))))
Content-type: text/html
@(skip 15)
<h1>TXR</h1>
@(skip)Updated: @YEAR-@MONTH-@DAY<br><a href="#index">Index</a>
@(bind TIME @(make-time-utc (int-str YEAR) (int-str MONTH) (int-str DAY)
                            0 0 0 nil))
@(bind VERSION nil)
@(collect :vars (BODY))
@  (some)
@    (cases)
<a name="@tag">&nbsp;</a>
@      (some)
<h@level>@sec @title</h@level>
@      (or)
<h@level>@sec @title
</h@level>
@      (end)
@      (bind newtag @(hash-title title))
@      (do (set [tagmap tag] newtag))
@      (output :into BODY)
<a name="@newtag">&nbsp;</a>
<h@level><a href="#@(toc-tag sec)" onclick="tocjump('@(toc-tag sec)')">@sec</a> @title</h@level>
@      (end)
@      (cat BODY "\n")
@    (or)
@BODY
@    (end)
@  (and)
<b>TXR</b> - text processing language (version @ver)
@    (set VERSION ver)
@  (end)
@(until)
<hr>
<a name="index">&nbsp;</a><h2>Index</h2>
@(end)
<hr>
@(collect :vars (TOC))
@  (some)
@    (cases)
@      (cases)
<dt><a href="#@tag">@num @rest</a><dd>
@      (or)
<dt><a href="#@tag">@num @rest
</a><dd>
@      (end)
@      (bind TOC `<dt><a name="@(toc-tag num)" class="tocanchor">@num</a> <a href="#@[tagmap tag]">@rest</a></dt>`)
@    (or)
<a name="index">@(skip)
@      (output :into TOC)
<h2>Contents</h2>
<noscript>
<h3>Please turn on Javascript to use the collapsible contents.</h3>
</noscript>
<a href="#/" onclick="toggleall(this)">@xpnall</a>
@      (end)
@    (or)
@TOC
@    (end)
@  (and)
<dt><a href="@nil">@nil TXR LISP</a><dd>
@  (and)
<dt><a href="#@tag">@(coll :vars (sym))<tt>@sym</tt>@(end)
@    (do (let ((n-tag [tagmap tag]))
           (mapdo (do pushnew n-tag [symhash (html-decode @1)]) sym)
           (set [tochash n-tag] rest)))
@  (and)
<dt><a href="#@tag">@num @nil
@    (maybe)
</a><dd>
@    (end)
<dl>
@    (cat TOC)
@    (bind pos @(car (search-regex TOC #/<\/dt/)))
@    (bind id @(gensym))
@    (do (set [TOC pos..pos]
              `<a href="#/" onclick="toggle(this, '@id')" class="toggle">@(if closed closedtxt opentxt)</a>`))
@    (output :into TOC)
@TOC
<dd><dl id="@id" class="tocsec"@(if closed " style=\"display: none\"")>
@    (end)
@  (end)
@(until)
This document was created by
@(end)
@(flatten TOC)
@(do (process-ambiguities symhash))
@(set BODY @(let ((inside-tt nil)
                  (inside-syntax nil))
              (mapcar (do cond
                        ((equal @1 "<tt>") (set inside-tt t) @1)
                        ((equal @1 "</tt>") (set inside-tt nil)
                                            (set inside-syntax nil)
                                            @1)
                        ((equal @1 "<dt>Syntax:<dd>") (set inside-syntax t) @1)
                        ((or (and inside-tt (not inside-syntax))
                             (match-regex @1 #/<dt><tt>/))
                          (regsub #/@?[\(\[][^ )&]+/
                                  (do let* ((at (if (eql [@1 0] #\@)
                                                 (pop @1)))
                                            (tok [@1 1..:])
                                            (bkt [@1 0])
                                            (tag [symhash (html-decode tok)]))
                                    (if tag
                                      `@at@bkt<a href="#@tag">@tok</a>`
                                      `@at@1`)) @1))
                        ((starts-with "<a name=" @1)
                         (match @(with `<a name="@tag">@rest`
                                       shash [direct tag])
                           @1
                           (join (collect-each ((sh shash))
                                   `<a name="@sh">&nbsp;</a>\n`)
                                 @1)))
                        ((search-regex @1 #/<h[1-9]>/) @1)
                        (t (regsub #/<tt>.%<\/tt>/
                             (do let* ((tok [@1 4 -5])
                                       (tend (break-str tok ") "))
                                       pfx sym sfx tag)
                               (cond
                                 ((match-str tok "@(")
                                  (set pfx "@("
                                       sym [tok 2 tend]
                                       sfx [tok tend .. :]
                                       tag [symhash (html-decode sym)]))
                                 (t (set tag [symhash (html-decode tok)]
                                         sym tok)))
                               (if tag
                                 `<tt>@pfx<a href="#@tag">@sym</a>@sfx</tt>`
                                 @1))
                             @1)))
                      BODY)))
@(bind (d-tag n-tag) @(transpose (hash-pairs disamb)))
@(output)
<!doctype html public "-//W3C//DTD HTML 4.01 Transitional//EN">
<html>
<head><title>Manpage for TXR @VERSION</title>
<meta http-equiv="Content-Type" content="text/html; charset=UTF-8">
<style>
.disambiguations dl {
  margin-bottom: 2048px;
}
dl.items dd:-moz-only-whitespace::after {
  content: "\00A0";
}
dl.items dd:empty:after {
  content: "\00A0";
}
dl.items dd {
  overflow: auto;
  min-width: calc(100% - 3em);
  margin-left: 3em;
  margin-bottom: 1ex;
}
dl.items dt {
  float: left;
  padding-right: 1ex;
}
kbd {
  background-color: #eee;
  border-radius: 3px;
  border: 1px solid #b4b4b4;
  box-shadow: 0 1px 1px rgba(0, 0, 0, .2), 0 2px 0 0 rgba(255, 255, 255, .7) inset;
  color: #333;
  display: inline-block;
  font-weight: 700;
  line-height: 1;
  padding: 2px 4px;
  white-space: nowrap;
}
</style>
<script type="text/javascript">
var xpanded = false;
function toggle(link, id) {
  var e = document.getElementById(id);
  if (e.style.display == '') {
    e.style.display = 'none';
    link.innerHTML = '@closedtxt';
  } else {
    e.style.display = '';
    link.innerHTML = '@opentxt';
  }
}
function toggleall(link) {
  var toc = document.getElementsByClassName("TOC");
  var dls = toc[0].getElementsByClassName("tocsec");
  var atoggles = toc[0].getElementsByClassName("toggle");
  var ndisp = xpanded ? 'none' : '';
  var nhtml = xpanded ? '@closedtxt' : '@opentxt'

  for (var i = 0; i < dls.length; i++)
    dls[i].style.display = ndisp;

  for (var i = 0; i < atoggles.length; i++)
    atoggles[i].innerHTML = nhtml;

  link.innerHTML = xpanded ? '@xpnall' : '@clpsall';

  xpanded = !xpanded;
}
function tocjump(hash) {
  var toc = document.getElementsByClassName("TOC");
  var tanch = toc[0].getElementsByClassName("tocanchor");

  for (var i = 0; i < tanch.length; i++) {
     var ta = tanch[i];

     if (ta.name == hash) {
       for (var e = ta.parentNode; e !== null; e = e.parentElement) {
         if (e.tagName == "DL") {
           var dt = e.previousElementSibling;
           e.style.display = '';
           if (dt !== null) {
             var atoggles = dt.getElementsByClassName("toggle");
             if (atoggles.length > 0)
               atoggles[0].innerHTML = '@opentxt';
           }
         }
       }
     }
  }
}
</script>
</head><body>
<h2>Manpage for <a href="#@[tagmap "lbAB"]">TXR </a>@VERSION</h2>
<h2>@(time-string-utc TIME "%b %d, %Y")</h2>
<p>
<form action="https://www.paypal.com/donate" method="post" target="_top">
<input type="hidden" name="hosted_button_id" value="X7D3YSVJBBBB8" />
<input type="image" src="https://www.paypalobjects.com/en_US/i/btn/btn_donate_LG.gif" border="0" name="submit" title="PayPal - The safer, easier way to pay online!" alt="Donate with PayPal button" />
<img alt="" border="0" src="https://www.paypal.com/en_CA/i/scr/pixel.gif" width="1" height="1" />
</form>
</p>
<div class="toc">
@(repeat)
@TOC
@(end)
</div>
@(repeat)
@BODY
@(first)
@(end)
<div class="disambiguations">
@(repeat)
<a name="@{d-tag}">
  <p>Topics matching <tt>@(hash-revget symhash d-tag)</tt>:
  <dl>
@ (repeat :counter (n 1))
    <dt><a href="#@{n-tag}">@n:</a> @[tochash n-tag]</dt>
@ (end)
  </dl>
</a>
@(end)
</div>
</body>
</html>
@(end)
@(do (let ((ignames '("*-1" "*-2" "*-20"
                      "*0" "*1" "*2" "*99"
                      "*n" "*r" "*v"
                      "--args" "--eargs" "-C"
                      ".."
                      "TXR_COMPAT"
                      "buf-get-" "buf-put-"))
           (imgsyms (hash-list (append-each* ((entry [remove-if (op equal "pub")
                                                                (package-alist)
                                                                car])
                                              (pkg-name [mapcar car entry])
                                              (pkg [mapcar cdr entry]))
                                 (let ((fn (casequal pkg-name
                                             (("usr" "keyword")
                                              (fun tostringp))
                                             (t (opip tostringp
                                                      (join-with ":" pkg-name))))))
                                   (mapcar fn (package-symbols pkg)))))))
       (each ((sym ignames))
         (del [symhash sym]))
       (let ((missing (hash-diff symhash imgsyms)))
         (dohash (sym val missing)
           (format *stderr* "~a: missing from image\n" sym)))))