styletalk.reb

Rebol [
	Title: "StyleTalk"
	Purpose: "Compact Style Sheets in Rebol"
	Version: 0.2.1
	Date: 17-Jun-2013
	Author: "Christopher Ross-Gill"
	Name: 'styletalk
	Type: 'module
	Exports: [to-css]
]

to-css: use [ruleset parser ??][

ruleset: context [
	; Values
	values: copy []
	unset: func [key [word!]][remove-each [k value] values [k = key]]
	set: func [key [word!] value [any-type!]][
		unset key repend values [key value]
	]

	; Values that are zero or more
	colors: copy []
	lengths: copy []
	; images: copy []
	transitions: copy []
	transformations: copy []
	; spacing: copy []

	enspace: func [value][join " " value]

	form-color: func [value [tuple! word!]][
		enspace either value/4 [
			["rgba(" value/1 "," value/2 "," value/3 "," either integer? value: value/4 / 255 [value][round/to value 0.01] ")"]
		][
			["rgb(" value/1 "," value/2 "," value/3")"]
		]
	]

	form-number: func [value [number!] unit [word! string! none!]][
		enspace case [
			value = 0 ["0"]
			unit [join value unit]
			value [form value]
		]
	]

	form-value: func [values /local value choices][
		any [
			switch value: take values [
				em pt px deg vw vh [form-number take values value]
				pct [form-number take values "%"]
				* [form-number take values none]
				| [","]
				radial [enspace ["radial-gradient(" remove form-values values ")"]]
				linear [enspace ["linear-gradient(" remove form-values values ")"]]
			]
			switch type?/word value [
				integer! decimal! [form-number value 'px]
				pair! [rejoin [form-number value/x 'px form-number value/y 'px]]
				time! [form-number value/second 's]
				tuple! [form-color value]
				string! [enspace mold value]
				url! file! [enspace [{url('} value {')}]]
				path! [enspace [{url("data:} form value {;base64,} enbase/base take values 64 {")}]]
			]
			enspace value
		]
	]

	form-transform: func [transform [block!] /local name direction][
		; [
		; 	  'translate direction length
		; 	| 'rotate angle opt ['origin percent percent]
		; 	| 'scale [direction number | 1 2 number]
		; ]

		switch/default take transform [
			translate [
				enspace [
					"translate" uppercase form take transform
					"(" next form-value transform ")"
				]
			]
			rotate [
				enspace ["rotate(" next form-value transform ")"]
			]
			scale [
				enspace [
					"scale" either word? transform/1 [uppercase form take transform][""]
					"(" next form-number take transform none either tail? transform [""][
						"," form-number take transform none
					] ")"
				]
			]
		][keep mold head insert transform name]
	]

	form-values: func [values [block!]][
		rejoin collect [
			while [not tail? values][keep form-value values]
		]
	]

	form-property: func [property [word!] values [string! block!] /vendors /inline prefix][
		if block? values [values: form-values values]
		rejoin collect [
			if any [vendors found? find [transition box-sizing transform-style transition-delay] property][
				foreach prefix [-webkit- -moz- -ms- -o-][
					keep form-property to word! join prefix form property values
				]
			]
			if prefix [insert next values prefix]
			keep ["^/^-" property ":" values ";"]
		]
	]

	render: has [value][
		; sort/skip values 2
		while [value: take lengths][
			value: compose [(value)]
			case [
				not find values 'width [set 'width value]
				not find values 'height [set 'height value]
			]
		]
		while [value: take colors][
			value: compose [(value)]
			case [
				not find values 'color [set 'color value]
				not find values 'background-color [set 'background-color value]
			]
		]
		rejoin collect [
			keep "{"
			foreach [property values] values [
				case [
					find [opacity] property [
						if tail? next values [insert values '*]
					]
					all [
						property = 'background-image
						find [radial linear] values/1
					][
						foreach prefix [-webkit- -moz- -ms- -o-][
							keep form-property/inline property copy values prefix
						]
					]
					
				]
				switch/default property [][
					keep form-property property values
				]
			]
			foreach transform transformations [
				transform: form-transform transform
				keep form-property/vendors 'transform transform
			]
			unless empty? transitions [
				keep form-property/vendors 'transition rejoin next collect [
					foreach transition transitions [
						keep ","
						keep form-values transition
					]
				]
			]
			keep "^/}"
		]
	]

	new: does [
		make self [
			values: copy []
			colors: copy []
			lengths: copy []
			; dimensions: copy []
			; images: copy []
			transitions: copy []
			transformations: copy []
			spacing: copy []
		]
	]
]

parser: context [
	google-fonts-base-url: http://fonts.googleapis.com/css?family=

	; Storage
	reset?: false
	rules: []
	google-fonts: []

	; Basic Types
	zero: use [zero][
		[set zero integer! (zero: either zero? zero [[]][[end skip]]) zero]
	]
	em: ['em number! | zero]
	pt: ['pt number!]
	px: [opt 'px number!]
	deg: ['deg number! | zero]
	scalar: ['* number! | zero]
	percent: ['pct number! | zero]
	vh: ['vh number! | zero]
	vw: ['vw number! | zero]
	color: [tuple! | named-color | 'transparent]
	time: [time!]
	pair: [pair!]
	binary: [end skip] ; [path! binary!] ; omitted until considered safe
	image: [binary | file! | url!]

	; Optionals
	named-color: [
		'aqua | 'black | 'blue | 'fuchsia | 'gray | 'green |
		'lime | 'maroon | 'navy | 'olive | 'orange | 'purple |
		'red | 'silver | 'teal | 'white | 'yellow
	]
	text-style: ['bold | 'italic | 'underline]
;	border-style: ['solid | 'dotted | 'dashed]
	overflow-style: [
		'visible | 'hidden | 'scroll | 'auto | 'initial | 'inherit
	]
	border-style: [ 
		'none | 'hidden | 'dotted | 'dashed | 'solid | 'double | 
		'groove | 'ridge | 'inset | 'outset | 'initial
	]
	transition-attribute: [
		  'width | 'height | 'top | 'bottom | 'right | 'left | 'z-index
		| 'background | 'color | 'border | 'opacity | 'margin
		| 'transform | 'font | 'indent | 'spacing
	]
	list-styles: [
		  'disc | 'circle | 'square | 'decimal | 'decimal-leading-zero
		| 'lower-roman | 'upper-roman | 'lower-greek | 'lower-latin
		| 'upper-latin | 'armenian | 'georgian | 'lower-alpha | 'upper-alpha
	]
	direction: ['x | 'y | 'z]
	position-x: ['right | 'left | 'center]
	position-y: ['top | 'bottom | 'middle | 'center]	; NOTE[BB]: Is 'middle valid value?
	position: [position-y | position-x]
	positions: [position-x position-y | position-y position-x | position-y | position-x]
	repeats: ['repeat-x | 'repeat-y | 'repeat ['x | 'y] | 'no-repeat | 'no 'repeat]
	font-name: [string! | 'sans-serif | 'serif | 'monospace]
	length: [em | pt | px | percent | vh | vw]
	angle: [deg]
	number: [scalar | number!]
	box-model: ['block | 'inline 'block | 'inline-block]

	; Capture/Use System
	; parse block [mark ... capture (:captured)]
	mark: capture: captured: none
	use [start extent][
		mark: [start:]
		capture: [extent: (new-line/all captured: copy/part start extent false)]
	]
	emit: func [name [word!] value [any-type!]][
		value: compose [(value)]
		; change all the non-standard words
		foreach [from to][
			[no repeat] 'no-repeat
			[no bold] 'normal
			[no italic] 'normal
			[no underline] 'none
			[inline block] 'inline-block
			[line height] 'line-height
		][
			replace value from to
		]
		current/set name value
	]
	emits: func [name [word!]][
		emit name captured
	]

	; The All-Powerful Selector Rule
	; Must be a way to simplify this.
	selector: use [
		dot-word primary qualifier
		form-element form-selectors
		out selectors selector
	][
		dot-word: use [word continue][
			; Matches only words that begin .something
			[
				set word word!
				(continue: either #"." = take form word [[]][[end skip]])
				continue
			]
		]

		primary: [tag! | issue! | dot-word]
		qualifier: [primary | get-word!]

		form-element: func [element [tag! issue! word! get-word!]][
			either tag? element [to string! element][mold element]
		]

		form-selectors: func [selectors [block!]][
			selectors: collect [
				parse selectors [
					some [mark some qualifier capture (keep/only captured)
					| word! capture (keep captured)]
				]
			]

			selectors: collect [
				while [find selectors 'and][
					keep/only copy/part selectors selectors: find selectors 'and
					selectors: next selectors
				] keep/only copy selectors
			]

			selectors: map-each selector selectors [
				collect [
					foreach selector reverse collect [
						while [find selector 'in][
							keep/only copy/part selector selector: find selector 'in
							keep 'has
							selector: next selector
						] keep/only copy selector
					][keep selector]
				]
			]

			selectors: collect [
				foreach selector selectors [
					parse selector [
						set selector block! (selector: map-each element selector [form-element element])
						any [
							'with mark block! capture (
								selector: collect [
									foreach selector selector [
										foreach element captured/1 [
											keep join selector form-element element
										]
									]
								]
							) |
							'has mark block! capture (
								selector: collect [
									foreach selector selector [
										foreach element captured/1 [
											keep rejoin [selector " " form-element element]
										]
									]
								]
							)
						]
					]
					keep/only selector
				]
			]

			rejoin remove collect [
				foreach selector selectors [
					foreach rule selector [
						keep "," keep "^/"
						keep rule
					]
				]
			]
		]

		selector: [
			some primary any [
				  'with some qualifier
				| 'in some primary
				| 'and selector
			]
		]

		[
			mark
			some primary any [
				  'with some qualifier
				| 'in some primary
				| 'and selector
			] capture
			(repend rules [form-selectors captured current: ruleset/new])
		]
	]

	; Each of the Properties fully BNFed
	property: [
		  mark box-model capture (emits 'display)
		| 'z-index mark number capture (emits 'z-index)
		| 'content mark string! capture (emits 'content)
		| mark 'border-box capture (emits 'box-sizing)
		| 'min some [
			  'width mark length capture (emits 'min-width)
			| 'height mark length capture (emits 'min-height)
		]
		| 'max some [
			  'width mark length capture (emits 'max-width)
			| 'height mark length capture (emits 'max-height)
		]
		| mark ['min-width | 'min-height | 'max-width | 'max-height] length capture (emits take captured)
		| 'height mark [length | 'auto] capture (emits 'height)
		| 'width mark [length | 'auto]capture (emits 'width)
		| 'margin [
			mark [
				  1 2 [length opt [length | 'auto]]
				| pair opt [length | pair]
			] capture (emits 'margin)
			|
		] any [
			  'top mark length capture (emits 'margin-top)
			| 'bottom mark length capture (emits 'margin-bottom)
			| 'right mark [length | 'auto] capture (emits 'margin-right)
			| 'left mark [length | 'auto] capture (emits 'margin-left)
		]
		| 'padding [
			mark [
				  1 4 length
				| pair opt [length | pair]
			] capture (emits 'padding)
			|
		] any [
			  'top mark length capture (emits 'padding-top)
			| 'bottom mark length capture (emits 'padding-bottom)
			| 'right mark [length | 'auto] capture (emits 'padding-right)
			| 'left mark [length | 'auto] capture (emits 'padding-left)
		]
		| 'border any [
			  mark 1 4 border-style capture (emits 'border-style)
			| mark 1 4 color capture (emits 'border-color)
			| 'top any [
				  mark length capture (emits 'border-top-width)
				| mark border-style capture (emits 'border-top-style)
				| mark color capture (emits 'border-top-color)
			]
			| 'bottom any [
				  mark length capture (emits 'border-bottom-width)
				| mark border-style capture (emits 'border-bottom-style)
				| mark color capture (emits 'border-bottom-color)
			]
			| 'right any [
				  mark length capture (emits 'border-right-width)
				| mark border-style capture (emits 'border-right-style)
				| mark color capture (emits 'border-right-color)
			]
			| 'left any [
				  mark length capture (emits 'border-left-width)
				| mark border-style capture (emits 'border-left-style)
				| mark color capture (emits 'border-left-color)
			]
			| 'radius [
				some [
					  'top mark 1 2 length capture (
						emits 'border-top-left-radius
						emits 'border-top-right-radius
					)
					| 'bottom mark 1 2 length capture (
						emits 'border-bottom-left-radius
						emits 'border-bottom-right-radius
					)
					| 'right mark 1 2 length capture (
						emits 'border-top-right-radius
						emits 'border-bottom-right-radius
					)
					| 'left mark 1 2 length capture (
						emits 'border-top-left-radius
						emits 'border-bottom-left-radius
					)
					| 'top 'right mark 1 2 length capture (emits 'border-top-right-radius)
					| 'top 'left mark 1 2 length capture (emits 'border-top-left-radius)
					| 'bottom 'right mark 1 2 length capture (emits 'border-bottom-right-radius)
					| 'bottom 'left mark 1 2 length capture (emits 'border-bottom-left-radius)
				]
				| mark 1 2 length capture (emits 'border-radius)
			]
			| mark 1 4 length capture (emits 'border-width)
		]
		| ['radius | 'rounded] mark length capture (emits 'border-radius)
		| 'rounded (emit 'border-radius [em 0.6])
		| 'outline any [
			  mark 1 4 border-style capture (emits 'outline-style)
			| mark 1 4 color capture (emits 'outline-color)
			| mark 1 4 length capture (emits 'outline-width)
		]
		| 'overflow mark overflow-style capture (emits 'overflow)
		| 'font any [
			  mark length capture (emits 'font-size)
			| mark some font-name capture (
				captured
				remove head forskip captured 2 [insert captured '|]
				emits 'font-family
			)
			| mark color capture (emits 'color)
			| 'line 'height mark number capture (emits 'line-height)
			| 'spacing mark number capture (emits 'letter-spacing)
			| 'shadow mark pair length color capture (emits 'text-shadow)
			| mark ['lighter | 'bolder] capture (emits 'font-weight)
			| mark opt 'no 'bold capture (emits 'font-weight)
			| mark opt 'no 'italic capture (emits 'font-style)
			| mark opt 'no 'underline capture (emits 'text-decoration)
			| ['line-through | 'strike 'through] (emit 'text-decoration 'line-through)
		]
		| 'text 'indent mark length capture (emits 'text-indent)
		| 'line 'height mark [length | scalar] capture (emits 'line-height)
		| 'spacing mark number capture (emits 'letter-spacing)
		| mark opt 'no 'bold capture (emits 'font-weight)
		| 'weight mark number capture (emits 'font-weight)
		| mark opt 'no 'italic capture (emits 'font-style)
		| mark opt 'no 'underline capture (emits 'text-decoration)
		| ['line-through | 'strike 'through] (emit 'text-decoration 'line-through)
		| 'shadow mark pair length color capture (emits 'box-shadow)
		| 'color mark [color | 'inherit] capture (emits 'color)
		| mark ['relative | 'absolute | 'fixed] capture (emits 'position) any [
			  'top mark length capture (emits 'top)
			| 'bottom mark length capture (emits 'bottom)
			| 'right mark length capture (emits 'right)
			| 'left mark length capture (emits 'left)
		]
		| 'opacity mark number capture (emits 'opacity)
		| mark 'nowrap capture (emits 'white-space)
		| mark 'center capture (emits 'text-align)
		| 'transition any [
			mark transition-attribute time opt time capture (
				append/only current/transitions captured
			)
		]
		| [
			  'delay mark time capture (emits 'transition-delay)
			| mark time opt time transition-attribute capture (
				append/only current/transitions head reverse next reverse captured
			)
			| mark time capture (emits 'transition)
		]
		| some [
			mark [
				  'translate direction length
				| 'rotate angle opt ['origin percent percent]
				| 'scale [['x | 'y] number | 1 2 number]
			] capture (append/only current/transformations captured)
		]
		| mark 'preserve-3d capture (emits 'transform-style)
		| 'hide (emit 'display none)
		| 'float mark ['none | position-x] capture (emits 'float)
		| 'opaque (emit 'opacity 1)
		| mark 'pointer capture (emits 'cursor)
		| ['canvas | 'background] any [
			  mark color capture (emits 'background-color)
			| mark [file! | url!] (emits 'background-image)
			| mark positions capture (emits 'background-position)
			| mark repeats capture (emits 'background-repeat)
			| mark ['contain | 'cover | 1 2 [length | 'auto]] capture (emits 'background-size)
			| mark ['scroll | 'fixed | 'local] capture (emits 'background-attachment)
			| mark pair capture (
				captured: first captured
				emit 'background-position reduce [
					'pct to integer! captured/x
					'pct to integer! captured/y
				]
			)
		]

		| mark [
			'radial color color capture (
				insert at captured 3 '|
			)
			| 'linear angle color color capture (
				insert at tail captured -2 '|
				insert at tail captured -1 '|
			)
			| 'linear opt 'to positions color color capture (
				unless 'to = captured/2 [insert next captured 'to]
				insert at tail captured -2 '|
				insert at tail captured -1 '|
			)
		] (emits 'background-image)

		; | mark binary capture (emits 'background-image) any [
		; 	  mark positions capture (emits 'background-position)
		; 	| mark repeats capture (emits 'background-repeat)
		; ]
		| mark image capture (emits 'background-image) any [
			  mark positions capture (emits 'background-position)
			| mark pair capture (
				captured: first captured
				emit 'background-position reduce [
					'pct to integer! captured/x
					'pct to integer! captured/y
				]
			)
			| mark repeats capture (emits 'background-repeat)
			| mark ['contain | 'cover] capture (emits 'background-size)
		]
		| 'no ['list opt 'style | 'bullet] (emit 'list-style-type 'none)
		| opt ['list opt 'style | 'bullet] mark list-styles capture (emits 'list-style-type)
		| mark ['inside | 'outside] capture (emits 'list-style-position)

		; Any Singleton Values
		| mark [
			  length capture (append/only current/lengths captured)
			| some color capture (append current/colors captured)
			| time capture (emits 'transition)
			| pair capture (
				emit 'width captured/1/x
				emit 'height captured/1/y
			)
		]
	]

	; Control
	current: value: none
	errors: copy []

	; Format Description
	dialect: [()
		opt ['css/reset (reset?: true)]
		opt [
			'google 'fonts [
				some [
					copy value [string! any issue!]
					(append/only google-fonts value)
					|
					set value url! (
						all [
							value: find/match value google-fonts-base-url
							append google-fonts value
						]
					)
				]
			]
		]

		[selector | (repend rules [["body"] current: ruleset/new])]

		any [
			selector | property

			| set value skip (append errors rejoin ["MISPLACED TOKEN: " mold value])
		]
	]

	; CSS Reset Stylesheet
	reset: to string! decompress 64#{
	eJyNU7Fu2zAQncOvIAwUaQ0pkt0mg4x27pBu3YoMpHiSWFOkTFIOnDT/3kfJNtyi
	RQKI4pF8vHv37lgseRfjUBVFTwfyjyRvatcX5HVdROdMKOoQCk+BYsEZ53y/vin5
	L74uV6tytb5LW/e6Jhuo4tZZ4u+HURpdc+V6oe0HtiwY62JvMi6dOmRc6X3GwyBs
	xsUwGIoZd/In1Zh140VPGetWGe/WGB8xPmHcYtxlfIAP4+rtbnSRsPTACriR0uNf
	e2cPPQylwDcAq9uM1zpBa6eAVQQWqkFkAk73ONYWwK1UGd+BFT7RDxkLvTCAhuj1
	lqbZWYDDKNMPNCLY7oXPGDZGeEEEspGwoVIInCq4dLBHDKMz1jiPmEbIxEGOMTrQ
	KJaNJqNCEsFQS1ZlkCsKaRJnMUSdUHEWLjbOARc7EvAdfTIxFDTwUdfpighaTTft
	XiAZRVFoE1K6knCHNbodIRrHfPaevII4T26nufUupch6skjNCpTLjXEYEduPEkQC
	ijVdDWPfC3/IWNQoG4e9BYdRaQd1wMTxZ3aF3VbbipcbdjWgNtq280I6j4Cz3Tgb
	86Cf0ESrsnx33KlQng6tGLHeU0pSmFwY3cKdFIGMtrRhL6xY8q/fv93forfCYMQh
	984Qn5oW6XnUAYG49O4xkA8cEv+t2FmpP5Q5qsX+J9GFQkdNUsJHEtXcq4lfql86
	SXzzjnTbIbVVOpk7ZD4LUCAezPEdTfcumn2XQJMd/gWoJCFTunwglWimjtydz3bz
	VvJUQ15KCl9fby5WJ8dTCybcXKS8dsaIIb3xk3UuYI63XJ+K+sLY3NtVlffuKW9c
	PYZcW5uIaIsm+hEPA31eTMVZPLwGm529jsPL7PUb/DXa0OKBf+FvC8Kfj01abk6t
	W26ODV1ukOxvKxG8Kj8FAAA=
	} 'zlib

	; Output
	render: does [
		rejoin collect [
			keep {/* StyleTalk Output */^/}
			if all [
				block? google-fonts
				not empty? google-fonts
			][
				keep "^/@import url ('"
				keep mold join google-fonts-base-url collect [
					repeat font length? google-fonts [
						unless font = 1 [keep "|"]
						case [
							url? google-fonts/:font [
								keep google-fonts/:font
							]
							block? google-fonts/:font [
								keep replace/all mold to url! take google-fonts/:font "%20" "+"
								repeat variant length? google-fonts/:font [
									keep back change to url! mold google-fonts/:font/:variant either variant = 1 [":"][","]
								]
							]
						]
					]
				]
				keep "');^/"
			]
			if reset? [
				keep "^//** CSS Reset Begin */^/^/"
				keep reset
				keep "/* CSS Reset End **/^/"
			]
			keep "^//** StyleTalk Output Begin */^/^/"
			foreach [selector rule] rules [
				keep selector
				keep " "
				keep rule/render
				keep "^/"
			]
			keep "^/^//* StyleTalk Output End **/^/"
		]
	]

	; Is Modular
	new: does [
		make parser [
			reset?: false
			google-fonts: copy []
			rules: copy []
			errors: copy []
			current: ruleset/new
			value: none
		]
	]
]

??: use [mark][[mark: (probe new-line/all copy/part mark 8 false)]]

to-css: func [dialect [file! url! string! block!] /local out][
	case/all [
		file? dialect [dialect: load dialect]
		url? dialect [dialect: load dialect]
		string? dialect [dialect: load dialect]
		not block? dialect [make error! "No Dialect!"]
	]

	out: parser/new
	if parse dialect out/dialect [
		out/render
	]
]

]