#  (C) Copyright David Abrahams 2002. Permission to copy, use, modify, sell and
#  distribute this software is granted provided this copyright notice appears in
#  all copies. This software is provided "as is" without express or implied
#  warranty, and with no claim as to its suitability for any purpose.

# Polymorphic class system built on top of core Jam facilities.
#
# Classes are defined by creating a rule of the same name to act as
# the "constructor", which in turn sets instance attributes and
# defines rules::
#
#     rule myclass ( arg1 )          # constructor
#     {
#         self.attribute = $(arg1) ;
#
#         rule method1 ( )           # method
#         {
#             return [ method2 ] ;
#         }
#
#         rule method2 ( )           # method
#         {
#             return $(self.attribute) ;
#         }
#     }
#     class myclass ;                # establish myclass as a class
#
# New instance modules are created by invoking [ new <class> <args...> ]::
#
#     local x = [ new myclass foo ] ;        # x is a new myclass object
#     assert.result foo : [ $(x).method1 ] ; # $(x).method1 returns "foo"
#
# To write a derived class, you must:
#
#   1. call the constructors of all base classes as <base>.__init__ from
#      the derived class' constructor rule
#
#   2. add the base classes to the derived class declaration. ::
#
#     rule derived ( arg )
#     {
#          myclass.__init__ $(arg) ;  # call base __init__
#          rule method2 ( )           # method override
#          {
#              return $(self.attribute)XXX ;
#          }
#     }
#     class derived : myclass ;
#
# All methods operate virtually, replacing behavior in the base
# classes. For example::
#
#     local y = [ new derived foo ] ;           # y is a new derived object
#     assert.result fooXXX : [ $(y).method1 ] ; # $(y).method1 returns "foo"
#
# Each class instance is its own core Jam module. All instance
# attributes and methods are accessible without additional
# qualification from within the class instance, and it has no
# unqualified access to any other names other than those defined or
# imported by the class' constructor or methods. By convention,
# attribute names are prefixed with "self.".

import numbers ;
import errors : * ;
import set ;
import modules ;
import assert ;

classes = ;

# Construct a class in the module of the caller, which should be a
# class instance. This rule is imported into each class and instance
# under the name <class-name>.__init__ for the most-derived class and
# all of its bases. It extracts <class-name> by inspecting the
# backtrace and uses that to call the user-defined intitialization
# function. The rule is imported *localized*, so it operates in the
# namespace of the instance.
local rule __init__ (
  * # all arguments are forwarded directly to the user-defined
    # initialization function.
)
{
    # pull the name of the class being initialized from the backtrace
    local bt = [ BACKTRACE 1 ] ;
    local class = [ MATCH ^(.*)[.]__init__$ : $(bt[4]) ] ;
    assert.nonempty-variable class ;
    
    # set the __class__
    __class__ ?= $(class) ;
    
    # The calling module is the instance name
    local instance = [ CALLER_MODULE ] ;

    # __name__ will denote the current class, similar to modules.
    __name__ = $(instance) ;
    
    # call the class rule that was defined by the user
    # This defines all of the class' member rules
    {
        local class = $(class) ; # protect this from being set by 
        $(class).$(class) $(1) : $(2) : $(3) : $(4) : $(5) : $(6) : $(7) : $(8) : $(9) ;
    }
    
    # Make sure all of the base classes have been initialized
    for local b in [ modules.peek class@$(class) : __bases__ ]
    {
        if ! $($(b).__init__.called)
        {
            errors.error $(class).$(class) failed to call base class constructor $(b).__init__ ;
        }
    }
    # Make all the class' member rules available as qualified names
    # within the instance
    local rules = [ RULENAMES $(instance) ] ;
    IMPORT $(instance) : $(rules) : $(instance) : $(class).$(rules) ;
    
    
    # note that the class' init function has been called
    $(class).__init__.called = true ;
}

# Declare a class. The caller should have defined a (local) rule
# called 'name' which acts as the new class' constructor. Module-local
# variables declared in the constructor will act like instance
# variables, and rules defined in the constructor will act like
# methods.
rule class ( 
  name      # The name of the class and of its initialization rule in
            # the caller's module 
    
  : bases * # list of base classes
)
{
    if $(name) in $(classes)
    {
        error class "$(name)" has already been declared ;
    }
    
    classes += $(name) ;
    IMPORT class : typecheck : .typecheck : [$(name)] ;
    
    # Each class is assigned a new module which acts as a namespace
    # for its rules and normal instance variables.
    
    # This is a record of the class' base classes
    modules.poke class@$(name) : __bases__ : $(bases) ;
    modules.poke class@$(name) : __name__ : $(name) ;
    
    module class@$(name)
    {
        # The constructor will be called through the __init__ rule
        # above. We import both rules into the class' module here,
        # then export them. Although rules are actually only called in
        # instances' modules, collecting them here saves us a
        # recursive traversal of all bases to import names into the
        # instance.
        IMPORT [ CALLER_MODULE ] : $(__name__) : class@$(__name__) : $(__name__).$(__name__) ;
        IMPORT class : __init__ : class@$(__name__) : $(__name__).__init__ ;
        EXPORT class@$(__name__) : $(__name__).$(__name__) $(__name__).__init__ ;

        # Bring the __init__ functions in from the base classes, and
        # check for inheritance cycles.
        for local base in $(__bases__)
        {
            local base-rules = [ RULENAMES class@$(base) ] ;
            
            if ( $(__name__).$(__name__) in $(base-rules) )
              || ( $(__name__).__init__ in $(base-rules) )
            {
                error base class cycle in class $(__name__) ;
            }
            
            IMPORT class@$(base) : $(base-rules) : class@$(__name__) : $(base-rules) ;
            EXPORT class@$(__name__) : $(base-rules) ;
            
            # Also make note of bidirectional inheritance links.
            module class@$(base)
            {
                __derived__ += $(1) ;
            }
        }
    }
}

# Create a new instance of the given class with the given (global)
# name. The class' __init__ function is called with args.
rule instance ( name : class args * : * )
{
    # Enter the namespace of the new object
    module $(name)
    {
        # always bring in the rules defined from this module, so that
        # users can easily call "inherit", for example.
        import class : * ;        
        
        # import all of the rules from the class into the instance,
        # using the optional localize parameter so that they execute
        # in the instance's namespace.
        local rules = [ RULENAMES class@$(>[1]) ] ;
        # ECHO instance $(name) inherits rules: $(rules) from class $(class) ;
        IMPORT class@$(>[1]) : $(rules) : $(<) : $(rules) : localize ;
        
        # Also import the instance's rules into the global module as
        # <instance-name>.<rulename>
        IMPORT $(<) : $(rules) : : $(<).$(rules) ;
        
        # Now initialize the instance
        $(>[1]).__init__ $(>[2-]) : $(3) : $(4) : $(5) : $(6) : $(7) : $(8) : $(9) ;
        
        # Make a record of the instance's class. We need to do this
        # last because it will be set to each of the class' base
        # classes as it is initialized.
        __class__ = $(>[1]) ;
    }
}


# create a new uniquely-named instance of the given class, returning
# its name.
rule new ( class args * : * )
{
    .next-instance.$(class) ?= 1 ;
    local name = object($(class))@$(.next-instance.$(class)) ;
    instance $(name) : $(class) $(args) : $(2) : $(3) : $(4) : $(5) : $(6) : $(7) : $(8) : $(9) ;
    
    # bump the next unique object name
    .next-instance.$(class) = [ numbers.increment $(.next-instance.$(class)) ] ;
    
    # Return the name of the new instance.
    return $(name) ;
}

rule bases ( class )
{
    if ! ( $(class) in $(classes) )
    {
        error class $(class) not defined ;
    }
    
    module class@$(class)
    {
        return $(__bases__) ;
    }
}

rule is-derived ( class : bases + )
{
    local all = $(class) $(bases) ;
    if ! ( $(all) in $(classes) )
    {
        error class(es) [ set.difference $(class) $(bases) : $(classes) ] not defined ;
    }
    
    local stack = $(class) ;
    local visited found ;
    while ( ! $(found) ) && $(stack)
    {
        local top = $(stack[1]) ;
        stack = $(stack[2-]) ;
        if ! ( $(top) in $(visited) )
        {
            visited += $(top) ;
            stack += [ bases $(top) ] ;
            
            if $(bases) in $(visited)
            {
                found = true ;
            }
        }
    }
    return $(found) ;
}

# Returns true if the 'value' is a class instance.
rule is-instance ( value # The value to check 
     )
{
    return [ MATCH "(object\\()[^@]+\\)@.*" : $(value) ] ;        
}

# Check if the given value is of the given type.
#
rule is-a (
    instance # The value to check.
    : type # The type to test for.
    )
{
    if [ is-instance $(instance) ]
    {
        return [ class.is-derived [ modules.peek $(instance) : __class__ ] : $(type) ] ;
    }
}

local rule typecheck ( x )
{
    local class-name = [ MATCH "^\\[(.*)\\]$" : [ BACKTRACE 1 ] ] ;
    if ! [ is-a $(x) : $(class-name) ]
    {
        return "Expected an instance of "$(class-name)" but got \""$(x)"\" for argument" ;
    }
}

rule __test__ ( )
{
    module class.__test__
    {
        import class : * ;
        import assert ;
        import errors : * ;
        
        # This will be the construction function for a class called
        # 'myclass'
        local rule myclass ( x_ * : y_ * )
        {
            # set some instance variables
            x = $(x_) ;
            y = $(y_) ;
            
            rule set-x ( newx * )
            {
                x = $(newx) ;
            }
            
            rule get-x ( )
            {
                return $(x) ;
            }
            
            rule set-y ( newy * )
            {
                y = $(newy) ;
            }
            
            rule get-y ( )
            {
                return $(y) ;
            }
            
            rule f ( )
            {
                return [ g $(x) ] ;
            }
            
            rule g ( args * )
            {
                if $(x) in $(y)
                {
                    return $(x) ;
                }
                else if $(y) in $(x)
                {
                    return $(y) ;
                }
                else
                {
                    return ;
                }
            }
            
            rule get-class ( )
            {
                return $(__class__) ;
            }
        }
        class myclass ;
        
        local rule derived1 ( z_ )
        {
            myclass.__init__ $(z_) : X ;
            z = $(z_) ;
            
            # override g
            rule g ( args * )
            {
                return derived1.g ;
            }
            
            rule h ( )
            {
                return derived1.h ;
            }
            
            rule get-z ( )
            {
                return $(z) ;
            }
        }
        class derived1 : myclass ;
        
        local rule derived2 ( )
        {
            myclass.__init__ 1 : 2 ;
            
            # override g
            rule g ( args * )
            {
                return derived2.g ;
            }
            
             rule get-x ( )
             {
                 # Test the ability to call base class functions with qualification.
                 return [ myclass.get-x ] ;
             }
        }
        class derived2 : myclass ;
        
        local rule derived2a ( )
        {
            derived2.__init__ ;
        }
        class derived2a : derived2 ;
        
        local rule expect_derived2 ( [derived2] x ) { }
            
        local rule bad_subclass ( )
        {
            # fails to call base class __init__ function
        }
        class bad_subclass : myclass ;
        
        local a = [ new myclass 3 4 5 : 4 5 ] ;
        local b = [ new derived1 4 ] ;
        local c = [ new derived2 ] ;
        local d = [ new derived2 ] ;
        local e = [ new derived2a ] ;
        
        expect_derived2 $(d) ;
        expect_derived2 $(e) ;
        
        # argument checking is set up to call exit(1) directly on
        # failure, and we can't hijack that with try, so we'd better
        # not do this test by default.  We could fix this by having
        # errors look up and invoke the EXIT rule instead; EXIT can be
        # hijacked ;-)
        if --fail-typecheck in [ modules.peek : ARGV ]
        {
            try ;
            {
                expect_derived2 $(a) ;
            }
            catch
              "Expected an instance of derived2 but got" instead
              ;
        }
        
        
        try ;
        {
            new bad_subclass ;
        }
        catch
          bad_subclass.bad_subclass failed to call base class constructor myclass.__init__
          ;
        
        try ;
        {
            class bad_subclass ;
        }
        catch bad_subclass has already been declared ;
        
        assert.result 3 4 5 : $(a).get-x ;
        assert.result 4 5 : $(a).get-y ;
        assert.result 4 : $(b).get-x ;
        assert.result X : $(b).get-y ;
        assert.result 4 : $(b).get-z ;
        assert.result 1 : $(c).get-x ;
        assert.result 2 : $(c).get-y ;
        assert.result 4 5 : $(a).f ;
        assert.result derived1.g : $(b).f ;
        assert.result derived2.g : $(c).f ;
        assert.result derived2.g : $(d).f ;
        
        # Check that the __class__  attribute is getting properly set.
        assert.result myclass : $(a).get-class ;
        assert.result derived1 : $(b).get-class ;
        
        $(a).set-x a.x ;
        $(b).set-x b.x ;
        $(c).set-x c.x ;
        $(d).set-x d.x ;
        assert.result a.x : $(a).get-x ;
        assert.result b.x : $(b).get-x ;
        assert.result c.x : $(c).get-x ;
        assert.result d.x : $(d).get-x ;
        
        rule derived3 ( )
        {
        }
        class derived3 : derived1 derived2 ;
        
        assert.result : bases myclass ;
        assert.result myclass : bases derived1 ;
        assert.result myclass : bases derived2 ;
        assert.result derived1 derived2 : bases derived3 ;
        
        assert.true is-derived derived1 : myclass ;
        assert.true is-derived derived2 : myclass ;
        assert.true is-derived derived3 : derived1 ;
        assert.true is-derived derived3 : derived2 ;
        assert.true is-derived derived3 : derived1 derived2 myclass ;
        assert.true is-derived derived3 : myclass ;
        
        assert.false is-derived myclass : derived1 ;
 
        assert.true is-instance $(a) ;
        assert.false is-instance bar ;
       
        assert.true is-a $(a) : myclass ;
        assert.true is-a $(c) : derived2 ;
        assert.true is-a $(d) : myclass ;
        assert.false is-a literal : myclass ;
    }
}