consumer_input_channel_experiment.tri (7356B)
1 -- Side-by-side input/state envelope experiment. 2 !import "consumers.base-source" B 3 !import "consumers.structural" S 4 !import "consumers.lexical-worker" L 5 !import "consumers.effect" E 6 !import "prelude" !Local 7 !import "io" !Local 8 9 load path = do onOk_ 10 source <- readFile path 11 pure (matchResult (_ _ : err "source parse failure" t) 12 (named _ : ok (snd named) t) (B.compileBaseSource source)) 13 experiment name = append "test/experiments/scp-input-channel/" (append name ".scp") 14 base name = append "lib/consumer/" (append name ".scp") 15 withState program state = S.makeConsumer state (snd program) 16 packed program = withState program t 17 rule input state output = S.makeRule input state output 18 selected = snd (resultOr t (B.compileBaseSource 19 "consumer selected\n [] @ _ => leaf\n [head | tail] @ _ => stem head")) 20 identityIR = S.makeConsumer t [(rule (S.patCapture 0) S.patAny (S.outCapture 0))] 21 identityWorker = resultOr t (L.lCompile identityIR) 22 -- E.run's driver still retains the environment; only the worker sees a 23 -- packed input. The effect driver still supplies retained state. 24 packedRefStep program input = (S.runConsumer 25 (S.makeConsumer t (snd program)) (pair input (fst program))) 26 packedLexStep program input = (L.lRunChecked (snd program) 27 (pair input (fst program))) 28 echo argument = pure (ok 7 t) 29 failEcho argument = pure (err "bad echo" t) 30 evaluate foldSource packedFoldSource mapSource packedMapSource prefixSource packedPrefixSource prependSource stateEntrySource stateFinishSource packedEntrySource packedFinishSource = 31 let refPrepend = packed prependSource in 32 let lexPrepend = resultOr t (L.lCompile refPrepend) in 33 let refMapper = packed selected in 34 let lexMapper = resultOr t (L.lCompile refMapper) in 35 let lexFold = resultOr t (L.lCompile 36 (withState foldSource (pair lexPrepend t))) in 37 let refPackedFold = packed packedFoldSource in 38 let lexPackedFold = resultOr t (L.lCompile refPackedFold) in 39 let refMap = withState mapSource refMapper in 40 let lexMap = resultOr t (L.lCompile (withState mapSource lexMapper)) in 41 let refPackedMap = packed packedMapSource in 42 let lexPackedMap = resultOr t (L.lCompile refPackedMap) in 43 let refPrefix = withState prefixSource "/api/" in 44 let lexPrefix = resultOr t (L.lCompile refPrefix) in 45 let refPackedPrefix = packed packedPrefixSource in 46 let lexPackedPrefix = resultOr t (L.lCompile refPackedPrefix) in 47 let refStateEntry = packed stateEntrySource in 48 let refStateFinish = packed stateFinishSource in 49 let refPackedEntry = packed packedEntrySource in 50 let refPackedFinish = packed packedFinishSource in 51 let lexStateEntry = resultOr t (L.lCompile refStateEntry) in 52 let lexStateFinish = resultOr t (L.lCompile refStateFinish) in 53 let lexPackedEntry = resultOr t (L.lCompile refPackedEntry) in 54 let lexPackedFinish = resultOr t (L.lCompile refPackedFinish) in 55 let stateRefs = [(pair "entry" refStateEntry) 56 (pair "finish" refStateFinish)] in 57 let packedRefs = [(pair "entry" refPackedEntry) 58 (pair "finish" refPackedFinish)] in 59 let stateLex = [(pair "entry" (S.makeConsumer t lexStateEntry)) 60 (pair "finish" (S.makeConsumer t lexStateFinish))] in 61 let packedLex = [(pair "entry" (S.makeConsumer t lexPackedEntry)) 62 (pair "finish" (S.makeConsumer t lexPackedFinish))] in 63 let work = [(pair [] []) (pair [1 2 3] [3 2 1]) 64 (pair [7] [7])] in 65 let maps = [(pair [] []) (pair [[] [t] [] [2]] [t 2]) 66 (pair [[3] [] [4]] [3 4])] in 67 let prefixes = [ 68 (pair "/api/item" (pair "/api/" (t "item"))) 69 (pair "/api/" (pair "/api/" (t ""))) 70 (pair "/api" (pair "/api/" t)) 71 (pair "/apix" (pair "/api/" t)) 72 (pair "anything" (pair "" (t "anything")))] in 73 let pureChecks = foldl and? true [ 74 (resultIsOk (L.lCompile refPackedFold)) 75 (resultIsOk (L.lCompile refPackedMap)) 76 (resultIsOk (L.lCompile refPackedPrefix)) 77 (foldl and? true (map (row : 78 let xs = fst row in let expected = snd row in 79 foldl and? true [ 80 (equal? (S.runConsumer (withState foldSource 81 (pair refPrepend t)) xs) (ok expected t)) 82 (equal? (L.lRunChecked lexFold xs) (ok expected t)) 83 (equal? (S.runConsumer refPackedFold 84 (pair xs (pair refPrepend t))) (ok expected t)) 85 (equal? (L.lRunChecked lexPackedFold 86 (pair xs (pair lexPrepend t))) (ok expected t))]) work)) 87 (foldl and? true (map (row : 88 let xs = fst row in let expected = snd row in 89 foldl and? true [ 90 (equal? (S.runConsumer refMap xs) (ok expected t)) 91 (equal? (L.lRunChecked lexMap xs) (ok expected t)) 92 (equal? (S.runConsumer refPackedMap 93 (pair xs refMapper)) (ok expected t)) 94 (equal? (L.lRunChecked lexPackedMap 95 (pair xs lexMapper)) (ok expected t))]) maps)) 96 (foldl and? true (map (row : 97 let target = fst row in let prefix = fst (snd row) in 98 let expected = snd (snd row) in 99 foldl and? true [ 100 (equal? (S.runConsumer (withState prefixSource prefix) 101 target) (ok expected t)) 102 (equal? (L.lRunOpenChecked lexPrefix target prefix) 103 (ok expected t)) 104 (equal? (S.runConsumer refPackedPrefix 105 (pair target prefix)) (ok expected t)) 106 (equal? (L.lRunChecked lexPackedPrefix 107 (pair target prefix)) (ok expected t))]) prefixes))] in 108 bind (E.run S.runConsumer stateRefs [(pair "Echo" echo)] "entry" 3 109 (pair identityIR 4)) (stateReference : 110 bind (E.run L.lEffectStep stateLex [(pair "Echo" echo)] "entry" 3 111 (pair identityWorker 4)) (stateCompiled : 112 bind (E.run packedRefStep packedRefs [(pair "Echo" echo)] "entry" 3 113 (pair identityIR 4)) (packedReference : 114 bind (E.run packedLexStep packedLex [(pair "Echo" echo)] "entry" 3 115 (pair identityWorker 4)) (packedCompiled : 116 bind (E.run S.runConsumer stateRefs [(pair "Echo" failEcho)] "entry" 3 117 (pair identityIR 4)) (stateFailed : 118 bind (E.run L.lEffectStep stateLex [(pair "Echo" failEcho)] "entry" 3 119 (pair identityWorker 4)) (stateLexFailed : 120 bind (E.run packedRefStep packedRefs [(pair "Echo" failEcho)] "entry" 3 121 (pair identityIR 4)) (packedRefFailed : 122 bind (E.run packedLexStep packedLex [(pair "Echo" failEcho)] "entry" 3 123 (pair identityWorker 4)) (packedFailed : 124 pure (ok (foldl and? true [pureChecks 125 (equal? stateReference (ok (pair 7 4) t)) 126 (equal? stateCompiled stateReference) 127 (equal? packedReference stateReference) 128 (equal? packedCompiled stateReference) 129 (equal? stateFailed (ok "bad echo" t)) 130 (equal? stateLexFailed stateFailed) 131 (equal? packedRefFailed stateFailed) 132 (equal? packedFailed stateFailed)]) t))))))))) 133 stage = do onOk_ 134 foldSource <- load (base "fold") 135 packedFoldSource <- load (experiment "packed-fold") 136 mapSource <- load (base "mapMaybe") 137 packedMapSource <- load (experiment "packed-mapMaybe") 138 prefixSource <- load (base "stripPrefix") 139 packedPrefixSource <- load (experiment "packed-stripPrefix") 140 prependSource <- load (base "prepend") 141 stateEntrySource <- load (experiment "state-entry") 142 stateFinishSource <- load (experiment "state-finish") 143 packedEntrySource <- load (experiment "packed-entry") 144 packedFinishSource <- load (experiment "packed-finish") 145 evaluate foldSource packedFoldSource mapSource packedMapSource 146 prefixSource packedPrefixSource prependSource stateEntrySource 147 stateFinishSource packedEntrySource packedFinishSource 148 main = io (onResult_ stage 149 (_ : putStrLn "input-channel-STAGE-FAIL") 150 (passed : putStrLn (matchBool "input-channel-ok" "input-channel-DIFFER" passed))) 151 main