implementation module Transpiler;

from FIO import WriteNBytes, StdOut, WriteLine, WriteChar;
from SYSTEM import ADR, ADDRESS;

from Terminal import Write, WriteLn, WriteString;
from Lexer import Lexer, LexerToken, lexer_current, lexer_lex, LexerKind;

(* Calls lexer_lex() but skips the comments. *)
proc transpiler_lex(lexer: PLexer) -> LexerToken;
var
  result: LexerToken;
begin
  result := lexer_lex(lexer);

  while result.kind = lexerKindComment do
    result := lexer_lex(lexer)
  end;

  return result
end;

(* Write a semicolon followed by a newline. *)
proc write_semicolon(output: File);
begin
  WriteChar(output, ';');
  WriteLine(output)
end;

proc write_current(lexer: PLexer);
var
  written_bytes: CARDINAL;
begin
  written_bytes := WriteNBytes(StdOut, ADDRESS(lexer^.Current - lexer^.Start), lexer^.Start)
end;

proc transpile_import(context: PTranspilerContext);
var
  token: LexerToken;
begin
  WriteString('FROM ');
  token := transpiler_lex(context^.lexer);

  write_current(context^.lexer);
  token := transpiler_lex(context^.lexer);
  WriteString(' IMPORT ');

  token := transpiler_lex(context^.lexer);
  write_current(context^.lexer);

  token := transpiler_lex(context^.lexer);
  while token.kind <> lexerKindSemicolon do
    WriteString(', ');
    token := transpiler_lex(context^.lexer);
    write_current(context^.lexer);
    token := transpiler_lex(context^.lexer)
  end;
  write_semicolon(context^.output);
  token := transpiler_lex(context^.lexer)
end;

proc transpile_import_part(context: PTranspilerContext);
var
  token: LexerToken;
begin
  token := lexer_current(context^.lexer);

  while token.kind = lexerKindFrom do
    transpile_import(context);
    token := lexer_current(context^.lexer)
  end;
  WriteLn()
end;

proc transpile_constant(context: PTranspilerContext);
var
  token: LexerToken;
begin
  WriteString('  ');
  token := lexer_current(context^.lexer);
  write_current(context^.lexer);

  token := transpiler_lex(context^.lexer);
  WriteString(' = ');

  token := transpiler_lex(context^.lexer);
  write_current(context^.lexer);

  token := transpiler_lex(context^.lexer);
  write_semicolon(context^.output)
end;

proc transpile_constant_part(context: PTranspilerContext) -> BOOLEAN;
var
  token: LexerToken;
  result: BOOLEAN;
begin
  token := lexer_current(context^.lexer);
  result := token.kind = lexerKindConst;

  if result then
    WriteString('CONST');
    WriteLn();
    token := transpiler_lex(context^.lexer);

    while token.kind = lexerKindIdentifier do
      transpile_constant(context);
      token := transpiler_lex(context^.lexer)
    end
  end;
  return result
end;

proc transpile_module(context: PTranspilerContext);
var
  token: LexerToken;
begin
  token := transpiler_lex(context^.lexer);

  if token.kind = lexerKindDefinition then
    WriteString('DEFINITION ');
    token := transpiler_lex(context^.lexer)
  end;
  if token.kind = lexerKindImplementation then
    WriteString('IMPLEMENTATION ');
    token := transpiler_lex(context^.lexer)
  end;
  WriteString('MODULE ');

  (* Write the module name and end the line with a semicolon and newline. *)
  token := transpiler_lex(context^.lexer);
  write_current(context^.lexer);

  token := transpiler_lex(context^.lexer);
  write_semicolon(context^.output);
  WriteLn();

  (* Write the module body. *)
  token := transpiler_lex(context^.lexer);
  transpile_import_part(context);
  if transpile_constant_part(context) then
    WriteLn()
  end;
  transpile_type_part(context);
  if transpile_variable_part(context) then
    WriteLn()
  end;
  transpile_procedure_part(context);
  transpile_statement_part(context);

  WriteString('END ');

  token := transpiler_lex(context^.lexer);
  write_current(context^.lexer);

  token := transpiler_lex(context^.lexer);
  Write('.');

  token := transpiler_lex(context^.lexer);
  WriteLn()
end;

proc transpile_type_fields(context: PTranspilerContext);
var
  token: LexerToken;
begin
  token := transpiler_lex(context^.lexer);

  while token.kind <> lexerKindEnd do
    WriteString('    ');
    write_current(context^.lexer);
    token := transpiler_lex(context^.lexer);
    WriteString(': ');
    transpile_type_expression(context);
    token := transpiler_lex(context^.lexer);

    if token.kind = lexerKindSemicolon then
      token := transpiler_lex(context^.lexer);
      Write(';')
    end;
    WriteLn()
  end
end;

proc transpile_record_type(context: PTranspilerContext);
begin
  WriteString('RECORD');
  WriteLn();
  transpile_type_fields(context);
  WriteString('  END')
end;

proc transpile_pointer_type(context: PTranspilerContext);
var
  token: LexerToken;
begin
  token := lexer_current(context^.lexer);
  WriteString('POINTER TO ');
  if token.kind = lexerKindPointer then
    token := transpiler_lex(context^.lexer)
  end;
  transpile_type_expression(context)
end;

proc transpile_array_type(context: PTranspilerContext);
var
  token: LexerToken;
begin
  WriteString('ARRAY');
  token := lexer_current(context^.lexer);

  if token.kind = lexerKindArray then
    token := transpiler_lex(context^.lexer)
  end;
  if token.kind <> lexerKindOf then
    WriteString('[1..');
    token := transpiler_lex(context^.lexer);
    write_current(context^.lexer);
    token := transpiler_lex(context^.lexer);
    Write(']')
  end;
  WriteString(' OF ');
  transpile_type_expression(context)
end;

proc transpile_enumeration_type(context: PTranspilerContext);
var
  token: LexerToken;
begin
  WriteString('(');
  WriteLn();
  WriteString('    ');

  token := transpiler_lex(context^.lexer);
  write_current(context^.lexer);

  token := transpiler_lex(context^.lexer);

  while token.kind = lexerKindComma do
    Write(',');
    WriteLn();
    WriteString('    ');
    token := transpiler_lex(context^.lexer);
    write_current(context^.lexer);

    token := transpiler_lex(context^.lexer)
  end;
  WriteLn();
  WriteString('  )')
end;

proc transpile_union_type(context: PTranspilerContext);
end;

proc transpile_procedure_type(context: PTranspilerContext);
var
  token: LexerToken;
begin
  token := transpiler_lex(context^.lexer);
  WriteString('PROCEDURE(');

  token := transpiler_lex(context^.lexer);

  while token.kind <> lexerKindRightParen do
    write_current(context^.lexer);

    token := transpiler_lex(context^.lexer);
    if token.kind = lexerKindComma then
      token := transpiler_lex(context^.lexer);
      WriteString(', ')
    end
  end;
  Write(')')
end;

proc transpile_type_expression(context: PTranspilerContext);
var
  token: LexerToken;
begin
  token := transpiler_lex(context^.lexer);
  if token.kind = lexerKindRecord then
    transpile_record_type(context)
  end;
  if token.kind = lexerKindLeftParen then
    transpile_enumeration_type(context)
  end;
  if (token.kind = lexerKindArray) or (token.kind = lexerKindLeftSquare) then
    transpile_array_type(context)
  end;
  if token.kind = lexerKindHat then
    transpile_pointer_type(context)
  end;
  if token.kind = lexerKindProc then
    transpile_procedure_type(context)
  end;
  if token.kind = lexerKindIdentifier then
    write_current(context^.lexer)
  end
end;

proc transpile_type_declaration(context: PTranspilerContext);
var
  token: LexerToken;
begin
  WriteString('  ');
  token := lexer_current(context^.lexer);
  write_current(context^.lexer);

  token := transpiler_lex(context^.lexer);
  WriteString(' = ');
  transpile_type_expression(context);
  token := transpiler_lex(context^.lexer);
  write_semicolon(context^.output);
end;

proc transpile_type_part(context: PTranspilerContext);
var
  token: LexerToken;
begin
  token := lexer_current(context^.lexer);

  if token.kind = lexerKindType then
    WriteString('TYPE');
    WriteLn();
    token := transpiler_lex(context^.lexer);

    while token.kind = lexerKindIdentifier do
      transpile_type_declaration(context);
      token := transpiler_lex(context^.lexer)
    end;
    WriteLn()
  end
end;

proc transpile_variable_declaration(context: PTranspilerContext);
var
  token: LexerToken;
begin
  WriteString('  ');
  token := lexer_current(context^.lexer);
  write_current(context^.lexer);

  token := transpiler_lex(context^.lexer);
  WriteString(': ');
  transpile_type_expression(context);
  token := transpiler_lex(context^.lexer);
  write_semicolon(context^.output)
end;

proc transpile_variable_part(context: PTranspilerContext) -> BOOLEAN;
var
  token: LexerToken;
  result: BOOLEAN;
begin
  token := lexer_current(context^.lexer);
  result := token.kind = lexerKindVar;

  if result then
    WriteString('VAR');
    WriteLn();
    token := transpiler_lex(context^.lexer);

    while token.kind = lexerKindIdentifier do
      transpile_variable_declaration(context);
      token := transpiler_lex(context^.lexer)
    end
  end;
  return result
end;

proc transpile_procedure_heading(context: PTranspilerContext) -> LexerToken;
var
  token: LexerToken;
  result: LexerToken;
begin
  WriteString('PROCEDURE ');

  result := transpiler_lex(context^.lexer);
  write_current(context^.lexer);

  token := transpiler_lex(context^.lexer);
  Write('(');

  token := transpiler_lex(context^.lexer);
  while token.kind <> lexerKindRightParen do
    write_current(context^.lexer);

    token := transpiler_lex(context^.lexer);
    WriteString(': ');

    transpile_type_expression(context);

    token := transpiler_lex(context^.lexer);
    if (token.kind = lexerKindSemicolon) or (token.kind = lexerKindComma) then
      WriteString('; ');
      token := transpiler_lex(context^.lexer)
    end
  end;
  WriteString(')');
  token := transpiler_lex(context^.lexer);

  (* Check for the return type and write it. *)
  if token.kind = lexerKindArrow then
    WriteString(': ');
    token := transpiler_lex(context^.lexer);
    write_current(context^.lexer);
    token := transpiler_lex(context^.lexer)
  end;
  token := transpiler_lex(context^.lexer);
  write_semicolon(context^.output);

  return result
end;

proc transpile_expression(context: PTranspilerContext, trailing_token: LexerKind);
var
  token: LexerToken;
  written_bytes: CARDINAL;
begin
  token := transpiler_lex(context^.lexer);

  while (token.kind <> trailing_token) & (token.kind <> lexerKindEnd) do
    written_bytes := 0;
    if token.kind = lexerKindNull then
      WriteString('NIL ');
      written_bytes := 1
    end;
    if (token.kind = lexerKindBoolean) & token.booleanKind then
      WriteString('TRUE ');
      written_bytes := 1
    end;
    if (token.kind = lexerKindBoolean) & (~token.booleanKind) then
      WriteString('FALSE ');
      written_bytes := 1
    end;
    if token.kind = lexerKindOr then
      WriteString('OR ');
      written_bytes := 1
    end;
    if token.kind = lexerKindAnd then
      WriteString('AND ');
      written_bytes := 1
    end;
    if token.kind = lexerKindNot then
      WriteString('NOT ');
      written_bytes := 1
    end;
    if written_bytes = 0 then
      write_current(context^.lexer);
      Write(' ')
    end;
    token := transpiler_lex(context^.lexer)
  end
end;

proc transpile_if_statement(context: PTranspilerContext);
var
  token: LexerToken;
begin
  WriteString('  IF ');
  transpile_expression(context, lexerKindThen);

  WriteString('THEN');
  WriteLn();
  transpile_statements(context);
  WriteString('  END');
  token := transpiler_lex(context^.lexer)
end;

proc transpile_while_statement(context: PTranspilerContext);
var
  token: LexerToken;
begin
  WriteString('  WHILE ');
  transpile_expression(context, lexerKindDo);

  WriteString('DO');
  WriteLn();
  transpile_statements(context);
  WriteString('  END');
  token := transpiler_lex(context^.lexer)
end;

proc transpile_assignment_statement(context: PTranspilerContext);
begin
  WriteString(' := ');
  transpile_expression(context, lexerKindSemicolon);
end;

proc transpile_call_statement(context: PTranspilerContext);
var
  token: LexerToken;
begin
  WriteString('(');
  token := transpiler_lex(context^.lexer);

  while (token.kind <> lexerKindSemicolon) & (token.kind <> lexerKindEnd) do
    write_current(context^.lexer);
    token := transpiler_lex(context^.lexer)
  end
end;

proc transpile_designator_expression(context: PTranspilerContext);
var
  token: LexerToken;
begin
  WriteString('  ');
  write_current(context^.lexer);
  token := transpiler_lex(context^.lexer);

  while token.kind = lexerKindLeftSquare do
    Write('[');
    token := transpiler_lex(context^.lexer);
    while token.kind <> lexerKindRightSquare do
      write_current(context^.lexer);
      token := transpiler_lex(context^.lexer)
    end;
    Write(']');
    token := transpiler_lex(context^.lexer)
  end;
  if token.kind = lexerKindHat then
    Write('^');
    token := transpiler_lex(context^.lexer)
  end;
  if token.kind = lexerKindDot then
    Write('.');
    token := transpiler_lex(context^.lexer);
    write_current(context^.lexer);
    token := transpiler_lex(context^.lexer)
  end;
  if token.kind = lexerKindHat then
    Write('^');
    token := transpiler_lex(context^.lexer)
  end;
  while token.kind = lexerKindLeftSquare do
    Write('[');
    token := transpiler_lex(context^.lexer);
    while token.kind <> lexerKindRightSquare do
      write_current(context^.lexer);
      token := transpiler_lex(context^.lexer)
    end;
    Write(']');
    token := transpiler_lex(context^.lexer)
  end
end;

proc transpile_return_statement(context: PTranspilerContext);
var
  token: LexerToken;
begin
  WriteString('  RETURN ');
  token := transpiler_lex(context^.lexer);
  write_current(context^.lexer);
  token := transpiler_lex(context^.lexer)
end;

proc transpile_statement(context: PTranspilerContext);
var
  token: LexerToken;
begin
  token := transpiler_lex(context^.lexer);

  if token.kind = lexerKindIf then
    transpile_if_statement(context)
  end;
  if token.kind = lexerKindWhile then
    transpile_while_statement(context)
  end;
  if token.kind = lexerKindReturn then
    transpile_return_statement(context)
  end;
  if token.kind = lexerKindIdentifier then
    transpile_designator_expression(context);
    token := lexer_current(context^.lexer);

    if token.kind = lexerKindAssignment then
      transpile_assignment_statement(context)
    end;
    if token.kind = lexerKindLeftParen then
      transpile_call_statement(context)
    end
  end
end;

proc transpile_statements(context: PTranspilerContext);
var
  token: LexerToken;
begin
  token := lexer_current(context^.lexer);

  while token.kind <> lexerKindEnd do
    transpile_statement(context);
    token := lexer_current(context^.lexer);

    if token.kind = lexerKindSemicolon then
      Write(';')
    end;
    WriteLn()
  end
end;

proc transpile_statement_part(context: PTranspilerContext);
var
  token: LexerToken;
begin
  token := lexer_current(context^.lexer);
  if token.kind = lexerKindBegin then
    WriteString('BEGIN');
    WriteLn();
    transpile_statements(context)
  end
end;

proc transpile_procedure_declaration(context: PTranspilerContext);
var
  token: LexerToken;
  seen_part: BOOLEAN;
  written_bytes: CARDINAL;
begin
  token := transpile_procedure_heading(context);
  seen_part := transpile_constant_part(context);
  seen_part := transpile_variable_part(context);
  transpile_statement_part(context);

  WriteString('END ');
  written_bytes := WriteNBytes(StdOut, ORD(token.identifierKind[1]), ADR(token.identifierKind[2]));

  token := transpiler_lex(context^.lexer);
  write_semicolon(context^.output);
  token := transpiler_lex(context^.lexer)
end;

proc transpile_procedure_part(context: PTranspilerContext);
var
  token: LexerToken;
begin
  token := lexer_current(context^.lexer);

  while token.kind = lexerKindProc do
    transpile_procedure_declaration(context);
    token := lexer_current(context^.lexer);
    WriteLn()
  end
end;

proc transpile(lexer: PLexer);
var
  token: LexerToken;
  written_bytes: CARDINAL;
  context: TranspilerContext;
begin
  context.indentation := 0;
  context.output := StdOut;
  context.lexer := lexer;

  transpile_module(ADR(context))
end;

end Transpiler.