--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/STONWriter.st Tue Jun 04 12:33:53 2019 +0100
@@ -0,0 +1,526 @@
+"{ Package: 'stx:goodies/ston' }"
+
+"{ NameSpace: Smalltalk }"
+
+Object subclass:#STONWriter
+ instanceVariableNames:'writeStream prettyPrint stonCharacters newLine asciiOnly jsonMode
+ keepNewLines referencePolicy level objects'
+ classVariableNames:'STONCharacters STONSimpleSymbolCharacters'
+ poolDictionaries:''
+ category:'STON-Core-Writer'
+!
+
+
+!STONWriter class methodsFor:'instance creation'!
+
+new
+ "return an initialized instance"
+
+ ^ self basicNew initialize.
+!
+
+on: writeStream
+ ^ self new
+ on: writeStream;
+ yourself
+! !
+
+!STONWriter class methodsFor:'class initialization'!
+
+initialize
+ "Modification timestamp 20170131"
+
+ self initializeSTONCharacters.
+ self initializeSTONSimpleSymbolCharacters
+!
+
+initializeSTONCharacters
+ | escapes |
+ STONCharacters := Array new: 127.
+ 32 to: 126 do: [ :each |
+ STONCharacters at: each + 1 put: #pass ].
+ "This is the minimal STON set of named escapes"
+ escapes := #( 8 '\b' 9 '\t' 10 '\n' 12 '\f' 13 '\r' 39 '\''' 92 '\\' ).
+ escapes pairWiseDo: [ :code :escape |
+ STONCharacters at: code + 1 put: escape ]
+
+ "Modified: / 04-06-2019 / 10:59:30 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+initializeSTONSimpleSymbolCharacters
+ "STONSimpleSymbolCharacters asArray collectWithIndex: [ :each :index |
+ each isZero ifTrue: [ (index - 1) asCharacter ] ]."
+
+ STONSimpleSymbolCharacters := ByteArray new: 256 withAll: 1.
+ 1 to: 256 do: [ :each | | char |
+ char := (each - 1) asCharacter.
+ (self isSimpleSymbolChar: char)
+ ifTrue: [
+ STONSimpleSymbolCharacters at: each put: 0 ] ]
+! !
+
+!STONWriter class methodsFor:'private'!
+
+isSimpleSymbolChar: char
+ ^ 'abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789-_./' includes: char
+! !
+
+!STONWriter methodsFor:'accessing'!
+
+jsonMode
+
+ ^ jsonMode
+! !
+
+!STONWriter methodsFor:'error handling'!
+
+error: aString
+ ^ STONWriterError signal: aString
+! !
+
+!STONWriter methodsFor:'initialize-release'!
+
+asciiOnly: boolean
+ asciiOnly := boolean
+!
+
+close
+ writeStream ifNotNil: [
+ writeStream close.
+ writeStream := nil ]
+!
+
+escape: char with: anObject
+ "Instruct me to escape char with object, either a replacement string or #pass"
+
+ "self escape: $/ with: '\/'."
+
+ self assert: (anObject isString | (anObject == #pass)).
+ self assert: char codePoint < 256.
+ self writeableStonCharacters at: char codePoint + 1 put: anObject
+
+ "Modified: / 04-06-2019 / 11:12:24 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+initialize
+ super initialize.
+ stonCharacters := STONCharacters.
+ prettyPrint := false.
+ newLine := Character cr asString.
+ level := 0.
+ referencePolicy := #normal.
+ jsonMode := keepNewLines := asciiOnly := false.
+ objects := IdentityDictionary new
+
+ "Modified: / 04-06-2019 / 10:58:29 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+jsonMode: boolean
+ (jsonMode := boolean)
+ ifTrue: [
+ self
+ escape: $' with: #pass;
+ escape: $" with: '\"' ]
+ ifFalse: [
+ self
+ escape: $" with: #pass;
+ escape: $' with: '\''' ]
+!
+
+keepNewLines: boolean
+ "If true, any newline CR, LF or CRLF inside strings or symbols will not be escaped
+ but will instead be converted to the newline convention chosen, see #newLine:
+ The default is false, where CR, LF or CRLF will be enscaped unchanged."
+
+ keepNewLines := boolean
+!
+
+newLine: string
+ "The sequence to use when ending a line, either CR, LF or CRLF"
+
+ newLine := string
+!
+
+on: aWriteStream
+ writeStream := aWriteStream
+!
+
+optimizeForLargeStructures
+ self class environment
+ at: #FLLargeIdentityDictionary
+ ifPresent: [ :identityDictionaryClass | objects := identityDictionaryClass new ].
+!
+
+prettyPrint: boolean
+ prettyPrint := boolean
+!
+
+referencePolicy: policy
+ self assert: ( #(#normal #ignore #error) includes: policy ).
+ referencePolicy := policy
+!
+
+reset
+ objects removeAll
+! !
+
+!STONWriter methodsFor:'private'!
+
+encodeCharacter: char
+ | code encoding |
+ "STONCharacters contains for the lower 127 characters (codes 0 to 126) either nil (unknown),
+ #pass (output as is, clean ASCII characters) or a full escape string"
+ ((code := char codePoint) < 127 and: [ (encoding := self stonCharacters at: code + 1) notNil ])
+ ifTrue: [
+ (encoding = #pass or: [ jsonMode and: [ char = $' ] ])
+ ifTrue: [ writeStream nextPut: char ]
+ ifFalse: [ writeStream nextPutAll: encoding ] ]
+ ifFalse: [
+ "always escape Latin1 C1 controls, or when asciiOnly is true"
+ (code > 16r9F and: [ asciiOnly not ])
+ ifTrue: [ writeStream nextPut: char ]
+ ifFalse: [ self escapeUnicode: code ] ]
+!
+
+encodeKey: key value: value
+ (jsonMode and: [ key isString not ])
+ ifTrue: [ self error: 'JSON key names in objects must be strings' ].
+ self nextPut: key.
+ self prettyPrintSpace.
+ writeStream nextPut: $:.
+ self prettyPrintSpace.
+ self nextPut: value
+!
+
+encodeString: string
+ writeStream nextPut: (jsonMode ifTrue: [ $" ] ifFalse: [ $' ]).
+ keepNewLines
+ ifTrue: [
+ self encodeStringKeepingNewLines: string ]
+ ifFalse: [
+ string do: [ :each | self encodeCharacter: each ] ].
+ writeStream nextPut: (jsonMode ifTrue: [ $" ] ifFalse: [ $' ])
+!
+
+encodeStringKeepingNewLines: string
+ | input char |
+ input := string readStream.
+ [ input atEnd ]
+ whileFalse: [
+ char := input next.
+ char = Character lf
+ ifTrue: [ writeStream nextPutAll: newLine ]
+ ifFalse: [
+ char = Character cr
+ ifTrue: [
+ input peekFor: Character lf.
+ writeStream nextPutAll: newLine ]
+ ifFalse: [ self encodeCharacter: char ] ] ]
+!
+
+escapeUnicode4: codePoint
+ writeStream nextPutAll: '\u'.
+ codePoint printOn: writeStream base: 16 nDigits: 4
+!
+
+escapeUnicode: codePoint
+ codePoint <= 16rFFFF
+ ifTrue: [ self escapeUnicode4: codePoint ]
+ ifFalse: [
+ codePoint <= 16r10FFFF
+ ifTrue: [ | leadSurrogate trailSurrogate shifted |
+ "Characters not in the Basic Multilingual Plane are encoded as a UTF-16 surrogate pair"
+ "See https://tools.ietf.org/html/rfc7159#section-7"
+ shifted := codePoint - 16r10000.
+ leadSurrogate := 16rD800 + (shifted // 16r400).
+ trailSurrogate := 16rDC00 + (shifted \\ 16r400).
+ self escapeUnicode4: leadSurrogate.
+ self escapeUnicode4: trailSurrogate ]
+ ifFalse: [ self error: 'Character Unicode code point outside encoder range' ] ]
+!
+
+indentedDo: block
+ level := level + 1.
+ block value.
+ level := level - 1
+!
+
+isSimpleSymbol: symbol
+ symbol isEmpty ifTrue: [ ^ false ].
+ ^ (symbol class
+ findFirstInString: symbol
+ inSet: STONSimpleSymbolCharacters
+ startingAt: 1) = 0
+!
+
+listElementSeparator
+ writeStream nextPut: $,.
+ self newlineIndent
+!
+
+mapElementSeparator
+ writeStream nextPut: $,.
+ self newlineIndent
+!
+
+newlineIndent
+ prettyPrint ifTrue: [
+ writeStream nextPutAll: newLine.
+ level timesRepeat: [ writeStream tab ] ]
+!
+
+prettyPrintSpace
+ prettyPrint ifTrue: [ writeStream space ]
+!
+
+shortListElementSeparator
+ writeStream nextPut: $,.
+ self prettyPrintSpace
+!
+
+stonCharacters
+ ^ stonCharacters ifNil: [ stonCharacters := STONCharacters ]
+!
+
+with: object do: block
+ | index |
+ referencePolicy = #ignore
+ ifTrue: [ ^ block value ].
+ (index := objects at: object ifAbsent: [ nil ]) notNil
+ ifTrue: [
+ referencePolicy = #error
+ ifTrue: [ ^ self error: 'shared reference detected' ].
+ self writeReference: index ]
+ ifFalse: [
+ index := objects size + 1.
+ objects at: object put: index.
+ block value ]
+!
+
+writeableStonCharacters
+ ^ self stonCharacters == STONCharacters
+ ifTrue: [ stonCharacters := stonCharacters copy ]
+ ifFalse: [ stonCharacters ]
+! !
+
+!STONWriter methodsFor:'public'!
+
+nextPut: anObject
+ anObject stonOn: self
+! !
+
+!STONWriter methodsFor:'writing'!
+
+encodeList: elements
+ writeStream nextPut: $[.
+ elements isEmpty
+ ifTrue: [
+ self prettyPrintSpace ]
+ ifFalse: [
+ self indentedDo: [
+ self newlineIndent.
+ elements
+ do: [ :each | self nextPut: each ]
+ separatedBy: [ self listElementSeparator ] ].
+ self newlineIndent ].
+ writeStream nextPut: $]
+!
+
+encodeMap: pairs
+ | first |
+ first := true.
+ writeStream nextPut: ${.
+ pairs isEmpty
+ ifTrue: [
+ self prettyPrintSpace ]
+ ifFalse: [
+ self indentedDo: [
+ self newlineIndent.
+ pairs keysAndValuesDo: [ :key :value |
+ first
+ ifTrue: [ first := false ]
+ ifFalse: [ self mapElementSeparator ].
+ self encodeKey: key value: value ] ].
+ self newlineIndent ].
+ writeStream nextPut: $}
+!
+
+writeAssociation: association
+ jsonMode
+ ifTrue: [ self error: 'wrong object class for JSON mode' ].
+ self
+ encodeKey: association key
+ value: association value
+!
+
+writeBoolean: boolean
+ writeStream print: boolean
+!
+
+writeFloat: float
+ writeStream print: float
+!
+
+writeFraction: fraction
+ jsonMode
+ ifTrue: [ self writeFloat: fraction asFloat ]
+ ifFalse: [ writeStream
+ print: fraction numerator;
+ nextPut: $/;
+ print: fraction denominator ]
+!
+
+writeInteger: integer
+ writeStream print: integer
+!
+
+writeList: collection
+ self with: collection do: [
+ self encodeList: collection ]
+!
+
+writeMap: hashedCollection
+ self with: hashedCollection do: [
+ self encodeMap: hashedCollection ]
+!
+
+writeNull
+ jsonMode
+ ifTrue: [ writeStream nextPutAll: 'null' ]
+ ifFalse: [ writeStream print: nil ]
+!
+
+writeObject: anObject
+ | instanceVariableNames |
+ (instanceVariableNames := anObject class stonAllInstVarNames) isEmpty
+ ifTrue: [
+ self writeObject: anObject do: [ self encodeMap: #() ] ]
+ ifFalse: [
+ self writeObject: anObject streamMap: [ :dictionary |
+ instanceVariableNames do: [ :each |
+ | value |
+
+ (value := anObject instVarNamed: each) notNil
+ ifTrue: [
+ dictionary at: each asSymbol put: value ]
+ ifFalse: [
+ anObject stonShouldWriteNilInstVars
+ ifTrue: [ dictionary at: each asSymbol put: nil ] ] ] ] ]
+!
+
+writeObject: anObject do: block
+ (jsonMode and: [ anObject class ~= STON listClass and: [ anObject class ~= STON mapClass and: [anObject class ~= ImmutableArray ] ] ])
+ ifTrue: [ self error: 'wrong object class for JSON mode' ].
+ self with: anObject do: [
+ writeStream nextPutAll: anObject class stonName.
+ self prettyPrintSpace.
+ block value ]
+
+ "Modified: / 20-05-2020 / 11:07:28 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+writeObject: object listSingleton: element
+ self writeObject: object do: [
+ writeStream nextPut: $[.
+ self
+ prettyPrintSpace;
+ nextPut: element;
+ prettyPrintSpace.
+ writeStream nextPut: $] ]
+!
+
+writeObject: anObject named: stonName do: block
+ (jsonMode and: [ anObject class ~= STON listClass and: [ anObject class ~= STON mapClass ] ])
+ ifTrue: [ self error: 'wrong object class for JSON mode' ].
+ self with: anObject do: [
+ writeStream nextPutAll: stonName.
+ self prettyPrintSpace.
+ block value ]
+!
+
+writeObject: object named: stonName listSingleton: element
+ self writeObject: object named: stonName do: [
+ writeStream nextPut: $[.
+ self
+ prettyPrintSpace;
+ nextPut: element;
+ prettyPrintSpace.
+ writeStream nextPut: $] ]
+!
+
+writeObject: object streamList: block
+ self writeObject: object do: [ | listWriter |
+ listWriter := STONListWriter on: self.
+ writeStream nextPut: $[.
+ self indentedDo: [
+ self newlineIndent.
+ block value: listWriter ].
+ self newlineIndent.
+ writeStream nextPut: $] ]
+!
+
+writeObject: object streamMap: block
+ self writeObject: object do: [ | mapWriter |
+ mapWriter := STONMapWriter on: self.
+ writeStream nextPut: ${.
+ self indentedDo: [
+ self newlineIndent.
+ block value: mapWriter ].
+ self newlineIndent.
+ writeStream nextPut: $} ]
+!
+
+writeObject: object streamShortList: block
+ self writeObject: object do: [ | listWriter |
+ listWriter := STONShortListWriter on: self.
+ writeStream nextPut: $[.
+ self indentedDo: [
+ self prettyPrintSpace.
+ block value: listWriter ].
+ self prettyPrintSpace.
+ writeStream nextPut: $] ]
+!
+
+writeReference: index
+ writeStream
+ nextPut: $@;
+ print: index
+!
+
+writeScaledDecimal: scaledDecimal
+ jsonMode
+ ifTrue: [ self writeFloat: scaledDecimal asFloat ]
+ ifFalse: [ writeStream
+ print: scaledDecimal numerator;
+ nextPut: $/;
+ print: scaledDecimal denominator;
+ nextPut: $s;
+ print: scaledDecimal scale ]
+!
+
+writeString: string
+ self encodeString: string
+!
+
+writeSymbol: symbol
+ jsonMode
+ ifTrue: [
+ self writeString: symbol ]
+ ifFalse: [
+ writeStream nextPut: $#.
+ (self isSimpleSymbol: symbol)
+ ifTrue: [
+ writeStream nextPutAll: symbol ]
+ ifFalse: [
+ self encodeString: symbol ] ]
+! !
+
+!STONWriter class methodsFor:'documentation'!
+
+version_HG
+
+ ^ '$Changeset: <not expanded> $'
+! !
+
+
+STONWriter initialize!