Sordie.co.uk

libsassy/libSassy.Evaluator.pas

Raw

{(
 )) libSassy.Evaluator
((    Infix evaluator with RTTI support
 ))
((  Copyright  Sordie Aranka Solomon-Smith 2015-2016
 ))
((  This work is made available under the terms of the Creative Commons
 )) Attribution-NonCommercial-ShareAlike 3.0 Unported license
((  http://creativecommons.org/licenses/by-nc-sa/3.0/
 )}

{
  Warning - This library uses Delphi's Rtti and TypInfo library which will in
  turn include massive RTL components such as SysUtils and Variants.
}

unit libSassy.Evaluator;

interface

uses
  System.Rtti,
  System.TypInfo,

  libSassy.RTTI,
  libSassy.Errors,
  libSassy.Strings,
  libSassy.Arrays;

type
{$REGION 'TClassFactory'}
  TClassFactory = class(TExpandableObject)
    function ReadExpandedProperty(const Name: String): TValue;  override;
    function IsExpandedReadable  (const Name: String): Boolean; override;
  end;
{$ENDREGION}

{$REGION 'TVariableStore'}
  TVariableStore = class(TExpandableObject)
  private
    fVariables: TDictionary<TValue>;

    fAutoDeclare: Boolean;
  public
    constructor Create;
    destructor  Destroy; override;

    function  ReadExpandedProperty (const Name: String): TValue;        override;
    procedure WriteExpandedProperty(const Name: String; Value: TValue); override;

    function IsExpandedReadable (const Name: String): Boolean; override;
    function IsExpandedWriteable(const Name: String): Boolean; override;

    property Variables: TDictionary<TValue> read fVariables;

    property AutoDeclare: Boolean read fAutoDeclare write fAutoDeclare;
  end;
{$ENDREGION}

{$REGION 'TEvaluator'}
  TEvaluator = class(TVariableStore)
  private
    fNamespace: TArray<TObject>;
  public
    constructor Create;
    destructor  Destroy; override;

    procedure Push(const Namespace: TObject); inline;
    procedure Pop;                            inline;

    function ReadValue (const Name: String; var   Value: TValue): Boolean;
    function WriteValue(const Name: String; const Value: TValue): Boolean;

    function Eval(const Expression: String): TValue;
  end;

  TEvaluatorError = class(TException);
{$ENDREGION}

implementation

{$REGION 'TClassFactory'}
function TClassFactory.ReadExpandedProperty;
var
  t: TRttiType;
begin
  TMonitor.Enter(Self);

  try
    t := RttiContext.FindPublishedType(Name);

    if t = nil then exit(inherited);

    Result := TValue.From<TObject>(t.GetMethod('NewInstance').Invoke(t.AsInstance.MetaclassType, []).AsObject);
  finally
    TMonitor.Exit(Self);
  end;
end;

function TClassFactory.IsExpandedReadable;
begin
  Result := RttiContext.FindPublishedType(Name) <> nil;
end;
{$ENDREGION}

{$REGION 'TVariableStore'}
constructor TVariableStore.Create;
begin
  inherited;

  fVariables := TDictionary<TValue>.Create;

  fAutoDeclare := False;
end;{TVariableStore.Create}

destructor TVariableStore.Destroy;
begin
  fVariables.Free;

  inherited;
end;{TVariableStore.Destroy}

function TVariableStore.ReadExpandedProperty;
var
  i: Integer;
begin
  i := fVariables.Find(Name);
  if i = -1 then
  begin
    if fAutoDeclare then
      Result := TValue.From<Integer>(0)
    else
      Result := inherited;
  end{if i}
  else
    Result := fVariables.Items[i]^.Value;
end;{TVariableStore.ReadExpandedProperty}

procedure TVariableStore.WriteExpandedProperty;
var
  i: Integer;
begin
  i := fVariables.Find(Name);
  if i = -1 then
  begin
    if fAutoDeclare then
      fVariables.Add(Name, Value)
    else
      inherited;
  end{if i}
  else
    fVariables.Items[i]^.Value := Value;
end;{TVariableStore.WriteExpandedProperty}

function TVariableStore.IsExpandedReadable;
begin
  Result := (fVariables.Find(Name) > -1) or fAutoDeclare;
end;{TVariableStore.IsExpandedReadable}

function TVariableStore.IsExpandedWriteable;
begin
  Result := (fVariables.Find(Name) > -1) or fAutoDeclare;
end;{TVariableStore.IsExpandedWriteable}
{$ENDREGION}

{$REGION 'TEvaluator'}
constructor TEvaluator.Create;
begin
  inherited;

  fNamespace := TArray<TObject>.Create;

  Push(Self);
end;

destructor TEvaluator.Destroy;
begin
  fNamespace.Free;

  inherited;
end;

procedure TEvaluator.Push;
begin
  fNamespace.Push(Namespace);
end;

procedure TEvaluator.Pop;
begin
  if fNamespace.Count > 1 then
    fNamespace.Pop;
end;

function TEvaluator.ReadValue;
  function ReadValueNS(Namespace: TObject): TValue;
  var
    i: Integer;
    p: array of TValue;
    s: String;
    c: Char;
    f: Boolean;

    procedure Whitespace;
    begin
      repeat
        if not String.CharInSet(Name[i], [#32, #9]) then exit;
        inc(i);
      until i > Name.Length;
    end;

    procedure OverName;
    begin
      Whitespace;

      s := '';

      repeat
        c := Name[i];

        if not String.CharInSet(c, ['A'..'Z', 'a'..'z', '0'..'9', '_']) then exit;

        s := s + c;

        inc(i);
      until i > Name.Length;
    end;

    procedure OverParams;
    var
      q:  Boolean;
      n:  Integer;
      v:  String;
      l:  TValue;
    begin
      q := False;
      n := 0;
      v := '';

      SetLength(p, 0);

      inc(i);

      repeat
        if not q then Whitespace;

        c := Name[i];

        case c of
          '"': q := not q;

          '(': if not q then inc(n);
          ')': if not q then dec(n);

          ',': if (not q) and (n = 0) then
               begin
                 l := Eval(v);

                 SetLength(p, length(p) + 1);
                 p[high(p)] := l;

                 inc(i);
                 v := '';
              end;
        end;

        if i > Name.Length then break;

        v := v + Name[i];

        inc(i);
      until (n = -1) or (i > Name.Length);

      if (n = -1) and (v.FirstChar = ')') then v := v.Start(-1);

      if not v.Empty then
      begin
        l := Eval(v);

        SetLength(p, length(p) + 1);
        p[high(p)] := l;
      end;
    end;
  begin
    Result := TValue.From<TObject>(Namespace);

    i := 1;

    repeat
      OverName;

      if Result.AsObject.IsReadable(s) then
      begin
        f := c = '(';

        if f then
        begin

          OverParams;
          c := Name[i];
        end;

        if f then
          Result := Result.AsObject.InvokeMethod(s, p)
        else
          Result := Result.AsObject.ReadProperty(s);
      end
      else TEvaluatorError.RaiseException('Cannot read value "' + s + '"');

      inc(i);
    until (c <> '.') or (i > length(Name));
  end;
var
  i: Integer;
begin
  for i := fNamespace.Count - 1 downto 0 do
    try
      Value := ReadValueNS(fNamespace[i]);
      exit(True);
    except end;

  Result := False;
end;

function TEvaluator.WriteValue;
  procedure WriteValueNS(Namespace: TObject);
  var
    i: Integer;
    s: String;
    p: String;
    v: TValue;
  begin
    for i := length(Name) downto 1 do
      if not String.CharInSet(Name[i], ['A'..'Z', 'a'..'z', '0'..'9', '_']) then break;

    s := Name.Copy (i + 1);
    p := Name.Start(i - 1);

    if s.Empty then TEvaluatorError.RaiseException('Syntax error');

    if p.Empty then
      v := TValue.From<TObject>(Namespace)
    else if not ReadValue(p, v) then
      TEvaluatorError.RaiseException(p);

    if not v.AsObject.IsWriteable(s) then
      TEvaluatorError.RaiseException(p);

    v.AsObject.WriteProperty(s, Value);
  end;
var
  i: Integer;
begin
  for i := fNamespace.Count - 1 downto 0 do
    try
      WriteValueNS(fNamespace[i]);
      exit(True);
    except end;

  Result := False;
end;

function TEvaluator.Eval;
var
  s, v: String;
  i:    Integer;

  function Compare: TValue; forward;

  procedure Whitespace;
  begin
    repeat
      if not String.CharInSet(s[i], [#32, #9]) then exit;
      inc(i);
    until i > length(s);
  end;

  function CheckSymbol(Symbol: String; Follow: String = ''; State: Boolean = True): Boolean;
  begin
    Whitespace;

    Result := copy(s, i, length(Symbol)) = Symbol;

    if Result and (not Follow.Empty) then
      Result := (pos(s[i + Symbol.Length], Follow) = 0) = State;

    if Result then inc(i, Symbol.Length);
  end;

  function GetConst(var Value: TValue): Boolean;
  var
    c: String;
  begin
    Whitespace;

    Result := True;

    case s[i] of
      '0'..'9':
      begin
        c := s[i];

        inc(i);

        while String.CharInSet(s[i], ['0'..'9', '.']) and (i <= length(s)) do
        begin
          c := c + s[i];
          inc(i);
        end;

        if pos('.', c) = 0 then
          Value := TValue.From<Integer>(c.AsInteger)
        else
          Value := TValue.From<Single>(c.AsFloat);
      end;

      '"':
      begin
        inc(i);

        c := '';

        while s[i] <> '"' do
        begin
          c := c + s[i];

          inc(i);

          if i > s.Length then
            TEvaluatorError.RaiseException('Expected "');
        end;

        inc(i);

        Value := TValue.From<String>(c);
      end;
    else
      Result := False;
    end;

    if Result then v := '';
  end;

  function GetValue(var Value: TValue): Boolean;
  var
    c: Char;

    procedure OverName;
    begin
      Whitespace;

      repeat
        c := s[i];

        if not String.CharInSet(c, ['A'..'Z', 'a'..'z', '0'..'9', '_']) then exit;

        v := v + c;

        inc(i);
      until i > s.Length;
    end;

    procedure OverParams;
    var
      q: Boolean;
      n: Integer;
    begin
      Whitespace;

      q := False;
      n := 0;

      repeat
        c := s[i];

        case c of
          '''': q := not q;

          '(': if not q then inc(n);
          ')': if not q then
               begin
                 dec(n);

                 if n = 0 then
                 begin
                   v := v + c; inc(i);
                   break;
                 end;
               end;
        end;

        v := v + c;

        inc(i);
      until i > s.Length;
    end;
  begin
    Whitespace;

    Result := False;

    if not String.CharInSet(s[i], ['A'..'Z', 'a'..'z', '_']) then exit;

    v := '';

    repeat
      OverName;

      if i > s.Length then break;

      if c = '.' then
      begin
        v := v + c; inc(i);

        continue;
      end
      else
      begin
        Whitespace;

        if c = '(' then
        begin
          Whitespace;

          OverParams;

          if c = '.' then
          begin
            v := v + c; inc(i);

            continue;
          end;
        end

        else break;
      end
    until i > s.Length;

    Result := ReadValue(v, Value);
  end;

  function IsNot: Boolean;
  begin
    Whitespace;

    Result := s[i] = '!';
    if Result then inc(i);
  end;

  function IsNeg: Boolean;
  begin
    Whitespace;

    Result := s[i] = '-';
    if Result then inc(i);
  end;

  function Bracket: TValue;
  var
    nt: Boolean;
    ng: Boolean;
  begin
    Whitespace;

    nt := IsNot;
    ng := IsNeg;

    v := '';

    if CheckSymbol('(') then
    begin
      Result := Compare;

      if not CheckSymbol(')') then TEvaluatorError.RaiseException('Expected )');
    end
    else
    begin
      if not GetConst(Result) then
        if not GetValue(Result) then
          TEvaluatorError.RaiseException('Expected value');
    end;

    if ng then Result := TValue.FromVariant(-Result.AsVariant);
    if nt then Result := TValue.From<Boolean>(not Result.AsBoolean);
  end;

  function Assign: TValue;
  var
    n: String;

    procedure Check;
    begin
      if v.Empty then
        TEvaluatorError.RaiseException('Expected variable');

      n := v;
    end;

    procedure GetValue;
    begin
      if not ReadValue(n, Result) then
        TEvaluatorError.RaiseException('Expected variable');
    end;

    procedure SetValue;
    begin
      if not WriteValue(n, Result) then
        TEvaluatorError.RaiseException('Expected variable');
    end;
  begin
    Whitespace;

    Result := Bracket;

    if CheckSymbol('=', '=') then
    begin
      Check;

      Result := Compare; SetValue;
    end
    else if CheckSymbol('*=') then
    begin
      Check;

      GetValue;
      Result := TValue.FromVariant(Result.AsVariant * Compare.AsVariant);
      SetValue;
    end
    else if CheckSymbol('/=') then
    begin
      Check;

      GetValue;
      Result := TValue.FromVariant(Result.AsVariant / Compare.AsVariant);
      SetValue;
    end
    else if CheckSymbol('\=') then
    begin
      Check;

      GetValue;
      Result := TValue.FromVariant(Result.AsVariant div Compare.AsVariant);
      SetValue;
    end
    else if CheckSymbol('%=') then
    begin
      Check;

      GetValue;
      Result := TValue.FromVariant(Result.AsVariant mod Compare.AsVariant);
      SetValue;
    end
    else if CheckSymbol('&=') then
    begin
      Check;

      GetValue;
      Result := TValue.FromVariant(Result.AsVariant and Compare.AsVariant);
      SetValue;
    end
    else if CheckSymbol('|=') then
    begin
      Check;

      GetValue;
      Result := TValue.FromVariant(Result.AsVariant or Compare.AsVariant);
      SetValue;
    end
    else if CheckSymbol('^=') then
    begin
      Check;

      GetValue;
      Result := TValue.FromVariant(Result.AsVariant xor Compare.AsVariant);
      SetValue;
    end
    else if CheckSymbol('+=') then
    begin
      Check;

      GetValue;
      Result := TValue.FromVariant(Result.AsVariant + Compare.AsVariant);
      SetValue;
    end
    else if CheckSymbol('-=') then
    begin
      Check;

      GetValue;
      Result := TValue.FromVariant(Result.AsVariant - Compare.AsVariant);
      SetValue;
    end
    else if CheckSymbol('++') then
    begin
      Check;

      GetValue;
      Result := TValue.FromVariant(Result.AsVariant + 1);
      SetValue;

      s := n + s.Copy(i); i := 1;
      Result := Compare;
    end
    else if CheckSymbol('--') then
    begin
      Check;

      GetValue;
      Result := TValue.FromVariant(Result.AsVariant - 1);
      SetValue;

      s := n + s.copy(i); i := 1;
      Result := Compare;
    end
  end;

  function MulDiv: TValue;
  begin
    Whitespace;

    Result := Assign;

    while True do
           if CheckSymbol('*', '=') then Result := TValue.FromVariant(Result.AsVariant *   Assign.AsVariant)
      else if CheckSymbol('/', '=') then Result := TValue.FromVariant(Result.AsVariant /   Assign.AsVariant)
      else if CheckSymbol('\', '=') then Result := TValue.FromVariant(Result.AsVariant div Assign.AsVariant)
      else if CheckSymbol('%', '=') then Result := TValue.FromVariant(Result.AsVariant mod Assign.AsVariant)
      else break;
  end;

  function Bitwise: TValue;
  begin
    Whitespace;

    Result := MulDiv;

    while True do
           if CheckSymbol('<<')      then Result := TValue.From<Cardinal>(Result.AsOrdinal shl MulDiv.AsOrdinal)
      else if CheckSymbol('>>')      then Result := TValue.From<Cardinal>(Result.AsOrdinal shr MulDiv.AsOrdinal)
      else if CheckSymbol('&', '&=') then Result := TValue.From<Cardinal>(Result.AsOrdinal and MulDiv.AsOrdinal)
      else if CheckSymbol('|', '|=') then Result := TValue.From<Cardinal>(Result.AsOrdinal or  MulDiv.AsOrdinal)
      else if CheckSymbol('^', '=')  then Result := TValue.From<Cardinal>(Result.AsOrdinal xor MulDiv.AsOrdinal)
      else break;
  end;

  function AddSub: TValue;
  begin
    Whitespace;

    Result := Bitwise;

    while True do
           if CheckSymbol('+', '+=') then Result := TValue.FromVariant(Result.AsVariant + Bitwise.AsVariant)
      else if CheckSymbol('-', '-=') then Result := TValue.FromVariant(Result.AsVariant - Bitwise.AsVariant)
      else break;
  end;

  function Compare: TValue;
  begin
    Whitespace;

    Result := AddSub;

    while True do
           if CheckSymbol('==')      then Result := TValue.From<Boolean>(Result.AsVariant =  AddSub.AsVariant)
      else if CheckSymbol('>=')      then Result := TValue.From<Boolean>(Result.AsVariant >= AddSub.AsVariant)
      else if CheckSymbol('<=')      then Result := TValue.From<Boolean>(Result.AsVariant <= AddSub.AsVariant)
      else if CheckSymbol('<>')      then Result := TValue.From<Boolean>(Result.AsVariant <> AddSub.AsVariant)
      else if CheckSymbol('>', '>=') then Result := TValue.From<Boolean>(Result.AsVariant >  AddSub.AsVariant)
      else if CheckSymbol('<', '<=') then Result := TValue.From<Boolean>(Result.AsVariant <  AddSub.AsVariant)
      else if CheckSymbol('!=')      then Result := TValue.From<Boolean>(Result.AsVariant <> AddSub.AsVariant)
      else if CheckSymbol('&&')      then Result := TValue.From<Boolean>((Result.AsBoolean) and (AddSub.AsBoolean))
      else if CheckSymbol('||')      then Result := TValue.From<Boolean>((Result.AsBoolean) or  (AddSub.AsBoolean))
      else break;

  end;
begin
  s := Expression;
  i := 1;

  Result := Compare;
end;
{$ENDREGION}

end.