d26f4b51118a1b0f3e4fde1ef8f744a920fdc71bea206abf5051a1d7bac0f7e6.tri (11270B)
1 !import prelude * 2 !import io * 3 !import source_module * 4 !import source_object * 5 !import source_resolve * 6 !export * 7 8 -- A named lock is an explicitly updated local snapshot. Rows record the 9 -- original reference, one coherent originating manifest, and every export 10 -- selected by that reference (the native import / re-export profile selects 11 -- a manifest's whole public interface). No ambient alias is read by a 12 -- locked build. The manifest remains authoritative for its export hashes. 13 sourceLockHeader = "arboricx.source-lock.v1\n" 14 sourceLockPath root name = append root (append "/locks/" name) 15 sourceLockRow ref hash entry = 16 append "pin\t" (append (sourceModuleEscape ref) 17 (append "\t" (append hash 18 (append "\t" (append (sourceModuleEscape (fst entry)) 19 (append "\t" (append (snd entry) "\n"))))))) 20 sourceLockRows_ self entries ref hash = 21 lazyList 22 (_ : t) 23 (entry rest : append (sourceLockRow ref hash entry) 24 (self rest ref hash)) 25 entries 26 sourceLockGroups_ self groups = 27 lazyList 28 (_ : t) 29 (group rest : append 30 (y sourceLockRows_ (snd (snd group)) (fst group) (fst (snd group))) 31 (self rest)) 32 groups 33 sourceLockEncode groups = 34 append sourceLockHeader (y sourceLockGroups_ groups) 35 36 -- A row is ref -> (manifest hash -> (export name -> exact tree hash)). 37 sourceLockParseRow fields = 38 lazyList 39 (_ : err "invalid lock row" t) 40 (tag r1 : lazyList 41 (_ : err "invalid lock row" t) 42 (encodedRef r2 : lazyList 43 (_ : err "invalid lock row" t) 44 (manifest r3 : lazyList 45 (_ : err "invalid lock row" t) 46 (encodedName r4 : lazyList 47 (_ : err "invalid lock row" t) 48 (tree extra : lazyBool 49 (_ : lazyResult 50 (problem unused : err problem t) 51 (ref unused : lazyResult 52 (problem unused : err problem t) 53 (name unused : lazyBool 54 (_ : ok (pair ref (pair manifest 55 (pair name tree))) t) 56 (_ : err "invalid lock ref, export or digest" t) 57 (and? (or? (sourceModuleDigest? ref) 58 (sourceModuleAliasValid ref)) 59 (and? (sourceModuleDigest? manifest) 60 (and? (sourceModuleExportNameValid name) 61 (sourceModuleDigest? tree))))) 62 (sourceModuleUnescape encodedName)) 63 (sourceModuleUnescape encodedRef)) 64 (_ : err "invalid lock row" t) 65 (and? (equal? tag "pin") (emptyList? extra))) 66 r4) 67 r3) 68 r2) 69 r1) 70 fields 71 sourceLockParseRows_ self rows acc = 72 lazyList 73 (_ : ok (reverse acc) t) 74 (line rest : lazyList 75 (_ : lazyList 76 (_ : ok (reverse acc) t) 77 (_ _ : err "blank lock row" t) 78 rest) 79 (_ _ : lazyResult 80 (problem unused : err problem t) 81 (entry unused : self rest (pair entry acc)) 82 (sourceLockParseRow (splitOnByte 9 line))) 83 line) 84 rows 85 sourceLockDecode bytes = 86 lazyList 87 (_ : err "empty lock" t) 88 (header lines : lazyBool 89 (_ : y sourceLockParseRows_ lines t) 90 (_ : err "unsupported lock version" t) 91 (equal? header "arboricx.source-lock.v1")) 92 (splitOnByte 10 bytes) 93 94 sourceLockDistinct_ self rows seen = 95 lazyList 96 (_ : ok (reverse seen) t) 97 (row rest : lazyMaybe 98 (_ : self rest (pair (pair (fst row) (fst (snd row))) seen)) 99 (previous : lazyBool 100 (_ : self rest seen) 101 (_ : err "incoherent lock snapshot" t) 102 (equal? previous (fst (snd row)))) 103 (sourceFindExternal seen (fst row))) 104 rows 105 sourceLockRowsFor_ self rows ref entries = 106 lazyList 107 (_ : reverse entries) 108 (row rest : lazyBool 109 (_ : self rest ref (pair (snd (snd row)) entries)) 110 (_ : self rest ref entries) 111 (equal? ref (fst row))) 112 rows 113 sourceLockRowsFor rows ref = y sourceLockRowsFor_ rows ref t 114 sourceLockCheckTrees_ self entries root = 115 lazyList 116 (_ : pure (ok t t)) 117 (entry rest : onResult_ (sourceObjectGetTree root (snd entry)) 118 (problem : pure (err problem t)) 119 (_ : self rest root)) 120 entries 121 sourceLockCheckTrees root entries = y sourceLockCheckTrees_ entries root 122 sourceLockVerify_ self refs root rows groups = 123 lazyList 124 (_ : pure (ok (reverse groups) t)) 125 (refHash rest : onResult_ (sourceModuleGetManifest root (snd refHash)) 126 (problem : pure (err problem t)) 127 (entries : lazyBool 128 (_ : onOk_ (sourceLockCheckTrees root entries) (_ : 129 self rest root rows (pair 130 (pair (fst refHash) (pair (snd refHash) entries)) groups))) 131 (_ : pure (err "lock export snapshot mismatch" t)) 132 (equal? entries (sourceLockRowsFor rows (fst refHash))))) 133 refs 134 sourceLockVerify root bytes = 135 lazyResult 136 (problem unused : pure (err problem t)) 137 (rows unused : lazyResult 138 (problem unused : pure (err problem t)) 139 (refs unused : lazyList 140 (_ : pure (err "lock requires a module" t)) 141 (_ _ : onResult_ (y sourceLockVerify_ refs root rows t) 142 (problem : pure (err problem t)) 143 (groups : lazyBool 144 (_ : pure (ok groups t)) 145 (_ : pure (err "noncanonical lock" t)) 146 (equal? bytes (sourceLockEncode groups)))) 147 refs) 148 (y sourceLockDistinct_ rows t)) 149 (sourceLockDecode bytes) 150 151 -- Gather each source ref once. Resolving an alias occurs once per update; 152 -- repeated directives share the same immutable manifest snapshot. 153 sourceLockCollect_ self refs root groups = 154 lazyList 155 (_ : pure (ok (reverse groups) t)) 156 (ref rest : lazyMaybe 157 (_ : onResult_ (sourceModuleResolveRef root ref) 158 (problem : pure (err problem t)) 159 (hash : onResult_ (sourceModuleGetManifest root hash) 160 (problem : pure (err problem t)) 161 (entries : onOk_ (sourceLockCheckTrees root entries) (_ : 162 self rest root (pair (pair ref (pair hash entries)) groups))))) 163 (_ : self rest root groups) 164 (sourceFindExternal groups ref)) 165 refs 166 sourceLockUseRefs_ self uses acc = 167 lazyList 168 (_ : ok (reverse acc) t) 169 (words rest : lazyResult 170 (problem unused : err problem t) 171 (spec unused : self rest (pair (fst spec) acc)) 172 (sourceModuleUseShape words)) 173 uses 174 sourceLockExportRefs_ self exports acc = 175 lazyList 176 (_ : ok (reverse acc) t) 177 (words rest : lazyResult 178 (problem unused : err problem t) 179 (spec unused : lazyBool 180 (_ : self rest (pair (snd spec) acc)) 181 (_ : self rest acc) 182 (equal? (fst spec) "from")) 183 (sourceModuleExportShape words)) 184 exports 185 sourceLockSourceRefs source = 186 lazyResult 187 (problem unused : err problem t) 188 (staged unused : lazyResult 189 (problem unused : err problem t) 190 (uses unused : lazyResult 191 (problem unused : err problem t) 192 (exports unused : ok (append uses exports) t) 193 (y sourceLockExportRefs_ (fst (snd staged)) t)) 194 (y sourceLockUseRefs_ (fst staged) t)) 195 (sourceModuleStage source) 196 sourceLockUpdate root name source = 197 lazyBool 198 (_ : lazyResult 199 (problem unused : pure (err problem t)) 200 (refs unused : onResult_ (y sourceLockCollect_ refs root t) 201 (problem : pure (err problem t)) 202 (groups : lazyList 203 (_ : pure (err "lock requires a module" t)) 204 (_ _ : onOk_ (createDirectory root) (_ : 205 onOk_ (createDirectory (append root "/locks")) (_ : 206 onOk_ (atomicWriteBytes (sourceLockPath root name) 207 (sourceLockEncode groups)) (_ : pure (ok t t))))) 208 groups)) 209 (sourceLockSourceRefs source)) 210 (_ : pure (err "invalid lock name" t)) 211 (sourceModuleAliasValid name) 212 213 sourceLockRewriteUses_ self uses groups = 214 lazyList 215 (_ : ok t t) 216 (words rest : lazyResult 217 (problem unused : err problem t) 218 (spec unused : lazyMaybe 219 (_ : err "unlocked module reference" t) 220 (group : lazyResult 221 (problem unused : err problem t) 222 (suffix unused : ok (append "!import " 223 (append (fst group) (append (lazyBool 224 (_ : " *\n") 225 (_ : append " as " (append (snd spec) "\n")) 226 (equal? (snd spec) "*")) suffix))) t) 227 (self rest groups)) 228 (sourceFindExternal groups (fst spec))) 229 (sourceModuleUseShape words)) 230 uses 231 sourceLockRewriteExports_ self exports groups = 232 lazyList 233 (_ : ok t t) 234 (words rest : lazyResult 235 (problem unused : err problem t) 236 (spec unused : lazyResult 237 (problem unused : err problem t) 238 (suffix unused : lazyBool 239 (_ : lazyMaybe 240 (_ : err "unlocked re-export" t) 241 (group : ok (append "!export * from " 242 (append (fst group) (append "\n" suffix))) t) 243 (sourceFindExternal groups (snd spec))) 244 (_ : ok (append "!export " 245 (append (fst spec) (append "\n" suffix))) t) 246 (equal? (fst spec) "from")) 247 (self rest groups)) 248 (sourceModuleExportShape words)) 249 exports 250 sourceLockRewriteSource source groups = 251 lazyResult 252 (problem unused : err problem t) 253 (staged unused : lazyResult 254 (problem unused : err problem t) 255 (uses unused : lazyResult 256 (problem unused : err problem t) 257 (exports unused : ok (append uses 258 (append exports (snd (snd staged)))) t) 259 (y sourceLockRewriteExports_ (fst (snd staged)) groups)) 260 (y sourceLockRewriteUses_ (fst staged) groups)) 261 (sourceModuleStage source) 262 -- Immutable binding selection without moving body coordinates. Rewritten 263 -- directives are interpreted separately, never prepended to the masked body. 264 sourceLockRewriteStaged source groups = (bindResult (sourceModuleStage source) 265 (staged _ : bindResult (sourceLockRewriteSource source groups) 266 (rewritten _ : bindResult (sourceModuleStage rewritten) 267 (header _ : ok (pair (fst header) 268 (pair (fst (snd header)) (snd (snd staged)))) t)))) 269 sourceLockUniqueRefs_ self refs seen = 270 lazyList 271 (_ : y sourceLockGroupRefs_ (reverse seen)) 272 (ref rest : lazyMaybe 273 (_ : self rest (pair (pair ref t) seen)) 274 (_ : self rest seen) 275 (sourceFindExternal seen ref)) 276 refs 277 sourceLockGroupRefs_ self groups = 278 lazyList 279 (_ : t) 280 (group rest : pair (fst group) (self rest)) 281 groups 282 sourceLockBuild root name source = 283 lazyBool 284 (_ : onResult_ (readFile (sourceLockPath root name)) 285 (problem : pure (err problem t)) 286 (bytes : onResult_ (sourceLockVerify root bytes) 287 (problem : pure (err problem t)) 288 (groups : lazyResult 289 (problem unused : pure (err problem t)) 290 (refs unused : lazyBool 291 (_ : lazyResult 292 (problem unused : pure (err problem t)) 293 (staged unused : sourceModuleBuildStaged root staged) 294 (sourceLockRewriteStaged source groups)) 295 (_ : pure (err "lock source references changed; update required" t)) 296 (equal? (y sourceLockGroupRefs_ groups) 297 (y sourceLockUniqueRefs_ refs t))) 298 (sourceLockSourceRefs source)))) 299 (_ : pure (err "invalid lock name" t)) 300 (sourceModuleAliasValid name) 301