tricu

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

e64258c8f1cef4fec9962284a9583a4329d2bc90534a60e84244d38bcf2d9507.tri (3405B)

      1 !import prelude *
      2 !import parser *
      3 !export *
      4 
      5 errUnexpectedEof = 1
      6 errUnexpectedBytes = 2
      7 errUnexpectedByte = 3
      8 
      9 unit = t
     10 
     11 -- Explicit boundary between the generic consumption-aware parser reply and
     12 -- the original Result (value, remainingBytes) binary API. The ordinary
     13 -- adapter preserves the new reply's remainder; legacy expectations instead
     14 -- restore the original input on *every* failure, even after a prefix matched.
     15 -- Neither conversion changes the old orParser's unconditional backtracking.
     16 binaryLegacyReply codeOf reply =
     17   parserMatchReply
     18     (diagnostic rest consumed committed : err (codeOf diagnostic) rest)
     19     (value rest consumed committed : ok value rest)
     20     reply
     21 
     22 binaryLegacyRollback codeOf bytes reply =
     23   parserMatchReply
     24     (diagnostic rest consumed committed : err (codeOf diagnostic) bytes)
     25     (value rest consumed committed : ok value rest)
     26     reply
     27 
     28 binaryLegacyExpectCode diagnostic =
     29   lazyBool
     30     (_ : errUnexpectedEof)
     31     (_ : errUnexpectedByte)
     32     (equal? (parserDiagnosticCode diagnostic) 1)
     33 
     34 -- New callers may inspect consumption directly; the established binary
     35 -- entrypoint below deliberately keeps its original Result reply.
     36 binaryReadU8Reply = parserAny
     37 
     38 readU8 = (bytes :
     39   binaryLegacyReply (_ : errUnexpectedEof) (binaryReadU8Reply bytes))
     40 
     41 readBytes_ self bs n i original acc =
     42   matchList
     43     (matchBool
     44       (ok (reverse acc) bs)
     45       (err errUnexpectedEof original)
     46       (equal? i n))
     47     (h r :
     48       matchBool
     49         (ok (reverse acc) bs)
     50         (self r n (succ i) original (pair h acc))
     51         (equal? i n))
     52     bs
     53 
     54 readBytes = (n bs :
     55   y readBytes_ bs n 0 bs t)
     56 
     57 expectBytes_ self expected bs original =
     58   matchList
     59     (ok unit bs)
     60     (expectedByte expectedRest :
     61       matchResult
     62         (code rest : err code original)
     63         (actual rest :
     64           matchBool
     65             (self expectedRest rest original)
     66             (err errUnexpectedBytes original)
     67             (equal? actual expectedByte))
     68         (readU8 bs))
     69     expected
     70 
     71 expectBytes = (expected bs :
     72   y expectBytes_ expected bs bs)
     73 
     74 binaryExpectU8Reply expected =
     75   parserMap (_ : unit) (parserExpect expected)
     76 
     77 expectU8 = (expected bs :
     78   binaryLegacyRollback binaryLegacyExpectCode bs
     79     (binaryExpectU8Reply expected bs))
     80 
     81 read2 = (bs : readBytes 2 bs)
     82 read4 = (bs : readBytes 4 bs)
     83 readU32BEBytes = (bs : read4 bs)
     84 
     85 -- ---------------------------------------------------------------------------
     86 -- Parser combinators
     87 -- ---------------------------------------------------------------------------
     88 
     89 pureParser = value bs : ok value bs
     90 failParser = code bs : err code bs
     91 
     92 mapParser = f p bs : mapResult f (p bs)
     93 bindParser = p f bs : bindResult (p bs) f
     94 thenParser = p q bs : bindResult (p bs) (_ : q)
     95 
     96 orParser = (p q bs :
     97   matchResult
     98     (_ _ : q bs)
     99     (value rest : ok value rest)
    100     (p bs))
    101 
    102 readWhile_ self pred bs acc =
    103   matchResult
    104     (code rest : ok (reverse acc) bs)
    105     (value rest :
    106       matchBool
    107         (self pred rest (pair value acc))
    108         (ok (reverse acc) (pair value rest))
    109         (pred value))
    110     (readU8 bs)
    111 
    112 readWhile = pred bs :
    113   y readWhile_ pred bs t
    114 
    115 readUntil = pred :
    116   readWhile (x : not? (pred x))
    117 
    118 readRemaining = bs : ok bs t
    119 
    120 peekU8 = (bs :
    121   binaryLegacyReply (_ : errUnexpectedEof) (parserPeek bs))
    122 
    123 eof? = (bs :
    124   matchBool
    125     (ok t bs)
    126     (err errUnexpectedEof bs)
    127     (emptyList? bs))
    128 
    129 expectAscii = expectBytes