├── LICENSE ├── README.md ├── assert.red ├── block-magic.red ├── iterator.red ├── profiler.red ├── pure-fun-test.red └── pure-fun.red /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2018 hiiamboris@gmail.com 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # red-pure-fun 2 | ## Purely functional DSL for Red 3 | 4 | This is an experiment in building a dialect that will: 5 | - allow computing pure expressions in the middle of Red code 6 | 7 | point is: when one sees a pure invocation, one is 100% sure it didn't shoot his ducks 8 | - do so in a declarative, orderless manner 9 | 10 | point is: tell the parser how X and Y and so and so can be computed and let it decide for itself if it needs to compute them and in what order 11 | - allow using recursive expressions, leveraging tail-call optimization when possible 12 | 13 | point is: get rid of loops to achieve better conciseness and readability of the code 14 | - be very simple, no sophisticated type inference (as a result, no laziness), just the bare minimum 15 | 16 | ## quick start 17 | 18 | download, run pure-fun-test.red, the test is the best explanation ;) 19 | 20 | some more info is in the file headers too 21 | 22 | ## status 23 | 24 | early alpha 25 | 26 | proves the concept, fun to play with, still slow but already can map() over 1k items 27 | 28 | might have lots of bugs yet 29 | 30 | syntax is a subject to change at any time 31 | 32 | ## syntax 33 | 34 | best shown by the examples in pure-fun-test.red 35 | 36 | but here's some short one: 37 | ``` 38 | paren-join: func [x y] [ as paren! append (copy to-block x) y ] 39 | 40 | rules: [ 41 | head b: => [ :first b ] 42 | rest b: => [ :next b ] 43 | x: ~ y: => [ :paren-join x y ] ;-- (thing ~ thing) concatenates 2 paren expressions into one 44 | x: + y: => [ :add x y ] 45 | impure-join b: x: => [:append/only b x] 46 | map _ [] => [[]] 47 | map f: b: => [map-tco (:copy []) f b] 48 | map-tco c: _ [] => [c] 49 | map-tco c: f: b: => [ 50 | map-tco (impure-join c (f ~ head b)) f (rest b) 51 | ] 52 | ] 53 | eval/using [ 54 | map (1 +) [1 2 3] 55 | ] rules 56 | ``` 57 | should return: `[2 3 4]` 58 | 59 | `eval` is given an expression that is matched against a set of patterns specified by `rules` 60 | 61 | #### in the pattern: 62 | 63 | words are matched as is (incl. ~ and +) 64 | 65 | anything except words is matched as is (1, 2, [], "string", you name it) 66 | 67 | set-words (x: y: ...) are catch-all patterns that match anything but words and use it as a named argument 68 | 69 | a repeated set-word (f: x: y: x:) only matches it's first bound value 70 | 71 | _ is a catch-all pattern that matches anything but words, without binding it 72 | 73 | #### in the expression: 74 | 75 | get-words are used to call normal Red functions from the global context 76 | 77 | ## evaluation order 78 | 79 | is similar to Red/Rebol: subexpressions come first 80 | 81 | suppose I have an expression `a b c d`, then it is evaluated in the following order: 82 | ``` 83 | a 84 | b 85 | a b 86 | c 87 | b c 88 | a b c 89 | d 90 | c d 91 | b c d 92 | a b c d 93 | ``` 94 | 95 | if at some point, a pattern matches, say, at `b c`, 96 | the subpattern gets replaced with the result of the subexpression specified by the rule 97 | and it becomes `a rslt d` and continues with `a rslt`, `d`, `rslt d`, `a rslt d`... 98 | 99 | an expression is being evaluated until either: 100 | - it's a singular value like 1 or [block] 101 | - it's end is hit and there are no matches 102 | 103 | in the latter case if expr consists of more than 1 token, it is enclosed into parens 104 | - as in the example above with (1 +): there's no pattern that can match `1 +` so it's passed as a value 105 | 106 | then `map` function uses `~` to glue the two paren-expressions `1 +` and `2` into `1 + 2` that triggers a summing pattern 107 | 108 | 109 | 110 | 111 | 112 | 113 | 114 | 115 | 116 | 117 | 118 | 119 | -------------------------------------------------------------------------------- /assert.red: -------------------------------------------------------------------------------- 1 | Red [ 2 | title: "Assert function for contract programming" 3 | file: %assert.red 4 | author: hiiamboris@gmail.com 5 | tabs: 2 6 | license: 'MIT 7 | usage: { 8 | `? assert` should help 9 | uncomment the line at the end to disable assertions 10 | } 11 | ] 12 | 13 | 14 | 15 | #include %block-magic.red 16 | 17 | unless attempt [get in system/words 'assert] [ 18 | 19 | assert: function [ 20 | "Yer typical assertion" 21 | contract [block!] "contract" 22 | /comment { 23 | contract can have one the of 3 formats: 24 | [condition "error message"] 25 | [condition 'word-to-blame] 26 | [condition] <- in this case last word of condition is blamed} 27 | /local tmp 28 | ][ 29 | set [cond msg] tmp: block-magic/transmute contract ;-- TODO: replace this with `reduce contract` when GC is available 30 | unless cond [ 31 | print ["ASSERTION FAILURE:" mold contract] 32 | either string? msg [ 33 | cause-error 'script 'invalid-arg [msg] 34 | ][ 35 | if none? msg [msg: last contract] 36 | cause-error 'script 'invalid-refine-arg [msg mold/part/flat get msg 1024] 37 | ] 38 | ] 39 | block-magic/dispel tmp 40 | ] 41 | 42 | assert: :comment ;-- uncomment to disable assertions 43 | 44 | 45 | ] -------------------------------------------------------------------------------- /block-magic.red: -------------------------------------------------------------------------------- 1 | Red [ 2 | title: "Free list of blocks/strings + simplest GC" 3 | file: %block-magic.red 4 | author: hiiamboris@gmail.com 5 | tabs: 2 6 | license: 'MIT 7 | purpose: "Avoid allocations when necessary" 8 | usage: { 9 | `conjure` instead of `copy []` 10 | `dispel` frees the block and inserts into a free list 11 | `transmute` instead of `reduce` 12 | `forge` instead of `copy` (supports /part refinement) 13 | } 14 | ] 15 | 16 | 17 | unless value? 'block-magic [ 18 | 19 | ;-- this here magic is to avoid allocations in absence of the GC -- 20 | ; I intentionally avoid make/free/reduce names, 21 | ; otherwise it's so easy to run into weirdest bugs possible 22 | ; plus compiler complains, and does so rightfully 23 | 24 | do reduce [has [type type! title] [ 25 | foreach type [block string] [ 26 | type!: to-word append form type "!" 27 | title: to-word append form type "-magic" 28 | do compose/deep [ 29 | (to-set-word title) context [ 30 | mana: [] ; free to use blocks/strings 31 | garbage: [] ; blocks/strings that should not live long 32 | prototype: (either type = 'block [[[]]][[""]]) ; for cloning 33 | 34 | conjure: does [ any [ take/last mana copy prototype ] ] ;-- allocate 35 | dispel: func [srs [(type!)]] [ append/only mana clear head srs ] ;-- free 36 | (either type = 'block [compose/deep [ ;-- reduce, for block only 37 | transmute: func [srs [(type!)]] [ head reduce/into srs conjure ] 38 | ]] []) 39 | forge: func [srs [(type!)] /part size [integer! (type!)]] [ ;-- copy 40 | append/part conjure srs any [size -1] 41 | ] 42 | 43 | to-garbage: func [srs [(type!)]] [ 44 | ; the cost of now/time is ~1us or 4x block picks 45 | append/only append garbage now/precise/time srs 46 | srs 47 | ] 48 | sweep: function [][ 49 | t0: now/precise/time - 0:0:10 ; allow 10 secs of roam around 50 | gr: garbage 51 | while [all [gr/1 gr/1 < t0]] [dispel gr/2 gr: skip gr 2] 52 | remove/part garbage gr 53 | ] 54 | 55 | methods: collect [foreach w keys-of self [if function? get/any :w [keep :w]]] 56 | 57 | ; only works for 'system or when set-words are already defined 58 | import: func [/into c /local w] [ 59 | c: any [c system/words] 60 | foreach w get bind 'methods (title) [ set bind :w :c get bind :w (title) ] 61 | ] 62 | 63 | ; for: make object! append list-imports [ .. ] 64 | list-imports: has [w] [ 65 | collect [ foreach w methods [keep to-set-word :w keep compose [get in (title) ([(to-lit-word :w)])]] ] 66 | ] 67 | ] 68 | ] 69 | ] 70 | ]] 71 | 72 | ] 73 | -------------------------------------------------------------------------------- /iterator.red: -------------------------------------------------------------------------------- 1 | Red [ 2 | title: "General purpose forward iterator" 3 | file: %iterator.red 4 | author: hiiamboris@gmail.com 5 | tabs: 2 6 | license: 'MIT 7 | purpose: "Iterate over arbitrary data, hide the format of that data and the iterator implementation details from the code using it" 8 | usage: { 9 | rollin' [x y z] over-stuff [... your code here ...] 10 | or, when decoupling is undesirable 11 | rollin' 'word over-stuff [ 12 | set [x y z] word 13 | ... your code here ... 14 | ] 15 | The contents of 'word or [x y z] is up to the iterator. 16 | To prepare it, make a generator that builds over `iterator/forward`. 17 | 18 | Example: 19 | 20 | over-even-items: func [b [series!]] [ 21 | make (iterator/forward) [ 22 | ;-- subject field will be set by 23 | subject: b 24 | 25 | ;-- reads & returns the data to the user, or unset! if no data 26 | ;-- hint: do [] returns unset! 27 | ;-- hint2: it is the iterator-self (to avoid rebinding the func body, which is slow) 28 | retrieve: func [it] [ 29 | also 30 | either 2 <= length? it/subject [it/subject/2][do []] 31 | it/subject: skip it/subject 2 32 | ] 33 | ] 34 | ] 35 | 36 | >> rollin' 'x over-even-items [1 2 3 4 5] [print [x "HERE!"]] 37 | 2 HERE! 38 | 4 HERE! 39 | } 40 | ] 41 | 42 | 43 | #include %assert.red 44 | #include %profiler.red 45 | 46 | if unset? :iterator [ 47 | 48 | ; general forward iterator format: 49 | iterator: context [ 50 | 51 | free-list: [] 52 | release: func [it [object!]] [append free-list it] 53 | 54 | ; since bind is super slow, I decided to pass the iterator as a parameter to retrieve 55 | ; this way any new iterator can be created without a 'bind' invocation 56 | forward: func ["Constructs a new iterator"] [ 57 | any [ 58 | take/last free-list 59 | context [ 60 | retrieve: func [it][] ; reads the current item and advances the iterator, returns unset! when no data 61 | subject: none ; the stuff that's being iterated over, any format 62 | ] 63 | ] 64 | ] 65 | 66 | iterator!: :object! ; just a type, can't do a better check in func specs 67 | 68 | ;-- better check 69 | iterator?: func [x][ 70 | all [ 71 | object? x 72 | in x 'retrieve 73 | in x 'subject 74 | ] 75 | ] 76 | 77 | ; rollin' 'x over stuff [...] 78 | ; rollin' [x y z] over stuff [...] 79 | ; BUG: 'return' from inside the body will only terminate the loop, but the workaround is slower 80 | profiler/count/* 81 | rollin': func [ 82 | "Iterate over arbitrary data" 83 | parts [block! word!] "data receiver" 84 | it [object!] "iterator" 85 | code [block!] "what to do" 86 | /keep "don't call release on the iterator" 87 | /local r 88 | ] [ 89 | assert [iterator? it] 90 | set/any 'r forever [ 91 | if unset? set/any parts (it/retrieve it) [break/return :r] 92 | ; profiler/stop rollin' 93 | set/any 'r do code 94 | ; profiler/start rollin' 95 | ] ; in case of break/return it's value is propagated up 96 | unless keep [release it] 97 | :r 98 | ] 99 | 100 | assert [none? rollin' 'x forward []] 101 | ] 102 | 103 | iterator?: :iterator/iterator? 104 | rollin': :iterator/rollin' 105 | 106 | 107 | ] -------------------------------------------------------------------------------- /profiler.red: -------------------------------------------------------------------------------- 1 | Red [ 2 | title: "Basic runtime profiler" 3 | file: %profiler.red 4 | author: hiiamboris@gmail.com 5 | tabs: 2 6 | license: 'MIT 7 | purpose: "Time the execution of individual (selected) scopes, display the results" 8 | usage: { 9 | Higher-level wrapper. Prefix any function with a `profiler/count`: 10 | profiler/count f: func [x y z] [g [x y z]] 11 | profiler/count g: func [x] [print x] 12 | loop 1000 [f 1 2 3] 13 | profiler/show 14 | 15 | On /* refinementof profiler/count: 16 | With /* the profiled function should use `return* value` instead of `return value`. 17 | Without /* it can use `return` but should not define (and call) any inner functions that use `return`, 18 | otherwise those inner functions will terminate the profiled function instead. 19 | 20 | Lower-level: 21 | f: does [ 22 | profiler/start 'f-func 23 | ...some weird code... 24 | g 25 | ...more badass code... 26 | profiler/stop 'f-func 27 | ] 28 | g: does [ 29 | profiler/start 'g-func 30 | ...wow another magic... 31 | profiler/stop 'g-func 32 | ] 33 | profiler/show 34 | 35 | Do as many (recursive, nested) calls to f or g, their *individual* execution times will be counted. 36 | } 37 | ] 38 | 39 | 40 | #include %assert.red 41 | 42 | 43 | if unset? :profiler [ 44 | 45 | profiler: context [ 46 | times: context [] 47 | 48 | t0: 0:0 49 | stack: copy [] 50 | 51 | mark: func [/out /local name t b] [ 52 | t: now/time/precise 53 | if name: last stack [ 54 | unless in times :name [times: make times reduce [to-set-word name reduce [0:0 0]] ] 55 | b: times/:name 56 | b/1: b/1 + t - t0 57 | if out [b/2: b/2 + 1] ; don't count exit from an inner call as a call to this func 58 | ] 59 | ] 60 | 61 | start: func ['name] [ 62 | mark 63 | append/only stack name 64 | t0: now/time/precise 65 | ] 66 | 67 | stop: func ['name /local lastname] [ 68 | mark/out 69 | lastname: take/last stack 70 | assert [lastname = name] 71 | t0: now/time/precise 72 | ] 73 | 74 | count: func [ 75 | "Prefix any func with me to profile it" 76 | 'name [set-word!] "gotta have a name to account and display" 77 | func-def [function!] "func definition" 78 | /* {redefine return* instead of return: 79 | With /* the profiled function should use `return* value` instead of `return value`. 80 | Without /* it can use `return` but should not define (and call) any inner functions that use `return`, 81 | otherwise those inner functions will terminate the profiling function instead} 82 | /local return-name 83 | ] [ 84 | return-name: either * ['return*]['return] 85 | do compose [set (to-lit-word name) 86 | func append union spec-of :func-def [/local _stackdepth] return-name compose/only [ 87 | profiler/start (to-word name) 88 | _stackdepth: length? profiler/stack 89 | (to-set-word return-name) func [x][throw/name x 'return] 90 | set/any 'r catch/name (body-of :func-def) 'return 91 | if _stackdepth = length? profiler/stack (compose [profiler/stop (to-word name)]) 92 | :r 93 | ] 94 | ] 95 | ] 96 | 97 | show: function [] [ 98 | print "^/PROFILING STATS:" 99 | total: 0:0 100 | foreach blk values-of times [total: total + blk/1] 101 | total: max 0:0.001 total ; no zero division 102 | lines: copy [] 103 | foreach [name blk] body-of times [ 104 | set [time calls] blk 105 | percall: round/to 1e6 * (to-float time) / max 1 calls 0.1 106 | append/only lines reduce [ 107 | round/to (to-percent (time / total)) 0.1 "^-" 108 | pad name 24 109 | time "^-in" calls "calls^-" 110 | pad/left percall 7 "us/call" lf] 111 | ] 112 | append/only lines reduce [100% "^-" pad "* TOTAL *" 24 total "^/"] 113 | sort lines 114 | print lines 115 | ] 116 | 117 | ] 118 | 119 | ;-- this one is totally independent 120 | clock: func [ 121 | "Evaluate some code and display the time it took" 122 | code /local t1 t2 123 | ] [ 124 | t1: now/precise/time 125 | do code 126 | t2: now/precise/time 127 | print [(t2 - t1) mold/flat code] 128 | ] 129 | 130 | ] 131 | 132 | -------------------------------------------------------------------------------- /pure-fun-test.red: -------------------------------------------------------------------------------- 1 | Red [ 2 | title: "Tests for pure-fun.red" 3 | file: %pure-fun-test.red 4 | author: hiiamboris@gmail.com 5 | tabs: 2 6 | license: 'MIT 7 | purpose: {To kill the idea with the results} 8 | ] 9 | 10 | 11 | #include %pure-fun.red 12 | 13 | ;-- HERE BE TESTS 14 | 15 | test: func [tree expr rslt /local got] [ 16 | log-test ["testing" mold/flat expr "vs" mold/flat/part rslt 128] 17 | unless rslt = got: pure/eval/using expr tree [ 18 | print ["FAILED: test" mold/flat expr "resulted in" mold/flat got "instead of" mold/flat rslt] 19 | ] 20 | ] 21 | 22 | 23 | ;-- primitive the arithmetic is based upon 24 | mathop: func [op [word!] x [number! pair! date! time!] y [number! pair! date! time!] /local buf] [ 25 | buf: [x op y] 26 | buf/2: op 27 | do buf 28 | ] 29 | 30 | ;join: func [a [block!] b [block!]] [append copy a b] 31 | impure-join: func [a b] [append forge to-block a to-block b] 32 | paren-join: func [x y] [ as paren! append (forge to-block x) y ] ; COPY HERE (to-block) 33 | ;append-into: func [a [block!] x] [append/only a x] 34 | ;fold: func [c ] 35 | 36 | 37 | impure-map: function [scope [map!] f [block! paren!] b [block!]] [ 38 | r: forge b 39 | expr: conjure 40 | forall r [ 41 | expr: head change/only change expr :f :r/1 42 | change r pure/eval-full expr with scope 43 | ] 44 | dispel expr 45 | head r 46 | ] 47 | 48 | ;-- like this: f (f (f c b/1) b/2) b/3 49 | impure-foldl: function [scope [map!] f [block! paren!] c b [block!]] [ 50 | expr: conjure 51 | forall b [ 52 | expr: head change/only change/only change expr :f :c :b/1 53 | c: pure/eval-full expr with scope 54 | ] 55 | dispel expr 56 | c 57 | ] 58 | 59 | ;-- like this: f b/1 (f b/2 (f b/3 c)) 60 | impure-foldr: function [scope [map!] f [block! paren!] c b [block!]] [ 61 | expr: conjure 62 | limit: index? b 63 | b: tail b 64 | while [limit < index? b] [ 65 | b: back b 66 | expr: head change/only change/only change expr :f :b/1 :c 67 | c: pure/eval-full expr with scope 68 | ] 69 | dispel expr 70 | c 71 | ] 72 | 73 | eval-in-subscope: func [scope [map!] subscope [map!] expr [block!] /local backup] [ 74 | backup: pattern/scope-merge scope subscope 75 | also 76 | pure/eval/with expr scope 77 | (pattern/scope-swap scope backup 78 | dispel backup) 79 | ] 80 | 81 | 82 | 83 | arith: [ 84 | x: + y: => [ :mathop/3 '+ x y ] 85 | x: - y: => [ :mathop/3 '- x y ] 86 | x: * y: => [ :mathop/3 '* x y ] 87 | x: / y: => [ :mathop/3 '/ x y ] 88 | x: ** y: => [ :mathop/3 '** x y ] 89 | x: or y: => [ :mathop/3 'or x y ] 90 | x: and y: => [ :mathop/3 'and x y ] 91 | x: xor y: => [ :mathop/3 'xor x y ] 92 | negate x: => [ :negate/1 x ] 93 | ] 94 | 95 | test arith [0] 0 96 | test arith [1] 1 97 | test arith [1 + 1] 2 98 | test arith [1 + 2 * 3] 9 99 | test arith [1 + (2 * 3)] 7 100 | test arith [2 ** 10] 1024 101 | test arith [1.0 / 2 ** 2.0] 0.25 102 | test arith [50% / 2] 25% 103 | test arith [3x3 * 3] 9x9 104 | test arith [3x2 * 2x4] 6x8 105 | test arith [3x2 * 2x4] 6x8 106 | test arith [10:00 * 2] 20:00 107 | test arith [16 ** (3.0 / (2 * (1 + (1) + (1)) + 6))] 2.0 108 | test arith [:add :max 1 2 3] 5 109 | test arith [negate 10] -10 110 | 111 | 112 | matching: [ 113 | f 1 => [1] 114 | f _ => [0] 115 | g x: => [x] 116 | ] 117 | 118 | test matching [f 1] 1 119 | test matching [f 2] 0 120 | test matching [g 3] 3 121 | 122 | serial: [ 123 | s => [[1 2 3]] 124 | head b: => [ :first/1 b ] 125 | rest b: => [ :next/1 b ] 126 | x: ~ y: => [ :paren-join/2 x y ] ;-- (thing ~ thing) concatenates 2 paren expressions into one 127 | join x: y: => [:impure-join/2 x y] 128 | impure-join b: x: => [:append/only/2 b x] 129 | 130 | replicate-tco c: [] => [c] 131 | replicate-tco c: b: => [ 132 | replicate-tco (impure-join c (head b)) (rest b) 133 | ] 134 | 135 | map' _ [] => [[]] 136 | map' f: b: => [map-tco (:block-magic/conjure/0) f b] 137 | map-tco c: _ [] => [c] 138 | map-tco c: f: b: => [ map-tco (impure-join c (f ~ head b)) f (rest b) ] 139 | 140 | map f: b: => [:impure-map/3 _scope_ f b] 141 | 142 | foldl' _ c: [] => [c] 143 | foldl' f: c: b: => [ 144 | foldl' f (f ~ (c head b)) (rest b) 145 | ] 146 | 147 | foldl f: c: b: => [ :impure-foldl/4 _scope_ f c b ] 148 | foldr f: c: b: => [ :impure-foldr/4 _scope_ f c b ] 149 | 150 | ; wow, a fork! 151 | if false then _ else y: => [y] 152 | if 0 then _ else y: => [y] 153 | if _ then x: else _ => [x] 154 | 155 | ; or like this 156 | either false _ y: => [y] 157 | either true x: _ => [x] 158 | either 0 _ y: => [y] 159 | either _ x: _ => [x] 160 | 161 | x: = x: => [true] 162 | x: = _ => [false] 163 | 164 | true? 0 => [false] 165 | true? false => [false] 166 | true? true => [true] 167 | true? _ => [true] 168 | 169 | odd? x: => [0 = (x and 1)] 170 | even? x: => [1 = (x and 1)] 171 | 172 | ; takes a block, evaluates as an expr 173 | eval x: => [:to-paren/1 x] 174 | 175 | split even: odd: [] => [ even odd ] 176 | split even: odd: xs: => [ 177 | eval either (1 and (head xs)) 178 | [ split even (join odd head xs) (rest xs) ] 179 | [ split (join even head xs) odd (rest xs) ] 180 | ] 181 | 182 | split' even: odd: [] => [ even odd ] 183 | split' even: odd: xs: => [ 184 | eval either (even? (head xs)) 185 | [ split' even (join odd head xs) (rest xs) ] 186 | [ split' (join even head xs) odd (rest xs) ] 187 | ] 188 | 189 | split'' even: odd: xs: => [ [ sp even odd xs ] 190 | using [ 191 | sp even: odd: [] => [even odd] 192 | sp even: odd: xs: => [sp even2 odd2 r] 193 | even2 => [eval either even? h [even][join even h]] 194 | odd2 => [eval either even? h [join odd h][odd]] 195 | h => [head xs] 196 | r => [rest xs] 197 | ] 198 | ] 199 | 200 | ; it's faster to precompile a set of patterns once than upon every call 201 | rules def: => [:pattern/compile/1 def] 202 | 203 | expr: using def: => [ 204 | :eval-in-subscope/3 _scope_ (rules def) expr 205 | ] 206 | 207 | ; short-circuits: expr1 | [expr2 | [expr3 ...]] 208 | true | _ => [true] 209 | false | b: => [eval b] 210 | 211 | sum x: y: => [x + y] 212 | 213 | loop 0 => [0] 214 | loop n: => [loop (n - 1)] 215 | 216 | f => [1 +] 217 | dup 0 b: => [b] 218 | dup n: b: => [dup (head b) (rest b)] 219 | ] 220 | 221 | test serial [[]] [] 222 | test serial [head [1]] 1 223 | test serial [head [1 2 3]] 1 224 | test serial [head [[1] [2] [3]]] [1] 225 | test serial [head head [[1] [2] [3]]] 1 226 | test serial [z x c] to-paren [z x c] 227 | test serial [(1 2) ~ (3)] to-paren [1 2 3] 228 | test serial [(1 2) ~ 3] to-paren [1 2 3] 229 | test serial [(1 2) ~ 3 ~ 4] to-paren [1 2 3 4] 230 | test serial [(1 2) ~ (3 4)] to-paren [1 2 3 4] 231 | test serial [1 ~ 2] to-paren [1 2] 232 | test serial [(1 (2)) ~ ((3))] to-paren [1 2 3] 233 | test serial [(1 (2 3)) ~ ((4 5) 6)] to-paren [1 (2 3) (4 5) 6] 234 | test serial [(head s) ~ (rest s)] to-paren [1 2 3] 235 | test serial [join [1 2 3] 4] [1 2 3 4] 236 | test serial [join 1 (2 3)] [1 2 3] 237 | 238 | hybrid: append copy arith serial 239 | ;log-eval: :print 240 | ;test hybrid [loop 10] 0 241 | ;print " --------- ---------------------- ------------------ " 242 | ;test hybrid [dup 2 (:copy [3 2 1 0])] [] 243 | test hybrid [map-tco (:copy []) [negate] [1 2 3]] [-1 -2 -3] 244 | test hybrid [map-tco (:copy []) (1 +) [1 2 3]] [2 3 4] 245 | test hybrid [map-tco (:copy []) [1 +] [1 2 3]] [2 3 4] 246 | test hybrid [map [negate] [1 2 3]] [-1 -2 -3] 247 | test hybrid [map (1 +) [1 2 3]] [2 3 4] 248 | test hybrid [map [1 +] [1 2 3]] [2 3 4] 249 | test hybrid [foldl' [sum] 0 [1 2 3]] 6 250 | test hybrid [foldl [sum] 0 [1 2 3]] 6 251 | test hybrid [foldr [sum] 0 [1 2 3]] 6 252 | test hybrid [foldl [sum] 0 [1 2 3]] 6 253 | test hybrid [foldl [join] [] [1 2 3]] [1 2 3] 254 | test hybrid [foldr [join] [] [1 2 3]] [1 2 3] 255 | 256 | subst: does [[ 257 | x: + y: => [:mathop/3 '* x y] 258 | sum 0 1 => [1] 259 | sum 1 0 => [10] 260 | sum _ _ => [100] 261 | ]] 262 | 263 | test hybrid [ either true 1 2 ] 1 264 | test hybrid [ either false 1 2 ] 2 265 | test hybrid [ eval either true [1][2] ] 1 266 | test hybrid [ eval either false [1][2] ] 2 267 | test hybrid [ either (1 = 1) 1 2 ] 1 268 | test hybrid [ either (1 = 2) 1 2 ] 2 269 | test hybrid [eval [1 + 2]] 3 270 | test hybrid [1 and (head [1 2 3])] 1 271 | test hybrid [split [] [] [1 2 3 4 5 6 7 8 9]] to-paren [[2 4 6 8] [1 3 5 7 9]] 272 | test hybrid [split' [] [] [1 2 3 4 5 6 7 8 9]] to-paren [[2 4 6 8] [1 3 5 7 9]] 273 | test hybrid [split'' [] [] [1 2 3 4 5 6 7 8 9]] to-paren [[2 4 6 8] [1 3 5 7 9]] 274 | test hybrid [3 + 4] 7 275 | test hybrid [ [3 + 4] using (:subst/0) ] 12 276 | test hybrid [ [sum 1 0] using (:subst/0) ] 10 277 | test hybrid [ [map [sum 1] [0 1 2]] using (:subst/0) ] [10 100 100] 278 | 279 | big-block-1: does [append/dup conjure -1 500] 280 | big-block1: does [append/dup conjure 1 500] 281 | big-block-n: has [r i] [also r: conjure repeat i 100 [append r i]] 282 | ;test hybrid [loop 100] 0 283 | ;test hybrid [replicate-tco (:copy []) :big-block1] big-block1 284 | test hybrid [map [negate] :big-block1] big-block-1 285 | test hybrid [map (2 +) :big-block-1] big-block1 286 | test hybrid [foldl [sum] 0 :big-block1] length? big-block1 287 | 288 | even-the-odds: as paren! [ 289 | [2 4 6 8 10 12 14 16 18 20 22 24 26 28 30 32 34 36 38 40 42 44 46 48 50 52 54 56 58 60 62 64 66 68 70 72 74 76 78 80 82 84 86 88 90 92 94 96 98 100] 290 | [1 3 5 7 9 11 13 15 17 19 21 23 25 27 29 31 33 35 37 39 41 43 45 47 49 51 53 55 57 59 61 63 65 67 69 71 73 75 77 79 81 83 85 87 89 91 93 95 97 99] 291 | ] 292 | 293 | clock [test hybrid [split [][] :big-block-n] even-the-odds] 294 | clock [test hybrid [split' [][] :big-block-n] even-the-odds] 295 | clock [test hybrid [split'' [][] :big-block-n] even-the-odds] 296 | 297 | 298 | profiler/show 299 | 300 | 301 | -------------------------------------------------------------------------------- /pure-fun.red: -------------------------------------------------------------------------------- 1 | Red [ 2 | title: "Purely functional dialect for Red" 3 | file: %pure-fun.red 4 | author: hiiamboris@gmail.com 5 | tabs: 2 6 | license: 'MIT 7 | purpose: { 8 | This is an experiment in building a dialect that will: 9 | - allow computing pure expressions in the middle of Red code 10 | point is: when one sees a pure invocation, one is 100% sure it didn't shoot his ducks 11 | - do so in a declarative, orderless manner 12 | point is: tell the parser how X and Y and so and so can be computed and let it decide for itself if it needs to compute them and in what order 13 | - allow using recursive expressions, leveraging tail-call optimization when possible 14 | point is: get rid of loops to achieve better conciseness and readability of the code 15 | - be very simple, no sophisticated type inference (as a result, no laziness), just the bare minimum 16 | } 17 | status: { 18 | early alpha, very very early 19 | proves the concept, but slow as hell: can't handle a map() over 100 items 20 | } 21 | ] 22 | 23 | 24 | #include %block-magic.red 25 | #include %assert.red 26 | #include %profiler.red 27 | #include %iterator.red 28 | 29 | ;------------- logging 30 | log-test: log-eval: log-pattern: log-loop: :print 31 | ;-- comment these to show the appropriate info: 32 | ;log-test: 33 | log-eval: 34 | log-pattern: 35 | log-loop: 36 | func [b][] 37 | 38 | 39 | 40 | ;-- ensure the behavior of paths/words is correct 41 | assert [get-word? first [:x] 'get-word?] 42 | assert [not get-word? first [:x/y] 'get-word?] 43 | assert [not get-word? first [:x/3] 'get-word?] 44 | assert [not get-path? first [:x] 'get-path?] 45 | assert [get-path? first [:x/y] 'get-path?] 46 | assert [get-path? first [:x/3] 'get-path?] 47 | 48 | ;-- typeset for path+word, doesn't work with the compiler :D 49 | impure-path!: make typeset! [get-word! get-path!] 50 | impure-path?: func [v][find impure-path! type? :v] 51 | 52 | ;-- gets the arity for a given impure-path! call 53 | ;impure-arity?: func [p [impure-path!]] [ 54 | impure-arity?: func [p [get-word! get-path!] /local p2 tmp] [ 55 | assert [any [get-word? p not empty? p] 'p] 56 | either get-word? p [ 57 | preprocessor/func-arity? spec-of get (bind to-word p 'system) 58 | ][ 59 | assert [get-path? p] 60 | either integer? last p [last p][ 61 | p2: as path! block-magic/conjure 62 | until [ 63 | append p2 pick p 1 + length? p2 64 | any-function? get p2 65 | ] 66 | ; rebind to global context 67 | p2: first bind tmp: block-magic/transmute [p2] 'system 68 | also 69 | preprocessor/func-arity?/with (spec-of get p2) to-path at p length? p2 70 | (block-magic/dispel as block! p2 71 | block-magic/dispel tmp) 72 | ] 73 | ] 74 | ] 75 | 76 | ;-- prepares impure-path for a call with `reduce` 77 | ;purify-path: func [p [impure-path!] /local r][ 78 | purify-path: func [p [get-word! get-path!] /local r][ 79 | r: as path! block-magic/conjure 80 | either get-word? p [append r to-word p][ 81 | assert [get-path? p] 82 | append r as path! p 83 | if integer? last r [take/last r] 84 | ] 85 | r 86 | ] 87 | 88 | assert [impure-path? first [:x] 'impure-path?] 89 | assert [impure-path? first [:x/3] 'impure-path?] 90 | assert [impure-path? first [:x/y] 'impure-path?] 91 | assert [to-path 'x = purify-path first [:x] 'purify-path] 92 | assert [to-path 'x = purify-path first [:x/3] 'purify-path] 93 | assert ['x/y = purify-path first [:x/y] 'purify-path] 94 | assert [3 = impure-arity? first [:x/3] 'impure-arity?] 95 | assert [ 96 | all [ 97 | c: context [ find: f: func [a b /c d /e f g /h][] ] 98 | 2 = impure-arity? first [:c/f] 99 | 3 = impure-arity? first [:c/f/c] 100 | 4 = impure-arity? first [:c/f/e] 101 | 4 = impure-arity? first [:c/f/e/h] 102 | 5 = impure-arity? first [:c/f/c/e/h] 103 | 5 = impure-arity? first [:c/find/c/e/h] 104 | 5 = impure-arity? first [:c/find/c/e/h] 105 | unset? unset 'c ; cleanup 106 | ] 'impure-arity? 107 | ] 108 | assert ['block-magic/conjure = purify-path first [:block-magic/conjure] 'purify-path] 109 | assert [0 = impure-arity? first [:block-magic/conjure] 'impure-arity?] 110 | 111 | 112 | 113 | ; TODO: special handling of true, false, none words -> into values? 114 | ; primitives (unevaluated) that are permitted in patterns declaration 115 | pattern-symbol!: make typeset! [word! set-word! number! any-string! any-list! char! pair! binary! date! time!] 116 | pattern-symbol?: func [v][find pattern-symbol! type? :v] 117 | 118 | 119 | pattern: context [ 120 | ; import symbols from block magic 121 | block-magic/import 122 | 123 | ; naming convention: 124 | ; pl is for pattern list 125 | 126 | valid-list?: func [pl [block!]] [ even? length? pl ] 127 | 128 | empty-list: does [ conjure ] 129 | empty-scope: has [m] [ 130 | also 131 | m: copy #() 132 | scope-push m compose/deep [[_scope_] [(m)]] 133 | ] 134 | 135 | count?: func [pl [block!]] [ 136 | assert [valid-list? pl] 137 | (length? pl) / 2 138 | ] 139 | 140 | ; makes a lookup key for a given pattern or expr 141 | ; everything but words is replaced by _, then a string is formed 142 | mangle: func [pat [block!] /local r] [ 143 | mold/flat/only also 144 | r: conjure 145 | parse pat [ 146 | collect into r some [ 147 | keep word! | 148 | keep ('_) skip 149 | ] 150 | ] 151 | ] 152 | 153 | ; makes a lookup key for a given single-word pattern (for arguments) 154 | mangle-arg: func [pat [block!] /local r] [ 155 | assert [1 = length? pat] 156 | assert [word? :pat/1] 157 | mold pat/1 158 | ] 159 | 160 | ; faster lookup, for single words 161 | ; => none if no match 162 | ; => [pat exp] if there's match 163 | profiler/count 164 | lookup-word: func [scope [map!] w [word!] /local pl] [ 165 | ; select may return: none, [none], [[pat exp]] 166 | all [ 167 | pl: select scope mold w 168 | pl/1 169 | ] 170 | ] 171 | 172 | ; => none if no match 173 | ; => [pat exp] if single match 174 | ; => [pat exp] if >1 matches (winner is returned) 175 | profiler/count 176 | lookup: func [scope [map!] expr [block!] /local pl] [ 177 | ; select may return: none, [none], [[pat exp pat exp ...]] 178 | if all [ 179 | pl: select scope mangle expr 180 | pl: pl/1 181 | ] [ 182 | assert [valid-list? pl] 183 | ;-- even if there's only 1 match it has to be score-d to check if it matches 184 | pl: clash pl scores: collect-scores pl expr 185 | dispel scores 186 | ] 187 | pl 188 | ] 189 | 190 | 191 | ; append a pair of [pat exp] into a pattern-list or a pattern-tree (at it's current (inner) level) 192 | list-attach: func [pl [block!] pat [block!] exp [block!]] [ 193 | list-attach-pair pl transmute [pat exp] 194 | ] 195 | list-attach-pair: func [pl [block!] pair [block!] /local i len] [ 196 | assert [all [block? pair/1 block? pair/2] 'pair] 197 | assert [2 <= length? pair] 198 | assert [valid-list? pl] 199 | append/part pl pair 2 200 | pl 201 | ] 202 | 203 | list-retrieve: func [it] [ 204 | also 205 | either tail? it/subject [do []][it/subject] 206 | it/subject: skip it/subject 2 207 | ] 208 | 209 | ; simple & fast iterator version 210 | list-iterator: has [it] [ 211 | also 212 | it: iterator/forward 213 | it/retrieve: :list-retrieve 214 | ] 215 | 216 | ; check if value matches the token 217 | ; set-word (value) and get-word (token) is prohibited 218 | ; word (value) matches only same word (token) 219 | ; not-word (value) matches: same not-word, set-word, '_' (token) 220 | token-match?: func [token value] [ 221 | assert [not set-word? value] 222 | assert [not get-word? token] 223 | any [ 224 | value = token 225 | all [ 226 | not word? value 227 | any [set-word? token token = '_] 228 | ] 229 | ] 230 | ] 231 | 232 | assert [token-match? 1 1] 233 | assert [token-match? [] []] 234 | assert [token-match? '_ 1] 235 | assert [token-match? '_ []] 236 | assert [token-match? to-set-word 'x 1] 237 | assert [token-match? to-set-word 'x []] 238 | assert [not token-match? 1 2] 239 | assert [not token-match? 1 []] 240 | assert [not token-match? 'x 'y] 241 | assert [not token-match? '_ 'y] 242 | assert [not token-match? to-set-word 'x 'y] 243 | 244 | ; returns a symbol suitable for context lookup 245 | ; word -> word 246 | ; anything else (values, set-words) -> _ (further selection is done incrementally by token-match?) 247 | symbol-for-value: func [value] [ 248 | either word? value [value]['_] 249 | ] 250 | 251 | ; simplistic iterator over a flat pattern list 252 | over-list: func [pl [block!] /local it] [ 253 | assert [valid-list? pl] 254 | also 255 | it: list-iterator 256 | it/subject: pl 257 | ] 258 | 259 | assert [123 = rollin' 'x over-list [[p][x]] [0 break/return 123] "rollin's broken"] 260 | assert [123 = rollin' 'x over-list [[p][x]] [123] "rollin's broken"] 261 | assert [none = rollin' 'x over-list [] [123] "rollin's broken"] 262 | 263 | 264 | ; swaps the [pat exp] pairs of pl with those held by scope 265 | ; returns the old contents that can be used as argument again to swap back 266 | ; e.g. if there was `f x: _ 1` mangled as `f _ _ _` and now another f is defined as 267 | ; `f 1 2 3` also mangled as `f _ _ _`, this f totally overrides the previous and there's no way to match the old pattern 268 | ; pl must only contain similar patterns 269 | ; this fn should be only used to put new sets of pattern blocks 270 | ; TODO: do the swapping ver 271 | 272 | ; for now just addition.. and no returned crap 273 | scope-decl: function [scope [map!] pl [block!]] [ 274 | pairs: forge pl 275 | rollin' 'pair over-list pairs [ 276 | set [pat exp] pair 277 | assert [block? pat] 278 | assert [block? exp] 279 | 280 | ; copy the [pat exp] sublist first, then change the original in place 281 | key: mangle pat 282 | blk: any [ scope/:key scope/:key: transmute [conjure] ] 283 | assert [1 = length? blk] 284 | assert [not none? blk/1 "none! unsupported yet"] 285 | list-attach-pair blk/1 pair 286 | ] 287 | true 288 | ] 289 | 290 | ; put a list of arguments (x, y, etc) into a scope 291 | ; pl: [[x] [1] [y] [2] ...] (no 2 patterns should be similar) 292 | ; returns what was replaced in the form acceptable by scope-swap 293 | ; => ["x" [[ [x][1] ]] "y" [[ [y][2] ]] ...] 294 | profiler/count 295 | scope-push: function [scope [map!] pl [block!]] [ 296 | pairs: forge pl 297 | rollin' 'pair over-list pairs [ 298 | set [pat exp] pair 299 | assert [block? pat] 300 | assert [block? exp] 301 | 302 | ; copy the [pat exp] sublist first, then change the original in place 303 | arg-pl: transmute [forge/part pair 2] 304 | assert [1 = length? arg-pl] 305 | assert [2 = length? arg-pl/1] 306 | change/only change/only pair mangle-arg pat arg-pl 307 | ] 308 | scope-swap scope pairs 309 | ] 310 | 311 | ; takes a list of pairs "key"/[value] and replaces these in the map 312 | ; [value] is wrapped in a block to avoid a double lookup 313 | ; => ["key1" [pl1] "key2" [pl2] ...] 314 | ; if "key" wasn't in the map, [none] is returned 315 | profiler/count 316 | scope-swap: func [scope [map!] pairs [block!] /local key blk blk0] [ 317 | assert [even? length? pairs] 318 | assert [0 < length? pairs] 319 | 320 | foreach [key blk] pairs [ 321 | assert [string? key] 322 | assert [block? blk] 323 | assert [1 = length? blk] 324 | 325 | blk0: any [scope/:key scope/:key: to-block none] 326 | ; never replace the link to self 327 | unless all [blk0/1 key = "_scope_"] [ 328 | swap blk0 blk 329 | ] 330 | 331 | assert [any [none? blk/1 block? blk/1] 'blk] 332 | ] 333 | pairs 334 | ] 335 | 336 | ; TODO: free list of maps for this case 337 | scope-merge: func [scope1 [map!] scope2 [map!]] [ 338 | scope-swap scope1 body-of scope2 339 | ] 340 | 341 | assert [ 342 | do reduce [has [m] [ 343 | m: #() 344 | all [ 345 | (compose/deep [ "x" [(none)] ]) = scope-push m [[x] [1]] 346 | (compose/deep [ "x" [ [[x] [1]] ] "y _" [(none)] ]) 347 | = scope-swap m [ "x" [none] "y _" [ [[y 2] [2 2] [y 3] [3 3]] ] ] 348 | scope-decl m [ [f 1][1 1] [f 2][2 2] [z]["Z"] ] 349 | [[ [f 1][1 1] [f 2][2 2] ]] = select m "f _" 350 | [[ [z]["Z"] ]] = select m "z" 351 | ] 352 | ]] 353 | "scope operations are broken" 354 | ] 355 | 356 | 357 | compile: function [spec [block!]] [ 358 | pl: empty-list 359 | unless parse spec [ 360 | any [ 361 | end: 362 | collect set pat any [ 363 | not '=> keep set w skip 364 | if (pattern-symbol? :w) 365 | ] 366 | ahead '=> skip ;-- "=>" 367 | set exp skip 368 | if (block? :exp) 369 | (list-attach pl :pat :exp) 370 | ] 371 | ] [print ["can't parse" mold spec "at" mold end] throw "pattern error"] 372 | 373 | also 374 | scope: empty-scope 375 | scope-decl scope pl 376 | ] 377 | 378 | ;catchall?: func [item] [any [item = '_ set-word? item]] 379 | 380 | ; detects similar patterns, but not enough to clash them 381 | profiler/count 382 | similar?: function [pat1 [block!] pat2 [block!]] [ 383 | assert [(length? pat1) = length? pat2] 384 | 385 | setwords: empty-list 386 | forall pat1 [ 387 | a: pat1/1 b: pat2/1 pat2: next pat2 388 | 389 | ; determine which word is new and check that they are either equal or one is known already 390 | new-word: none 391 | switch (either set-word? a [1][0]) + (either set-word? b [2][0]) [ 392 | 3 [ ; both are set-words 393 | unless find setwords a [new-word: a] 394 | if a <> b [ 395 | unless find setwords b [ ; b is unknown and different 396 | ; then a should not be unknown 397 | if new-word [return false] 398 | new-word: b 399 | ] 400 | ] 401 | ] 402 | 2 [unless find setwords b [new-word: b]] 403 | 1 [unless find setwords a [new-word: a]] 404 | ] 405 | 406 | if new-word [append setwords a] 407 | 408 | ; set-words were accounted for, now should only consider that 409 | ; if one of items is a word, another pattern should also have (the same) word there 410 | ; except if any word is _ - it is similar to anything 411 | if all [ a <> b a <> '_ b <> '_ any [word? a word? b] ][ return false ] 412 | ] 413 | true 414 | ] 415 | 416 | assert [similar? [f x:] [f 1]] 417 | assert [similar? [f _] [f 1]] 418 | assert [similar? [f 1] [f 2]] 419 | assert [not similar? [f 1] [g 1]] 420 | 421 | all-similar?: function [pl [block!]] [ 422 | assert [valid-list? pl] 423 | assert [1 <= count? pl] 424 | either 1 = count? pl [true][ 425 | ; there's another way: go item by item, but that's probably slower 426 | it: over-list pl 427 | ; extract 1st pair 428 | rollin' [refpat refexp] it [break] 429 | ; compare to all others 430 | rollin' [pat exp] it [ 431 | unless similar? refpat pat [break/return false] 432 | true 433 | ] 434 | ] 435 | ] 436 | 437 | ; calc's pattern's score based on given values list (expr with it's items evaluated) 438 | ; => -100 if no match, >= 0 if a match 439 | profiler/count 440 | score?: function [pat [block!] values [block!]] [ 441 | assert [1 < length? pat] ; pointless for singular patterns 442 | assert [(length? pat) <= length? values] 443 | 444 | r: 0 v: values 445 | log-pattern ["score: trying" mold/flat pat "with" mold/flat values] 446 | forall pat [ 447 | w: pat/1 448 | unless token-match? w v/1 [ return -100 ] 449 | ; only increase score if w is a value or repeated set-words 450 | case [ 451 | set-word? w [ 452 | if prev-idx: find/reverse pat w [ ; none or pat at the previous occurrence of w 453 | prev-v: pick values index? prev-idx 454 | if v/1 <> prev-v [return -100] ; drop the pattern - previous occurrence doesn't match 455 | r: r + 1 ; incr score for the value matched that of a repeated set-word 456 | ] 457 | ] 458 | not word? w [ ; w is a value matched exactly 459 | r: r + 1 ; incr score for the value matched one directly specified in the pattern 460 | ] 461 | ] 462 | v: next v 463 | ] 464 | log-pattern ["score of" pat "=" r] 465 | r 466 | ] 467 | 468 | collect-scores: func [pl [block!] expr [block!] /local r] [ 469 | r: forge [] 470 | rollin' [pat _] over-list pl [append r score? pat expr] 471 | r 472 | ] 473 | 474 | ; clashes similar patterns using a list of scores 475 | ; => selected [pattern expr] 476 | profiler/count 477 | clash: function [pl [block!] scores [block!]] [ 478 | assert [valid-list? pl] 479 | assert [1 <= count? pl] 480 | assert [all-similar? pl] 481 | assert [(count? pl) = length? scores] 482 | 483 | winner: none 484 | best-score: -1 485 | rollin' 'pair over-list pl [ 486 | set [pat exp] pair 487 | if scores/1 > best-score [ 488 | ;assert [sc <> best-score "ambiguous pattern match in clash"] 489 | best-score: scores/1 490 | winner: pair 491 | ] 492 | scores: next scores 493 | ] 494 | assert [winner] 495 | winner: forge/part winner 2 ; pair didn't have to copy 496 | winner 497 | ] 498 | 499 | ; transform a list of values (of pattern's length) into a list of pairs for set-words 500 | ; => a list of pairs of `name value` form, composed only from named set-words 501 | ; i.e. assign [f x: y: x: _ 5] [f 1 2 1 4 5] => [[x] [1] [y] [2]] 502 | assign: function [pat [block!] values [block!]] [ 503 | assert [not empty? pat] 504 | assert [(length? pat) <= length? values] 505 | 506 | paired: empty-list 507 | forall pat [ 508 | if set-word? w: pat/1 [ 509 | unless old?: find/reverse pat w [ 510 | append paired transmute [ 511 | transmute [to-word w] 512 | transmute [values/1] 513 | ] 514 | ] 515 | ] 516 | values: next values 517 | ] 518 | paired 519 | ] 520 | 521 | 522 | ] 523 | 524 | 525 | 526 | pure: context [ 527 | ; import symbols from block magic 528 | block-magic/import 529 | 530 | ; evaluation of a single-token pattern 531 | ; if token is a parens, forks with eval-full 532 | ; => none if no match (and expr is unchanged), otherwise: 533 | ; if /deferred then 534 | ; may return => [same-tree [subexpr]], expr is unchanged yet 535 | ; but if value is immediately available w/o any changes, => 1 536 | ; if not then => 1 and expr is changed in place with the result of eval-full 537 | profiler/count 538 | eval-single: function [expr [block!] 'with [word!] scope [map!] /deferred] [ 539 | log-eval ["eval-single" mold/flat expr "with" mold/flat scope "/" deferred] 540 | 541 | assert ['with = with "syntax of eval-single is wrong"] 542 | assert [1 <= length? expr] 543 | 544 | ; variants: 545 | ; word => should match exactly 546 | ; set-word or _ => forbidden 547 | ; any other value => returned as is (no matching, as single-token catchalls are forbidden) 548 | 549 | ; return values as is, and words too if tree is unspecified 550 | r: 1 551 | value: expr/1 552 | found?: false 553 | case [ 554 | paren? value [subex: as block! value found?: true] 555 | word? value [ 556 | set [pat subex] pattern/lookup-word scope value 557 | found?: not none? subex 558 | ] 559 | ] 560 | if found? [ ; unless it's a word that never matched or a normal (not parens value) 561 | assert [block? subex] 562 | r: either deferred [ 563 | transmute [scope subex] 564 | ][ 565 | subex: forge subex ; for eval-full to change it in place 566 | ; eval-full always returns a singular value, parens if needed 567 | subresult: eval-full subex with scope 568 | change/only expr subresult 569 | ;dispel subex 570 | 1 571 | ] 572 | ] 573 | log-eval ["eval-single =>" mold/flat expr/1] 574 | r 575 | ] 576 | 577 | ; eval an expr of fixed size (expr block itself can be longer) 578 | ; => none if no match (and expr is unchanged), otherwise: 579 | ; if /deferred then => [new-scope [subexpr] backup], expr is unchanged yet 580 | ; if not then => the new size (which is 1 ofc) and then the expr is changed in place with eval-full 581 | profiler/count 582 | eval-fixed: function [expr [block!] 'of [word!] size [integer!] 'with [word!] scope [map!] /deferred] [ 583 | log-eval ["eval-fixed" mold/flat expr "of" size "with" mold/flat scope "/" deferred] 584 | 585 | assert [[of with] = transmute [of with] "syntax of eval-fixed is wrong"] 586 | assert [size <= length? expr] 587 | assert [1 < size] ; otherwise should use eval-single 588 | assert [not impure-path? expr/1] 589 | 590 | matches: pattern/lookup scope ecopy: forge/part expr size 591 | dispel ecopy 592 | 593 | log-eval ["matches:" mold/flat matches "scores:" mold/flat scores] 594 | r: none 595 | unless empty? matches [ 596 | ;print ["eval-fixed" mold/flat expr "of" size] 597 | 598 | ; select a match 599 | match: none 600 | either 1 = pattern/count? matches [ ; there's only one? 601 | match: matches 602 | ][ 603 | ; got a couple of matches 604 | ; they should be all similar to be of use 605 | assert [pattern/all-similar? matches] 606 | scores: pattern/collect-scores matches expr 607 | match: pattern/clash matches scores 608 | ] 609 | 610 | if match [ 611 | set [pat subex] match 612 | backup: none 613 | 614 | ; populate the scope with arguments 615 | extra-args: pattern/assign pat expr 616 | unless empty? extra-args [ 617 | backup: pattern/scope-push scope extra-args 618 | ] 619 | 620 | r: either deferred [ 621 | transmute [scope subex backup] 622 | ][ 623 | subex: forge subex ; for eval-full to change it in place 624 | ; eval-full always returns a singular value, parens if needed 625 | subresult: eval-full subex with scope 626 | change/part/only expr subresult size 627 | if backup [pattern/scope-swap scope backup] 628 | ;dispel subex 629 | 1 630 | ] 631 | 632 | ] 633 | ] 634 | ; if r = none then no (unambiguous) match => should return none 635 | log-eval ["eval-fixed =>" mold/flat r] 636 | ;print ["eval-fixed =>" mold/flat r] 637 | r 638 | ] 639 | 640 | ; eval all subpatterns of expr (starting with 2nd token), but not the whole pattern 641 | ; all single tokens should be final 642 | ; expr is modified in place, returns it's new size so the caller can adjust 643 | ; => new size (= size means unmodified, since it maps multiple items into one) 644 | ; always true: 2 <= new size <= size 645 | profiler/count 646 | eval-subpatterns: function [expr [block!] 'of [word!] size [integer!] 'with [word!] scope [map!]] [ 647 | assert [[of with] = transmute [of with] "syntax of eval-subpatterns is wrong"] 648 | assert [size <= length? expr] 649 | assert [2 < size] ; pointless with 2 tokens 650 | 651 | subsize: 2 652 | while [subsize < size] [ 653 | subex: skip expr (size - subsize) 654 | if newsize: eval-fixed subex of subsize with scope [ 655 | assert [1 = newsize] 656 | size: size - subsize + newsize 657 | subsize: newsize 658 | ] 659 | subsize: subsize + 1 660 | ] 661 | ; might as well reduce expr to 2 tokens... 662 | size 663 | ] 664 | 665 | ; evaluates expr starting with 1 token, and continuing until either 666 | ; expr becomes as long as /size/ and doesn't match any patterns (doesn't extend it past the /size/) 667 | ; => size then 668 | ; tail of expr is met 669 | ; => length? expr then 670 | ; expr is modified in place 671 | ; => never none! (is there even a need?) 672 | ; expr is expected to be totally unevaluated 673 | ; size can be set to length? expr for unrestricted evaluation 674 | profiler/count 675 | eval-limited: function [expr [block!] 'till [word!] size [integer!] 'with [word!] scope [map!]] [ 676 | assert [[till with] = transmute [till with] "syntax of eval-limited is wrong"] 677 | assert [1 <= size] 678 | assert [size <= length? expr] 679 | 680 | done: 0 681 | while [all [done < size done < length? expr]] [ 682 | 683 | ; eval the next token - expand the pattern 684 | ; if it's a call to an impure func, call it 685 | rest: skip expr done 686 | either impure-path? rest/1 [ 687 | unless eval-impure rest with scope [ 688 | ; there's an impure call that can't be done 689 | ; so there's no more need to try to match this expr, as it won't 690 | break 691 | ] 692 | ][ 693 | ; normal token 694 | eval-single rest with scope 695 | ] 696 | done: done + 1 697 | 698 | ; evaluating subexprs is unreliable here: 699 | ; `:f/2 x + y` ... will fire with `x` and `+` 700 | ; so I disabled it completely 701 | ; use (x + y) to denote an expr 702 | ; eval any subexpressions 703 | ; if 3 <= done [ done: any [(eval-subpatterns expr of done with scope) done] ] 704 | 705 | ; try to eval the whole piece 706 | ; if 2 <= done [ done: any [(eval-fixed expr of done with scope) done] ] 707 | ] 708 | 709 | done 710 | ] ; eval-limited 711 | 712 | ; expr should start with an impure-path! 713 | ; it'll discover the arity and call eval-subpatterns until the arity is fulfilled 714 | ; then calls the impure function and modifies expr 715 | ; => 1 on successful match (and thus call) 716 | ; => none otherwise (expr is unmodified) 717 | profiler/count 718 | eval-impure: function [expr [block!] 'with [word!] scope [map!]] [ 719 | log-eval ["^/eval-impure" mold/flat expr "with" mold/flat scope] 720 | 721 | assert ['with = with "syntax of eval-impure is wrong"] 722 | assert [1 <= length? expr] 723 | assert [impure-path? expr/1] 724 | 725 | arity: impure-arity? expr/1 726 | log-eval ["arity is:" arity] 727 | 728 | ; prepare the arguments 729 | if all [ 730 | 1 <= arity ; requires arguments? 731 | arity < length? expr ; is there a chance we can have them? 732 | ][ eval-limited (next expr) till arity with scope ] 733 | 734 | ; invoke if there are enough args in the expr 735 | if arity < length? expr [ 736 | log-eval ["ready to invoke" mold/flat expr] 737 | ; make a valid red-expression 738 | subexp: forge/part expr (arity + 1) 739 | change/only subexp ppath: purify-path expr/1 740 | repeat i arity [ 741 | ; pass any paren! as a block! otherwise it'll be reduced 742 | ; (could also pass as `first [(x)]` but that's super slow) 743 | pos: skip subexp i 744 | if paren? pos/1 [change/only pos to-block pos/1] 745 | ] 746 | log-eval ["made as subexp" mold/flat subexp] 747 | result: do bind subexp 'system 748 | log-eval ["call result:" mold/flat result] 749 | dispel subexp 750 | dispel as block! ppath 751 | assert [not any-word? result] ; should return a value, I guess... 752 | change/only/part expr result (arity + 1) 753 | return 1 754 | ] 755 | 756 | none 757 | ] 758 | 759 | ; => always a singular value: 760 | ; either normal, or 761 | ; a `to-paren expr` if the expr contains > 1 tokens 762 | ; expr is modified in place before returning, or to-paren-ing 763 | ; always works on the whole expr (no limits) 764 | ; TCO-enabled 765 | profiler/count 766 | eval-full: function [expr [block!] 'with [word!] scope [map!]] [ 767 | assert ['with = with "syntax of eval-full is wrong"] 768 | assert [1 <= length? expr] 769 | 770 | log-eval ["^/eval-full" mold/flat expr "with" mold/flat scope] 771 | backups: conjure 772 | 773 | until [ 774 | replaced?: false ; becomes true if TCO occurs 775 | log-eval ["EXPR:" mold/flat expr] 776 | case [ 777 | 778 | ; simplest 1-token expr 779 | 1 = length? expr [ 780 | ; if it's a call to an impure func, call it 781 | either impure-path? expr/1 [ 782 | eval-impure expr with scope 783 | break ; can't let impure calls to return *expressions*... it's too much 784 | ][ 785 | ; normal token + TCO is possible here immediately 786 | if result: eval-single/deferred expr with scope [ 787 | if block? result [ ; deferred can return 1 in case result was obvious 788 | dispel expr 789 | expr: forge result/2 790 | replaced?: true 791 | ] 792 | ] 793 | ] 794 | ] 795 | 796 | ; 2+ tokens... 797 | true [ 798 | size: 0 799 | while [size < length? expr] [ 800 | 801 | rest: skip expr size 802 | log-eval ["REST:" mold/flat rest] 803 | 804 | ; if it's a call to an impure func, call it 805 | either impure-path? rest/1 [ 806 | unless (eval-impure rest with scope) [ 807 | ; there's an impure call that can't be done 808 | ; so there's no more need to try to match this expr, as it won't 809 | break 810 | ] 811 | ; in case of impure func, don't advance the size 812 | ; suppose it returned a paren (expr ..), it should be reevaluated then 813 | either 1 = length? expr [ 814 | replaced?: true break ; use eval-single instead 815 | ][ 816 | continue 817 | ] 818 | ][ 819 | ; otherwise eval the next token - expand the pattern 820 | eval-single rest with scope 821 | ] 822 | size: size + 1 823 | 824 | ; when size >= 3 eval subexpressions 825 | if 3 <= size [ 826 | size: any [(eval-subpatterns expr of size with scope) size] 827 | ] 828 | 829 | ; try to eval the fully-sized subexpr 830 | if 2 <= size [ 831 | either size = length? expr [ 832 | ; TCO is possible when size = expr length 833 | if result: eval-fixed/deferred expr of size with scope [ 834 | dispel expr 835 | set [scope expr backup] result 836 | if backup [append/only backups backup] 837 | expr: forge expr 838 | replaced?: true 839 | break ; start afresh from the 1st token 840 | ] 841 | ][ 842 | ; otherwise must fork 843 | size: any [(eval-fixed expr of size with scope) size] 844 | ] 845 | ] 846 | 847 | ] ; while [] 848 | ] ; 'true' case 849 | 850 | ] ; case [] 851 | 852 | not replaced? 853 | ] ; until.. 854 | 855 | ; restore all backed up stuff back 856 | ; TODO: maybe speed it up somehow or just copy the map initially? 857 | unless empty? backups [ 858 | backups: tail backups 859 | until [ 860 | backups: back backups 861 | pattern/scope-swap scope backups/1 862 | head? backups 863 | ] 864 | ] 865 | 866 | ; should return paren if contains >1 token 867 | r: either 1 < length? expr [ 868 | ;to-paren expr 869 | as paren! expr 870 | ][ 871 | expr/1 872 | ] 873 | r 874 | ] ; eval-full 875 | 876 | 877 | eval: function [ 878 | "Evaluate a pure expression" 879 | expr [block!] "<- yep, this one" 880 | /using patterns [block!] "a set of patterns (rules) to match against" 881 | /with scope [map!] "a map with precompiled patterns set" 882 | ] [ 883 | assert [not all [using with] "too much args"] 884 | scope: any [ 885 | scope 886 | either using [pattern/compile patterns][empty-scope] 887 | ] 888 | eval-full (forge expr) with scope 889 | ] 890 | 891 | ] 892 | 893 | 894 | 895 | ;-- this is the whole of API ;) 896 | eval: :pure/eval 897 | 898 | 899 | --------------------------------------------------------------------------------