tricu

consumer_effect_files.tri (8593B)

---

 -- The Python runner supplies probeRoot as fixture data.
 !import "prelude" !Local
 !import "io" !Local
 !import "consumers.structural" S
 !import "consumers.lexical-worker" L
 !import "consumers.unit-compile" U
 !import "consumers.effect-compose" E
 !import "consumers.effect" Registry
 !import "consumers.file-effects" Files
 !import "consumers.copy-bytes" Copy
 !import "consumers.effect-packages" Packages
 
 record name argument = bind get (trace : put (pair (pair name argument) trace))
 readBytes path = bind (record "ReadBytes" path) (_ : Files.readBytes path)
 writeBytesHandler argument = bind (record "WriteBytes" argument) (_ : Files.writeBytesHandler argument)
 operations = [(pair "ReadBytes" readBytes) (pair "WriteBytes" writeBytesHandler)]
 reference rows = map (row : pair (fst row) (fst (snd (snd row)))) rows
 lexical rows = map (row : pair (fst row) (S.makeConsumer t (L.lWorker t (fst (snd row))))) rows
 -- Registries wrap lexical descriptors in consumers; pure calls need the descriptor.
 refWorker receivers name = lazyMaybe (_ : t) (value : value) (Registry.lookup receivers name)
 lexWorker receivers name = snd (refWorker receivers name)
 path name = append probeRoot name
 rawText = append "alpha\r\nbeta\rZ\n" [0 195 169 255]
 normalizedText = append "alpha\nbetaZ\n" [0 195 169 255]
 ownedPackage receivers entry names helpers = (bindResult (Packages.ownedRows names receivers)
   (owned _ : E.makePackage entry owned helpers))
 runCase step package input state = (bind (put t) (_ :
   bind (E.run step operations package input state) (result :
     bind get (trace : pure (pair result (reverse trace))))))
 recovered outcome stage = (matchResult (_ _ : false)
   (value _ : and? (equal? (fst value) "recovered")
     (and? (equal? (fst (snd value)) stage)
       (not? (emptyList? (snd (snd value)))))) outcome)
 propagated outcome stage = (matchResult
   (value _ : and? (equal? (fst value) stage) (not? (emptyList? (snd value))))
   (_ _ : false) outcome)
 checkConversion step receivers getWorker helper = (let transform = getWorker receivers "removeCR" in
   E.prepare (ownedPackage receivers "convert" ["convert" "convertEnd"]
     [(pair "copyText" helper)]) (package :
   bind (runCase step package (pair (path "/input") (path "/output")) transform) (converted :
     bind (readFile (path "/output")) (written :
       bind (runCase step package (pair (path "/input") (path "/identity"))
         (getWorker receivers "identityText")) (injected :
         bind (readFile (path "/identity")) (unchanged :
           bind (runCase step package (pair (path "/absent") (path "/untouched")) transform) (readFailure :
             bind (runCase step package (pair (path "/input") (path "/missing/output")) transform) (writeFailure :
               bind (runCase step helper (path "/input") (pair transform (path "/missing/output"))) (propagation :
                 pure (pair [converted injected readFailure writeFailure propagation] (foldl and? true [
                   (equal? (fst converted) (ok (path "/output") t))
                   (equal? (snd converted) [(pair "ReadBytes" (path "/input"))
                     (pair "WriteBytes" (pair (path "/output") normalizedText))])
                   (equal? written (ok normalizedText t))
                   (equal? (fst injected) (ok (path "/identity") t))
                   (equal? unchanged (ok rawText t))
                   (recovered (fst readFailure) "read")
                   (equal? (snd readFailure) [(pair "ReadBytes" (path "/absent"))])
                   (recovered (fst writeFailure) "write")
                   (equal? (snd writeFailure) [(pair "ReadBytes" (path "/input"))
                     (pair "WriteBytes" (pair (path "/missing/output") normalizedText))])
                   (propagated (fst propagation) "write")
                   (equal? (snd propagation) (snd writeFailure))])))))))))))
 checkTwo step receivers getWorker = (E.prepare
   (ownedPackage receivers "readPair" ["readPair" "pairFirst" "pairSecond"] t) (package :
   let appender = getWorker receivers "appendParts" in
   bind (runCase step package (pair (path "/input") (path "/input-second")) appender) (combined :
     bind (runCase step package (pair (path "/absent") (path "/input-second")) appender) (firstFailure :
       bind (runCase step package (pair (path "/input") (path "/absent")) appender) (secondFailure :
         pure (pair [combined firstFailure secondFailure] (foldl and? true [
           (equal? combined (pair (ok (append rawText "second\r\n") t)
             [(pair "ReadBytes" (path "/input")) (pair "ReadBytes" (path "/input-second"))]))
           (propagated (fst firstFailure) "read-first")
           (equal? (snd firstFailure) [(pair "ReadBytes" (path "/absent"))])
           (propagated (fst secondFailure) "read-second")
           (equal? (snd secondFailure) [(pair "ReadBytes" (path "/input"))
             (pair "ReadBytes" (path "/absent"))])])))))))
 -- Manifest decoding is test input adaptation. The list is loaded through real
 -- IO; all traversal, requests, accumulation, and error policy remain in SCP.
 loadPaths manifest = (onResult_ (readFile manifest)
   (problem : pure (err problem t))
   (bytes : pure (ok (lazyBool (_ : t) (_ : lines bytes) (equal? bytes t)) t)))
 batchState receivers getWorker = (pair (getWorker receivers "writeAll")
   (pair "batch\n" (pair (getWorker receivers "reversePaths") t)))
 traceFor paths = map (destination : pair "WriteBytes" (pair destination "batch\n")) paths
 batchFailure actual first bad = (matchResult
   (value _ : and? (equal? (fst value) bad)
     (and? (equal? (fst (snd value)) [first])
       (not? (emptyList? (snd (snd value))))))
   (_ _ : false) actual)
 checkBatch step receivers getWorker paths emptyPaths failedPaths = (let state = batchState receivers getWorker in
   E.prepare (ownedPackage receivers "writeAll" ["writeAll" "writeNext"] t) (package :
   bind (runCase step package paths state) (completed :
     bind (runCase step package emptyPaths state) (empty :
       bind (runCase step package failedPaths state) (failed :
         pure (pair [completed empty failed] (foldl and? true [
           (equal? completed (pair (ok paths t) (traceFor paths)))
           (equal? empty (pair (ok t t) t))
           (batchFailure (fst failed) (path "/batch-first") (path "/missing/batch"))
           (equal? (snd failed) (traceFor [(path "/batch-first") (path "/missing/batch")]))])))))))
 check rows packages paths emptyPaths failedPaths = (let refs = reference rows in
   E.prepare (L.lPrepareEffectReceivers (lexical rows)) (lex :
   thenIO (putStrLn "READY")
     (bind (checkConversion S.runConsumer refs refWorker (fst packages)) (refConversion :
       bind (checkTwo S.runConsumer refs refWorker) (refTwo : thenIO (putStrLn "REF_CONVERSION_DONE")
         (bind (checkConversion L.lPreparedEffectStep lex lexWorker (snd packages)) (lexConversion :
           bind (checkTwo L.lPreparedEffectStep lex lexWorker) (lexTwo : thenIO (putStrLn "LEX_CONVERSION_DONE")
             (bind (checkBatch S.runConsumer refs refWorker paths emptyPaths failedPaths) (refBatch :
               thenIO (putStrLn "REF_BATCH_DONE")
                 (bind (checkBatch L.lPreparedEffectStep lex lexWorker paths emptyPaths failedPaths) (lexBatch :
                   thenIO (putStrLn "LEX_BATCH_DONE")
                     (putStrLn (matchBool "consumer-effect-files-ok" "consumer-effect-files-DIFFER"
                       (foldl and? true [(equal? refConversion lexConversion) (snd lexConversion)
                         (equal? refBatch lexBatch) (snd lexBatch)
                         (equal? refTwo lexTwo) (snd lexTwo)])))))))))))))))
 main = io (onResult_ (readFile "demos/consumers/effect-files/workflows.scp")
   (_ : putStrLn "consumer-effect-files-source-error")
   (source : lazyResult
     (_ _ : putStrLn "consumer-effect-files-compile-error")
     (rows _ : onResult_ (readFile "lib/consumer/effects/copy-bytes.scp")
       (_ : putStrLn "consumer-effect-files-helper-source-error")
       (helperSource : lazyResult
         (_ _ : putStrLn "consumer-effect-files-helper-compile-error")
         (packages _ : onResult_ (loadPaths (path "/targets"))
       (_ : putStrLn "consumer-effect-files-manifest-error")
       (paths : onResult_ (loadPaths (path "/failed-targets"))
         (_ : putStrLn "consumer-effect-files-manifest-error")
         (failedPaths : onResult_ (loadPaths (path "/empty-targets"))
           (_ : putStrLn "consumer-effect-files-manifest-error")
           (emptyPaths : check rows packages paths emptyPaths failedPaths))))
         (Copy.compileSource helperSource)))
     (U.compileScpUnit source t)))
 main