REBOL [
    Title: "Custom Types"
    Purpose: {
        To allow the user to define new datatypes (actually, something that
        looks like a datatype).
    }
    Author: "Gabriele Santilli"
    EMail: giesse@rebol.it
    File: %custom-types.r
    License: {
Copyright (C) 2003  Gabriele Santilli

This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.

http://www.gnu.org/copyleft/gpl.html
    }
    Date: 9-Nov-2004
    Version: 1.19.0 ; majorv.minorv.status
                    ; status: 0: unfinished; 1: testing; 2: stable
    History: [
        10-Aug-2004 1.1.0 "History start"
        10-Aug-2004 1.2.0 "type?*, custom-type?, define-action"
        11-Aug-2004 1.3.0 "finished define-action, finished standard actions definition code"
        15-Oct-2004 1.4.0 "Now uses %standard-actions.r"
        15-Oct-2004 1.5.0 "Added TO* multiaction"
        15-Oct-2004 1.6.0 "Fixed TO*"
        15-Oct-2004 1.7.0 "Finished define-type"
        15-Oct-2004 1.8.0 "Fixed TO*"
        15-Oct-2004 1.9.0 "Fixed DEFINE-CONVERSION"
        19-Oct-2004 1.10.0 "Added magic to DEFINE-ACTION :) Also now using the INVALID-ARG function"
        19-Oct-2004 1.11.0 "Fixed DEFINE-ACTION"
        19-Oct-2004 1.12.0 "INVALID-ARG -> INVALID-ARGUMENT"
        19-Oct-2004 1.13.0 "Fixed CUSTOM-TYPE?"
        28-Oct-2004 1.14.0 "Changed actions definition for easier creation of non-standard actions"
        29-Oct-2004 1.15.0 "Added REBUILD definition (added DISMANTLE to standard-actions.r)"
        29-Oct-2004 1.16.0 "Fixed REBUILD"
         9-Nov-2004 1.17.0 "Added SET-IN, GET-IN, SET* and GET*"
         9-Nov-2004 1.18.0 "Changed GET* and SET*"
         9-Nov-2004 1.19.0 "Fixed SET*"
    ]
]

type?*:
    func [
        "Extended TYPE? function; always returns a WORD!"
        value [any-type!]
    ] [
        either object? get/any 'value [
            either in value 'type [
                value/type
            ] [
                'object!
            ]
        ] [
            type?/word get/any 'value
        ]
    ]

custom-type?:
    func [
        "Returns TRUE if the value is of a custom type"
        value [any-type!]
    ] [
        found? all [object? get/any 'value in value 'type in value 'actions]
    ]

define-action:
    func [
        "Defines a user action with given spec" [catch]
        name [word!] "Action name"
        spec [block!] "Help string (opt) followed by arg words (and opt type and string)"
        /local first-arg name' native
    ] [
        if not parse spec [opt string! opt block! set first-arg word! to end] [
            invalid-argument spec
        ]
        name': form name
        if #"*" = last name' [remove back tail name']
        native: to word! name'
        if all [value? native action? get native] [native: get native]
        name': to word! append name' #"'"
        use [magic] [
            set name func spec compose/deep/only [
                (to lit-word! first-arg)
                either custom-type? (to get-word! first-arg) [
                    ; assumes that the action code is already bound to this
                    ; function context. (this gets done when the action code is created)
                    (head insert insert insert make path! 4 first-arg 'actions name')
                ] [
                    ; pass to native action, if there is one.
                    magic
                ]
            ]
            either action? :native [
                magic: pass-args :native first second get name
            ] [
                magic: does compose [invalid-argument (fourth second get name)]
            ]
        ]
    ]
    
use [i] [
    i: 1
    foreach name [
        first second third fourth fifth sixth seventh eighth ninth tenth
    ] [
        set to word! join name "*" func compose [
            (rejoin ["Returns the " name " value of a series."]) [catch]
            series
        ] compose [
            pick* :series (i)
        ]
        i: i + 1
    ]
]

foreach [name spec] [#include %standard-actions.r] [
    define-action name spec
]

rebuild:
    func [
        "Rebuild a dismantled value"
        pieces [block!]
        /local type
    ] [
        'pieces
        if 'dismantled <> pick pieces 1 [invalid-argument pieces]
        if not all [word? type: pick pieces 2  custom-type? get/any type] [invalid-argument pieces]
        type: get type
        type/actions/rebuild'
    ]

get-in:
    func [
        "Get an attribute of a value" [catch]
        value [object!]
        attribute
        /default defval "Default value to return (instead of NONE)"
    ] [
        'value
        if paren? :attribute [attribute: do attribute]
        either custom-type? value [
            value/actions/get-in'
        ] [
            get any [in value attribute 'defval]
        ]
    ]
set-in:
    func [
        "Set an attribute of a value" [catch]
        target [object!]
        attribute
        value
    ] [
        'target
        if paren? :attribute [attribute: do attribute]
        either custom-type? target [
            target/actions/set-in'
        ] [
            set in target attribute :value
        ]
    ]

get*:
    func [
        "Gets the value of a path." [catch]
        path [path!]

        /local value
    ] [
        value: first path
        path: next path
        value: throw-on-error [get value]
        while [not tail? path] [
            either custom-type? :value [
                value: get-in value first path
                path: next path
            ] [
                path: head insert copy path 'value
                value: do path
                path: tail path
            ]
        ]
        :value
    ]
set*:
    func [
        "Sets the value of a path." [catch]
        path [path!]
        value

        /local target
    ] [
        throw-on-error [
            target: get* copy/part path -1 + length? path
            set-in target last path value
        ]
    ]

context [
    conversions: context [ ]
    set 'define-conversion func [
        "Define a type conversion"
        from-type [word!] "Converts from this type..."
        to-type [word!] "...to this type"
        locals [block!]
        body [block!] "Conversion code (gets bound to the context of TO*)"
        /local f
    ] [
        f: has locals body
        conversions: make conversions compose/deep [
            (to set-word! to-type) make either value? (to lit-word! to-type) [(to-type)] [object!] [
                (to set-word! from-type) :f
            ]
        ]
        bind second :f to*-context
    ]
    tmp: none
    set 'to* func [
        {Constructs and returns a new value after conversion.} [catch]
        type [any-type!] "The datatype or example value."
        spec [any-type!] "The attributes of the new value."
    ] [
        tmp: either datatype? get/any 'type [to word! type] [type?* get/any 'type]
        if not tmp: in conversions tmp [
            invalid-argument get/any 'type
        ]
        tmp: get tmp
        if not tmp: in tmp type?* get/any 'spec [
            invalid-argument get/any 'spec
        ]
        do get tmp
    ]
    to*-context: third sixth second :to*
]

define-type:
    func [
        "Define a custom type" [catch]
        name [word!] "Type name"
        ctx [block!] "Type context definition"
        actions' [block!] "Type actions definition"
        /local name* global-action
    ] [
        set name context compose [
            type: (to lit-word! name)
            actions: [ ]
            foreach [name locals body] actions' [
                name*: form name
                if #"'" <> last name* [invalid-argument name]
                remove back tail name*
                if not function? set/any 'global-action get/any to word! name* [
                    if not function? set/any 'global-action get/any to word! join name* "*" [
                        invalid-argument name
                    ]
                ]
                insert/only insert/only insert insert tail actions to set-word! name 'has locals bind body first second :global-action
            ]
            actions: context actions
            (ctx)
        ]
    ]