basis/vocabs/prettyprint/prettyprint.factor

   1 ! Copyright (C) 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs colors fry io
   4 io.styles kernel literals make math.order namespaces parser
   5 prettyprint.backend prettyprint.sections prettyprint.stylesheet
   6 sequences sets sorting ui.theme vocabs vocabs.parser ;
   7 FROM: io.styles => inset ;
   8 IN: vocabs.prettyprint
   9
  10 : pprint-vocab ( vocab -- )
  11     [ vocab-name ] [ lookup-vocab vocab-style ] bi styled-text ;
  12
  13 : pprint-in ( vocab -- )
  14     [ \ IN: pprint-word pprint-vocab ] with-pprint ;
  15
  16 <PRIVATE
  17
  18 : sort-vocabs ( seq -- seq' )
  19     [ vocab-name ] sort-with ;
  20
  21 : pprint-using ( seq -- )
  22     "syntax" lookup-vocab '[ _ = ] reject
  23     sort-vocabs [
  24         \ USING: pprint-word
  25         [ pprint-vocab ] each
  26         \ ; pprint-word
  27     ] with-pprint ;
  28
  29 GENERIC: pprint-qualified ( qualified -- )
  30
  31 M: qualified pprint-qualified ( qualified -- )
  32     [
  33         dup [ vocab>> vocab-name ] [ prefix>> ] bi = [
  34             \ QUALIFIED: pprint-word
  35             vocab>> pprint-vocab
  36         ] [
  37             \ QUALIFIED-WITH: pprint-word
  38             [ vocab>> pprint-vocab ] [ prefix>> text ] bi
  39         ] if
  40     ] with-pprint ;
  41
  42 M: from pprint-qualified ( from -- )
  43     [
  44         \ FROM: pprint-word
  45         [ vocab>> pprint-vocab "=>" text ]
  46         [ names>> [ text ] each ] bi
  47         \ ; pprint-word
  48     ] with-pprint ;
  49
  50 M: exclude pprint-qualified ( exclude -- )
  51     [
  52         \ EXCLUDE: pprint-word
  53         [ vocab>> pprint-vocab "=>" text ]
  54         [ names>> [ text ] each ] bi
  55         \ ; pprint-word
  56     ] with-pprint ;
  57
  58 M: rename pprint-qualified ( rename -- )
  59     [
  60         \ RENAME: pprint-word
  61         [ word>> text ]
  62         [ vocab>> text "=>" text ]
  63         [ words>> >alist first first text ]
  64         tri
  65     ] with-pprint ;
  66
  67 : filter-interesting ( seq -- seq' )
  68     [ [ vocab? ] [ extra-words? ] bi or ] reject ;
  69
  70 PRIVATE>
  71
  72 : (pprint-manifest ( manifest -- quots )
  73     [
  74         [ search-vocabs>> [ '[ _ pprint-using ] , ] unless-empty ]
  75         [ qualified-vocabs>> filter-interesting [ '[ _ pprint-qualified ] , ] each ]
  76         [ current-vocab>> [ '[ _ pprint-in ] , ] when* ]
  77         tri
  78     ] { } make ;
  79
  80 : pprint-manifest) ( quots -- )
  81     [ nl ] [ call( -- ) ] interleave ;
  82
  83 : pprint-manifest ( manifest -- )
  84     (pprint-manifest pprint-manifest) ;
  85
  86 [
  87     nl
  88     { { font-style bold } { font-name "sans-serif" } } [
  89         "Restarts were invoked adding vocabularies to the search path." print
  90         "To avoid doing this in the future, add the following forms" print
  91         "at the top of the source file:" print nl
  92     ] with-style
  93     {
  94         { page-color $ vocab-background-color }
  95         { border-color $ vocab-border-color }
  96         { inset { 5 5 } }
  97     } [ manifest get pprint-manifest ] with-nesting
  98     nl nl
  99 ] print-use-hook set-global