tricu

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

consumer_source_link.tri (4863B)

      1 !import "consumers.module" M
      2 !import "consumers.structural" S
      3 !import "consumers.lexical-worker" X
      4 !import "consumers.text-summary" T
      5 !import "source.object" O
      6 !import "source.module" Mod
      7 !import "source.resolve" R
      8 !import "prelude" !Local
      9 !import "io" !Local
     10 root = "__ROOT__"
     11 sourceSucc = "lib/consumer/succ.scp"
     12 sourceCount = "lib/consumer/text/countLines.scp"
     13 sourceEntry = "demos/consumers/text-summary/summary-entry.scp"
     14 sourceReceiver = "demos/consumers/text-summary/summary-receiver.scp"
     15 row alias hash name = pair alias (pair hash name)
     16 -- No Python embedding: ordinary IO stages unchanged authored source bytes as
     17 -- CAS objects; the descriptor pins their digests, not filesystem paths.
     18 stage = do onOk_
     19   succ <- readFile sourceSucc
     20   succHash <- M.cmPutSource root succ
     21   counter <- readFile sourceCount
     22   counterHash <- M.cmPutSource root counter
     23   entry <- readFile sourceEntry
     24   entryHash <- M.cmPutSource root entry
     25   receiver <- readFile sourceReceiver
     26   receiverHash <- M.cmPutSource root receiver
     27   wrong <- M.cmPutImports root [(row "counter" counterHash "notCountLines")]
     28   _ <- onResult_ (M.cmLoad root wrong)
     29     (problem : pure (lazyBool (_ : ok t t)
     30       (_ : err "wrong export was not rejected" t)
     31       (equal? problem "SCP import export name mismatch")))
     32     (_ : pure (err "wrong export was accepted" t))
     33   M.cmPutImports root [(row "successor" succHash "succBinary")
     34     (row "counter" counterHash "countLines")
     35     (row "entry" entryHash "summaryEntry")
     36     (row "receiver" receiverHash "summaryReceiver")]
     37 lookup defs name = R.sourceFindExternal defs name
     38 successor defs = lazyMaybe t (worker : worker) (lookup defs "successor")
     39 configure defs counter = (S.makeConsumer
     40   (T.counterState (resultOr t (X.lCompile (successor defs)))) (snd counter))
     41 checkLoaded defs = lazyMaybe false (counter : lazyMaybe false
     42   (entry : lazyMaybe false (receiver : foldl and? true [
     43     resultIsOk (X.lCompile (successor defs))
     44     resultIsOk (X.lCompile (configure defs counter))
     45     resultIsOk (X.lCompileOpen entry)
     46     resultIsOk (X.lCompileOpen receiver)
     47     equal? (T.render (pair 1 (resultOr t (X.lRunChecked
     48       (resultOr t (X.lCompile (configure defs counter))) "a\nb")))) "lines: 2"])
     49     (lookup defs "receiver")) (lookup defs "entry")) (lookup defs "counter")
     50 -- Compile linked IR without source embedding and retain real named ReadText IO.
     51 linkedSummary defs path =
     52   (lazyMaybe (_ : pure (pair 0 "missing counter"))
     53     (counter : lazyMaybe (_ : pure (pair 0 "missing entry"))
     54       (entry : lazyMaybe (_ : pure (pair 0 "missing receiver"))
     55         (receiver : lazyResult
     56           (_ _ : pure (pair 0 "counter compile failed"))
     57           (counterWorker _ : lazyResult
     58             (_ _ : pure (pair 0 "entry compile failed"))
     59             (entryWorker _ : lazyResult
     60               (_ _ : pure (pair 0 "receiver compile failed"))
     61               (receiverWorker _ : T.summaryLexical counterWorker entryWorker receiverWorker path)
     62               (X.lCompileOpen receiver))
     63             (X.lCompileOpen entry))
     64           (X.lCompile (configure defs counter)))
     65         (lookup defs "receiver")) (lookup defs "entry")) (lookup defs "counter"))
     66 -- Verify negative decode and name mismatch before accepting/publishing.
     67 negative hash = foldl and? true [
     68   resultIsErr (M.cmDecode "arboricx.scp-imports.v2\n")
     69   resultIsErr (M.cmDecode (append (M.cmRow "x" hash "countLines") M.cmHeader))
     70   resultIsErr (M.cmDecode (append (append M.cmHeader (M.cmRow "bad" hash "countLines")) "junk"))
     71   resultIsErr (M.cmDecode (M.cmEncode [(row "same" hash "countLines") (row "same" hash "countLines")]))
     72   resultIsErr (M.cmDecode (M.cmEncode [(row "wrong" "bad" "countLines")]))]
     73 run digest =
     74   (onResult_ (M.cmLoad root digest)
     75   (problem : putStrLn (append "link-error=" problem))
     76   (defs : onResult_ (M.cmPublishIR root defs ["successor" "counter" "entry" "receiver"])
     77     (problem : putStrLn (append "publish-error=" problem))
     78     (manifest : onResult_ (Mod.sourceModuleLoadSelected root manifest "counter")
     79       (problem : putStrLn (append "sidecar-error=" problem))
     80       (stored : do bind
     81         _ <- putStrLn (append "imports=" digest)
     82         _ <- putStrLn (append "sidecars=" manifest)
     83         good <- linkedSummary defs "__SAMPLE__"
     84         missing <- linkedSummary defs "__MISSING__"
     85         putStrLn (matchBool "source-link-ok" "source-link-DIFFER"
     86           (foldl and? true [
     87             (resultIsOk (X.lCompile (successor defs)))
     88             (checkLoaded defs)
     89             (equal? (T.render good) "lines: 2")
     90             (equal? (fst missing) 0)
     91             (equal? stored (lazyMaybe (_ : t) (value : value) (lookup defs "counter")))
     92             (negative "0123456789abcdef0123456789abcdef0123456789abcdef0123456789abcdef")]))))))
     93 main = io (onResult_ stage (problem : putStrLn (append "stage-error=" problem))
     94   (digest : run digest))
     95 main