build-driver.tri (6799B)
1 !import prelude * 2 !import io * 3 !import source_workspace_build as W 4 !import source_module as M 5 !import source_object as O 6 !import consumers_validate as V 7 !import consumers_configure as C 8 !import consumers_lexical_worker as L 9 !export * 10 -- Reusable build boundaries over portable request trees. This module does 11 -- not enforce time/reduction budgets: invoke each phase under an external 12 -- deadline. No exported configuration is run during code building. 13 14 workspaceRequestTag = "arboricx.workspace-build-request.v1" 15 configurationRequestTag = "scp-configuration-request.v1" 16 entryConfigurationRequestTag = "scp-entry-configuration-request.v1" 17 entryConfigurationProfile = "scp-configuration.entry-state.v1" 18 codeResultTag = "arboricx.workspace-build-result.v1" 19 configurationResultTag = "scp-configuration-result.v1" 20 invocationProfile = "scp-invocation.result.v1" 21 configurationProfile = "scp-configuration.lexical-worker.v1" 22 workspaceBuildRequest directory declarations name compiler = (pair workspaceRequestTag 23 (pair directory (pair declarations (pair name compiler)))) 24 configurationRequest manifest name input state = (pair configurationRequestTag 25 (pair manifest (pair name (pair input state)))) 26 entryConfigurationRequest manifest entry name state = (pair entryConfigurationRequestTag 27 (pair manifest (pair entry (pair name state)))) 28 -- Fixed four-field record. Input and state fields are opaque arbitrary trees. 29 driverFour record next = (lazyBool 30 (_ : matchPair (a rest : lazyBool 31 (_ : matchPair (b rest : lazyBool 32 (_ : matchPair (c d : next a b c d) rest) 33 (_ : err "invalid request fields" t) (V.vPair? rest)) rest) 34 (_ : err "invalid request fields" t) (V.vPair? rest)) record) 35 (_ : err "invalid request fields" t) (V.vPair? record)) 36 driverRequest request tag next = (lazyBool 37 (_ : lazyBool (_ : driverFour (snd request) next) 38 (_ : err "unknown build request version" t) (equal? (fst request) tag)) 39 (_ : err "invalid build request" t) (V.vPair? request)) 40 driverWorkspaceRequest request = (driverRequest request workspaceRequestTag 41 (directory declarations name compiler : lazyBool 42 (_ : bindResult (W.workspaceDeclarations declarations) 43 (_ _ : ok (pair directory (pair declarations (pair name compiler))) t)) 44 (_ : err "invalid workspace build fields" t) 45 (and? (triage false (_ : false) (_ _ : y W.wbPathChars_ directory) directory) 46 (and? (M.sourceModuleAliasValid name) (O.sourceObjectHashValid compiler))))) 47 driverConfigurationRequest request = (driverRequest request configurationRequestTag 48 (manifest name input state : lazyBool 49 (_ : ok (pair manifest (pair name (pair input state))) t) 50 (_ : err "invalid configuration selection" t) 51 (and? (O.sourceObjectHashValid manifest) (M.sourceModuleExportNameValid name)))) 52 buildCode root request = (lazyResult 53 (problem unused : pure (err problem t)) 54 (fields unused : onOk_ (W.workspaceBuildGraph (fst fields) (fst (snd fields)) 55 root (snd (snd (snd fields))) (fst (snd (snd fields)))) 56 (built : pure (ok (pair codeResultTag built) t))) 57 (driverWorkspaceRequest request)) 58 codeManifest result = fst (snd result) 59 codeReceipt result = snd (snd result) 60 configurationWorkers result = fst (snd result) 61 configurationInvocations result = fst (snd (snd result)) 62 configurationReceipt result = snd (snd (snd result)) 63 -- Standard callable wrapper. Success AND failure remain SCP Result data; 64 -- no formatting, file IO, shape dispatch or host-side SCP evaluator is added. 65 invocation worker = input : L.lRunChecked worker input 66 invocationRows rows = map (row : pair (fst row) (input : L.lRunChecked (snd row) input)) rows 67 configurationReceiptBytes fields inputHash stateHash workers invocations = ( 68 configurationReceiptBytesWithProfile configurationProfile fields inputHash stateHash workers invocations) 69 configurationReceiptBytesWithProfile profile fields inputHash stateHash workers invocations = (append 70 "arboricx.configuration-receipt.v1\ncode\t" (append (fst fields) 71 (append "\nentry\t" (append (M.sourceModuleEscape (fst (snd fields))) 72 (append "\ninput\t" (append inputHash (append "\nstate\t" (append stateHash 73 (append "\nworkers\t" (append workers (append "\ninvocations\t" (append invocations 74 (append "\ninvocation-profile\t" (append invocationProfile 75 (append "\nconfiguration-profile\t" (append profile "\n")))))))))))))))) 76 driverPublish root fields rows = driverPublishWithProfile configurationProfile root fields rows 77 driverPublishWithProfile profile root fields rows = (onOk_ 78 (M.sourceModulePublishNames root rows (C.configurationNames rows)) (workers : 79 onOk_ (M.sourceModulePublishNames root (invocationRows rows) (C.configurationNames rows)) 80 (invocations : onOk_ (O.sourceObjectPutTree root (fst (snd (snd fields)))) 81 (inputHash : onOk_ (O.sourceObjectPutTree root (snd (snd (snd fields)))) 82 (stateHash : onOk_ (O.sourceObjectStore root "arboricx.configuration-receipt.v1" 83 (configurationReceiptBytesWithProfile profile fields inputHash stateHash workers invocations)) 84 (receipt : pure (ok (pair configurationResultTag 85 (pair workers (pair invocations receipt))) t))))))) 86 configurePinned root request = (lazyResult 87 (problem unused : pure (err problem t)) 88 (fields unused : onOk_ (M.sourceModuleLoadSelected root (fst fields) (fst (snd fields))) 89 (entry : lazyResult 90 (problem unused : pure (err (pair "configuration invocation" problem) t)) 91 (rows unused : lazyResult 92 (problem unused : pure (err (pair "configuration output" problem) t)) 93 (checked unused : driverPublish root fields checked) 94 (C.configurationRows rows)) 95 (L.lRunChecked (L.lWorker (snd (snd (snd fields))) entry) 96 (fst (snd (snd fields)))))) 97 (driverConfigurationRequest request)) 98 99 -- Bind one checked pinned entry to explicit state using the same publication 100 -- and receipt authority. Input in this profile records the publication name. 101 bindPinned root request = (lazyResult 102 (problem unused : pure (err problem t)) 103 (fields unused : onOk_ (M.sourceModuleLoadSelected root (fst fields) (fst (snd fields))) 104 (entry : lazyResult 105 (problem unused : pure (err problem t)) 106 (checked unused : driverPublishWithProfile entryConfigurationProfile root fields checked) 107 (C.configurationRows [(pair (fst (snd (snd fields))) 108 (L.lWorker (snd (snd (snd fields))) entry))]))) 109 (driverRequest request entryConfigurationRequestTag 110 (manifest entry name state : lazyBool 111 (_ : ok (pair manifest (pair entry (pair name state))) t) 112 (_ : err "invalid entry configuration selection" t) 113 (and? (O.sourceObjectHashValid manifest) 114 (and? (M.sourceModuleExportNameValid entry) (M.sourceModuleExportNameValid name))))))