basis/help/syntax/syntax.factor

   1 ! Copyright (C) 2005, 2009 Slava Pestov.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3
   4 USING: accessors arrays ascii combinators
   5 combinators.short-circuit compiler.units definitions help
   6 help.markup help.topics kernel lexer math math.order namespaces
   7 parser sequences splitting strings strings.parser vocabs.parser
   8 words ;
   9
  10 IN: help.syntax
  11
  12 DEFER: HELP{
  13
  14 <PRIVATE
  15
  16 :: parse-help-token ( end -- str/obj/f literal? )
  17     ?scan-token dup {
  18         [ "{" = [ \ HELP{ ] [ f ] if ]
  19         [ "syntax" lookup-word ]
  20         [ { [ "$" head? ] [ "help.markup" lookup-word ] } 1&& ]
  21         [ dup ?last ":{[(/\"" member-eq? [ search ] [ drop f ] if ]
  22     } 1|| {
  23         { [ dup not ] [ drop f ] }
  24         { [ dup end eq? ] [ 2drop f f ] }
  25         { [ dup parsing-word? ] [
  26             [
  27                 nip V{ } clone swap execute-parsing first
  28                 dup wrapper? [ wrapped>> \ $link swap 2array ] when
  29             ] keep \ " = ] }
  30         { [ dup ] [ nip f ] }
  31     } cond ;
  32
  33 : push-help-text ( accum sbuf obj -- accum sbuf' )
  34     [ dup empty? [ >string suffix! SBUF" " clone ] unless ]
  35     [ [ suffix! ] curry dip ] bi* ;
  36
  37
  38 : help-block? ( word -- ? )
  39     {
  40         $description $heading $subheading $syntax
  41         $class-description $error-description $var-description
  42         $contract $notes $curious $deprecated $errors
  43         $side-effects $content $warning $subsections $nl
  44         $list $table $example $unchecked-example $code
  45     } member-eq? ;
  46
  47 : ?push-help-space ( accum sbuf obj -- accum sbuf' obj )
  48     over empty? [
  49         pick [ f ] [
  50             last {
  51                 [ string? not ]
  52                 [ dup array? [ ?first ] when help-block? not ]
  53             } 1&&
  54         ] if-empty
  55     ] [
  56         over last " (" member? not
  57     ] if
  58     over string? [ over ?first " .,;:)" member? not and ] when
  59     [ [ CHAR: \s suffix! ] dip ] when ;
  60
  61 :: parse-help-text ( end -- seq )
  62     V{ } clone SBUF" " clone [
  63         lexer get line>> :> m
  64         end parse-help-token :> ( obj literal? )
  65         lexer get line>> :> n
  66
  67         obj string? n m - 1 > and [
  68             { [ dup empty? not ] [ over ?last string? ] } 0||
  69             [ \ $nl push-help-text ] when
  70         ] when
  71
  72         obj [
  73             [
  74                 literal? [ ?push-help-space ] unless
  75                 dup string? not literal? or
  76                 [ push-help-text ] [ append! ] if
  77             ] when*
  78         ] keep
  79     ] loop [ >string suffix! ] unless-empty >array ; inline
  80
  81 : parse-help-values ( -- seq )
  82     [ scan-token dup "}" = not ] [
  83         dup "{" = [
  84             drop \ } parse-until >array
  85         ] [
  86             ":" ?tail drop scan-object 2array
  87         ] if
  88     ] produce nip ;
  89
  90 : whitespace ( seq -- n )
  91     [ [ blank? ] all? ] reject [ 0 ] [
  92         [ [ blank? not ] find drop ] [ min ] map-reduce
  93     ] if-empty ;
  94
  95 : trim-whitespace ( seq -- seq' )
  96     dup rest-slice dup whitespace
  97     [ '[ _ index-or-length tail ] map! ] unless-zero drop
  98     0 over [ [ blank? ] trim-head ] change-nth ;
  99
 100 : code-lines ( str -- seq )
 101     split-lines trim-whitespace [ [ blank? ] all? ] trim ;
 102
 103 : make-example ( str -- seq )
 104     code-lines dup { [ array? ] [ length 1 > ] } 1&& [
 105         dup length 1 - over [ unescape-string ] change-nth
 106         \ $example prefix
 107     ] when ;
 108
 109 : parse-help-examples ( -- seq )
 110     \ } parse-until dup [ string? ] all?
 111     [ [ make-example ] { } map-as ] [ >array ] if ;
 112
 113 : parse-help-code ( -- seq )
 114     \ } parse-until dup { [ length 1 = ] [ first string? ] } 1&&
 115     [ first code-lines ] [ >array ] if ;
 116
 117 : help-text? ( word -- ? )
 118     {
 119         $description $snippet $emphasis $strong $heading
 120         $subheading $syntax $class-description
 121         $error-description $var-description $contract $notes
 122         $curious $deprecated $errors $side-effects $content
 123         $slot $image $warning
 124     } member-eq? ;
 125
 126 : help-code? ( word -- ? )
 127     { $example $unchecked-example $code } member-eq? ;
 128
 129 : help-values? ( word -- ? )
 130     { $values $inputs $outputs } member-eq? ;
 131
 132 : help-examples? ( word -- ? )
 133     { $examples } member-eq? ;
 134
 135 PRIVATE>
 136
 137 SYNTAX: HELP{
 138     scan-object dup \ } eq? [ drop { } ] [
 139         {
 140             { [ dup help-text? ] [ \ } parse-help-text ] }
 141             { [ dup help-code? ] [ parse-help-code ] }
 142             { [ dup help-values? ] [ parse-help-values ] }
 143             { [ dup help-examples? ] [ parse-help-examples ] }
 144             [ \ } parse-until >array ]
 145         } cond swap prefix
 146     ] if suffix! ;
 147
 148 SYNTAX: HELP:
 149     H{ { "{" POSTPONE: HELP{ } } [
 150         scan-word bootstrap-word
 151         [ >link save-location ]
 152         [ [ parse-array-def ] dip set-word-help ]
 153         bi
 154     ] with-words ;
 155
 156 SYNTAX: ARTICLE:
 157     location [
 158         scan-object scan-object
 159         \ ; parse-help-text <article>
 160         over add-article >link
 161     ] dip remember-definition ;
 162
 163 SYNTAX: ABOUT:
 164     current-vocab scan-object >>help changed-definition ;