7dd972f55e13bf81425e84f68fa1cae0380adeae129462c68026b83dbca9426a.tri (11361B)
1 !import prelude * 2 !import io * 3 !import source_object * 4 !import source_module * 5 !import source_resolve * 6 !import source_build * 7 !export * 8 9 -- Explicit bootstrap staging map. Each canonical row is: 10 -- KIND<TAB>localAlias<TAB>legacyHeaderName<TAB>relativePath<TAB>comma-separated dependency aliases (or '-' for none) 11 -- KIND is unit (export local definitions only), reexport (also explicitly 12 -- re-export every declared dependency), or native (checked native headers and 13 -- explicit authored exports, staged without rewriting). The legacy name is checked against 14 -- an original !import header only. Paths and dependency edges come exclusively 15 -- from this file, never tricu.workspace. 16 sourceMapHeader = "arboricx.source-map.v1\n" 17 sourceMapAliasSegments_ self names = 18 lazyList 19 (_ : true) 20 (name rest : andLazy? (sourceModuleAliasValid name) 21 (_ : self rest)) 22 names 23 sourceMapLegacyValid name = 24 y sourceMapAliasSegments_ (splitOnByte 46 name) 25 sourceMapPathSegments_ self names = 26 lazyList 27 (_ : true) 28 (name rest : andLazy? (sourceModuleAliasValid name) 29 (_ : self rest)) 30 names 31 sourceMapPathValid path = 32 lazyList 33 (_ : false) 34 (stem suffix : lazyList 35 (_ : false) 36 (extension extra : and? (emptyList? extra) 37 (and? (equal? extension "tri") 38 (y sourceMapPathSegments_ (splitOnByte 47 stem)))) 39 suffix) 40 (splitOnByte 46 path) 41 sourceMapDependenciesValid_ self deps rows = 42 lazyList 43 (_ : true) 44 (dep rest : andLazy? 45 (and? (sourceModuleAliasValid dep) 46 (and? (not? (emptyList? dep)) 47 (lazyMaybe false (_ : true) (sourceFindExternal rows dep)))) 48 (_ : self rest rows)) 49 deps 50 sourceMapParseRow row seen = 51 lazyList 52 (_ : err "invalid source map row" t) 53 (tag rest1 : lazyList 54 (_ : err "invalid source map row" t) 55 (name rest2 : lazyList 56 (_ : err "invalid source map row" t) 57 (legacy rest3 : lazyList 58 (_ : err "invalid source map row" t) 59 (path rest4 : lazyList 60 (_ : err "invalid source map row" t) 61 (depString extra : lazyBool 62 (_ : lazyMaybe 63 (_ : ok (pair name 64 (pair legacy (pair path 65 (pair (lazyBool (_ : t) (_ : splitOnByte 44 depString) 66 (equal? depString "-")) tag)))) t) 67 (_ : err "duplicate source map name" t) 68 (sourceFindExternal seen name)) 69 (_ : err "invalid source map name, path or fields" t) 70 (and? (or? (or? (equal? tag "unit") (equal? tag "native")) 71 (and? (equal? tag "reexport") 72 (not? (equal? depString "-")))) 73 (and? (emptyList? extra) 74 (and? (sourceModuleAliasValid name) 75 (and? (sourceMapLegacyValid legacy) 76 (sourceMapPathValid path)))))) 77 rest4) 78 rest3) 79 rest2) 80 rest1) 81 (splitOnByte 9 row) 82 sourceMapParseRows_ self rows seen = 83 lazyList 84 (_ : ok (reverse seen) t) 85 (row rest : lazyList 86 (_ : lazyBool 87 (_ : ok (reverse seen) t) 88 (_ : err "blank source map row" t) 89 (emptyList? rest)) 90 (_ _ : lazyResult 91 (problem unused : err problem t) 92 (entry unused : self rest (pair entry seen)) 93 (sourceMapParseRow row seen)) 94 row) 95 rows 96 -- A false dependency check is a Result error, not an implicit lookup. 97 sourceMapValidateDeps_ self rows all = 98 lazyList 99 (_ : ok all t) 100 (row rest : lazyBool 101 (_ : self rest all) 102 (_ : err "undeclared source map dependency" t) 103 (y sourceMapDependenciesValid_ (fst (snd (snd (snd row)))) all)) 104 rows 105 sourceMapDependencyField deps = 106 lazyList (_ : "-") (_ _ : intercalate "," deps) deps 107 sourceMapEncodeRows_ self rows = 108 lazyList 109 (_ : t) 110 (row rest : append (snd (snd (snd (snd row)))) 111 (append "\t" (append (fst row) 112 (append "\t" (append (fst (snd row)) 113 (append "\t" (append (fst (snd (snd row))) 114 (append "\t" (append 115 (sourceMapDependencyField (fst (snd (snd (snd row))))) 116 (append "\n" (self rest))))))))))) 117 rows 118 sourceMapEncode rows = append sourceMapHeader (y sourceMapEncodeRows_ rows) 119 sourceMapDecode bytes = 120 lazyList 121 (_ : err "empty source map" t) 122 (header rows : lazyBool 123 (_ : lazyResult 124 (problem unused : err problem t) 125 (entries unused : lazyList 126 (_ : err "source map requires a unit" t) 127 (_ _ : lazyResult 128 (problem unused : err problem t) 129 (validated unused : lazyBool 130 (_ : ok validated t) 131 (_ : err "noncanonical source map" t) 132 (equal? bytes (sourceMapEncode validated))) 133 (y sourceMapValidateDeps_ entries entries)) 134 entries) 135 (y sourceMapParseRows_ rows t)) 136 (_ : err "unsupported source map version" t) 137 (equal? header "arboricx.source-map.v1")) 138 (splitOnByte 10 bytes) 139 140 sourceMapExpectedImport legacy = 141 pair "!import" (pair (append "\"" (append legacy "\"")) 142 (pair "!Local" t)) 143 sourceMapStripHeader_ self original rows map = 144 lazyList 145 (_ : lazyList 146 (_ : ok t t) 147 (line rest : lazyList 148 (_ : ok (unlines (pair line rest)) t) 149 (head tail : lazyBool 150 (_ : err "undeclared bootstrap import" t) 151 (_ : ok (unlines (pair line rest)) t) 152 (equal? "!import" head)) 153 (words line)) 154 original) 155 (dep rest : lazyMaybe 156 (_ : err "undeclared source map dependency" t) 157 (entry : lazyList 158 (_ : err "missing bootstrap import" t) 159 (line tail : lazyBool 160 (_ : self tail rest map) 161 (_ : err "bootstrap import differs from explicit source map" t) 162 (equal? (words line) (sourceMapExpectedImport (fst entry)))) 163 original) 164 (sourceFindExternal map dep)) 165 rows 166 -- Compare derived local edges, not the spelling or layout of declarations. 167 -- Native author bytes, namespaces and exports remain unchanged. 168 sourceMapCheckNativeHeader source deps = (bindResult 169 (sourceModuleHeaderStage source) (staged _ : lazyBool 170 (_ : ok t t) 171 (_ : err "native source differs from explicit source map" t) 172 (equal? (fst staged) deps))) 173 sourceMapPrepareBody row original all = 174 lazyBool 175 (_ : lazyResult 176 (problem unused : err problem t) 177 (_ unused : ok original t) 178 (sourceMapCheckNativeHeader original 179 (fst (snd (snd (snd row)))))) 180 (_ : y sourceMapStripHeader_ (lines original) 181 (fst (snd (snd (snd row)))) all) 182 (equal? (snd (snd (snd (snd row)))) "native") 183 sourceMapUseHeader_ self deps = 184 lazyList 185 (_ : t) 186 (dep rest : append "!import " 187 (append dep (append " *\n" (self rest)))) 188 deps 189 sourceMapReexportHeader_ self deps = 190 lazyList 191 (_ : t) 192 (dep rest : append "!export * from " 193 (append dep (append "\n" (self rest)))) 194 deps 195 sourceMapLegacyOverlay row body = 196 (append (y sourceMapUseHeader_ (fst (snd (snd (snd row))))) 197 (append "!export *\n" 198 (append (lazyBool 199 (_ : y sourceMapReexportHeader_ (fst (snd (snd (snd row))))) 200 (_ : t) 201 (equal? (snd (snd (snd (snd row)))) "reexport")) 202 body))) 203 sourceMapOverlay row body = (lazyBool 204 (_ : body) 205 (_ : sourceMapLegacyOverlay row body) 206 (equal? (snd (snd (snd (snd row)))) "native")) 207 sourceMapStageOne sourceRoot overlayRoot all row = 208 onResult_ (readFile (append sourceRoot (append "/" 209 (fst (snd (snd row))))) ) 210 (problem : pure (err problem t)) 211 (original : lazyResult 212 (problem unused : pure (err problem t)) 213 (body unused : onOk_ 214 (sourceObjectDigest "arboricx.source.v1" original) 215 (rawDigest : onOk_ 216 (sourceObjectDigest "arboricx.source.v1" 217 (sourceMapOverlay row body)) 218 (overlayDigest : onOk_ 219 (atomicWriteBytes (append overlayRoot 220 (append "/" (append (fst row) ".tri"))) 221 (sourceMapOverlay row body)) 222 (_ : pure (ok 223 (pair (fst row) (pair rawDigest overlayDigest)) t))))) 224 (sourceMapPrepareBody row original all)) 225 sourceMapStageAll_ self rows sourceRoot overlayRoot all records = 226 lazyList 227 (_ : pure (ok (reverse records) t)) 228 (row rest : onResult_ (sourceMapStageOne sourceRoot overlayRoot 229 all row) 230 (problem : pure (err problem t)) 231 (record : self rest sourceRoot overlayRoot all 232 (pair record records))) 233 rows 234 sourceMapRecords_ self records = 235 lazyList 236 (_ : t) 237 (record rest : append "input\t" (append (fst record) 238 (append "\t" (append (fst (snd record)) 239 (append "\t" (append (snd (snd record)) 240 (append "\n" (self rest)))))))) 241 records 242 sourceMapBuildReceipt mapHash compiler rootName result records = 243 append "arboricx.source-map-build.v1\n" 244 (append "map\t" (append mapHash 245 (append "\ncompiler\t" (append compiler 246 (append "\nroot\t" (append rootName 247 (append "\t" (append (fst result) 248 (append "\t" (append (snd result) 249 (append "\n" (y sourceMapRecords_ records)))))))))))) 250 251 -- Prepare a checked overlay from a versioned, content-addressed source map. 252 -- Returns the immutable map ID and input (original, overlay) digest rows. 253 sourceMapStage sourceRoot overlayRoot casRoot mapBytes = 254 lazyResult 255 (problem unused : pure (err problem t)) 256 (rows unused : onResult_ (sourceObjectStore casRoot 257 "arboricx.source-map.v1" mapBytes) 258 (problem : pure (err problem t)) 259 (mapHash : onOk_ (createDirectory overlayRoot) (_ : 260 onResult_ (y sourceMapStageAll_ rows sourceRoot overlayRoot 261 rows t) 262 (problem : pure (err problem t)) 263 (records : pure (ok (pair mapHash (pair rows records)) t))))) 264 (sourceMapDecode mapBytes) 265 266 -- Root build receipt references the complete map and source input snapshot; 267 -- the regular module receipts still describe each generated source unit. 268 sourceMapBuildWith buildGraph sourceRoot overlayRoot casRoot compiler mapBytes rootName = 269 onResult_ (sourceMapStage sourceRoot overlayRoot casRoot mapBytes) 270 (problem : pure (err problem t)) 271 (staged : lazyMaybe 272 (_ : pure (err "root missing from source map" t)) 273 (_ : onResult_ (buildGraph overlayRoot casRoot compiler rootName) 274 (problem : pure (err problem t)) 275 (result : onResult_ (sourceObjectStore casRoot 276 "arboricx.source-map-build.v1" 277 (sourceMapBuildReceipt (fst staged) compiler rootName result 278 (snd (snd staged)))) 279 (problem : pure (err problem t)) 280 (buildReceipt : pure (ok (pair result buildReceipt) t)))) 281 (sourceFindExternal (fst (snd staged)) rootName)) 282 283 -- Explicit generation backends share staging, graph policy and map receipts. 284 -- The selected graph owns its distinct module options identity; neither wrapper 285 -- catches compilation failure or attempts another backend. 286 sourceMapBuild sourceRoot overlayRoot casRoot compiler mapBytes rootName = 287 sourceMapBuildWith sourceBuildGraph sourceRoot overlayRoot casRoot compiler mapBytes rootName 288 sourceMapBuildStable sourceRoot overlayRoot casRoot compiler mapBytes rootName = 289 sourceMapBuildWith sourceBuildGraphStable sourceRoot overlayRoot casRoot compiler mapBytes rootName 290