sourcePatternLowering.tri (9168B)
1 -- Compiler-built equation descriptions: no new surface syntax or host parser. 2 !import "prelude" !Local 3 !import "source.pattern" P 4 !import "source.compile" K 5 !import "source.core" C 6 7 any = P.sourcePatternAny t 8 leaf = P.sourcePatternLeaf t 9 capture name = P.sourcePatternCapture name t 10 stem child = P.sourcePatternStem child t 11 fork left right = P.sourcePatternFork left right t 12 whole name child = P.sourcePatternWhole name child t 13 literal tree = P.sourcePatternLiteral tree t 14 pin core = P.sourcePatternPin core t 15 lit = P.spLit 16 var = P.spVar 17 lam = P.spLam 18 app = P.spApp 19 bodyList elements = C.sourceCoreList elements t t 20 eq = P.sourceEquation 21 22 compile equations = (lazyResult (problem rest : err problem rest) 23 (core rest : K.sourceCompileCore core) (P.sourceLowerEquations equations)) 24 run equations value = (lazyResult (problem rest : err problem rest) 25 (function rest : ok (function value) t) (compile equations)) 26 run2 equations first second = (lazyResult (problem rest : err problem rest) 27 (function rest : ok (function first second) t) (compile equations)) 28 29 shapeEquations = [ 30 (eq [leaf] (lit 1)) 31 (eq [(stem (capture "child"))] (lit 2)) 32 (eq [(fork (capture "left") (capture "right"))] (lit 3)) 33 (eq [any] (lit 4)) 34 ] 35 booleanEquations = [ 36 (eq [leaf] (lit "false")) 37 (eq [(stem leaf)] (lit "true")) 38 (eq [any] (lit "invalid")) 39 ] 40 wholeEquations = [ 41 (eq [(whole "whole" (fork (capture "left") (capture "right")))] 42 (bodyList [(var 2) (var 1) (var 0)])) 43 (eq [any] (lit t)) 44 ] 45 nestedEquations = [ 46 (eq [(fork (stem (capture "x")) (capture "y"))] 47 (bodyList [(var 1) (var 0)])) 48 (eq [any] (lit t)) 49 ] 50 multiEquations = [ 51 (eq [(fork (stem (capture "x")) (capture "y")) (capture "z")] 52 (bodyList [(var 2) (var 1) (var 0)])) 53 (eq [any any] (lit t)) 54 ] 55 fallthroughEquations = [ 56 (eq [(fork (capture "lost") (literal 99))] (lit "wrong")) 57 (eq [(capture "whole")] (var 0)) 58 ] 59 closureEquations = [ 60 (eq [(capture "saved")] (lam (bodyList [(var 1) (var 0)]))) 61 ] 62 outerEquations = [ 63 (eq [(capture "inner")] (bodyList [(var 0) (var 1)])) 64 ] 65 pinEquations = [ 66 (eq [(pin (var 0))] (lit "equal")) 67 (eq [any] (lit "different")) 68 ] 69 pinNestedEquations = [ 70 (eq [(fork (stem (capture "x")) (pin (var 0)))] (var 0)) 71 (eq [any] (lit 0)) 72 ] 73 -- Resolved core remains open under the surrounding binder until wrapped. 74 compileUnderOuter equations = (lazyResult (problem rest : err problem rest) 75 (core rest : K.sourceCompileCore (lam core)) (P.sourceLowerEquations equations)) 76 77 -- This worker normalizes under abstract input, returns on Leaf, and diverges 78 -- on Fork. Use it in an unselected equation without constructing a known 79 -- divergent top-level constant (which cannot itself be exported normally). 80 loop_ self input = (lazyList (_ : 7) (head rest : self input) input) 81 loop input = y loop_ input 82 lazyEquations = [ 83 (eq [leaf] (lit 23)) 84 (eq [(capture "input")] (app (lit loop) (var 0))) 85 ] 86 lazyFirstEquations = [ 87 (eq [(whole "input" leaf)] (app (lit loop) (var 0))) 88 (eq [any] (lit 24)) 89 ] 90 91 checks input = (foldl and? true [ 92 (equal? (run shapeEquations t) (ok 1 t)) 93 (equal? (run shapeEquations (t 8)) (ok 2 t)) 94 (equal? (run shapeEquations (pair 8 9)) (ok 3 t)) 95 (equal? (run booleanEquations t) (ok "false" t)) 96 (equal? (run booleanEquations (t t)) (ok "true" t)) 97 (equal? (run booleanEquations (t (t t))) (ok "invalid" t)) 98 (equal? (run booleanEquations (pair t t)) (ok "invalid" t)) 99 (equal? (run [(eq [(capture "x")] (var 0))] input) (ok input t)) 100 (equal? (run wholeEquations (pair 10 20)) (ok [(pair 10 20) 10 20] t)) 101 (equal? (run nestedEquations (pair (t 10) 20)) (ok [10 20] t)) 102 (equal? (run2 multiEquations (pair (t 10) 20) 30) (ok [10 20 30] t)) 103 (equal? (run fallthroughEquations (pair 10 20)) (ok (pair 10 20) t)) 104 (equal? ((resultOr t (compile closureEquations)) 10 20) [10 20]) 105 (equal? ((resultOr t (compileUnderOuter outerEquations)) 10 20) [20 10]) 106 (equal? ((resultOr t (compileUnderOuter pinEquations)) input input) "equal") 107 (equal? ((resultOr t (compileUnderOuter pinEquations)) 10 20) "different") 108 (equal? ((resultOr t (compileUnderOuter pinNestedEquations)) 20 (pair (t 10) 20)) 10) 109 (equal? (run [(eq [(literal "call")] (lit 31)) (eq [any] (lit 32))] "call") (ok 31 t)) 110 (equal? (run [(eq [(literal loop)] (lit 33)) (eq [any] (lit 34))] loop) (ok 33 t)) 111 (equal? (run lazyEquations t) (ok 23 t)) 112 (equal? (run lazyFirstEquations (pair 10 20)) (ok 24 t)) 113 (equal? (run [(eq [(capture "x")] (var 0)) (eq [any] (lit 99))] input) (ok input t)) 114 (resultIsErr (P.sourceLowerEquations [])) 115 (resultIsErr (P.sourceLowerEquations [(eq [] (lit t))])) 116 (resultIsErr (P.sourceLowerEquations [(eq [leaf] (lit t))])) 117 (resultIsErr (P.sourceLowerEquations [(eq [leaf] (lit t)) (eq [any any] (lit t))])) 118 (resultIsErr (P.sourceLowerEquations [(eq [(fork (capture "x") (capture "x"))] (lit t)) (eq [any] (lit t))])) 119 (resultIsErr (P.sourceLowerEquations [(eq [(whole "x" (capture "x"))] (lit t))])) 120 (resultIsErr (P.sourceLowerEquations [(eq [(capture "x") (capture "x")] (lit t))])) 121 (resultIsOk (P.sourceLowerEquations [(eq [(whole "x" any)] (var 0))])) 122 (equal? (P.sourceLowerEquations wholeEquations) (P.sourceLowerEquations wholeEquations)) 123 ]) 124 main = checks [1 2 3] 125 main 126 127 -- Independent expected data for the runtime comparator. The compiler and 128 -- pattern constructors only build inputs, never calculate expected outputs. 129 fixture equations wrappers arguments expected = pair equations (pair wrappers (pair arguments expected)) 130 diagnostic label found location = pair 48 (pair label (pair found (pair location t))) 131 fixtureLeaf = fixture shapeEquations [] [t] (ok 1 t) 132 fixtureStem = fixture shapeEquations [] [(t 8)] (ok 2 t) 133 fixtureFork = fixture shapeEquations [] [(pair 8 9)] (ok 3 t) 134 fixtureFalse = fixture booleanEquations [] [t] (ok "false" t) 135 fixtureTrue = fixture booleanEquations [] [(t t)] (ok "true" t) 136 fixtureInvalidStem = fixture booleanEquations [] [(t (t t))] (ok "invalid" t) 137 fixtureInvalidFork = fixture booleanEquations [] [(pair t t)] (ok "invalid" t) 138 fixtureWhole = fixture wholeEquations [] [(pair 10 20)] (ok [(pair 10 20) 10 20] t) 139 fixtureNested = fixture nestedEquations [] [(pair (t 10) 20)] (ok [10 20] t) 140 fixtureMulti = fixture multiEquations [] [(pair (t 10) 20) 30] (ok [10 20 30] t) 141 fixtureFallthrough = fixture fallthroughEquations [] [(pair 10 20)] (ok (pair 10 20) t) 142 fixtureClosure = fixture closureEquations [] [10 20] (ok [10 20] t) 143 fixtureOuter = fixture outerEquations [t] [10 20] (ok [20 10] t) 144 fixturePinHit = fixture pinEquations [t] [10 10] (ok "equal" t) 145 fixturePinMiss = fixture pinEquations [t] [10 20] (ok "different" t) 146 fixturePinNested = fixture pinNestedEquations [t] [20 (pair (t 10) 20)] (ok 10 t) 147 fixtureString = fixture [(eq [(literal "call")] (lit 31)) (eq [any] (lit 32))] [] ["call"] (ok 31 t) 148 fixtureNumber = fixture [(eq [(literal 42)] (lit 31)) (eq [any] (lit 32))] [] [43] (ok 32 t) 149 fixtureFunctionLiteral = fixture [(eq [(literal loop)] (lit 33)) (eq [any] (lit 34))] [] [loop] (ok 33 t) 150 fixtureLazyLater = fixture lazyEquations [] [t] (ok 23 t) 151 fixtureLazyEarlier = fixture lazyFirstEquations [] [(pair 10 20)] (ok 24 t) 152 fixtureOrder = fixture [(eq [(capture "x")] (var 0)) (eq [any] (lit 99))] [] [42] (ok 42 t) 153 fixtureEmpty = fixture [] [] [] (err (diagnostic "nonempty equations" t t) t) 154 fixtureZeroArity = fixture [(eq [] (lit t))] [] [] (err (diagnostic "positive equation arity" 0 t) t) 155 fixtureCatchall = fixture [(eq [leaf] (lit t))] [] [] (err (diagnostic "final irrefutable equation" t t) t) 156 fixtureArity = fixture [(eq [leaf] (lit t)) (eq [any any] (lit t))] [] [] (err (diagnostic "consistent arity" 2 t) t) 157 fixtureDuplicate = fixture [(eq [(fork (capture "x") (P.sourcePatternCapture "x" [3 4]))] (lit t)) (eq [any] (lit t))] [] [] (err (diagnostic "unique capture" "x" [3 4]) t) 158 fixtureWholeDuplicate = fixture [(eq [(whole "x" (capture "x"))] (lit t))] [] [] (err (diagnostic "unique capture" "x" t) t) 159 fixtureCrossArgumentDuplicate = fixture [(eq [(capture "x") (capture "x")] (lit t))] [] [] (err (diagnostic "unique capture" "x" t) t) 160 fixtureWholeCatchall = fixture [(eq [(whole "x" any)] (var 0))] [] [42] (ok 42 t) 161 -- Wrong-value and wrong-location controls must make the comparator false. 162 fixtureWrongValue = fixture wholeEquations [] [(pair 10 20)] (ok [(pair 10 20) 20 10] t) 163 fixtureWrongLocation = fixture [(eq [(fork (capture "x") (P.sourcePatternCapture "x" [3 4]))] (lit t)) (eq [any] (lit t))] [] [] (err (diagnostic "unique capture" "x" [3 5]) t) 164 165 fixtureUnknownTag = fixture [(eq [(P.sourcePatternNode 9 t [6 7])] (lit t)) (eq [any] (lit t))] [] [] (err (diagnostic "pattern tag" 9 [6 7]) t) 166 fixtureIgnoredArgument = fixture [(eq [any (capture "second")] (var 0))] [] [10 20] (ok 20 t) 167 fixtureBodyNoFallthrough = fixture [(eq [leaf] (lit (err "chosen body" t))) (eq [any] (lit 99))] [] [t] (ok (err "chosen body" t) t) 168 -- The pin would diverge if reached. A miss on the first argument must avoid 169 -- inspecting the later argument or evaluating its surrounding-scope pin. 170 fixturePinUnreached = fixture [ 171 (eq [leaf (pin (app (lit loop) (var 0)))] (lit 31)) 172 (eq [any any] (lit 32)) 173 ] [t] [(pair 10 20) (t 8) t] (ok 32 t)