tricu

An interpreted language for exploring Tree Calculus
Log | Files | Refs | README | LICENSE

7c8362f2607c1226562ef0133d149de15ff94578a9305b08cf347824910da446.tri (14737B)

      1 !import prelude *
      2 !import io *
      3 !import source_object *
      4 !import source_module *
      5 !import source_lock *
      6 !import source_bundle *
      7 !import source_resolve *
      8 !import source_unit *
      9 !export *
     10 
     11 -- Local imports/re-exports acquire workspaceRoot/NAME.tri; !source is build-only.
     12 -- Other profiles supply read/compile steps over the same graph and receipts.
     13 -- References resolve only through selected locals or immutable full hashes.
     14 sourceBuildSourcePath workspace name =
     15   append workspace (append "/" (append name ".tri"))
     16 sourceBuildContains_ self names name =
     17   lazyList
     18     (_ : false)
     19     (item rest : lazyBool
     20       (_ : true)
     21       (_ : self rest name)
     22       (equal? item name))
     23     names
     24 -- Graph acquisition and binding use the same interpreter as module compilation.
     25 sourceBuildStage source = (bindResult (sourceModuleHeaderStage source)
     26   (staged _ : ok (pair (fst staged) source) t))
     27 
     28 -- Lock rewriting is reused as a pure immutable-ref substitution, not as a
     29 -- lockfile read. The groups below are selected from this build's local graph
     30 -- or explicit full hashes; no moving module alias is consulted.
     31 sourceBuildResolveRefs_ self refs root groups =
     32   lazyList
     33     (_ : pure (ok groups t))
     34     (ref rest : lazyMaybe
     35       (_ : lazyBool
     36         (_ : onResult_ (sourceModuleGetManifest root ref)
     37           (problem : pure (err problem t))
     38           (entries : self rest root (pair
     39             (pair ref (pair ref entries)) groups)))
     40         (_ : pure (err "undeclared local source reference" t))
     41         (sourceObjectHashValid ref))
     42       (_ : self rest root groups)
     43       (sourceFindExternal groups ref))
     44     refs
     45 sourceBuildGroupsFromLocals_ self locals root groups =
     46   lazyList
     47     (_ : pure (ok (reverse groups) t))
     48     (dep rest : onResult_ (sourceModuleGetManifest root
     49         (fst (snd dep)))
     50       (problem : pure (err problem t))
     51       (entries : self rest root (pair
     52         (pair (fst dep) (pair (fst (snd dep)) entries)) groups)))
     53     locals
     54 sourceBuildLocalRows_ self locals =
     55   lazyList
     56     (_ : t)
     57     (dep rest : append "local\t"
     58       (append (fst dep) (append "\t"
     59         (append (fst (snd dep)) (append "\t"
     60           (append (snd (snd dep))
     61             (append "\n" (self rest))))))))
     62     locals
     63 sourceBuildPinRows_ self exports ref manifest =
     64   lazyList
     65     (_ : t)
     66     (entry rest : append "pin\t"
     67       (append ref (append "\t"
     68         (append manifest (append "\t"
     69           (append (sourceModuleEscape (fst entry))
     70             (append "\t" (append (snd entry)
     71               (append "\n" (self rest ref manifest))))))))))
     72     exports
     73 sourceBuildAllPinRows_ self groups =
     74   lazyList
     75     (_ : t)
     76     (group rest : append
     77       (y sourceBuildPinRows_ (snd (snd group)) (fst group)
     78         (fst (snd group)))
     79       (self rest))
     80     groups
     81 sourceBuildReceiptBytes sourceDigest compilerDigest optionsDigest manifestHash locals groups =
     82   append "arboricx.build-receipt.v1\n"
     83     (append "source\t" (append sourceDigest
     84       (append "\ncompiler\t" (append compilerDigest
     85         (append "\noptions\t" (append optionsDigest
     86           (append "\noutput\t" (append manifestHash
     87             (append "\n" (append (y sourceBuildLocalRows_ locals)
     88               (y sourceBuildAllPinRows_ groups)))))))))))
     89 sourceBuildPutReceipt root source compiler optionsDigest manifestHash locals groups =
     90   onOk_ (sourceObjectDigest "arboricx.source.v1" source) (sourceDigest :
     91     sourceObjectStore root "arboricx.build-receipt.v1"
     92       (sourceBuildReceiptBytes sourceDigest compiler optionsDigest
     93         manifestHash locals groups))
     94 
     95 -- A mutable local index is only an acceleration hint. CAS manifests, receipts,
     96 -- and tree objects remain the authoritative outputs. The key fixes the staged
     97 -- source, declared compiler/options, ordered local receipts, and exact import
     98 -- pins. A changed input must miss even if the old checkpoint still exists.
     99 sourceBuildCacheKeyBytes sourceHash compiler options locals groups =
    100   append "arboricx.source-build-key.v1\nsource\t" (append sourceHash
    101     (append "\ncompiler\t" (append compiler
    102       (append "\noptions\t" (append options
    103         (append "\n" (append (y sourceBuildLocalRows_ locals)
    104           (y sourceBuildAllPinRows_ groups))))))))
    105 sourceBuildCachePath root name =
    106   append root (append "/cache/source-build/" name)
    107 sourceBuildCacheBytes key manifest receipt =
    108   append "arboricx.source-build-cache.v1\t" (append key
    109     (append "\t" (append manifest (append "\t" receipt))))
    110 sourceBuildCacheDecode bytes =
    111   lazyList
    112     (_ : err "invalid build cache checkpoint" t)
    113     (version rest1 : lazyList
    114       (_ : err "invalid build cache checkpoint" t)
    115       (key rest2 : lazyList
    116         (_ : err "invalid build cache checkpoint" t)
    117         (manifest rest3 : lazyList
    118           (_ : err "invalid build cache checkpoint" t)
    119           (receipt extra : lazyBool
    120             (_ : ok (pair key (pair manifest receipt)) t)
    121             (_ : err "invalid build cache checkpoint" t)
    122             (and? (equal? version "arboricx.source-build-cache.v1")
    123               (and? (emptyList? extra)
    124                 (and? (sourceObjectHashValid key)
    125                   (and? (sourceObjectHashValid manifest)
    126                     (and? (sourceObjectHashValid receipt)
    127                       (equal? bytes (sourceBuildCacheBytes key manifest receipt))))))))
    128           rest3)
    129         rest2)
    130       rest1)
    131     (splitOnByte 9 bytes)
    132 sourceBuildCachePublish root name key manifest receipt =
    133   onOk_ (createDirectory root) (_ :
    134     onOk_ (createDirectory (append root "/cache")) (_ :
    135       onOk_ (createDirectory (append root "/cache/source-build")) (_ :
    136         atomicWriteBytes (sourceBuildCachePath root name)
    137           (sourceBuildCacheBytes key manifest receipt))))
    138 
    139 sourceBuildCacheVerifyGroups_ self groups root locals =
    140   lazyList
    141     (_ : pure (ok t t))
    142     (group rest : lazyMaybe
    143       (_ : onOk_ (sourceLockCheckTrees root (snd (snd group)))
    144         (_ : self rest root locals))
    145       (_ : self rest root locals)
    146       (sourceFindExternal locals (fst group)))
    147     groups
    148 sourceBuildCacheVerifyGroups root groups locals =
    149   y sourceBuildCacheVerifyGroups_ groups root locals
    150 
    151 -- A checkpoint whose key matches current inputs must be complete and valid.
    152 -- Local dependencies were verified by the graph walker before this lookup;
    153 -- check full-hash external imports here as well as this unit's own exports.
    154 -- An unused imported tree may be corrupted even when the output still exists.
    155 -- Reject corruption instead of silently rebuilding and concealing it.
    156 sourceBuildCacheUse root sourceHash options compiler locals groups memo name entry =
    157   onResult_ (sourceObjectGet root "arboricx.build-receipt.v1"
    158       (snd (snd entry)))
    159     (problem : pure (err problem t))
    160     (receiptBytes : lazyBool
    161       (_ : onOk_ (sourceBuildCacheVerifyGroups root groups locals) (_ :
    162         onResult_ (sourceModuleGetManifest root (fst (snd entry)))
    163           (problem : pure (err problem t))
    164           (exports : onOk_ (sourceLockCheckTrees root exports) (_ :
    165             pure (ok (pair (pair (fst (snd entry)) (snd (snd entry)))
    166               (pair (pair name (pair (fst (snd entry)) (snd (snd entry)))) memo)) t)))))
    167       (_ : pure (err "build cache receipt mismatch" t))
    168       (equal? receiptBytes
    169         (sourceBuildReceiptBytes sourceHash compiler options
    170           (fst (snd entry)) locals groups)))
    171 
    172 sourceBuildCached root source unit compiler locals groups memo name build optionsName =
    173   onOk_ (sourceObjectDigest "arboricx.source.v1" source) (sourceHash :
    174     onOk_ (sourceObjectDigest "arboricx.build-options.v1"
    175       optionsName) (options :
    176       onOk_ (sourceObjectDigest "arboricx.source-build-key.v1"
    177         (sourceBuildCacheKeyBytes sourceHash compiler options locals groups))
    178         (key : onResult_ (fileExists (sourceBuildCachePath root name))
    179           (problem : pure (err problem t))
    180           (exists : lazyBool
    181             (_ : onResult_ (readFile (sourceBuildCachePath root name))
    182               (problem : pure (err problem t))
    183               (bytes : lazyResult
    184                 (problem unused : pure (err problem t))
    185                 (entry unused : lazyBool
    186                   (_ : sourceBuildCacheUse root sourceHash options compiler
    187                     locals groups memo name entry)
    188                   (_ : sourceBuildCompile root source unit compiler locals
    189                     groups memo name key build options)
    190                   (equal? (fst entry) key))
    191                 (sourceBuildCacheDecode bytes)))
    192             (_ : sourceBuildCompile root source unit compiler locals
    193               groups memo name key build options)
    194             exists))))
    195 
    196 sourceBuildCompile root source unit compiler locals groups memo name key build options =
    197   onResult_ (build root unit groups)
    198     (problem : pure (err problem t))
    199     (manifestHash : onResult_ (sourceBuildPutReceipt root source
    200         compiler options manifestHash locals groups)
    201       (problem : pure (err problem t))
    202       (receiptHash : onOk_
    203         (sourceBuildCachePublish root name key manifestHash receiptHash)
    204         (_ : pure (ok (pair (pair manifestHash receiptHash)
    205           (pair (pair name (pair manifestHash receiptHash)) memo)) t))))
    206 sourceBuildFinish root source unit refs compiler locals memo name build options =
    207   onResult_ (y sourceBuildGroupsFromLocals_ locals root t)
    208     (problem : pure (err problem t))
    209     (localGroups : onResult_ (y sourceBuildResolveRefs_ refs root
    210         localGroups)
    211       (problem : pure (err problem t))
    212       (groups : sourceBuildCached root source unit compiler
    213         locals groups memo name build options))
    214 
    215 -- The recursive walker is explicitly passed to the dependency-list helper:
    216 -- top-level definitions remain nonrecursive for fresh bootstrap stores.
    217 -- The walker uses (read/stage, (compile, unit -> options bytes)); the public
    218 -- compatibility API adapts constant options names. The shared walker owns
    219 -- dependencies, immutable pins, receipts, checkpoints and cycles.
    220 -- read/stage returns (fingerprint bytes, (dependencies, (refs, unit))).
    221 sourceBuildReadTriPath path =
    222   onResult_ (readFile path)
    223     (problem : pure (err problem t))
    224     (source : lazyResult
    225       (problem unused : pure (err problem t))
    226       (staged unused : lazyResult
    227         (problem unused : pure (err problem t))
    228         (refs unused : pure (ok (pair source
    229           (pair (fst staged) (pair refs (snd staged)))) t))
    230         (sourceLockSourceRefs (snd staged)))
    231       (sourceBuildStage source))
    232 sourceBuildReadTri workspace name =
    233   sourceBuildReadTriPath (sourceBuildSourcePath workspace name)
    234 sourceBuildCompileTriWith compileDefinitions root source groups = (lazyResult
    235   (problem unused : pure (err problem t))
    236   (staged unused : sourceModuleBuildStagedWith compileDefinitions root staged)
    237   (sourceLockRewriteStaged source groups))
    238 
    239 sourceBuildCompileTri root clean groups =
    240   sourceBuildCompileTriWith compileModuleDefinitions root clean groups
    241 sourceBuildStableTriProfile =
    242   pair (workspace name : sourceBuildReadTri workspace name)
    243     (pair (root unit groups : sourceBuildCompileTriWith compileStableModuleDefinitions root unit groups)
    244       "source-module.stable.v1")
    245 sourceBuildTriProfile =
    246   pair (workspace name : sourceBuildReadTri workspace name)
    247     (pair (root unit groups : sourceBuildCompileTri root unit groups)
    248       "source-module.reference.v1")
    249 sourceBuildDeps_ self deps walk workspace root compiler stack memo profile locals =
    250   lazyList
    251     (_ : pure (ok (pair (reverse locals) memo) t))
    252     (name rest : onResult_ (walk name workspace root compiler stack memo profile)
    253       (problem : pure (err problem t))
    254       (out : self rest walk workspace root compiler stack (snd out) profile
    255         (pair (pair name (fst out)) locals)))
    256     deps
    257 sourceBuildWalk_ self name workspace root compiler stack memo profile =
    258   lazyBool
    259     (_ : lazyMaybe
    260       (_ : lazyMaybe
    261         (_ : onResult_ ((fst profile) workspace name)
    262           (problem : pure (err problem t))
    263           (staged : onResult_
    264             (y sourceBuildDeps_ (fst (snd staged)) self workspace root compiler
    265               (pair (pair name t) stack) memo profile t)
    266             (problem : pure (err problem t))
    267             (built : sourceBuildFinish root (fst staged)
    268               (snd (snd (snd staged))) (fst (snd (snd staged)))
    269               compiler (fst built) (snd built) name
    270               (fst (snd profile))
    271               ((snd (snd profile)) (snd (snd (snd staged)))))))
    272         (_ : pure (err "local-source dependency cycle" t))
    273         (sourceFindExternal stack name))
    274       (cached : pure (ok (pair cached memo) t))
    275       (sourceFindExternal memo name))
    276     (_ : pure (err "invalid local source name" t))
    277     (sourceModuleAliasValid name)
    278 
    279 -- Unit-sensitive options select cache/receipt identity, not graph policy.
    280 -- Profile = (read/stage, (compile, unit -> options bytes)). This permits
    281 -- explicit mixed frontend/path selection without changing source identity.
    282 -- Returns (moduleManifestHash, buildReceiptHash). Compiler identity remains
    283 -- runner-declared reproducibility metadata, not proof.
    284 sourceBuildGraphUnitProfile workspace root compilerDigest name profile =
    285   lazyBool
    286     (_ : onResult_ (y sourceBuildWalk_ name workspace root compilerDigest t t
    287         profile)
    288       (problem : pure (err problem t))
    289       (output : pure (ok (fst output) t)))
    290     (_ : pure (err "invalid compiler artifact digest" t))
    291     (sourceObjectHashValid compilerDigest)
    292 -- Compatibility adapter: existing profiles keep their constant options name.
    293 sourceBuildGraphProfile workspace root compilerDigest name profile =
    294   (sourceBuildGraphUnitProfile workspace root compilerDigest name
    295     (pair (workspace name : (fst profile) workspace name)
    296       (pair (root unit groups : (fst (snd profile)) root unit groups)
    297         (unit : snd (snd profile)))))
    298 sourceBuildGraph workspace root compilerDigest name =
    299   sourceBuildGraphProfile workspace root compilerDigest name sourceBuildTriProfile
    300 
    301 -- One portable IO action drives local dependency builds, their separate
    302 -- receipts, immutable manifest selection, and the final indexed bundle.
    303 -- Returns (manifestHash, (receiptHash, bundleFileHash)).
    304 sourceBuildGraphBundle workspace root compilerDigest name outputPath =
    305   onResult_ (sourceBuildGraph workspace root compilerDigest name)
    306     (problem : pure (err problem t))
    307     (built : onResult_ (sourceBundlePack root (fst built) outputPath)
    308       (problem : pure (err problem t))
    309       (bundleHash : pure (ok (pair (fst built)
    310         (pair (snd built) bundleHash)) t)))
    311 
    312 -- Same graph/IO/publication ABI; distinct backend options and artifact identity.
    313 sourceBuildGraphStable workspace root compilerDigest name =
    314   sourceBuildGraphProfile workspace root compilerDigest name sourceBuildStableTriProfile
    315