tricu

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

unit-build.tri (2870B)

      1 !import prelude *
      2 !import io *
      3 !import source_build as G
      4 !import source_module as M
      5 !import source_lock as K
      6 !import consumers_unit_compile as UC
      7 !export *
      8 -- Native SCP units reuse the shared graph, import pins and export publisher.
      9 -- Header masking preserves body byte offsets, lines and columns. No header
     10 -- rewrite is fed to the SCP parser; immutable rewrites only select CAS values.
     11 
     12 -- The shared interpreter owns edges, masking and located header errors. This
     13 -- frontend supplies only its stricter import binding policy.
     14 scpUnitStage source = M.sourceModuleHeaderStageWith ubQualifier source
     15 ubQualifier spec = (lazyBool
     16   (_ : err "SCP imports require qualified imports (Self is reserved)" t)
     17   (_ : ok t t)
     18   (or? (equal? (snd spec) "Self")
     19     (not? (and? (M.sourceModuleExportNameValid (snd spec))
     20       (foldl and? true (map (byte : not? (equal? byte 46)) (snd spec)))))))
     21 ubUses_ self uses = (lazyList (_ : ok t t)
     22   (use rest : bindResult (M.sourceModuleUseShape use) (spec _ :
     23     bindResult (ubQualifier spec) (_ _ : self rest))) uses)
     24 ubUses uses = y ubUses_ uses
     25 ubRefs staged = (bindResult (ubUses (fst (snd staged))) (_ _ :
     26   bindResult (y K.sourceLockUseRefs_ (fst (snd staged)) t) (uses _ :
     27     bindResult (y K.sourceLockExportRefs_ (fst (snd (snd staged))) t)
     28       (exports _ : ok (append uses exports) t))))
     29 ubImmutableHeader staged groups = (bindResult
     30   (y K.sourceLockRewriteUses_ (fst (snd staged)) groups) (uses _ :
     31     bindResult (y K.sourceLockRewriteExports_ (fst (snd (snd staged))) groups)
     32       (exports _ : M.sourceModuleStage (append uses exports))))
     33 scpUnitReadPath path = (onResult_ (readFile path)
     34   (problem : pure (err problem t))
     35   (source : lazyResult (problem unused : pure (err problem t))
     36     (staged unused : lazyResult (problem unused : pure (err problem t))
     37       (refs unused : pure (ok (pair source
     38         (pair (fst staged) (pair refs staged))) t)) (ubRefs staged))
     39     (scpUnitStage source)))
     40 scpUnitRead workspace name =
     41   scpUnitReadPath (append workspace (append "/" (append name ".scp")))
     42 scpUnitCompile root staged groups = (lazyResult
     43   (problem unused : pure (err problem t))
     44   (header unused : onResult_ (M.sourceModuleExtendUses root (fst header))
     45     (problem : pure (err problem t))
     46     (available : lazyResult (problem unused : pure (err problem t))
     47       (compiled unused : M.sourceModuleSelect root
     48         (map (row : pair (fst row) (fst (snd row))) compiled)
     49         (fst (snd header)))
     50       (UC.compileScpModuleBody (snd (snd (snd staged))) available)))
     51   (ubImmutableHeader staged groups))
     52 scpUnitProfile = (pair (workspace name : scpUnitRead workspace name)
     53   (pair (root staged groups : scpUnitCompile root staged groups)
     54     "scp-unit.lexical-worker.v2"))
     55 scpUnitBuildGraph workspace root compilerDigest name =
     56   G.sourceBuildGraphProfile workspace root compilerDigest name scpUnitProfile