#!/usr/bin/perl
# Automatically compose numeric type promotion and subtype substitution tests.
# $Id: makeTests,v 1.2 2006/01/15 00:43:31 eric Exp $

use strict;

my @promotables = qw(double
		     float
		     decimal);

my @intTypes = qw(integer
		  nonPositiveInteger
		  negativeInteger
		  long
		  int
		  short
		  byte
		  nonNegativeInteger
		  unsignedLong
		  unsignedInt
		  unsignedShort
		  unsignedByte
		  positiveInteger);

my $PREFIX = 'tP';
my $DIR = 'http://www.w3.org/2001/sw/DataAccess/tests/data/TypePromotion/';

my $manifest = &openManifest();

# Numeric type promotions.
for (my $iL = 0; $iL < @promotables; $iL++) {
    for (my $iR = $iL; $iR < @promotables; $iR++) {
	my $typeL = $promotables[$iL];
	my $typeR = $promotables[$iR];
	&promotionTest($typeL, $typeR, $typeL, $manifest, 1);
    }
}

# Substitue subtype of integer with integer.
foreach my $intType (@intTypes) {
    &promotionTest($intType, 'short', 'integer', $manifest, 1);
}

# Promote subtype of integer to promotable.
foreach my $promotable (@promotables) {
    &promotionTest('short', $promotable, $promotable, $manifest, 1);
}

# Negative substitution tests.
&promotionTest('short', 'short', 'short', $manifest, 0);
&promotionTest('byte', 'short', 'short', $manifest, 0);
&promotionTest('short', 'long', 'decimal', $manifest, 0);
&promotionTest('short', 'int', 'float', $manifest, 0);
&promotionTest('short', 'byte', 'double', $manifest, 0);

# Negative numeric type promotions.
for (my $iL = 0; $iL < @promotables; $iL++) {
    for (my $iR = $iL+1; $iR < @promotables; $iR++) {
	my $typeL = $promotables[$iL];
	my $typeR = $promotables[$iR];
	&promotionTest($typeL, $typeR, $typeR, $manifest, 0);
    }
}

&closeManifest($manifest);

# end

sub openManifest {
    my $fh;
    open ($fh, '>', 'manifest.ttl') || die "failed to write to \"manifest.ttl\".";
    print $fh "# \$Id\$

\@prefix rdf:    <http://www.w3.org/1999/02/22-rdf-syntax-ns#> .
\@prefix rdfs:	<http://www.w3.org/2000/01/rdf-schema#> .
\@prefix dawgt:   <http://www.w3.org/2001/sw/DataAccess/tests/test-dawg#> .
\@prefix mf:     <http://www.w3.org/2001/sw/DataAccess/tests/test-manifest#> .
\@prefix qt:     <http://www.w3.org/2001/sw/DataAccess/tests/test-query#> .

<>  rdf:type mf:Manifest ;
    rdfs:comment \"Type Promotion Tests\" ;
    mf:entries
    (
";
    return $fh;
}

sub promotionTest {
    my ($typeL, $typeR, $typeResult, $man, $pass) = @_;
    my $fh;
    my $testName = $pass ? "$PREFIX-$typeL-$typeR" : "$PREFIX-$typeL-$typeR-fail";

    my $queryFile = "$testName.rq";
    open ($fh, '>', $queryFile) || die "failed to write to \"$queryFile\".";
    print $fh "# Positive test: product of type promotion within the xsd:decimal type tree.
# \$Id\$

PREFIX t: <$DIR$PREFIX-0#>
PREFIX rdf: <http://www.w3.org/1999/02/22-rdf-syntax-ns#>
PREFIX xsd: <http://www.w3.org/2001/XMLSchema#>
ASK
 WHERE { t:${typeL}1 rdf:value ?l .
         t:${typeR}1 rdf:value ?r .
         FILTER ( datatype(?l + ?r) = xsd:$typeResult ) }
";
    close $fh;

    my $res = $pass ? 'true' : 'false';
    print $man "     [  mf:name    \"$testName\" ;
        rdfs:comment
            \"Positive test: product of type promotion within the xsd:decimal type tree.\" ;
        mf:action
            [ qt:data   <$PREFIX.ttl> ;
              qt:query  <$queryFile> ] ;
        mf:result  <$res.ttl> ;
        dawgt:approval dawgt:NotApproved
      ]

";
}

sub closeManifest {
    my ($fh) = @_;
    print $fh "    # End of tests
   ).
";
    close $fh;
}