consumer_build_driver.tri (5614B)
1 !import "prelude" !Local 2 !import "io" !Local 3 !import "consumers.build-driver" D 4 !import "consumers.structural" S 5 !import "consumers.lexical-worker" L 6 !import "source.module" M 7 !import "source.object" O 8 root = "__ROOT__" 9 compiler = "0123456789abcdef0123456789abcdef0123456789abcdef0123456789abcdef" 10 stateIR = S.makeConsumer t [(S.makeRule S.patAny (S.patCapture 0) (S.outCapture 0))] 11 onlyLeafIR = S.makeConsumer t [(S.makeRule S.patLeaf S.patAny (S.outLiteral t))] 12 configIR entry = (S.makeConsumer t [(S.makeRule (S.patCapture 0) (S.patCapture 1) 13 (S.outFork 14 (S.outFork (S.outLiteral "echo") 15 (S.outFork (S.outLiteral "scp-worker.v1") 16 (S.outFork (S.outFork (S.outCapture 0) (S.outCapture 1)) (S.outLiteral entry)))) 17 (S.outLiteral t)))]) 18 requestChecks manifest = (let request = D.configurationRequest manifest "configure" 7 9 in 19 foldl and? true [ 20 (resultIsOk (D.driverConfigurationRequest request)) 21 (resultIsOk (D.driverConfigurationRequest (D.configurationRequest manifest "configure" 22 (pair "scp-source.reference.v1" t) (pair "unknown IR" t)))) 23 (resultIsErr (D.driverConfigurationRequest t)) 24 (resultIsErr (D.driverConfigurationRequest (pair "scp-configuration-request.v2" (snd request)))) 25 (resultIsErr (D.driverConfigurationRequest (pair D.configurationRequestTag 26 (pair manifest (pair "configure" t))))) 27 (resultIsErr (D.driverConfigurationRequest (D.configurationRequest "bad" "configure" t t))) 28 (resultIsErr (D.driverConfigurationRequest (D.configurationRequest manifest "bad name" t t))) 29 (resultIsOk (D.driverWorkspaceRequest (D.workspaceBuildRequest "/explicit" [] "root" compiler))) 30 (resultIsErr (D.driverWorkspaceRequest (D.workspaceBuildRequest "/explicit" [] "root" "bad"))) 31 (resultIsErr (D.driverWorkspaceRequest (D.workspaceBuildRequest "" [] "root" compiler))) 32 (resultIsErr (D.driverWorkspaceRequest (D.workspaceBuildRequest "/explicit" [] "bad.name" compiler))) 33 (resultIsErr (D.driverWorkspaceRequest (pair "unknown" t)))]) 34 expectFailure action = onResult_ action (_ : pure (ok true t)) (_ : pure (ok false t)) 35 scenario = do onOk_ 36 state <- pure (L.lCompile stateIR) 37 leaf <- pure (L.lCompile onlyLeafIR) 38 configuration <- pure (L.lCompile (configIR (snd (snd state)))) 39 invalid <- pure (L.lCompile (S.makeConsumer t [(S.makeRule S.patAny S.patAny (S.outLiteral 42))])) 40 failing <- pure (L.lCompile (S.makeConsumer t 41 [(S.makeRule S.patAny S.patAny (S.outLiteral [(pair "fail" leaf)]))])) 42 manifest <- M.sourceModulePublishNames root 43 [(pair "configure" (snd (snd configuration))) (pair "invalid" (snd (snd invalid))) 44 (pair "failing" (snd (snd failing)))] 45 ["configure" "invalid" "failing"] 46 result <- D.configurePinned root (D.configurationRequest manifest "configure" 7 9) 47 repeated <- D.configurePinned root (D.configurationRequest manifest "configure" 7 9) 48 changedState <- D.configurePinned root (D.configurationRequest manifest "configure" 7 10) 49 changedInput <- D.configurePinned root (D.configurationRequest manifest "configure" 8 9) 50 failResult <- D.configurePinned root (D.configurationRequest manifest "failing" t t) 51 sameFailWorker <- D.configurePinned root (D.configurationRequest manifest "failing" 42 9) 52 failInvoke <- M.sourceModuleLoadSelected root (D.configurationInvocations failResult) "fail" 53 worker <- M.sourceModuleLoadSelected root (D.configurationWorkers result) "echo" 54 invoke <- M.sourceModuleLoadSelected root (D.configurationInvocations result) "echo" 55 receipt <- O.sourceObjectGet root "arboricx.configuration-receipt.v1" (D.configurationReceipt result) 56 inputHash <- O.sourceObjectPutTree root 7 57 stateHash <- O.sourceObjectPutTree root 9 58 unknown <- expectFailure (D.configurePinned root (D.configurationRequest manifest "missing" t t)) 59 malformed <- expectFailure (D.configurePinned root (D.configurationRequest manifest "invalid" t t)) 60 invalidRequest <- expectFailure (D.buildCode root t) 61 let checks = foldl and? true [unknown malformed invalidRequest (requestChecks manifest) 62 (equal? result repeated) 63 (equal? (invoke "argument") (ok (pair 7 9) t)) 64 (equal? (invoke "argument") (L.lRunChecked worker "argument")) 65 (equal? (D.invocation leaf "not-leaf") (err "no matching consumer rule" t)) 66 (equal? (failInvoke "not-leaf") (err "no matching consumer rule" t)) 67 (equal? (D.configurationWorkers failResult) (D.configurationWorkers sameFailWorker)) 68 (not? (equal? (D.configurationReceipt failResult) (D.configurationReceipt sameFailWorker))) 69 (equal? (S.runConsumer (S.makeConsumer 9 (snd (configIR (snd (snd state))))) 7) 70 (ok [(pair "echo" worker)] t)) 71 (not? (equal? (D.configurationReceipt result) (D.configurationReceipt changedState))) 72 (not? (equal? (D.configurationReceipt result) (D.configurationReceipt changedInput))) 73 (lExist? (append "code\t" manifest) (lines receipt)) 74 (lExist? "entry\tconfigure" (lines receipt)) 75 (lExist? (append "input\t" inputHash) (lines receipt)) 76 (lExist? (append "state\t" stateHash) (lines receipt)) 77 (lExist? (append "workers\t" (D.configurationWorkers result)) (lines receipt)) 78 (lExist? (append "invocations\t" (D.configurationInvocations result)) (lines receipt)) 79 (lExist? "invocation-profile\tscp-invocation.result.v1" (lines receipt)) 80 (lExist? "configuration-profile\tscp-configuration.lexical-worker.v1" (lines receipt))] in 81 pure (ok checks t) 82 main = io (onResult_ scenario 83 (problem : do bind 84 _ <- putStrLn "build-driver-error" 85 pure problem) 86 (passed : putStrLn (matchBool "build-driver-ok" "build-driver-DIFF" passed))) 87 main