consumer_unit_source.tri (6651B)
1 !import "prelude" !Local 2 !import "io" !Local 3 !import "lexer" X 4 !import "parser" P 5 !import "consumers.source" C 6 !import "consumers.base-source" B 7 !import "consumers.unit-source" U 8 !import "consumers.unit-compile" UC 9 !import "consumers.structural" S 10 !import "consumers.lexical-worker" L 11 !import "consumers.validate" V 12 !import "consumers.configure" CF 13 !import "consumers.linked-reference" R 14 15 lookup rows name = lazyMaybe (_ : t) (value : value) (C.cSlot rows name) 16 entry rows name = fst (lookup rows name) 17 authored rows name = fst (snd (lookup rows name)) 18 worker rows name = L.lWorker t (entry rows name) 19 run rows name input = L.lRunChecked (worker rows name) input 20 ref rows name input = (R.runLinkedReference (R.linkedReferenceRows rows) 21 (worker rows name) input) 22 problemCode result = lazyResult (problem _ : P.parserDiagnosticCode problem) (_ _ : 0) result 23 problemLocation result = lazyResult (problem _ : P.parserDiagnosticLocation problem) (_ _ : t) result 24 identityRules = S.makeConsumer t [(S.makeRule (S.patCapture 0) S.patAny (S.outCapture 0))] 25 checks source identity = (lazyResult (_ _ : false) 26 (rows _ : 27 let exports = run rows "configure" 42 in 28 let configured = lookup (resultOr t exports) "identity" in 29 foldl and? true [ 30 (equal? (length rows) 5) 31 (equal? (entry rows "identity") (snd (snd identity))) 32 (equal? (run rows "forwarded" 42) (ok 42 t)) 33 (equal? (run rows "forwarded" 42) (ref rows "forwarded" 42)) 34 (equal? exports (ref rows "configure" 42)) 35 (resultIsOk (CF.configurationRows (resultOr t exports))) 36 (equal? (L.lRunChecked configured 42) (ok 42 t)) 37 (equal? (run rows "shadow" 9) (ok (pair 9 (snd (snd identity))) t)) 38 (foldl and? true (map (row : resultIsOk (V.vValidate (fst (snd (snd row))))) rows)) 39 (equal? (problemCode (UC.compileScpUnit "consumer a\n _ @ _ => Self.missing" [])) 22) 40 (equal? (problemCode (UC.compileScpUnit "consumer a\n _ @ _ => Self.a" [])) 24) 41 (equal? (problemCode (UC.compileScpUnit 42 "consumer a\n _ @ _ => Self.b\nconsumer b\n _ @ _ => Self.a" [])) 24) 43 (equal? (problemCode (UC.compileScpUnit 44 "consumer a\n _ @ _ => Self.b\nconsumer b\n _ @ _ => Missing.code" [])) 22) 45 (equal? (problemCode (U.parseScpUnit 46 "consumer a\n _ @ _ => leaf\nconsumer a\n _ @ _ => leaf")) 21) 47 (equal? (X.lexerPositionLine (problemLocation (U.parseScpUnit 48 "consumer a\n _ @ _ => leaf\nconsumer a\n _ @ _ => leaf"))) 3) 49 (equal? (X.lexerPositionLine (problemLocation (UC.compileScpUnit 50 "-- retained positions\n\nconsumer a\n _ @ _ => Missing.code" []))) 4) 51 (resultIsErr (U.parseScpUnit "")) 52 (equal? (U.parseScpModuleBody "-- barrel body\n") (ok [] t)) 53 (equal? (UC.compileScpModuleBody "" []) (ok [] t)) 54 (equal? (B.compileBaseSource "!export identity\nconsumer identity\n x @ _ => x") 55 (B.compileBaseSource "consumer identity\n x @ _ => x")) 56 (resultIsErr (B.compileBaseSource "!export different\nconsumer identity\n x @ _ => x")) 57 (resultIsErr (B.compileBaseSource "!export *\nconsumer identity\n x @ _ => x")) 58 (resultIsErr (B.compileBaseSource "!import dep as D\nconsumer identity\n x @ _ => x")) 59 (let located = resultOr t (B.compileBaseSourceLocated 60 "!export identity\n-- comment\nconsumer identity\n x @ _ => x") in 61 equal? (X.lexerPositionLine (fst (head (snd located)))) 4) 62 (resultIsErr (U.parseScpUnit "consumer a")) 63 (resultIsErr (U.parseScpUnit "consumer a\n _ @ _ => Lib.")) 64 (resultIsErr (U.parseScpUnit "consumer a\n _ @ _ => Lib.a.b")) 65 (resultIsErr (U.parseScpUnit "consumer a\n Lib.x @ _ => leaf")) 66 (resultIsOk (B.compileBaseSource "consumer old\n x.y @ _ => x.y")) 67 (resultIsErr (UC.compileScpUnit "consumer a\n _ @ _ => missing" [])) 68 (equal? (run (resultOr t (UC.compileScpUnit 69 "consumer a\n _ @ _ => (\"scp-source.reference.v1\", (\"Self.missing\", leaf))" [])) "a" t) 70 (ok (pair "scp-source.reference.v1" (pair "Self.missing" t)) t)) 71 (resultIsErr (UC.compileScpUnit "consumer a\n _ @ _ => Self.a" 72 [(pair "Self.a" t)])) 73 (resultIsErr (UC.compileScpUnit "consumer a\n _ @ _ => Lib.a" 74 [(pair "Lib.a" t) (pair "Lib.a" (t t))])) 75 (resultIsOk (UC.compileScpUnit "consumer recur\n x @ s => recur x @ s" [])) 76 (resultIsOk (U.parseScpUnit "consumer a\n consumer @ _ => consumer")) 77 (equal? (problemCode (UC.compileScpUnit 78 "consumer a\n _ @ _ => (Self.a, Missing.code)" [])) 22) 79 (equal? (run (resultOr t (UC.compileScpUnit 80 "consumer a\n _ @ _ => Lib.opaque" 81 [(pair "Lib.opaque" (pair U.usReferenceTag (pair "Self.missing" t)))])) "a" t) 82 (ok (pair U.usReferenceTag (pair "Self.missing" t)) t)) 83 (foldl and? true (map (template : resultIsOk (UC.compileScpUnit 84 (append "consumer a\n x @ s => " template) [(pair "Lib.value" 42)])) 85 ["stem Lib.value" "(Lib.value, x)" "equal Lib.value x" 86 "recur Lib.value @ s" 87 "become Lib.value x @ Lib.value" 88 "call Lib.value Lib.value as answer in (answer, Lib.value)" 89 "match Lib.value of (leaf => Lib.value | _ => Lib.value)" 90 "choose leaf Lib.value Lib.value"])) 91 (let stateRows = resultOr t (UC.compileScpUnit 92 "consumer state\n _ @ s => s\nconsumer caller\n worker @ _ => call worker leaf as value in value\nconsumer delegate\n worker @ _ => become worker leaf @ 42" []) in 93 let target = L.lWorker 9 (entry stateRows "state") in 94 foldl and? true [ 95 (equal? (run stateRows "caller" target) (ok 9 t)) 96 (equal? (ref stateRows "caller" target) (ok 9 t)) 97 (equal? (run stateRows "delegate" target) (ok 42 t)) 98 (equal? (ref stateRows "delegate" target) (ok 42 t)) 99 (resultIsErr (run stateRows "caller" (entry stateRows "state"))) 100 (resultIsErr (ref stateRows "caller" (entry stateRows "state")))]) 101 (let reversedRows = resultOr t (UC.compileScpDefinitions 102 (reverse (resultOr t (U.parseScpUnit source))) 103 [(pair "Lib.identity" (snd (snd identity)))]) in 104 foldl and? true (map (row : equal? (fst (snd row)) 105 (entry reversedRows (fst row))) rows)) 106 ]) 107 (UC.compileScpUnit source [(pair "Lib.identity" (snd (snd identity)))])) 108 main = io (onResult_ (readFile "test/fixtures/consumer-unit.scp") 109 (_ : putStrLn "unit-read-failed") 110 (source : lazyResult (_ _ : putStrLn "identity-compile-failed") 111 (identity _ : lazyBool (_ : putStrLn "scp-unit-source-ok") 112 (_ : putStrLn "scp-unit-source-failed") (checks source identity)) 113 (L.lCompile identityRules))) 114 main