;"Copyright (C) 2018 Keziah Wesley

You can redistribute and/or modify this file under the terms of the
GNU Affero General Public License as published by the Free Software
Foundation, either version 3 of the License, or (at your option) any
later version.

This file is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Affero General Public License for more details.

You should have received a copy of the GNU Affero General Public
License along with this file. If not, see
<http://www.gnu.org/licenses/>."

<FLOAD "chartable.mud">

<MOBLIST PARSER>

parse!-
PARSE-TABLE!-

DEFAULT-TABLE!-PARSER

read-all!-PARSER

%<AND <BLOCK (<MOBLIST pp> <GET PARSER OBLIST> <GET CHARTABLE OBLIST> <ROOT>)> <>>

;"Operation:
  Input string is provided to parser. Parser consumes from input and updates state.
  Beginning and end of input will be treated as token boundaries.
  Parser will return producing a value after reading 1 complete expression
  (possibly leaving some input leftover)."

;"If PARSE receives a partial input, it emits an ERROR. READ installs a
  handler for the ERROR INTERRUPT that attempts to get more data and
  ERRET."

<DEFINE CHARSTREAM (s) [.s 1 1]>
<DEFINE COPY-CHARSTREAM (s) <MAPF ,VECTOR ,AND? .s>>
<DEFINE SET-CHARSTREAM (x y) <PUT .x 1 <1 .y>> <PUT .x 2 <2 .y>> <PUT .x 3 <3 .y>>>
<DEFINE NEWLINE-POS (s) <PUT .s 2 <+ 1 <2 .s>>> <PUT .s 3 0>>
<DEFINE GET-POS (x) (<2 .x> <3 .x>)>
<DEFINE EAT-CHAR (s) <PUT .s 1 <REST <1 .s>>> <PUT .s 3 <+ 1 <3 .s>>>>
<DEFINE PEEK-CHAR (s) <ASCII <1 <1 .s>>>>
<DEFINE NEXT-CHAR (s "AUX" (c <PEEK-CHAR .s>))
 <EAT-CHAR .s>
 <COND (<==? 33 .c> <SET c <bang <PEEK-CHAR .s>>> <EAT-CHAR .s>)>
 .c>
;"TODO: eliminate this and rely on peeking"
<DEFINE RETURN-CHAR (s "AUX")
 <COND (<==? %<ASCII 10> <1 <BACK <1 .s>>>> <PUT .s 2 <- <2 .s> 1>>)>
 <PUT .s 1 <BACK <1 .s>>>>

<DEFINE parse (t s "AUX" c sp "NAME" a)
 <COND (<EMPTY? <1 .s>> <RETURN EOF .a>)>
 <SET c <NEXT-CHAR .s>>
 <SET sp <SPECIAL? .t .c>>
 <COND (.sp <APPLY .sp .t .s .a>)
       (ELSE <APPLY <DEFAULT-HANDLER .t> .t .c .s .a>)>>

;"BLOCK is documented as modifying the value of .OBLIST, so I'm
  assuming passing a lookup param to READ has a similar effect rather
  than setting an internal variable."

<DEFINE read (s "OPTIONAL" (OBLIST .OBLIST))
 <parse ,default <CHARSTREAM .s>>>

<DEFINE read-all (s "OPTIONAL" (OBLIST .OBLIST))
 <SET s <CHARSTREAM .s>>
 <MAPF ,LIST <FUNCTION ("AUX" res)
  <COND (<EMPTY? <1 .s>> <MAPSTOP>)
  	(ELSE <SET res <parse ,default .s>>
	 <COND (<==? .res EOF> <MAPSTOP>) (ELSE .res)>)>>>>

;"Don't try to READ in objects of these types."
<NEWTYPE closer FIX>
<NEWTYPE prototemplate VECTOR>
;"TODO: set appropriate ERROR as closer's EVALTYPE."

<DEFINE bang (c) <+ .c #FIX %<LSH 1 21>>>
<DEFINE banged? (c) <G=? .c #FIX %<LSH 1 21>>>
<DEFINE unbang (c) <- .c #FIX %<LSH 1 21>>>
<DEFINE explode-bang (c)
 <COND (<banged? .c> <STRING %<1 "!"> <CHTYPE .c CHARACTER>>) (ELSE <CHTYPE .c CHARACTER>)>>

;"Create the appropriate ERROR if there's a brace mismatch."
;"Otherwise do nothing. Return value is ignored."
<DEFINE check-closer (pos c opener s "TUPLE" closers)
 <COND
  (<TYPE? .c closer>
   <COND
    (<MEMQ <CHTYPE .c FIX> .closers>)
    ;"TODO: position info"
    (ELSE <ERROR BRACE-MISMATCH (POS .pos
    	  	 		 OPENER <explode-bang .opener>
    	  	 		 EXPECTED <MAPF ,LIST ,explode-bang .closers>
				 FOUND <explode-bang <CHTYPE .c FIX>>)>)>)
  (<==? .c EOF> <ERROR UNCLOSED-BRACKET <explode-bang .opener> .pos>)>>

;"TODO: accept radix in PARSE"
<SETG radix 10>

;"Create a standard Muddle CHARTABLE."
<DEFINE make-default ("AUX" (t <CHARTABLE>))
 <BULK-UPDATE .t
  <SET-SPECIAL .t 9 T <FUNCTION (t s a) <AGAIN .a>>> ;"HT"
  <SET-SPECIAL .t 10 T <FUNCTION (t s a) <NEWLINE-POS .s> <AGAIN .a>>> ;"LF"
  <SET-SPECIAL .t 11 T <FUNCTION (t s a) <AGAIN .a>>> ;"VT"
  <SET-SPECIAL .t 12 T <FUNCTION (t s a) <AGAIN .a>>> ;"FF"
  <SET-SPECIAL .t 13 T <FUNCTION (t s a) <AGAIN .a>>> ;"CR"
  <SET-SPECIAL .t 32 T <FUNCTION (t s a) <AGAIN .a>>> ;"space"
  <SET-SPECIAL .t <ASCII !\.> <> <FUNCTION (t s a) <FORM LVAL <parse .t .s>>>>
  <SET-SPECIAL .t <ASCII !\,> T <FUNCTION (t s a) <FORM GVAL <parse .t .s>>>>
  <SET-SPECIAL .t <bang <ASCII !\.>> <> <FUNCTION (t s a) <CHTYPE <FORM LVAL <parse .t .s>> SEGMENT>>>
  <SET-SPECIAL .t <bang <ASCII !\,>> T <FUNCTION (t s a) <CHTYPE <FORM GVAL <parse .t .s>> SEGMENT>>>
  <SET-SPECIAL .t <ASCII !\'> T <FUNCTION (t s a) <FORM QUOTE <parse .t .s>>>>
  <SET-SPECIAL .t <ASCII !\;> T <FUNCTION (t s a) <parse .t .s> <AGAIN .a>>>
  <SET-SPECIAL .t <ASCII !\%> T <FUNCTION (t s a)
   <COND (<==? %<ASCII !\%> <PEEK-CHAR .s>> <EAT-CHAR .s> <EVAL <parse .t .s>> <AGAIN .a>)>
   <EVAL <parse .t .s>>>>
  <SET-SPECIAL .t <ASCII !\#> T <FUNCTION (t s a "AUX" (type <parse .t .s>)) <CHTYPE <parse .t .s> .type>>>
  <SET-SPECIAL .t <bang <ASCII !\\>> T <FUNCTION (t s a) <NEXT-CHAR .s>>>
  <SET-SPECIAL .t <ASCII !\*> <> <FUNCTION (t s a) <parse-octal .t .s .a>>>

  <SET-SPECIAL .t <ASCII !\"> T <FUNCTION (t s a)
   <MAPF ,STRING <FUNCTION ("AUX" (c <NEXT-CHAR .s>))
    <COND (<==? .c %<ASCII !\\>> <MAPRET <CHTYPE <NEXT-CHAR .s> CHARACTER>>)
    	  (<banged? .c> <MAPRET %<1 "!"> <CHTYPE <unbang .c> CHARACTER>>)
    	  (<==? .c %<ASCII !\">> <MAPSTOP>)
    	  (<==? .c 10> <NEWLINE-POS .s> <MAPRET <CHTYPE .c CHARACTER>>)
	  (ELSE <MAPRET <CHTYPE .c CHARACTER>>)>>>>>

  ;"TODO: macros for reducing the redundancy of all these openers and closers."

  ;"A closer is an illegal object for anything except the corresponding opener."
  <SET-SPECIAL .t <ASCII !\>> T <FUNCTION (t s a) <CHTYPE <ASCII !\>> closer>>>
  <SET-SPECIAL .t <ASCII !\)> T <FUNCTION (t s a) <CHTYPE <ASCII !\)> closer>>>
  <SET-SPECIAL .t <ASCII !\]> T <FUNCTION (t s a) <CHTYPE <ASCII !\]> closer>>>
  <SET-SPECIAL .t <ASCII !\}> T <FUNCTION (t s a) <CHTYPE <ASCII !\}> closer>>>
  <SET-SPECIAL .t <bang <ASCII !\>>> T <FUNCTION (t s a) <CHTYPE <bang <ASCII !\>>> closer>>>
  <SET-SPECIAL .t <bang <ASCII !\)>> T <FUNCTION (t s a) <CHTYPE <bang <ASCII !\)>> closer>>>
  <SET-SPECIAL .t <bang <ASCII !\]>> T <FUNCTION (t s a) <CHTYPE <bang <ASCII !\]>> closer>>>
  <SET-SPECIAL .t <bang <ASCII !\}>> T <FUNCTION (t s a) <CHTYPE <bang <ASCII !\}>> closer>>>

  <SET-SPECIAL .t <ASCII !\(> T <FUNCTION (t s a "AUX" pos)
   <SET pos <GET-POS .s>>
   <MAPF ,LIST <FUNCTION ("AUX" (x <parse .t .s>))
    <COND (<check-closer .x <ASCII !\(> .s <ASCII !\)>> <MAPSTOP>)
	  (ELSE <MAPRET .x>)>>>>>

  <SET-SPECIAL .t <ASCII !\<> T <FUNCTION (t s a "AUX" pos)
   <SET pos <GET-POS .s>>
   <MAPF ,FORM <FUNCTION ("AUX" (x <parse .t .s>))
    <COND (<check-closer .pos .x <ASCII !\<> .s <ASCII !\>>> <MAPSTOP>)
	  (ELSE <MAPRET .x>)>>>>>

  <SET-SPECIAL .t <ASCII !\[> T <FUNCTION (t s a "AUX" pos)
   <SET pos <GET-POS .s>>
   <MAPF ,VECTOR <FUNCTION ("AUX" (x <parse .t .s>))
    <COND (<check-closer .pos .x <ASCII !\[> .s <ASCII !\]>> <MAPSTOP>)
	  (ELSE <MAPRET .x>)>>>>>

  <SET-SPECIAL .t <bang <ASCII !\[>> T <FUNCTION (t s a "AUX" pos)
   <SET pos <GET-POS .s>>
   <MAPF ,UVECTOR <FUNCTION ("AUX" (x <parse .t .s>))
    <COND (<check-closer .pos .x <bang <ASCII !\[>> .s <ASCII !\]>> <bang <ASCII !\]>> <MAPSTOP>)
	  (ELSE <MAPRET .x>)>>>>>

  <SET-SPECIAL .t <bang <ASCII !\<>> T <FUNCTION (t s a "AUX" pos)
   <SET pos <GET-POS .s>>
   <CHTYPE <MAPF ,FORM <FUNCTION ("AUX" (x <parse .t .s>))
    <COND (<check-closer .pos .x <bang <ASCII !\<>> .s <ASCII !\>>> <bang <ASCII !\>>> <MAPSTOP>)
	  (ELSE <MAPRET .x>)>>> SEGMENT>>>

  ;"The prototemplate returned is an illegal object for anything except #-syntax."
  <SET-SPECIAL .t <ASCII !\{> T <FUNCTION (t s a "AUX" pos)
   <SET pos <GET-POS .s>>
   <CHTYPE <MAPF ,VECTOR <FUNCTION ("AUX" (x <parse .t .s>))
    <COND (<check-closer .pos .x <ASCII !\{> .s <ASCII !\}>> <MAPSTOP>)
	  (ELSE <MAPRET .x>)>>> prototemplate>>>

  ;"Plain backslash just gets default handling in the lexer. It's only
    special to the scalar sublexer."

  <SET-DEFAULT .t ,parse-scalar>>>

;"Lookup a string in an OBLIST / OBLIST list. If it isn't found,
  insert it into the OBLIST / head of the OBLIST list."
<DEFINE lookup-multi (a os)
 <COND (<TYPE? .os OBLIST> <OR <LOOKUP .a .os> <INSERT .a .os>>)
       (ELSE <OR <MAPF <> <FUNCTION (o "AUX" (atm <LOOKUP .a .o>))
   	     	           <COND (.atm <MAPLEAVE .atm>)>> .os>
	         <INSERT .a <1 .os>>>)>>

;"TODO: BLOCK..."
<DEFINE parse-atom (t s a "AUX" (atoms ()) atm pn is-trailed "NAME" getpn)
 ;"Copy up to any trailer into a temporary STRING."
 <SET is-trailed <>>
 <SET pn <MAPF ,STRING <FUNCTION ("AUX" (k <PEEK-CHAR .s>))
  <COND (<BREAKER? .t .k> <MAPSTOP>)
 	(<==? .k %<bang <ASCII !\->>> <SET is-trailed T> <EAT-CHAR .s> <MAPSTOP>)
 	(<banged? .k> <EAT-CHAR .s> <MAPRET %<1 "!"> <CHTYPE <unbang .k> CHARACTER>>)
 	(ELSE <EAT-CHAR .s> <MAPRET <CHTYPE .k CHARACTER>>)>>>>
 ;"Gather trailer-separated PNAMEs into a stack."
 <COND (.is-trailed <SET atoms (.pn !.atoms)> <AGAIN .getpn>)>
 ;"Now we have a LIST of STRINGs containing our trailed PNAMEs, with
   the last still in .pn. The final PNAME is special: because it has
   no trailer, we look it up in our oblist list."
 <COND
  (<EMPTY? .pn> <ROOT>
   ;"Special case: we have an OBLIST, not an ATOM identifying an OBLIST."
   <SET atm <OR <LOOKUP <1 .atoms> .atm> <INSERT <1 .atoms> .atm>>>
   <SET atoms <REST .atoms>>)
  (ELSE <SET atm <lookup-multi .pn .OBLIST>>)>
 <COND (<EMPTY? .atoms> <RETURN .atm .getpn>)>
 ;"Lookup each atom in the oblist denoted the previous (trailer),"
 ;"except the last, which is our ATOM."
 <MAPF <>
  <FUNCTION (x "AUX" ob)
   <SET ob <MOBLIST .atm>>
   <SET atm <OR <LOOKUP .x .ob> <INSERT .x .ob>>>>
  .atoms>>

<DEFINE parse-octal (t s a "AUX" (z <COPY-CHARSTREAM .s>) c (n 0) (havedigits <>) "NAME" oct)
 <SET c <NEXT-CHAR .z>>
 <COND
  ;"Ended without a trailing *?"
  (<BREAKER? .t .c> <RETURN-CHAR .s> <parse-atom .t .s .a>)
  ;"Made it to *?"
  (<==? .c %<ASCII !\*>>
   <COND (.havedigits <SET-CHARSTREAM .s .z> <RETURN <CHTYPE .n FIX> .a>)
   	 (ELSE <RETURN-CHAR .s> <parse-atom .t .s .a>)>)
  ;"Got another octit?"
  (<AND <L=? %<ASCII !\0> .c> <L=? .c %<ASCII !\9>>>
   <SET n <ORB <- .c %<ASCII !\0>> <LSH .n 3>>>
   <SET havedigits T>
   <AGAIN .oct>)
  ;"Not octal after all."
  (ELSE <RETURN-CHAR .s> <parse-atom .t .s .a>)>>

;"If current radix isn't 10, pre-scan to see whether there's a decimal point."
<DEFINE num-rad (s)
 <COND
  (<==? ,radix 10> 10)
  (ELSE
   <REPEAT ((z <COPY-CHARSTREAM .s>) "NAME" rdx)
    <SET c <NEXT-CHAR .z>>
    <COND (<BREAKER? .t .c> <RETURN ,radix .rdx>)
      ;"Docs aren't clear on exponent-notation fixes without decimal points."
      ;"Decimal makes more sense..."
      (<==? %<ASCII !\e> .c> <RETURN 10 .rdx>)
      (<==? %<ASCII !\E> .c> <RETURN 10 .rdx>)
      (<==? %<ASCII !\.> .c> <RETURN 10 .rdx>)>>)>>

<DEFINE parse-decimal (t c s a "AUX" (havedigits <>) (n 0) (sgn 1) (z <COPY-CHARSTREAM .s>) (rad <num-rad .s>))
 <COND (<==? .c %<ASCII !\->> <SET sgn -1>)
       (ELSE <RETURN-CHAR .z> <SET havedigits T>)>
 <REPEAT ("NAME" decimal)
  <SET c <NEXT-CHAR .z>>
  <COND
   ;"Done?"
   (<BREAKER? .t .c>
    <COND (.havedigits <RETURN-CHAR .z> <SET-CHARSTREAM .s .z> <RETURN <* .n .sgn> .a>)
    	  (ELSE <RETURN-CHAR .s> <RETURN <parse-atom .t .s .a> .a>)>)
   ;"Got a digit?"
   (<AND <L=? %<ASCII !\0> .c> <L? .c <+ %<ASCII !\0> .rad>>>
    <SET n <+ <* .n .rad> <- .c %<ASCII !\0>>>>
    <SET havedigits T>)
   ;".?"
   ;"[eE]?"
   ;"Not a decimal."
   (ELSE <RETURN-CHAR .s> <RETURN <parse-atom .t .s .a> .a>)>>>

;"The Scalar Sublexer."
;"Parse an object that begins with a non-special character: FIX/FLOAT/ATOM."
<DEFINE parse-scalar (t c s a "AUX" rad)
 <COND
  (<OR <==? .c %<ASCII !\->> <AND <L=? %<ASCII !\0> .c> <L=? .c %<ASCII !\9>>>>
   <parse-decimal .t .c .s .a>)
  (ELSE <RETURN-CHAR .s> <parse-atom .t .s .a>)>>

;"Fallback to use if PARSE-TABLE!- is empty and no argument is provided."
<SETG default <make-default>>
<DEFINE DEFAULT-TABLE () ,default>

%<AND <ENDBLOCK> <>>

;"Like MAPF ,AND with early termination."
<DEFINE ALL? (fn "TUPLE" argses "NAME" all)
 <MAPF <> <FUNCTION ("TUPLE" xs) <COND (<NOT <APPLY .fn !.xs>> <RETURN <> .all>)>> !.argses>
 T>

;"This belongs in a PRINT module. Here for testing."
<DEFINE PPRINT (x "OPTIONAL" (lvl 0))
 <COND
  (<TYPE? .x LIST> <PRINC !\(> <PPRINT-SEQ .x <+ .lvl 1>> <PRINC !\)>)
  (<AND <TYPE? .x FORM> <NOT <OR <EMPTY? .x> <==? <1 .x> LVAL> <==? <1 .x> GVAL>>>>
   <PRINC !\<> <PPRINT-SEQ .x <+ .lvl 1>> <PRINC !\>>)
  (ELSE <PRIN1 .x>)>>
<DEFINE PPRINT-SEQ (x lvl)
 <COND (<EMPTY? .x>)
       ;"TODO: more aggressive single-lining"
       (<ALL? <FUNCTION (y) <OR <NOT <TYPE? .y FORM LIST>>
       	      		        <EMPTY? .y>
				<==? <1 .y> LVAL>
				<==? <1 .y> GVAL>>> .x>
        <PRIN1 <1 .x>>
        <MAPF <> <FUNCTION (y) <PRINC !\ > <PRIN1 .y>> <REST .x>>)
       (ELSE
        <PPRINT <1 .x> .lvl>
	<MAPF <> <FUNCTION (y) <CRLF> <INDENT .lvl> <PPRINT .y .lvl>> <REST .x>>)>>
<DEFINE INDENT (lvl) <PRINC <ISTRING .lvl !\ >>>

<PROG ()
 <SET sss <ISTRING 40000>>
 <SET sss <SUBSTRUC .sss 0 <READSTRING .sss <OPEN "READB" "./chartable.mud">>>>
 <PPRINT <read-all!-PARSER .sss>>
 >

<QUIT>