basis/multiline/multiline.factor

   1 ! Copyright (C) 2007 Daniel Ehrenberg
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: namespaces make parser lexer kernel sequences words
   4 quotations math accessors locals ;
   5 IN: multiline
   6
   7 ERROR: bad-heredoc identifier ;
   8
   9 <PRIVATE
  10
  11 : rest-of-line ( -- seq )
  12     lexer get [ line-text>> ] [ column>> ] bi tail ;
  13
  14 : next-line-text ( -- str )
  15     lexer get dup next-line line-text>> ;
  16
  17 : (parse-here) ( -- )
  18     next-line-text [
  19         dup ";" =
  20         [ drop lexer get next-line ]
  21         [ % "\n" % (parse-here) ] if
  22     ] [ ";" unexpected-eof ] if* ;
  23
  24 PRIVATE>
  25
  26 ERROR: text-found-before-eol string ;
  27
  28 : parse-here ( -- str )
  29     [
  30         rest-of-line dup [ drop ] [ text-found-before-eol ] if-empty
  31         (parse-here)
  32     ] "" make but-last ;
  33
  34 SYNTAX: STRING:
  35     scan-new-word
  36     parse-here 1quotation
  37     ( -- string ) define-inline ;
  38
  39 <PRIVATE
  40
  41 :: (scan-multiline-string) ( i end -- j )
  42     lexer get line-text>> :> text
  43     text [
  44         end text i start* [| j |
  45             i j text subseq % j end length +
  46         ] [
  47             text i short tail % CHAR: \n ,
  48             lexer get next-line
  49             0 end (scan-multiline-string)
  50         ] if*
  51     ] [ end unexpected-eof ] if ;
  52
  53 :: (parse-multiline-string) ( end-text skip-n-chars -- str )
  54     [
  55         lexer get
  56         [ skip-n-chars + end-text (scan-multiline-string) ]
  57         change-column drop
  58     ] "" make ;
  59
  60 :: advance-same-line ( text -- )
  61     lexer get [ text length + ] change-column drop ;
  62
  63 :: (parse-til-line-begins) ( begin-text -- )
  64     lexer get still-parsing? [
  65         lexer get line-text>> begin-text sequence= [
  66             begin-text advance-same-line
  67         ] [
  68             lexer get line-text>> % "\n" %
  69             lexer get next-line
  70             begin-text (parse-til-line-begins)
  71         ] if
  72     ] [
  73         begin-text bad-heredoc
  74     ] if ;
  75
  76 : parse-til-line-begins ( begin-text -- seq )
  77     [ (parse-til-line-begins) ] "" make ;
  78
  79 PRIVATE>
  80
  81 : parse-multiline-string ( end-text -- str )
  82     1 (parse-multiline-string) ;
  83
  84 SYNTAX: /* "*/" parse-multiline-string drop ;
  85
  86 SYNTAX: HEREDOC:
  87     lexer get skip-blank
  88     rest-of-line
  89     lexer get next-line
  90     parse-til-line-begins suffix! ;
  91
  92 SYNTAX: DELIMITED:
  93     lexer get skip-blank
  94     rest-of-line
  95     lexer get next-line
  96     0 (parse-multiline-string) suffix! ;