pascal
/
pas2js
réplica de https://gitlab.com/freepascal.org/fpc/pas2js.git


			
							123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245
							program turtlecompile;

{$mode objfpc}

uses
  Math, Classes, SysUtils, browserapp, Web, webfilecache, pas2jswebcompiler;

Type

  { TWebCompilerDemo }

  TWebCompilerDemo = Class(TBrowserApplication)
  Private
    btnCloseNotification,
    BRun : TJSHTMLButtonElement;
    MSource : TJSHTMLTextAreaElement;
    MLog: TJSHTMLElement;
    pnlLog : TJSHTMLElement;
    RFrame : TJSHTMLIFrameElement;
    FCompiler : TPas2JSWebCompiler;
    procedure ClearResult;
    procedure DoLog(Sender: TObject; const Msg: String);
    function HideNotification(aEvent: TJSMouseEvent): boolean;
    procedure LogError(const aMsg: string);
    procedure OnUnitsLoaded(Sender: TObject; aFileName: String; aError: string);
    function Prepare(aSource: string): string;
    function RunClick(aEvent: TJSMouseEvent): boolean;
    procedure RunResult;
  Protected
    function CompileClick(aEvent: TJSMouseEvent): boolean;
    Procedure LinkElements;
    Property Compiler : TPas2JSWebCompiler Read FCompiler;
  Public
    Constructor Create(aOwner : TComponent); override;
    Procedure Execute;
  end;

Const
  // Default run HTML page, shown in IFrame.

  SHTMLHead =
    '<HTML>'+LineEnding+
    '<head>'+LineEnding+
    '  <meta charset="UTF-8">'+LineEnding+
    '  <Title>Pas2JS Turtle graphics program output</Title>'+LineEnding+
    '  <script type="application/javascript">'+LineEnding;

  SHTMLTail =
    '   </script>'+LineEnding+
    '  <link href="bulma.min.css" rel="stylesheet">'+LineEnding+
    '</head>'+LineEnding+
    '<body>'+LineEnding+
    '  <div class="container is-fluid">'+LineEnding+
    '    <div class="box">'+LineEnding+
    '      <h1 class="is-title">Run program output</h1>'+LineEnding+
    '      <div class="block" style="min-height: 75hv;">'+LineEnding+
    '        <canvas id="cnvTurtle" style="width: 100%; height: 100%;"></canvas>'+LineEnding+
    '      </div> <!-- .block --> '+LineEnding+
    '    </div> <!-- .box -->'+LineEnding+
    '  </div> <!-- .container -->'+LineEnding+
    '<script>'+LineEnding+
    '  rtl.run();'+LineEnding+
    '</script>'+LineEnding+
    '</body>'+LineEnding+
    '</HTML>';


{ TWebCompilerDemo }

procedure TWebCompilerDemo.LogError(const aMsg : string);

begin
  MLog.InnerText:=aMsg;
  pnlLog.classList.remove('is-hidden');
end;

procedure TWebCompilerDemo.OnUnitsLoaded(Sender: TObject; aFileName: String; aError: string);
begin
  BRun.classList.remove('is-loading');
  if aError='' then
    BRun.disabled:=False
  else
    begin
    LogError('Error Loading "'+aFileName+'": '+AError);
    end;
end;

procedure TWebCompilerDemo.LinkElements;
begin
  BRun:=TJSHTMLButtonElement(GetHTMLElement('btnRun'));
  BRun.onClick:=@CompileClick;
  btnCloseNotification:=TJSHTMLButtonElement(GetHTMLElement('btnCloseNotification'));
  btnCloseNotification.onClick:=@HideNotification;
  MSource:=TJSHTMLTextAreaElement(GetHTMLElement('memSource'));
  MLog:=GetHTMLElement('lblCompilerOutput');
  pnlLog:=GetHTMLElement('pnlLog');
  RFrame:=TJSHTMLIFrameElement(Document.getElementById('runarea'));
end;

constructor TWebCompilerDemo.Create(aOwner : TComponent);
begin
  Inherited;
  FCompiler:=TPas2JSWebCompiler.Create;
  Compiler.Log.OnLog:=@DoLog;
end;

function TWebCompilerDemo.RunClick(aEvent: TJSMouseEvent): boolean;

Var
  Src : String;

begin
  Result:=True;
end;

procedure TWebCompilerDemo.DoLog(Sender: TObject; const Msg: String);
begin
  MLog.InnerHTML:=MLog.InnerHTML+'<BR>'+Msg;
end;

function TWebCompilerDemo.HideNotification(aEvent: TJSMouseEvent): boolean;
begin
  pnlLog.classList.Add('is-hidden');
end;


Procedure TWebCompilerDemo.ClearResult;

begin
end;

function TWebCompilerDemo.Prepare(aSource : string) : string;

var
  Src,un : String;
  p, pu, pp, ps : Integer;
  doinsert,withcomma : boolean;

begin
  Result:=aSource;
  Src:=LowerCase(aSource);
  p:=pos('begin',Src);
  p:=Min(P,pos('function ',Src));
  p:=Min(P,pos('procedure ',Src));
  doinsert:=true;
  withcomma:=false;
  pu:=Pos('uses',Src);
  // No uses
  if (pu=0) then
    begin
    pp:=pos('program',src);
    if pp=0 then
      pu:=1
    else
      pu:=pos(';',Src,pp+6)+1;
    System.Insert(#10'uses  ;',result,pu);
    pu:=pu+6;
    end
  else
    begin
    pu:=pu+5;
    ps:=pos(';',Src,pu);
    if pos('turtlegraphics',Src,pu)<ps then
      doinsert:=False;
    withcomma:=true;
    end;
  if doInsert then
    begin
    un:=' turtlegraphics';
    if Withcomma then
      un:=un+', ';
    System.insert(un,result,pu);
    end;
   Writeln('Final code : ',Result);
end;

Procedure TWebCompilerDemo.RunResult;

var
  Src : String;

begin
  Src:=Compiler.WebFS.GetFileContent('main.js');
  if Src='' then
    begin
    Window.Alert('No source available');
    exit;
    end;
  Src:=SHTMLHead+Src+LineEnding+SHTMLTail;
  RFrame['srcdoc']:=Src;
end;

function TWebCompilerDemo.CompileClick(aEvent: TJSMouseEvent): boolean;

  Procedure ShowResult(success : boolean);

  begin
    ClearResult;
    BRun.classList.remove('is-loading');
    if not Success then
      pnlLog.classList.remove('is-hidden');
    BRun.Disabled:=False;
  end;

Var
  args : TStrings;
  Res : Boolean;

begin
  Result:=False;
  BRun.classList.add('is-loading');
  //  BRun.disabled:=True;
  ClearResult;
  MLog.InnerHTML:='';
  Compiler.WebFS.SetFileContent('main.pp',Prepare(MSource.value));
  args:=TStringList.Create;
  try
    Args.Add('-Tbrowser');
    Args.Add('-Jc');
    Args.Add('-Jirtl.js');
    Args.Add('main.pp');
    RFrame.Src:='run.html';
    Compiler.Run('','',Args,True);
    Res:=Compiler.ExitCode=0;
    ShowResult(Res);
    if Res then
    RunResult;
  finally
   Args.Free;
  end;
end;

procedure TWebCompilerDemo.Execute;
begin
  LinkElements;
  Compiler.WebFS.LoadBaseURL:='sources';
  BRun.classList.add('is-loading');
  Compiler.WebFS.LoadFiles(['rtl.js','system.pas','p2jsres.pas','sysutils.pas','types.pas','typinfo.pas','classes.pas','rtlconsts.pas','js.pas','simplelinkedlist.pas','web.pas','weborworker.pas','browserconsole.pas','turtlegraphics.pas'],@OnUnitsLoaded);

end;

begin
  With TWebCompilerDemo.Create(Nil) do
    Execute;
end.