specs.dylan

Module:       %testworks
Synopsis:     Generate tests based on an API specification
Author:       Andy Armstrong
Copyright:    Original Code is Copyright (c) 1995-2004 Functional Objects, Inc.
              All rights reserved.
License:      See License.txt in this distribution for details.
Warranty:     Distributed WITHOUT WARRANTY OF ANY KIND


// Keeps track of all the individual specs generated by the `define
// interface-specification-suite` macro.
define class <interface-spec> (<object>)
  // Maps definition spec names (symbols) to <definition-spec> objects.
  constant slot definition-specs :: <table> = make(<table>);
end class;

define function add-definition-spec
    (api :: <interface-spec>, spec :: <definition-spec>) => ()
  let specs = api.definition-specs;
  let name = spec.spec-name;
  if (element(specs, name, default: #f))
    error("duplicate spec for %=", name);
  end;
  specs[name] := spec;
end;

define function interface-specification-class-specs
    (api :: <interface-spec>, superclass :: <class>) => (class-specs :: <sequence>)
  let class-specs = make(<stretchy-vector>);
  for (spec :: <definition-spec> in api.definition-specs)
    if (instance?(spec, <class-spec>))
      let class = spec.class-spec-class;
      if (subtype?(class, superclass))
        add!(class-specs, spec);
      end;
    end;
  end;
  class-specs
end function;

define function interface-specification-classes
    (api :: <interface-spec>, superclass :: <class>) => (classes :: <sequence>)
  map(class-spec-class, interface-specification-class-specs(api, superclass))
end;

define function interface-specification-class-instantiable?
    (spec :: <interface-spec>, class :: <class>) => (instantiable? :: <boolean>)
  block (return)
    for (class-spec in interface-specification-class-specs(spec, <object>))
      if (class = class-spec-class(class-spec))
        return(class-spec-instantiable?(class-spec))
      end;
    end
  end
end function;

define abstract class <definition-spec> (<object>)
  constant slot spec-name :: <symbol>,
    required-init-keyword: name:;
end class <definition-spec>;

define method spec-title
    (spec :: <definition-spec>) => (title :: <byte-string>)
  as-lowercase(as(<byte-string>, spec-name(spec)))
end method spec-title;

/// Protocols

// User code should implement this if there are required init args.
define open generic make-test-instance
    (class :: <class>) => (object);

// TODO: document this
define open generic destroy-test-instance
    (class :: <class>, object :: <object>) => ();

// Build a test suite out of a list of binding specifications.
// The test-*-specification tests are automatic checks done by testworks.
// The test-* tests are expected to be written by the user.
define macro binding-spec-suite-definer
  { define binding-spec-suite ?suite-name:name (?options:*)
      ?specs:*
    end }
    => { define suite ?suite-name (?options)
           ?specs
         end }
 specs:
  { } => { }
  { ?spec:*; ... } => { ?spec ... }
 spec:
  { ?modifiers:* class ?class-name:name (?superclasses:*) ?test-options:* ; }
    => { test "test-" ## ?class-name ## "-specification"; }
  { ?modifiers:* function ?function-name:name (?parameters:*) => (?results:*) ?test-options:* ; }
    => { test "test-" ## ?function-name ## "-specification"; }
  { variable ?variable-name:name :: ?type:expression ?test-options:* ; }
    => { test "test-" ## ?variable-name ## "-specification"; }
  { constant ?constant-name:name :: ?type:expression ?test-options:* ; }
    => { test "test-" ## ?constant-name ## "-specification"; }

  // These two allow interface specification suites to be broken up into
  // logical parts if desired, and then nested into one overall suite.
  { suite ?:name; } => { suite ?name; }
  { test ?:name; }  => { test ?name; }
end macro;

define macro binding-specs-definer
  { define binding-specs ?suite-specification:name (?options:*) end }
    => { }

  // class specs
  { define binding-specs ?suite-specification:name (?options:*)
      ?modifiers:* class ?class-name:name (?superclasses:*), #rest ?test-options:* ;
      ?more-specs:*
    end }
    => { define test "test-" ## ?class-name ## "-specification" (?test-options)
           let class-spec = make(<class-spec>,
                                 name: ?#"class-name",
                                 class: ?class-name,
                                 superclasses: vector(?superclasses),
                                 modifiers: vector(?modifiers));
           add-definition-spec(?suite-specification, class-spec);
           check-class-specification(class-spec);
         end;
         define binding-specs ?suite-specification (?options)
           ?more-specs
         end; }

  // function specs
  { define binding-specs ?suite-specification:name (?options:*)
      ?modifiers:* function ?function-name:name (?parameters:*) => (?results:*), #rest ?test-options:* ;
      ?more-specs:*
    end }
    => { define test "test-" ## ?function-name ## "-specification" (?test-options)
           let function-spec
             = make(<function-spec>,
                    name: ?#"function-name",
                    function: ?function-name,
                    parameters: vector(?parameters),
                    results: vector(?results),
                    modifiers: vector(?modifiers));
           add-definition-spec(?suite-specification, function-spec);
           check-function-specification(function-spec);
         end;
         define binding-specs ?suite-specification (?options)
           ?more-specs
         end; }

  // variable specs
  { define binding-specs ?suite-specification:name (?options:*)
      variable ?variable-name:name :: ?type:expression, #rest ?test-options:* ;
      ?more-specs:*
    end }
    => { define test "test-" ## ?variable-name ## "-specification" (?test-options)
           let variable-spec
             = make(<variable-spec>,
                    name: ?#"variable-name",
                    type: ?type,
                    getter: method () => (value :: ?type)
                              ?variable-name
                            end,
                    setter: method (value :: ?type) => (value :: ?type)
                              ?variable-name := value
                            end);
           add-definition-spec(?suite-specification, variable-spec);
           check-variable-specification(variable-spec);
         end;
         define binding-specs ?suite-specification (?options)
           ?more-specs
         end; }

  // constant specs
  { define binding-specs ?suite-specification:name (?options:*)
      constant ?constant-name:name :: ?type:expression, #rest ?test-options:* ;
      ?more-specs:*
    end }
    => { define test "test-" ## ?constant-name ## "-specification" (?test-options)
           // TODO: Is it possible to generate code for constant specs that
           // tries to set the constant and fails if it works? ...without
           // generating a compiler warning when it's actually constant?
           let constant-spec
             = make(<constant-spec>,
                    name: ?#"constant-name",
                    type: ?type,
                    getter: method () ?constant-name end);
           add-definition-spec(?suite-specification, constant-spec);
           check-constant-specification(constant-spec);
         end;
         define binding-specs ?suite-specification (?options)
           ?more-specs
         end; }

  // Drop `test blah;` on the floor; it's handled by `define binding-spec-suite`.
  { define binding-specs ?suite-specification:name (?options:*)
      test ?test-name:name;
      ?more-specs:*
    end }
    => { define binding-specs ?suite-specification (?options)
           ?more-specs
         end; }

  // Drop `suite blah;` on the floor; it's handled by `define binding-spec-suite`.
  { define binding-specs ?suite-specification:name (?options:*)
      suite ?suite-name:name;
      ?more-specs:*
    end }
    => { define binding-specs ?suite-specification (?options)
           ?more-specs
         end; }
modifiers:
  { }
    => { }
  { ?modifier:name ... }
    => { ?#"modifier", ... }
end macro binding-specs-definer;

/// Define a test suite based on a list of binding specifications.
define macro interface-specification-suite-definer
  { define interface-specification-suite ?suite-name:name (?options:*)
      ?specs:*
    end }
    => { // A constant to which all the specs are added so that tests can be
         // written in a generic way, if desired, by asking whether a spec is
         // instantiable, what type it is, etc.
         define constant "$" ## ?suite-name ## "-spec" = make(<interface-spec>);
         define binding-specs "$" ## ?suite-name ## "-spec" (?options)
           ?specs
         end;
         define binding-spec-suite ?suite-name (?options)
           ?specs
         end }
end macro;

/// Variable specs

define abstract class <abstract-variable-spec> (<definition-spec>)
  constant slot variable-spec-type :: <type>,
    required-init-keyword: type:;
  constant slot variable-spec-getter :: <function>,
    required-init-keyword: getter:;
end class <abstract-variable-spec>;

define class <variable-spec> (<abstract-variable-spec>)
  constant slot variable-spec-setter :: <function>,
    required-init-keyword: setter:;
end class <variable-spec>;

define class <constant-spec> (<abstract-variable-spec>)
end class <constant-spec>;

/// Variable testing

define function check-variable-specification
    (variable-spec :: <variable-spec>)
 => ()
  let title = spec-title(variable-spec);
  check-instance?(format-to-string("Variable %s has the correct type", title),
                  variable-spec-type(variable-spec),
                  variable-spec-getter(variable-spec)());
  check-true(format-to-string("Variable %s can be set to itself", title),
             begin
               let value = variable-spec-getter(variable-spec)();
               variable-spec-setter(variable-spec)(value) = value
             end);
end function check-variable-specification;

define function check-constant-specification
    (constant-spec :: <constant-spec>)
 => ()
  let title = spec-title(constant-spec);
  check-instance?(format-to-string("Constant %s has the correct type", title),
                  variable-spec-type(constant-spec),
                  variable-spec-getter(constant-spec)());
end function check-constant-specification;

/// Class specs

define class <class-spec> (<definition-spec>)
  constant slot class-spec-class :: <class>,
    required-init-keyword: class:;
  constant slot class-spec-superclasses :: <sequence>,
    required-init-keyword: superclasses:;
  slot class-spec-modifiers :: <sequence> = #[],
    init-keyword: modifiers:;
end class <class-spec>;

define method initialize (this :: <class-spec>, #key)
  next-method();
  let modifiers = this.class-spec-modifiers;
  // Ensure no conflicting modifiers were specified.
  if ((member?(#"sealed", modifiers) & member?(#"open", modifiers))
      | (member?(#"primary", modifiers) & member?(#"free", modifiers))
      | (member?(#"abstract", modifiers) & member?(#"concrete", modifiers)))
    error("Conflicting modifiers specified for class %s",
          this.class-spec-class);
  end if;
  // Classes are concrete by default.
  if (~member?(#"abstract", modifiers) & ~member?("concrete", modifiers))
    modifiers := add!(modifiers, #"concrete");
  end if;
  // Classes are free by default.
  if (~member?(#"free", modifiers) & ~member?("primary", modifiers))
    modifiers := add!(modifiers, #"free");
  end if;
  // Classes are sealed by default.
  if (~member?(#"sealed", modifiers) & ~member?("open", modifiers))
    modifiers := add!(modifiers, #"sealed");
  end if;
  this.class-spec-modifiers := modifiers;
end method initialize;


/// Class checking

define method class-spec-instantiable?
    (class-spec :: <class-spec>) => (instantiable? :: <boolean>)
  member?(#"instantiable", class-spec-modifiers(class-spec))
end method class-spec-instantiable?;

define method check-class-specification
    (class-spec :: <class-spec>)
 => ()
  // TODO: can we check the "sealed" and "open" declarations by trying to
  // `make` a subclass at runtime?
  let title = spec-title(class-spec);
  let class = class-spec-class(class-spec);
  check-instance?(format-to-string("Variable %s is a class", title),
                  <class>, class);
  check-true(format-to-string("Variable %s has the correct superclasses", title),
             class-has-correct-superclasses?(class-spec));
  check-class-instantiation(class-spec);
end method check-class-specification;

define method class-has-correct-superclasses?
    (class-spec :: <class-spec>)
 => (correct? :: <boolean>)
  let class = class-spec-class(class-spec);
  every?(method (superclass :: <class>) => (subtype? :: <boolean>)
           subtype?(class, superclass)
         end,
         class-spec-superclasses(class-spec))
end method class-has-correct-superclasses?;

/// Class instantiation checks

define method make-test-instance
    (class :: <class>) => (object)
  make(class)
end method make-test-instance;

define method destroy-test-instance
    (class :: <class>, object :: <object>) => ()
  #f
end method destroy-test-instance;

define method check-class-instantiation
    (class-spec :: <class-spec>)
 => ()
  let class = class-spec-class(class-spec);
  let title = spec-title(class-spec);
  if (class-spec-instantiable?(class-spec))
    let instance = #f;
    check-instance?(format-to-string("make %s with required arguments", title),
                    class,
                    instance := make-test-instance(class));
    if (instance)
      destroy-test-instance(class, instance)
    end
  else
    check-condition
      (format-to-string("make(%s) errors because not instantiable", title),
       <error>,
       begin
         let instance = make-test-instance(class);
         destroy-test-instance(class, instance)
       end)
  end
end method check-class-instantiation;

/// Function specs

define class <function-spec> (<definition-spec>)
  constant slot function-spec-function :: <function>,
    required-init-keyword: function:;
  constant slot function-spec-modifiers :: <sequence> = #[],
    init-keyword: modifiers:;
  constant slot %function-spec-parameters :: <sequence> = #[],
    init-keyword: parameters:;
  constant slot %function-spec-results :: <sequence> = #[],
    init-keyword: results:;
end class <function-spec>;

/// Function spec modeling

define method function-spec-parameters
    (function-spec :: <function-spec>)
 => (required :: <sequence>, rest? :: <boolean>,
     keys :: <sequence>, all-keys? :: <boolean>);
  let spec-parameters = %function-spec-parameters(function-spec);
  local
    method identify-required
        (index :: <integer>)
     => (required :: <sequence>, rest? :: <boolean>,
         keys :: <sequence>, all-keys? :: <boolean>);
      if (index < spec-parameters.size)
        let item = spec-parameters[index];
        if (instance?(item, <type>))
          identify-required(index + 1)
        else
          let required = copy-sequence(spec-parameters, end: index);
          if (item == #"rest")
            identify-key(required, #t, index + 1)
          else
            identify-key(required, #f, index)
          end if
        end if
      else
        values(spec-parameters, #f, #[], #f)
      end if
    end method,
    method identify-key
        (required :: <sequence>, rest? :: <boolean>, index :: <integer>)
     => (required :: <sequence>, rest? :: <boolean>,
         keys :: <sequence>, all-keys? :: <boolean>);
      if (index < spec-parameters.size)
        let item = spec-parameters[index];
        if (item == #"key")
          identify-keys(required, rest?, index + 1, index + 1)
        else
          error("Unrecognized parameter %= in %s", item,
                spec-name(function-spec));
        end if
      else
        values(required, rest?, #[], #f)
      end if
    end method,
    method identify-keys
        (required :: <sequence>, rest? :: <boolean>,
         first-key-index :: <integer>, index :: <integer>)
     => (required :: <sequence>, rest? :: <boolean>,
         keys :: <sequence>, all-keys? :: <boolean>);
      if (index < spec-parameters.size)
        let item = spec-parameters[index];
        if (item == #"all-keys")
          if (index + 1 ~= spec-parameters.size)
            error("#\"all-keys\" must be the final parameter item");
          end if;
          let keys
            = copy-sequence(spec-parameters,
                            start: first-key-index, end: index);
          values(required, rest?, keys, #t)
        elseif (instance?(item, <symbol>))
          identify-keys(required, rest?, first-key-index, index + 1)
        else
          error("Unrecognized parameter %= in %s", item,
                spec-name(function-spec));
        end if
      else
        let keys
          = copy-sequence(spec-parameters, start: first-key-index, end: index);
        values(required, rest?, keys, #f)
      end if
    end method;
  identify-required(0)
end method function-spec-parameters;

define method function-spec-results
    (function-spec :: <function-spec>)
 => (required :: <sequence>, rest? :: <boolean>);
  let spec-results = %function-spec-results(function-spec);
  local
    method identify-required
        (index :: <integer>)
     => (required :: <sequence>, rest? :: <boolean>);
      if (index < spec-results.size)
        let item = spec-results[index];
        if (instance?(item, <type>))
          identify-required(index + 1)
        elseif (item == #"rest")
          if (index + 1 ~= spec-results.size)
            error("#\"rest\" must appear as the last parameter item");
          end if;
          values(copy-sequence(spec-results, end: index), #t)
        else
          error("Unrecognized result %= in %s", item,
                spec-name(function-spec));
        end if
      else
        values(spec-results, #f)
      end if
    end method;
  identify-required(0)
end method function-spec-results;

define method function-spec-generic?
    (function-spec :: <function-spec>)
 => (generic? :: <boolean>)
  member?(#"generic", function-spec-modifiers(function-spec))
end method function-spec-generic?;

define function function-spec-type
    (function-spec :: <function-spec>)
 => (type :: <type>, type-name :: <string>)
  if (function-spec-generic?(function-spec))
    values(<generic-function>, "generic-function")
  else
    values(<function>, "function")
  end
end function function-spec-type;

define function function-spec-check-name
    (function-name :: <string>, type-name :: <string>)
 => (check-name :: <string>)
  format-to-string("Variable %s is a %s and all of its specializer types"
                     " are bound", function-name, type-name)
end function function-spec-check-name;

define function check-function-specification-parameters
    (title :: <string>, function-spec :: <function-spec>)
 => ();
  let function = function-spec-function(function-spec);
  let (required :: <sequence>, rest? :: <boolean>,
       keys :: <sequence>, all-keys? :: <boolean>)
    = function-spec-parameters(function-spec);
  let actual-specializers
    = function-specializers(function);
  let (actual-required-number, actual-rest?, actual-keys)
    = function-arguments(function);

  check-true(format-to-string("function %s can handle the maximum number"
                                " of specified arguments", title),
             actual-rest?
               | (~rest? & required.size <= actual-required-number));
  check-true(format-to-string("function %s can handle the minimum number"
                                " of specified arguments", title),
             required.size >= actual-required-number);

  // TODO(cgay): This fails for cases where a library adds a method to
  // an existing generic function. For example,
  //     open generic-function \< (<date>, <date>) => (<boolean>);
  // The generic is defined on (<object>, <object>) so the below test fails.
  // We should be able to iterate over the gf methods and see if there's
  // one exactly matching the spec's types.  (On the other hand, having
  // that in the spec doesn't seem nearly as useful as writing a test that
  // calls <date> < <date> and gets the right result.)

  for (spec in required,
       actual in actual-specializers,
       index from 0)
    check-true(format-to-string("function %s argument %d type %s"
                                  " is a subtype of the specified type %s",
                                title, index, actual, spec),
               subtype?(actual, spec));
  end for;

  for (key in keys)
    check-true(format-to-string("function %s can handle keyword"
                                  " argument %=", title, key),
               actual-rest?
                 | actual-keys == #"all"
                 | (instance?(actual-keys, <sequence>)
                      & member?(key, actual-keys)));
  end for;
  if (all-keys?)
    check-true(format-to-string("function %s can handle all keywords", title),
               actual-rest? | actual-keys == #"all");
  end if;
end function;

define function check-function-specification-results
    (title :: <string>, function-spec :: <function-spec>)
 => ();
  let function = function-spec-function(function-spec);
  let (required :: <sequence>, rest? :: <boolean>)
    = function-spec-results(function-spec);
  let (actual-return-types, actual-rest?) = function-return-values(function);
  check-true(format-to-string("function %s can return the minimum number"
                                " of specified return values", title),
             actual-return-types.size >= required.size
               | actual-rest?);
  check-true(format-to-string("function %s can not exceed the maximum number"
                                " of specified return values", title),
             actual-return-types.size <= required.size
               | rest?);
  for (spec in required, return-type in actual-return-types, index from 0)
    check-true(format-to-string("function %s return value %d type %s"
                                  " is a subtype of the specified type %s",
                                title, index, return-type, spec),
               subtype?(return-type, spec));
  end for;
end function;

define function check-function-specification
    (function-spec :: <function-spec>)
 => ()
  let title = spec-title(function-spec);
  let function = function-spec-function(function-spec);
  let (type, type-name) = function-spec-type(function-spec);
  check-instance?(function-spec-check-name(title, type-name),
                  type, function);
  check-function-specification-parameters(title, function-spec);
  check-function-specification-results(title, function-spec);
end function check-function-specification;