consumer_output_match.tri (7959B)
1 -- Match computed trees using the same patterns as consumer rule heads. 2 !import "consumers.base-source" B 3 !import "consumers.structural" S 4 !import "consumers.lexical-worker" L 5 !import "consumers.validate" V 6 !import "parser" P 7 !import "lexer" Position 8 !import "prelude" !Local 9 !import "io" !Local 10 11 load path = do onOk_ 12 source <- readFile path 13 pure (matchResult (_ _ : err "source parse failure" t) 14 (named _ : ok (snd named) t) (B.compileBaseSource source)) 15 base name = append "lib/consumer/" (append name ".scp") 16 worker program state = S.makeConsumer state (snd program) 17 compare reference executable input = (equal? 18 (S.runConsumer reference input) (L.lRunChecked executable input)) 19 errorCode source = (matchResult 20 (diagnostic _ : P.parserDiagnosticCode diagnostic) 21 (_ _ : 0) (B.compileBaseSource source)) 22 nested = snd (resultOr t (B.compileBaseSource 23 "consumer nested\n value @ _ => match stem value of (leaf => leaf | stem item => match stem item of (leaf => leaf | stem inner => inner))")) 24 paired = snd (resultOr t (B.compileBaseSource 25 "consumer paired\n x @ _ => (match x of (leaf => 1 | stem y => 2 | _ => 3), 4)")) 26 booleanPair = snd (resultOr t (B.compileBaseSource 27 "consumer booleanPair\n x @ _ => (choose equal x leaf 1 2, 4)")) 28 listMatch = snd (resultOr t (B.compileBaseSource 29 "consumer listMatch\n [] @ _ => []\n [x | xs] @ _ => [match x of (leaf => 0 | _ => 1) | recur xs @ leaf]")) 30 ordered = snd (resultOr t (B.compileBaseSource 31 "consumer ordered\n x @ _ => match x of ((as whole stem leaf, leaf) => whole | (left, right) => right | _ => 3)")) 32 asCase = snd (resultOr t (B.compileBaseSource 33 "consumer asCase\n x @ _ => match x of (as whole stem leaf => whole | _ => leaf)")) 34 prefixCase = S.makeConsumer t [(S.makeRule (S.patCapture 0) S.patAny (S.outMatch 35 (S.outCapture 0) [(pair (resultOr t (S.expandPrefix "api/" 1)) 36 (S.outCapture 1))]))] 37 failed = snd (resultOr t (B.compileBaseSource 38 "consumer failed\n [] @ _ => leaf")) 39 malformed = snd (resultOr t (B.compileBaseSource 40 "consumer malformed\n x @ _ => (leaf, leaf)")) 41 literalCase = snd (resultOr t (B.compileBaseSource 42 "consumer literals\n x @ _ => match x of (leaf => \"before\" | stem value => \"before\")")) 43 lazyCase = snd (resultOr t (B.compileBaseSource 44 "consumer lazy\n x @ _ => match x of (leaf => become leaf leaf @ leaf | stem value => value)")) 45 located = B.compileBaseSourceLocated "-- comment\nconsumer loc\n x @ _ => match x of (leaf => leaf | stem y => y)" 46 checks mapper textMapper prefix = 47 let refText = worker textMapper t in 48 let lexText = resultOr t (L.lCompile refText) in 49 let refPrefix = worker prefix "/api/" in 50 let lexPrefix = resultOr t (L.lCompile refPrefix) in 51 let refTextMap = worker mapper refText in 52 let lexTextMap = resultOr t (L.lCompile (worker mapper lexText)) in 53 let refPathMap = worker mapper refPrefix in 54 let lexPathMap = resultOr t (L.lCompile (worker mapper lexPrefix)) in 55 let refBad = worker mapper malformed in 56 let lexBad = resultOr t (L.lCompile 57 (worker mapper (resultOr t (L.lCompile malformed)))) in 58 let refFail = worker mapper failed in 59 let lexFail = resultOr t (L.lCompile 60 (worker mapper (resultOr t (L.lCompile failed)))) in 61 let lexNested = resultOr t (L.lCompile nested) in 62 let lexPaired = resultOr t (L.lCompile paired) in 63 let lexBooleanPair = resultOr t (L.lCompile booleanPair) in 64 let lexListMatch = resultOr t (L.lCompile listMatch) in 65 let lexOrdered = resultOr t (L.lCompile ordered) in 66 let lexAs = resultOr t (L.lCompile asCase) in 67 let lexPrefixCase = resultOr t (L.lCompile prefixCase) in 68 let rewritten = S.replaceLiteral literalCase "before" "after" in 69 let lexRewritten = resultOr t (L.lCompile rewritten) in 70 let lexLazy = resultOr t (L.lCompile lazyCase) in 71 let text = ["alpha" "" "#note" "beta"] in 72 let paths = ["/api/" "/other" "/api/item"] in 73 foldl and? true [ 74 (resultIsOk (L.lCompile (worker mapper lexText))) 75 (resultIsOk (L.lCompile (worker mapper lexPrefix))) 76 (compare refTextMap lexTextMap text) 77 (equal? (S.runConsumer refTextMap text) (ok ["alpha" "beta"] t)) 78 (compare refPathMap lexPathMap paths) 79 (equal? (S.runConsumer refPathMap paths) (ok ["" "item"] t)) 80 (compare refTextMap lexTextMap []) 81 (compare refPathMap lexPathMap ["/other"]) 82 (compare refBad lexBad ["x"]) 83 (equal? (S.runConsumer refBad ["x"]) (err "no matching output arm" t)) 84 (compare refFail lexFail ["x"]) 85 (equal? (S.runConsumer refFail ["x"]) 86 (err "no matching consumer rule" t)) 87 (compare nested lexNested 7) 88 (equal? (S.runConsumer nested 7) (ok 7 t)) 89 (compare paired lexPaired t) 90 (compare paired lexPaired (t t)) 91 (compare paired lexPaired (pair t t)) 92 (equal? (L.lRunChecked lexPaired t) (ok (pair 1 4) t)) 93 (equal? (L.lRunChecked lexPaired (t t)) (ok (pair 2 4) t)) 94 (equal? (L.lRunChecked lexPaired (pair t t)) (ok (pair 3 4) t)) 95 (compare booleanPair lexBooleanPair t) 96 (compare booleanPair lexBooleanPair (t t)) 97 (equal? (L.lRunChecked lexBooleanPair t) (ok (pair 1 4) t)) 98 (equal? (L.lRunChecked lexBooleanPair (t t)) (ok (pair 2 4) t)) 99 (compare listMatch lexListMatch [t (t t) t]) 100 (equal? (L.lRunChecked lexListMatch [t (t t) t]) 101 (ok [0 1 0] t)) 102 (compare ordered lexOrdered (pair (t t) t)) 103 (equal? (S.runConsumer ordered (pair (t t) t)) (ok (t t) t)) 104 (compare ordered lexOrdered (pair (t t) (t t))) 105 (equal? (S.runConsumer ordered (pair (t t) (t t))) (ok (t t) t)) 106 (compare ordered lexOrdered (pair t 8)) 107 (equal? (S.runConsumer ordered (pair t 8)) (ok 8 t)) 108 (compare ordered lexOrdered t) 109 (equal? (S.runConsumer ordered t) (ok 3 t)) 110 (compare asCase lexAs (t t)) 111 (equal? (S.runConsumer asCase (t t)) (ok (t t) t)) 112 (compare asCase lexAs 7) 113 (compare prefixCase lexPrefixCase "api/foo") 114 (equal? (S.runConsumer prefixCase "api/foo") (ok "foo" t)) 115 (compare prefixCase lexPrefixCase "other") 116 (equal? (S.runConsumer prefixCase "other") 117 (err "no matching output arm" t)) 118 (resultIsOk (V.vValidate rewritten)) 119 (equal? (S.runConsumer rewritten t) (ok "after" t)) 120 (equal? (S.runConsumer rewritten (t t)) (ok "after" t)) 121 (equal? (L.lRunChecked lexRewritten t) (ok "after" t)) 122 (equal? (L.lRunChecked lexRewritten (t t)) (ok "after" t)) 123 (compare lazyCase lexLazy (t 7)) 124 (equal? (S.runConsumer lazyCase (t 7)) (ok 7 t)) 125 (equal? (errorCode "consumer bad\n x @ _ => match x of (leaf => value | stem value => value)") 22) 126 (equal? (errorCode "consumer bad\n value @ _ => match value of (leaf => leaf | stem value => value)") 21) 127 (resultIsOk located) 128 (equal? (Position.lexerPositionLine (snd (fst (snd (resultOr t located))))) 3) 129 (equal? (V.vValidate (S.makeConsumer t [ 130 (S.makeRule S.patAny S.patAny (S.outMatch 131 (S.outLiteral t) [(pair (S.patStem (S.patCapture 0)) (S.outCapture 9))]))])) 132 (err (V.vDiagnostic "malformed" 0 ["arm" "output"] "unknown capture") t)) 133 (equal? (V.vValidate (S.makeConsumer t [ 134 (S.makeRule S.patAny S.patAny (S.outMatch (S.outLiteral t) []))])) 135 (err (V.vDiagnostic "malformed" 0 ["output"] "empty match") t)) 136 (equal? (V.vValidate (S.makeConsumer t [ 137 (S.makeRule (S.patCapture 0) S.patAny (S.outMatch 138 (S.outCapture 0) [(pair (S.patCapture 0) (S.outCapture 0))]))])) 139 (err (V.vDiagnostic "malformed" 0 ["pattern" "output"] "duplicate binding") t)) 140 (equal? (V.vValidate (S.makeConsumer t [ 141 (S.makeRule S.patAny S.patAny (pair 9 t))])) 142 (err (V.vDiagnostic "malformed" 0 ["output"] "match payload") t))] 143 stage = do onOk_ 144 mapper <- load (base "mapMaybe") 145 textMapper <- load "test/fixtures/keep-data-line.scp" 146 prefix <- load (base "stripPrefix") 147 pure (ok (checks mapper textMapper prefix) t) 148 main = io (onResult_ stage 149 (_ : putStrLn "output-match-LOAD-FAIL") 150 (success : putStrLn (matchBool "output-match-ok" "output-match-DIFFER" success))) 151 main