basis/vocabs/prettyprint/prettyprint.factor

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