basis/vocabs/prettyprint/prettyprint.factor

   1 ! Copyright (C) 2009 Slava Pestov.
   2 ! See https://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: FactorTan }
  88     { inset { 5 5 } }
  89 }
  90
  91 [
  92     [
  93         nl
  94         { { font-style bold } { font-name "sans-serif" } } [
  95             "Restarts were invoked adding vocabularies to the search path." print
  96             "To avoid doing this in the future, add the following forms" print
  97             "at the top of the source file:" print nl
  98         ] with-style
  99         manifest-style [ manifest get pprint-manifest ] with-nesting
 100         nl nl flush
 101     ] with-output>error
 102 ] print-use-hook set-global