--- /dev/null
+! Copyright (C) 2016 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays assocs combinators combinators.short-circuit
+continuations fry io.encodings.utf8 io.files kernel locals make
+math math.order modern.paths modern.slices sequences
+sequences.extras sets splitting strings unicode vocabs.loader ;
+IN: modern
+
+ERROR: string-expected-got-eof n string ;
+ERROR: long-opening-mismatch tag open n string ch ;
+
+! (( )) [[ ]] {{ }}
+MACRO:: read-double-matched ( open-ch -- quot: ( n string tag ch -- n' string seq ) )
+ open-ch dup matching-delimiter {
+ [ drop 2 swap <string> ]
+ [ drop 1string ]
+ [ nip 2 swap <string> ]
+ } 2cleave :> ( openstr2 openstr1 closestr2 )
+ [| n string tag! ch |
+ ch {
+ { CHAR: = [
+ tag 1 cut-slice* drop tag! ! tag of (=( is ( here, fix it
+ n string openstr1 slice-til-separator-inclusive [ -1 modify-from ] dip :> ( n' string' opening ch )
+ ch open-ch = [ tag openstr2 n string ch long-opening-mismatch ] unless
+ opening matching-delimiter-string :> needle
+
+ n' string' needle slice-til-string :> ( n'' string'' payload closing )
+ n'' string
+ tag opening payload closing 4array
+ ] }
+ { open-ch [
+ tag 1 cut-slice* swap tag! 1 modify-to :> opening
+ n 1 + string closestr2 slice-til-string :> ( n' string' payload closing )
+ n' string
+ tag opening payload closing 4array
+ ] }
+ [ [ tag openstr2 n string ] dip long-opening-mismatch ]
+ } case
+ ] ;
+
+: read-double-matched-paren ( n string tag ch -- n' string seq ) CHAR: ( read-double-matched ;
+: read-double-matched-bracket ( n string tag ch -- n' string seq ) CHAR: [ read-double-matched ;
+: read-double-matched-brace ( n string tag ch -- n' string seq ) CHAR: { read-double-matched ;
+
+DEFER: lex-factor-top
+DEFER: lex-factor
+ERROR: lex-expected-but-got-eof n string expected ;
+! For implementing [ { (
+: lex-until ( n string tag-sequence -- n' string payload )
+ 3dup '[
+ [
+ lex-factor-top dup f like [ , ] when* [
+ dup [
+ ! } gets a chance, but then also full seq { } after recursion...
+ [ _ ] dip '[ _ sequence= ] any? not
+ ] [
+ drop t ! loop again?
+ ] if
+ ] [
+ _ _ _ lex-expected-but-got-eof
+ ] if*
+ ] loop
+ ] { } make ;
+
+DEFER: section-close?
+DEFER: upper-colon?
+DEFER: lex-factor-nested
+: lex-colon-until ( n string tag-sequence -- n' string payload )
+ '[
+ [
+ lex-factor-nested dup f like [ , ] when* [
+ dup [
+ ! This is for ending COLON: forms like ``A: PRIVATE>``
+ dup section-close? [
+ drop f
+ ] [
+ ! } gets a chance, but then also full seq { } after recursion...
+ [ _ ] dip '[ _ sequence= ] any? not
+ ] if
+ ] [
+ drop t ! loop again?
+ ] if
+ ] [
+ f
+ ] if*
+ ] loop
+ ] { } make ;
+
+: split-double-dash ( seq -- seqs )
+ dup [ { [ "--" sequence= ] } 1&& ] split-when
+ dup length 1 > [ nip ] [ drop ] if ;
+
+MACRO:: read-matched ( ch -- quot: ( n string tag -- n' string slice' ) )
+ ch dup matching-delimiter {
+ [ drop "=" swap prefix ]
+ [ nip 1string ]
+ } 2cleave :> ( openstreq closestr1 ) ! [= ]
+ [| n string tag |
+ n string tag
+ 2over nth-check-eof {
+ { [ dup openstreq member? ] [ ch read-double-matched ] } ! (=( or ((
+ { [ dup blank? ] [
+ drop dup '[ _ matching-delimiter-string closestr1 2array members lex-until ] dip
+ swap unclip-last 3array ] } ! ( foo )
+ [ drop [ slice-til-whitespace drop ] dip span-slices ] ! (foo)
+ } cond
+ ] ;
+
+: read-bracket ( n string slice -- n' string slice' ) CHAR: [ read-matched ;
+: read-brace ( n string slice -- n' string slice' ) CHAR: { read-matched ;
+: read-paren ( n string slice -- n' string slice' ) CHAR: ( read-matched ;
+: read-string-payload ( n string -- n' string )
+ over [
+ { CHAR: \\ CHAR: \" } slice-til-separator-inclusive {
+ { f [ drop ] }
+ { CHAR: \" [ drop ] }
+ { CHAR: \\ [ drop next-char-from drop read-string-payload ] }
+ } case
+ ] [
+ string-expected-got-eof
+ ] if ;
+
+:: read-string ( n string tag -- n' string seq )
+ n string read-string-payload drop :> n'
+ n' string
+ n' [ n string string-expected-got-eof ] unless
+ n n' 1 - string <slice>
+ n' 1 - n' string <slice>
+ tag -rot 3array ;
+
+: take-comment ( n string slice -- n' string comment )
+ 2over ?nth CHAR: [ = [
+ [ 1 + ] 2dip 2over ?nth read-double-matched-bracket
+ ] [
+ [ slice-til-eol drop ] dip swap 2array
+ ] if ;
+
+: terminator? ( slice -- ? )
+ {
+ [ ";" sequence= ]
+ [ "]" sequence= ]
+ [ "}" sequence= ]
+ [ ")" sequence= ]
+ } 1|| ;
+
+ERROR: expected-length-tokens n string length seq ;
+: ensure-no-false ( n string seq -- n string seq )
+ dup [ length 0 > ] all? [ [ length ] keep expected-length-tokens ] unless ;
+
+ERROR: token-expected n string obj ;
+ERROR: unexpected-terminator n string slice ;
+: read-lowercase-colon ( n string slice -- n' string lowercase-colon )
+ dup [ CHAR: : = ] count-tail
+ '[
+ _ [ lex-factor ] replicate ensure-no-false dup [ token-expected ] unless
+ dup terminator? [ unexpected-terminator ] when
+ ] dip swap 2array ;
+
+: (strict-upper?) ( string -- ? )
+ {
+ ! All chars must...
+ [
+ [
+ { [ CHAR: A CHAR: Z between? ] [ "':-\\#" member? ] } 1||
+ ] all?
+ ]
+ ! At least one char must...
+ [ [ { [ CHAR: A CHAR: Z between? ] [ CHAR: ' = ] } 1|| ] any? ]
+ } 1&& ;
+
+: strict-upper? ( string -- ? )
+ { [ ":" sequence= ] [ (strict-upper?) ] } 1|| ;
+
+! <A <A: but not <A>
+: section-open? ( string -- ? )
+ {
+ [ "<" head? ]
+ [ length 2 >= ]
+ [ rest strict-upper? ]
+ [ ">" tail? not ]
+ } 1&& ;
+
+: html-self-close? ( string -- ? )
+ {
+ [ "<" head? ]
+ [ length 2 >= ]
+ [ rest strict-upper? not ]
+ [ [ blank? ] any? not ]
+ [ "/>" tail? ]
+ } 1&& ;
+
+: html-full-open? ( string -- ? )
+ {
+ [ "<" head? ]
+ [ length 2 >= ]
+ [ second CHAR: / = not ]
+ [ rest strict-upper? not ]
+ [ [ blank? ] any? not ]
+ [ ">" tail? ]
+ } 1&& ;
+
+: html-half-open? ( string -- ? )
+ {
+ [ "<" head? ]
+ [ length 2 >= ]
+ [ second CHAR: / = not ]
+ [ rest strict-upper? not ]
+ [ [ blank? ] any? not ]
+ [ ">" tail? not ]
+ } 1&& ;
+
+: html-close? ( string -- ? )
+ {
+ [ "</" head? ]
+ [ length 2 >= ]
+ [ rest strict-upper? not ]
+ [ [ blank? ] any? not ]
+ [ ">" tail? ]
+ } 1&& ;
+
+: special-acute? ( string -- ? )
+ {
+ [ section-open? ]
+ [ html-self-close? ]
+ [ html-full-open? ]
+ [ html-half-open? ]
+ [ html-close? ]
+ } 1|| ;
+
+: upper-colon? ( string -- ? )
+ dup { [ length 0 > ] [ [ CHAR: : = ] all? ] } 1&& [
+ drop t
+ ] [
+ {
+ [ length 2 >= ]
+ [ "\\" head? not ] ! XXX: good?
+ [ ":" tail? ]
+ [ dup [ CHAR: : = ] find drop head strict-upper? ]
+ } 1&&
+ ] if ;
+
+: section-close? ( string -- ? )
+ {
+ [ length 2 >= ]
+ [ "\\" head? not ] ! XXX: good?
+ [ ">" tail? ]
+ [
+ {
+ [ but-last strict-upper? ]
+ [ { [ ";" head? ] [ rest but-last strict-upper? ] } 1&& ]
+ } 1||
+ ]
+ } 1&& ;
+
+: read-til-semicolon ( n string slice -- n' string semi )
+ dup '[ but-last ";" append ";" 2array { "--" ")" } append lex-colon-until ] dip
+ swap
+ ! What ended the FOO: .. ; form?
+ ! Remove the ; from the payload if present
+ ! XXX: probably can remove this, T: is dumb
+ ! Also in stack effects ( T: int -- ) can be ended by -- and )
+ dup ?last {
+ { [ dup ";" sequence= ] [ drop unclip-last 3array ] }
+ { [ dup ";" tail? ] [ drop unclip-last 3array ] }
+ { [ dup "--" sequence= ] [ drop unclip-last -rot 2array [ rewind-slice ] dip ] }
+ { [ dup "]" sequence= ] [ drop unclip-last -rot 2array [ rewind-slice ] dip ] }
+ { [ dup "}" sequence= ] [ drop unclip-last -rot 2array [ rewind-slice ] dip ] }
+ { [ dup ")" sequence= ] [ drop unclip-last -rot 2array [ rewind-slice ] dip ] } ! (n*quot) breaks
+ { [ dup section-close? ] [ drop unclip-last -rot 2array [ rewind-slice ] dip ] }
+ { [ dup upper-colon? ] [ drop unclip-last -rot 2array [ rewind-slice ] dip ] }
+ [ drop 2array ]
+ } cond ;
+
+ERROR: colon-word-must-be-all-uppercase-or-lowercase n string word ;
+: read-colon ( n string slice -- n' string colon )
+ {
+ { [ dup strict-upper? ] [ read-til-semicolon ] }
+ { [ dup ":" tail? ] [ dup ":" head? [ read-lowercase-colon ] unless ] } ! :foo: vs foo:
+ [ ]
+ } cond ;
+
+: read-acute-html ( n string slice -- n' string acute )
+ {
+ ! <FOO <FOO:
+ { [ dup section-open? ] [
+ [
+ matching-section-delimiter 1array lex-until
+ ] keep swap unclip-last 3array
+ ] }
+ ! <foo/>
+ { [ dup html-self-close? ] [
+ ! do nothing special
+ ] }
+ ! <foo>
+ { [ dup html-full-open? ] [
+ dup [
+ rest-slice
+ dup ">" tail? [ but-last-slice ] when
+ "</" ">" surround 1array lex-until unclip-last
+ ] dip -rot 3array
+ ] }
+ ! <foo
+ { [ dup html-half-open? ] [
+ ! n seq slice
+ [ { ">" "/>" } lex-until ] dip
+ ! n seq slice2 slice
+ over ">" sequence= [
+ "</" ">" surround array '[ _ lex-until ] dip unclip-last
+ -rot roll unclip-last [ 3array ] 2dip 3array
+ ] [
+ ! self-contained
+ swap unclip-last 3array
+ ] if
+ ] }
+ ! </foo>
+ { [ dup html-close? ] [
+ ! Do nothing
+ ] }
+ [ [ slice-til-whitespace drop ] dip span-slices ]
+ } cond ;
+
+: read-acute ( n string slice -- n' string acute )
+ [ matching-section-delimiter 1array lex-until ] keep swap unclip-last 3array ;
+
+! Words like append! and suffix! are allowed for now.
+: read-exclamation ( n string slice -- n' string obj )
+ dup { [ "!" sequence= ] [ "#!" sequence= ] } 1||
+ [ take-comment ] [ merge-slice-til-whitespace ] if ;
+
+ERROR: no-backslash-payload n string slice ;
+: (read-backslash) ( n string slice -- n' string obj )
+ merge-slice-til-whitespace dup "\\" tail? [
+ ! \ foo, M\ foo
+ dup [ CHAR: \\ = ] count-tail
+ '[
+ _ [ skip-blank-from slice-til-whitespace drop ] replicate
+ ensure-no-false
+ dup [ no-backslash-payload ] unless
+ ] dip swap 2array
+ ] when ;
+
+DEFER: lex-factor-top*
+: read-backslash ( n string slice -- n' string obj )
+ ! foo\ so far, could be foo\bar{
+ ! remove the \ and continue til delimiter/eof
+ [ "\"!:[{(<>\s\r\n" slice-til-either ] dip swap [ span-slices ] dip
+ over "\\" head? [
+ drop
+ ! \ foo
+ dup [ CHAR: \\ = ] all? [ (read-backslash) ] [ merge-slice-til-whitespace ] if
+ ] [
+ ! foo\ or foo\bar (?)
+ over "\\" tail? [ drop (read-backslash) ] [ lex-factor-top* ] if
+ ] if ;
+
+! If the slice is 0 width, we stopped on whitespace.
+! Advance the index and read again!
+
+: read-token-or-whitespace-top ( n string slice -- n' string slice/f )
+ dup length 0 = [ [ 1 + ] 2dip drop lex-factor-top ] when ;
+
+: read-token-or-whitespace-nested ( n string slice -- n' string slice/f )
+ dup length 0 = [ [ 1 + ] 2dip drop lex-factor-nested ] when ;
+
+: lex-factor-fallthrough ( n/f string slice/f ch/f -- n'/f string literal )
+ {
+ { CHAR: \ [ read-backslash ] }
+ { CHAR: [ [ read-bracket ] }
+ { CHAR: { [ read-brace ] }
+ { CHAR: ( [ read-paren ] }
+ { CHAR: ] [ ] }
+ { CHAR: } [ ] }
+ { CHAR: ) [ ] }
+ { CHAR: " [ read-string ] }
+ { CHAR: ! [ read-exclamation ] }
+ { CHAR: > [
+ [ [ CHAR: > = not ] slice-until ] dip merge-slices
+ dup section-close? [
+ [ slice-til-whitespace drop ] dip ?span-slices
+ ] unless
+ ] }
+ { f [ ] }
+ } case ;
+
+! Inside a FOO: or a <FOO FOO>
+: lex-factor-nested* ( n/f string slice/f ch/f -- n'/f string literal )
+ {
+ ! Nested ``A: a B: b`` so rewind and let the parser get it top-level
+ { CHAR: : [
+ ! A: B: then interrupt the current parser
+ ! A: b: then keep going
+ merge-slice-til-whitespace
+ dup { [ upper-colon? ] [ ":" = ] } 1||
+ ! dup upper-colon?
+ [ rewind-slice f ]
+ [ read-colon ] if
+ ] }
+ { CHAR: < [
+ ! FOO: a b <BAR: ;BAR>
+ ! FOO: a b <BAR BAR>
+ ! FOO: a b <asdf>
+ ! FOO: a b <asdf asdf>
+
+ ! if we are in a FOO: and we hit a <BAR or <BAR:
+ ! then end the FOO:
+ ! Don't rewind for a <foo/> or <foo></foo>
+ [ slice-til-whitespace drop ] dip span-slices
+ dup section-open? [ rewind-slice f ] when
+ ] }
+ { CHAR: \s [ read-token-or-whitespace-nested ] }
+ { CHAR: \r [ read-token-or-whitespace-nested ] }
+ { CHAR: \n [ read-token-or-whitespace-nested ] }
+ [ lex-factor-fallthrough ]
+ } case ;
+
+: lex-factor-nested ( n/f string -- n'/f string literal )
+ ! skip-whitespace
+ "\"\\!:[{(]})<>\s\r\n" slice-til-either
+ lex-factor-nested* ; inline
+
+: lex-factor-top* ( n/f string slice/f ch/f -- n'/f string literal )
+ {
+ { CHAR: : [ merge-slice-til-whitespace read-colon ] }
+ { CHAR: < [
+ ! FOO: a b <BAR: ;BAR>
+ ! FOO: a b <BAR BAR>
+ ! FOO: a b <asdf>
+ ! FOO: a b <asdf asdf>
+
+ ! if we are in a FOO: and we hit a <BAR or <BAR:
+ ! then end the FOO:
+ [ slice-til-whitespace drop ] dip span-slices
+ ! read-acute-html
+ dup section-open? [ read-acute ] when
+ ] }
+
+ { CHAR: \s [ read-token-or-whitespace-top ] }
+ { CHAR: \r [ read-token-or-whitespace-top ] }
+ { CHAR: \n [ read-token-or-whitespace-top ] }
+ [ lex-factor-fallthrough ]
+ } case ;
+
+: lex-factor-top ( n/f string -- n'/f string literal )
+ ! skip-whitespace
+ "\"\\!:[{(]})<>\s\r\n" slice-til-either
+ lex-factor-top* ; inline
+
+ERROR: compound-syntax-disallowed n seq obj ;
+: check-for-compound-syntax ( n/f seq obj -- n/f seq obj )
+ dup length 1 > [ compound-syntax-disallowed ] when ;
+
+: check-compound-loop ( n/f string -- n/f string ? )
+ [ ] [ peek-from ] [ previous-from ] 2tri
+ [ blank? ] bi@ or not ! no blanks between tokens
+ pick and ; ! and a valid index
+
+: lex-factor ( n/f string/f -- n'/f string literal/f )
+ [
+ ! Compound syntax loop
+ [
+ lex-factor-top f like [ , ] when*
+ ! concatenated syntax ( a )[ a 1 + ]( b )
+ check-compound-loop
+ ] loop
+ ] { } make
+ check-for-compound-syntax
+ ! concat ! "ALIAS: n*quot (n*quot)" string>literals ... breaks here
+ ?first f like ;
+
+: string>literals ( string -- sequence )
+ [ 0 ] dip [
+ [ lex-factor [ , ] when* over ] loop
+ ] { } make 2nip ;
+
+: vocab>literals ( vocab -- sequence )
+ ".private" ?tail drop
+ vocab-source-path utf8 file-contents string>literals ;
+
+: path>literals ( path -- sequence )
+ utf8 file-contents string>literals ;
+
+: lex-paths ( vocabs -- assoc )
+ [ [ path>literals ] [ nip ] recover ] map-zip ;
+
+: lex-vocabs ( vocabs -- assoc )
+ [ [ vocab>literals ] [ nip ] recover ] map-zip ;
+
+: failed-lexing ( assoc -- assoc' ) [ nip array? ] assoc-reject ;
+
+: lex-core ( -- assoc ) core-vocabs lex-vocabs ;
+: lex-basis ( -- assoc ) basis-vocabs lex-vocabs ;
+: lex-extra ( -- assoc ) extra-vocabs lex-vocabs ;
+: lex-roots ( -- assoc ) lex-core lex-basis lex-extra 3append ;
+
+: lex-docs ( -- assoc ) all-docs-paths lex-paths ;
+: lex-tests ( -- assoc ) all-tests-paths lex-paths ;
+
+: lex-all ( -- assoc )
+ lex-roots lex-docs lex-tests 3append ;
projects / factor.git / blobdiff