#  (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.

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

classes = ;

# Declare a class with the given name. 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 : bases * )
{
    if $(name) in $(classes)
    {
        error class "$(name)" has already been declared ;
    }
    
    classes += $(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) : __derived__ : ;
    modules.poke class@$(name) : __name__ : $(name) ;
    
    module class@$(name)
    {
        # always bring in the rules defined from this module, so that
        # users can easily call "inherit", for example.
        import class : * ;
        
        # The constructor will be known as "__init__" in the class'
        # namespace. 
        IMPORT [ CALLER_MODULE ] : $(__name__) : class@$(__name__) : __init__ ;
        
        # Cause the __init__ function and all of the class modules
        # rules to be visible to the builtin RULENAMES rule. We'll
        # need them in order to implement subclasses and instances of
        # the class.
        EXPORT class@$(__name__) : __init__ # [ RULENAMES class ]
          ;

        # Bring the __init__ functions in from the base classes, using
        # the optional localize parameter so that it will execute in
        # the instance's module
        for local base in $(__bases__)
        {
            # ECHO import __init__ from module class@$(base) into class@$(__name__) as $(base).__init__ ;
            IMPORT class@$(base) : __init__ : class@$(__name__) : $(base).__init__ ;
            EXPORT class@$(__name__) : $(base).__init__ ;
            module class@$(base)
            {
                # not using symbolic name "name" here because it might
                # be a module-local variable
                __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)
    {
        # 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
        __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]) ;
    }
}

# Keeps track of the next unique object name to generate
next-instance = 1 ;

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

rule __test__ ( )
{
    module class.__test__
    {
        import class : * ;
        import assert ;
        
        # 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 ;
                }
            }
        }
        
        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 ;
            }
        }
        
        class derived2 : myclass ;
        
        local a = [ new myclass 3 4 5 : 4 5 ] ;
        local b = [ new derived1 4 ] ;
        local c = [ new derived2 ] ;
        local d = [ new derived2 ] ;
        
        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 ;
        $(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 ;
    }
}