tricu

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

31ffd58166bf861e82da0a90594cfb9c6c12e19baa51d5166fe0e4414d24af94.tri (11363B)

      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 entries ref hash =
     21   lazyList
     22     (_ : t)
     23     (entry rest : append (sourceLockRow ref hash entry)
     24       (sourceLockRows rest ref hash))
     25     entries
     26 sourceLockGroups groups =
     27   lazyList
     28     (_ : t)
     29     (group rest : append
     30       (sourceLockRows (snd (snd group)) (fst group) (fst (snd group)))
     31       (sourceLockGroups rest))
     32     groups
     33 sourceLockEncode groups =
     34   append sourceLockHeader (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 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 : sourceLockParseRows 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       (_ : sourceLockParseRows lines t)
     90       (_ : err "unsupported lock version" t)
     91       (equal? header "arboricx.source-lock.v1"))
     92     (splitOnByte 10 bytes)
     93 
     94 sourceLockDistinct rows seen =
     95   lazyList
     96     (_ : ok (reverse seen) t)
     97     (row rest : lazyMaybe
     98       (_ : sourceLockDistinct rest (pair (pair (fst row) (fst (snd row))) seen))
     99       (previous : lazyBool
    100         (_ : sourceLockDistinct rest seen)
    101         (_ : err "incoherent lock snapshot" t)
    102         (equal? previous (fst (snd row))))
    103       (sourceFindExternal seen (fst row)))
    104     rows
    105 sourceLockSelectRows rows ref entries =
    106   lazyList
    107     (_ : reverse entries)
    108     (row rest : lazyBool
    109       (_ : sourceLockSelectRows rest ref (pair (snd (snd row)) entries))
    110       (_ : sourceLockSelectRows rest ref entries)
    111       (equal? ref (fst row)))
    112     rows
    113 sourceLockRowsFor rows ref = sourceLockSelectRows rows ref t
    114 sourceLockCheckEntries entries root =
    115   lazyList
    116     (_ : pure (ok t t))
    117     (entry rest : onResult_ (sourceObjectGetTree root (snd entry))
    118       (problem : pure (err problem t))
    119       (_ : sourceLockCheckEntries rest root))
    120     entries
    121 sourceLockCheckTrees root entries = sourceLockCheckEntries entries root
    122 sourceLockVerifyRefs 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           sourceLockVerifyRefs 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_ (sourceLockVerifyRefs 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       (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 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             sourceLockCollect rest root (pair (pair ref (pair hash entries)) groups)))))
    163       (_ : sourceLockCollect rest root groups)
    164       (sourceFindExternal groups ref))
    165     refs
    166 sourceLockUseRefs uses acc =
    167   lazyList
    168     (_ : ok (reverse acc) t)
    169     (words rest : lazyResult
    170       (problem unused : err problem t)
    171       (spec unused : sourceLockUseRefs rest (pair (fst spec) acc))
    172       (sourceModuleUseShape words))
    173     uses
    174 sourceLockExportRefs exports acc =
    175   lazyList
    176     (_ : ok (reverse acc) t)
    177     (words rest : lazyResult
    178       (problem unused : err problem t)
    179       (spec unused : lazyBool
    180         (_ : sourceLockExportRefs rest (pair (snd spec) acc))
    181         (_ : sourceLockExportRefs 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         (sourceLockExportRefs (fst (snd staged)) t))
    194       (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_ (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 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           (sourceLockRewriteUses rest groups))
    228         (sourceFindExternal groups (fst spec)))
    229       (sourceModuleUseShape words))
    230     uses
    231 sourceLockRewriteExports 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         (sourceLockRewriteExports 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         (sourceLockRewriteExports (fst (snd staged)) groups))
    260       (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 refs seen =
    270   lazyList
    271     (_ : sourceLockGroupRefs (reverse seen))
    272     (ref rest : lazyMaybe
    273       (_ : sourceLockUniqueRefs rest (pair (pair ref t) seen))
    274       (_ : sourceLockUniqueRefs rest seen)
    275       (sourceFindExternal seen ref))
    276     refs
    277 sourceLockGroupRefs groups = map fst groups
    278 sourceLockBuild root name source =
    279   lazyBool
    280     (_ : onResult_ (readFile (sourceLockPath root name))
    281       (problem : pure (err problem t))
    282       (bytes : onResult_ (sourceLockVerify root bytes)
    283         (problem : pure (err problem t))
    284         (groups : lazyResult
    285           (problem unused : pure (err problem t))
    286           (refs unused : lazyBool
    287             (_ : lazyResult
    288               (problem unused : pure (err problem t))
    289               (staged unused : sourceModuleBuildStaged root staged)
    290               (sourceLockRewriteStaged source groups))
    291             (_ : pure (err "lock source references changed; update required" t))
    292             (equal? (sourceLockGroupRefs groups)
    293               (sourceLockUniqueRefs refs t)))
    294           (sourceLockSourceRefs source))))
    295     (_ : pure (err "invalid lock name" t))
    296     (sourceModuleAliasValid name)
    297