$use Access Arithm Box Class Convert StdIO Stream;

$box FileName InputStream;

$box Errors;

$func Error s.line s.column e.message = ;
Error s.line s.column e.message =
  <Put &Errors (<TokenPosition s.line s.column> e.message)>;

$public $func Lexer stream e.filename = e.tokens;
Lexer stream e.filename =
  <Store &InputStream stream>,
  <Store &FileName e.filename>,
  <Store &Errors /*empty*/>,
  <GetTokens 0 1>;

$func GetTokens e.chars s.line s.column = e.tokens;
GetTokens e.chars s.line s.column =
  {
    e.chars : /*empty*/ = {
      /*empty*/ (<GetSourceLine>) <Add s.line 1> 1;
      (EOF <TokenPosition s.line s.column>) () s.line s.column;
    };
    {
      <SkipBlanksAndComments e.chars s.line s.column>;
      <ScanKeyword e.chars s.line s.column>;
      <ScanString e.chars s.line s.column>;
      <ScanIdentifier e.chars s.line s.column>;
      <Error s.line s.column "Invalid character '" <L 0 e.chars> "'">,
        (<Middle 1 0 e.chars>) s.line <Add s.column 1>;
    };
  } :: e.tokens (e.chars) s.line s.column,
  {
    e.tokens : (EOF e) = e.tokens;
    e.tokens <GetTokens e.chars s.line s.column>;
  };

$func? SkipBlanksAndComments e.chars s.line s.column = (e.chars) s.line s.column;
SkipBlanksAndComments e.chars s.line s.column =
  e.chars : \{
    s.ch e.rest,
      ' \t\r\n' : e s.ch e = (e.rest) s.line <Add s.column 1>;
    '/*' e.rest =
      $trap <SkipComment e.rest s.line <Add s.column 2>>
      $with {
        "Unclosed comment" =
          <Error s.line s.column "Unclosed comment">,
          () s.line s.column;
      };
  };

$func SkipComment e.chars s.line s.column = (e.chars) s.line s.column;
SkipComment e.chars s.line s.column =
  e.chars : {
    /*empty*/ = {
      <SkipComment <GetSourceLine> <Add s.line 1> 1>;
      $error "Unclosed comment";
    };
    '*/' e.rest = (e.rest) s.line <Add s.column 2>;
    s.ch e.rest = <SkipComment e.rest s.line <Add s.column 1>>;
  };

$func? ScanKeyword e.chars s.line s.column = e.token (e.chars) s.line s.column;
ScanKeyword e.chars s.line s.column =
  e.chars : \{
    \{
      ';'  e.rest = SC 1 e.rest;
      ':'  e.rest = COLON 1 e.rest;
      ','  e.rest = COMMA 1 e.rest;
      '*'  e.rest = ASTERISK 1 e.rest;
      '->' e.rest = TO 2 e.rest;
      '='  e.rest = EQ 1 e.rest;
      '('  e.rest = LPAR 1 e.rest;
      ')'  e.rest = RPAR 1 e.rest;
      '[]' e.rest = CONCAT 2 e.rest;
      '~'  e.rest = STRING 1 e.rest;
    };
    \{
      'dec'       e.rest = DEC 3 e.rest;
      'var'       e.rest = VAR 3 e.rest;
      'def'       e.rest = DEF 3 e.rest;    
      'undefined' e.rest = UNDEFINED 9 e.rest;
      'if'        e.rest = IF 2 e.rest;
      'then'      e.rest = THEN 4 e.rest;
      'else'      e.rest = ELSE 4 e.rest;    
      'where'     e.rest = WHERE 5 e.rest;
    } :: s.tk s.length e.rest,
      e.rest : \{
        /*empty*/;
        s.ch e, # <IsAlphanumeric s.ch>;
      } =
      s.tk s.length e.rest;
  } :: s.tk s.length e.rest =
  (s.tk <TokenPosition s.line s.column>) (e.rest) s.line <Add s.column s.length>; 

$func? ScanString e.chars s.line s.column = e.token (e.chars) s.line s.column;
ScanString e.chars s.line s.column =
  e.chars : '"' e.rest =
  <ScanStringRest e.rest s.line <Add s.column 1>> :: e.string (e.chars) s.new_line s.new_column,
  {
    e.string : e.str Unclosed =
      <Error s.line s.column "Unclosed string">,
      e.str;
    e.string;
  } :: e.string,
  (STRING e.string <TokenPosition s.line s.column>) (e.chars) s.new_line s.new_column;

$func ScanStringRest e.chars s.line s.column = e.string (e.chars) s.line s.column;
ScanStringRest e.chars s.line s.column =
  {
    e.chars : s.ch e.rest = {
      s.ch : '"' = (e.rest) s.line <Add s.column 1>;
      {
        s.ch : '\\' =
          e.rest : {
            'n'  e.rest2 = '\n' 2 e.rest2;
            'r'  e.rest2 = '\r' 2 e.rest2;
            't'  e.rest2 = '\t' 2 e.rest2;
            '"'  e.rest2 = '"'  2 e.rest2;
            '~'  e.rest2 = '~'  2 e.rest2; // What is it for??? (See p. 6 of the Introduction to LFC)
            '\\' e.rest2 = '\\' 2 e.rest2;
            s1 s2 s3 e.rest2,
              '01234567' : e s1 e,
              '01234567' : e s2 e,
              '01234567' : e s3 e =
              <BytesToChars <ToInt s1 s2 s3>> 4 e.rest2;
            e =
              <Error s.line s.column "Invalid sequence after \\">,
              '\\' 1 e.rest;
          };
        s.ch 1 e.rest;
      } : s.char s.length e.other =
        s.char <ScanStringRest e.other s.line <Add s.column s.length>>;
    };
    Unclosed () s.line s.column;
  };

$public $func? ScanIdentifier e.chars s.line s.column = e.token (e.chars) s.line s.column;
ScanIdentifier e.chars s.line s.column =
  e.chars : s.ch e.rest,
  \{
    <IsLetter s.ch>;
    s.ch : '_';
  } =
  e.rest : e.head e.tail, \{
    e.tail : /*empty*/ = e.head (e.tail);
    e.tail : s.first e, # <IsAlphanumeric s.first> = e.head (e.tail);
  } :: e.head (e.tail) =
  (IDENTIFIER s.ch e.head <TokenPosition s.line s.column>) (e.tail) s.line <Add 1 <Add s.column <Length e.head>>>;

$func? GetSourceLine = e.chars;
GetSourceLine =
  <Get &InputStream> : s.stream,
  # <IsEnd_of_Stream s.stream> =
  <Get_Line s.stream> : {
    e.line '\r\n' = e.line;
    e.line '\n'   = e.line;
    e.line '\r'   = e.line;
    e.line        = e.line;
  };

$func TokenPosition s.line s.column = t.token_position;
TokenPosition s.line s.column = (<Get &FileName> s.line s.column);

$func? IsAlphanumeric s.char = ;
IsAlphanumeric s.char = \{
  <IsLetter s.char>;
  <IsDigit s.char>;
  s.char : '_';
};

$func Main = e;
Main = <WriteLn <Lexer <Expr_Open '1a"b\\cd\n ef'>>>,
  <WriteLn <Get &Errors>>;