basis/vocabs/prettyprint/prettyprint.factor

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