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.constants fry io io.styles kernel
   4 make namespaces parser 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 ( 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 ( from -- )
  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 ( exclude -- )
  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 ( rename -- )
  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