"{ Package: 'stx:goodies/xmlsuite/xquery' }"

"{ NameSpace: XQuery }"

Perseus::AstInterpreter subclass:#XQueryInterpreter

	instanceVariableNames:'documentProvider documentAdaptorsPool funcTable

		defaultElementNamespaceURI defaultFunctionNamespaceURI

		prefixToNamespaceURIMapping currentFocus pendingUpdateList

		externalContext baseUri typeFactory'

	classVariableNames:'Verbose'

	poolDictionaries:''

	category:'XQuery-Core'

!

!XQueryInterpreter class methodsFor:'instance creation'!

new

    Verbose := false.

    ^ self basicNew initialize.

    "Created: / 24-12-2006 / 15:42:05 / janfrog"

    "Modified: / 21-11-2009 / 20:16:11 / Jan Kurs <kursj1@fel.cvut.cz>"

! !

!XQueryInterpreter class methodsFor:'accessing'!

examples

    ^#(

        ('1+1'

         '1+1')

    )

    "Created: / 04-05-2010 / 12:41:31 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

isVerbose

    ^Verbose == true

    "Created: / 12-04-2007 / 11:14:25 / janfrog"

!

verbose: aBoolean

    Verbose := aBoolean

    "Created: / 12-04-2007 / 11:14:09 / janfrog"

! !

!XQueryInterpreter class methodsFor:'defaults'!

defaultBaseUri

    ^ ''.

    "Created: / 25-07-2009 / 15:08:55 / Jan Kurs <kursj1@fel.cvut.cz>"

!

defaultDocumentProvider

    "default value for the 'documentProvider' instance variable (automatically generated)"

    ^XQuery::XDMAdaptorProvider default.

    "Modified: / 02-12-2006 / 12:00:09 / ked"

    "Modified: / 05-12-2006 / 14:59:22 / janfrog"

    "Created: / 18-09-2008 / 16:38:05 / Jan Vrany <vranyj1@fel.cvut.cz>"

    "Modified: / 28-01-2010 / 11:19:30 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

defaultFuncTable

    "default value for the 'funcTable' instance variable (automatically generated)"

    ^XQueryFuncTable new.

    "Created: / 09-09-2006 / 09:53:19 / ked"

! !

!XQueryInterpreter methodsFor:'accessing'!

baseUri

    baseUri isNil ifTrue: [ self baseUri: self class defaultBaseUri].

    ^ baseUri.

    "Modified: / 15-09-2009 / 21:42:04 / Jan Kurs <kursj1@fel.cvut.cz>"

!

baseUri: value

    baseUri := value.

    "Created: / 25-07-2009 / 15:07:10 / Jan Kurs <kursj1@fel.cvut.cz>"

!

currentNodeSet

    ^context nodeSet

    "Created: / 05-12-2007 / 10:37:08 / janfrog"

    "Modified: / 18-09-2008 / 16:13:10 / Jan Vrany <vranyj1@fel.cvut.cz>"

!

currentNodeSet:anObject 

    self assert:(anObject isNil or:[ anObject class == XQuerySequence ]).

    ^context nodeSet: anObject

    "Created: / 18-11-2007 / 08:11:01 / janfrog"

    "Modified: / 05-12-2007 / 10:39:38 / janfrog"

    "Modified: / 18-09-2008 / 16:41:34 / Jan Vrany <vranyj1@fel.cvut.cz>"

!

defaultFunctionNamespaceURI

    ^ defaultFunctionNamespaceURI

    "Created: / 28-12-2006 / 12:38:13 / janfrog"

!

documentProvider

    documentProvider isNil ifTrue:[documentProvider := self class defaultDocumentProvider].

    ^ documentProvider

    "Modified: / 10-12-2006 / 13:30:28 / janfrog"

    "Created: / 18-09-2008 / 16:36:47 / Jan Vrany <vranyj1@fel.cvut.cz>"

!

externalContext

    "return context which could be changed from external environment"

    externalContext isNil ifTrue:[

        externalContext := self newContext: 0.

    ].

    ^ externalContext

    "Modified: / 18-04-2009 / 12:43:15 / Jan Kurs <kursj1@fel.cvut.cz>"

!

externalContext: aContext

    externalContext := aContext

    "Modified: / 18-04-2009 / 12:43:15 / Jan Kurs <kursj1@fel.cvut.cz>"

    "Created: / 04-05-2010 / 18:56:54 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

focus

    ^currentFocus

    "Created: / 01-07-2009 / 15:01:51 / Jan Kurs <kursj1@fel.cvut.cz>"

!

funcTable

    funcTable isNil ifTrue:[

        funcTable := self class defaultFuncTable.

    ].

    ^ funcTable

    "Created: / 09-09-2006 / 09:53:19 / ked"

!

funcTable:something

    funcTable := something.

    "Created: / 09-09-2006 / 09:53:19 / ked"

!

languageName

    ^'XQuery'

    "Created: / 18-04-2010 / 22:23:37 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

prefixToNamespaceURIMapping

    ^ prefixToNamespaceURIMapping

    "Created: / 28-12-2006 / 12:34:19 / janfrog"

!

subInterpreter

    ^self class new

        externalContext: self context flatten

    "Created: / 04-05-2010 / 18:51:40 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

typeFactory

    typeFactory ifNil:

    [   

        typeFactory := TypeFactory new.

    ].

    ^ typeFactory

    "Modified: / 01-11-2009 / 19:11:12 / Jan Kurs <kursj1@fel.cvut.cz>"

! !

!XQueryInterpreter methodsFor:'accessing - classes'!

compilerClass

    "Superclass Perseus::Interpreter says that I am responsible to implement this method"

    ^XQueryCompiler

    "Created: / 18-09-2008 / 17:04:25 / Jan Vrany <vranyj1@fel.cvut.cz>"

!

contextClass

    ^ XQueryContext

    "Created: / 18-09-2008 / 17:11:21 / Jan Vrany <vranyj1@fel.cvut.cz>"

    "Modified: / 20-04-2010 / 19:43:48 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

contextProxyClass

    ^ContextProxy

    "Created: / 18-09-2008 / 18:25:29 / Jan Vrany <vranyj1@fel.cvut.cz>"

!

debuggerClass

    ^XQuery::Debugger

    "Created: / 20-04-2010 / 20:38:21 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

debuggerServiceClass

    ^XQuery::DebuggerService

    "Created: / 20-04-2010 / 19:44:44 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

parserClass

    "Superclass Perseus::Interpreter says that I am responsible to implement this method"

    ^XQueryParser

    "Created: / 18-09-2008 / 16:58:05 / Jan Vrany <vranyj1@fel.cvut.cz>"

! !

!XQueryInterpreter methodsFor:'accessing - document'!

documentAdaptorsFor: aURI

    documentAdaptorsPool ifNil:[

        documentAdaptorsPool := Dictionary new.

    ].

    ^documentAdaptorsPool at: aURI ifAbsentPut:[

        (self documentProvider documentAdaptorsFor: aURI)

    ].

    "Modified: / 02-12-2006 / 11:59:45 / ked"

    "Created: / 20-09-2007 / 10:34:10 / janfrog"

    "Modified: / 18-09-2008 / 16:36:34 / Jan Vrany <vranyj1@fel.cvut.cz>"

!

releaseDocumentAdaptors

    documentAdaptorsPool ifNotNil:

        [documentAdaptorsPool do:

            [:documentAdaptors |

            documentAdaptors do:

                [:documentAdaptor|

                documentAdaptor releaseResources]].

        documentAdaptorsPool := nil].

    "Modified: / 02-11-2006 / 10:28:44 / ked"

    "Created: / 18-09-2008 / 16:36:34 / Jan Vrany <vranyj1@fel.cvut.cz>"

! !

!XQueryInterpreter methodsFor:'accessing - vars'!

bindExternalVar:aName to:aValue

    "bind variable to external context - this could be done before XQuery execution"

    ^self bindVar:aName to:aValue inContext: self externalContext

    "Created: / 18-04-2009 / 12:40:37 / Jan Kurs <kursj1@fel.cvut.cz>"

!

bindVar:aName to:aValue

    ^self bindVar:aName to:aValue inContext: context

    "Modified: / 02-11-2006 / 10:29:47 / ked"

    "Created: / 28-03-2007 / 17:28:05 / janfrog"

    "Modified: / 18-09-2008 / 15:40:07 / Jan Vrany <vranyj1@fel.cvut.cz>"

!

bindVar:aName to:aValue inContext:aContext 

    self assert: (aName class = XQuerySequence).

    self assert: (aName containsSingleAtomicValue).

    TypeFactory current: self typeFactory do:

    [

        aContext variableAt: aName first stringValue put: aValue

    ].

    "Modified: / 02-11-2006 / 10:29:47 / ked"

    "Created: / 20-03-2007 / 23:01:25 / janfrog"

    "Modified: / 05-11-2009 / 23:02:30 / Jan Kurs <kursj1@fel.cvut.cz>"

!

bindVar:aName toInteger:anInteger 

    ^self bindVar:aName

        to:(AtomicItem withNumber:anInteger)

    "Modified: / 02-11-2006 / 10:29:47 / ked"

    "Created: / 28-03-2007 / 20:19:43 / janfrog"

    "Modified: / 07-10-2009 / 11:54:24 / Jan Kurs <kursj1@fel.cvut.cz>"

!

bindVarIfNotNil:aName to:aValue

    ^self bindVarIfNotNil:aName to:aValue inContext: context

    "Modified: / 02-11-2006 / 10:29:47 / ked"

    "Created: / 28-03-2007 / 21:24:49 / janfrog"

    "Modified: / 18-09-2008 / 15:40:07 / Jan Vrany <vranyj1@fel.cvut.cz>"

!

bindVarIfNotNil:aName to:aValue inContext:aContext 

    aName ifNotNil:[self bindVar: aName to: aValue inContext: aContext]

    "Modified: / 02-11-2006 / 10:29:47 / ked"

    "Created: / 28-03-2007 / 21:24:40 / janfrog"

!

unbindVar:aName 

    ^self unbindVar:aName inContext: context

    "Modified: / 02-11-2006 / 10:30:18 / ked"

    "Created: / 28-03-2007 / 17:29:05 / janfrog"

    "Modified: / 18-09-2008 / 15:40:07 / Jan Vrany <vranyj1@fel.cvut.cz>"

!

unbindVar:aName inContext:aContext 

    aContext variables removeKey:aName ifAbsent:[]

    "Modified: / 02-11-2006 / 10:30:18 / ked"

    "Created: / 28-03-2007 / 17:28:42 / janfrog"

    "Modified: / 28-03-2007 / 21:24:04 / janfrog"

!

valueOfVar:aName inContext:aContext

    self assert: (aName isAtomicValue).

    ^(aContext variableAt: aName stringValue) clone.

    "Created: / 03-09-2006 / 13:41:51 / ked"

    "Modified: / 14-12-2006 / 23:29:54 / ked"

    "Modified: / 20-03-2007 / 23:05:35 / janfrog"

    "Modified: / 05-10-2009 / 16:01:22 / Jan Kurs <kursj1@fel.cvut.cz>"

    "Modified: / 16-12-2009 / 09:59:14 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!XQueryInterpreter methodsFor:'comparison expr'!

generalComparison:generalComp leftSeq:leftSeq rightSeq:rightSeq 

    |comparisonOperations lSeq rSeq |

    "

    3.5.2 General Comparisons

    The general comparison operators are =, !!=, <, <=, >, and >=. General comparisons are existentially 

    quantified comparisons that may be applied to operand sequences of any length. The result of a 

    general comparison that does not raise an error is always true or false.

    A general comparison is evaluated by applying the following rules, in order:

       1.Atomization is applied to each operand. After atomization, each operand is a sequence of atomic values.

       2.The result of the comparison is true if and only if there is a pair of atomic values, one in the first 

            operand sequence and the other in the second operand sequence, that have the required magnitude 

            relationship. Otherwise the result of the comparison is false. The magnitude relationship between two 

            atomic values is determined by applying the following rules. If a cast operation called for by these 

            rules is not successful, a dynamic error is raised. [err:FORG0001]

     "

    lSeq := leftSeq asAtomizedSequence.

    rSeq := rightSeq asAtomizedSequence.

    comparisonOperations := self generalComparisonOperations.

    ^ XQuerySequence withBoolean:

    (lSeq anySatisfy: [:itemLeft | rSeq anySatisfy:[:itemRight | 

        | left right |

        left := nil.

        right := nil.

    "

    a.If one of the atomic values is an instance of xs:untypedAtomic and the other is an instance of a 

       numeric type, then the xs:untypedAtomic value is cast to the type xs:double.

    "

            (((itemLeft isType: 'xs:untypedAtomic') and: [itemRight isSubtypeOf: 'xs:decimal']) 

            or: [

            ((itemRight isType: 'xs:untypedAtomic') and: [itemLeft isSubtypeOf: 'xs:decimal'])]) ifTrue: [

                left := itemLeft castAs: 'xs:decimal'.

                right := itemRight castAs: 'xs:decimal'.

            ].

    "

    b.If one of the atomic values is an instance of xs:untypedAtomic and the other is an instance of 

       xs:untypedAtomic or xs:string, then the xs:untypedAtomic value (or values) is (are) cast to the 

       type xs:string.

    "

            (((itemRight isType: 'xs:untypedAtomic') and: [itemLeft isSubtypeOf: 'xs:untypedAtomic']) 

            or: [

            ((itemRight isType: 'xs:untypedAtomic') and: [itemLeft isSubtypeOf: 'xs:string'])

            or: [

            ((itemRight isType: 'xs:string') and: [itemLeft isSubtypeOf: 'xs:untypedAtomic']) ] ])

            ifTrue: [ 

                left := itemLeft castAs: 'xs:string'.

                right := itemRight castAs: 'xs:string'.

            ].

    "

    c.If one of the atomic values is an instance of xs:untypedAtomic and the other is not an instance 

       of xs:string, xs:untypedAtomic, or any numeric type, then the xs:untypedAtomic value is cast to 

       the dynamic type of the other value.

    "

            ((itemRight isType: 'xs:untypedAtomic') and: [left isNil]) 

            ifTrue: [ 

                left := itemLeft.

                right := itemRight castAs: left type.

            ].

            ((itemLeft isType: 'xs:untypedAtomic') and: [right isNil]) 

            ifTrue: [ 

                right := itemRight.

                left := itemLeft castAs: right type.

            ].

            (left isNil and: [right isNil]) ifTrue: [

                right := itemRight.

                left := itemLeft.

            ].

            self assert: (left isSubtypeOf: 'xs:untypedAtomic') not.

            self assert: (right isSubtypeOf: 'xs:untypedAtomic') not.

            (comparisonOperations at:generalComp) 

                value:(left)

                value:(right) 

        ]]).

    "Created: / 04-10-2009 / 18:39:54 / Jan Kurs <kursj1@fel.cvut.cz>"

    "Modified: / 05-10-2009 / 19:10:01 / Jan Kurs <kursj1@fel.cvut.cz>"

!

generalComparisonOperations

    |comparisonOperations|

    comparisonOperations := Dictionary new.

    comparisonOperations

        at:#eqGeneral

            put:[:left :right |

                left = right.

            ];

        at:#neGeneral

            put:[:left :right | 

                left ~= right.

            ];

        at:#ltGeneral

            put:[:left :right | 

                left < right.

            ];

        at:#leGeneral

            put:[:left :right | 

                left <= right.

            ];

        at:#gtGeneral

            put:[:left :right | 

                left > right.

            ];

        at:#geGeneral

            put:[:left :right | 

                left >= right.

            ].

    ^ comparisonOperations.

    "Created: / 04-10-2009 / 18:42:16 / Jan Kurs <kursj1@fel.cvut.cz>"

    "Modified: / 05-10-2009 / 18:12:56 / Jan Kurs <kursj1@fel.cvut.cz>"

!

nodeComparison:nodeComp leftSeq:leftSeq rightSeq:rightSeq 

    "If either operand is an empty sequence, the result of the comparison is an empty sequence"

    |comparisonOperations|

    (leftSeq size = 0) ifTrue:[

        ^ XQuerySequence new:0

    ].

    (rightSeq size = 0) ifTrue:[

        ^ XQuerySequence new:0

    ].

     "Each operand must be either a single node or an empty sequence; otherwise a type error is raised"

    self assert:(leftSeq size = 1).

    self assert:(rightSeq size = 1).

    self assert:(leftSeq first isSubtypeOf:'node').

    self assert:(rightSeq first isSubtypeOf:'node').

    comparisonOperations := self nodeComparisonOperations.

    ^ XQuerySequence 

        withBoolean:((comparisonOperations at:nodeComp) value:(leftSeq first)

                value:(rightSeq first))