tricu

A lazy functional language based on Tree Calculus
Log | Files | Refs | README | LICENSE

8090a03dbe01b0403683c71d1a2f944c41647a77acb7918c36f0b8f329e9648c.tri (11735B)

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