tricu

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

226ea0650ed7935d5380749e6d9719e400d227004a217874d3ab98698a7581df.tri (12505B)

      1 !import prelude *
      2 !import binary *
      3 !export *
      4 
      5 
      6 arboricxMagic = [(65) (82) (66) (79) (82) (73) (67) (88)]
      7 arboricxMajorVersion = [(0) (1)]
      8 arboricxMinorVersion = [(0) (0)]
      9 arboricxManifestSectionId = [(0) (0) (0) (1)]
     10 arboricxNodesSectionId = [(0) (0) (0) (2)]
     11 
     12 -- Manifest magic and version constants
     13 arboricxManifestMagic = [(65) (82) (66) (77) (78) (70) (83) (84)]
     14 arboricxManifestMajorVersion = [(0) (1)]
     15 arboricxManifestMinorVersion = [(0) (0)]
     16 
     17 errMissingSection = 4
     18 errUnsupportedVersion = 5
     19 errDuplicateSection = 6
     20 errDuplicateNode = 7
     21 errInvalidNodePayload = 8
     22 errMissingNode = 9
     23 errInvalidManifestMagic = 10
     24 errUnsupportedManifestVersion = 11
     25 errTrailingManifestBytes = 12
     26 errManifestValidationFailed = 13
     27 
     28 nodePayloadLeafTag = 0
     29 nodePayloadStemTag = 1
     30 nodePayloadForkTag = 2
     31 
     32 readArboricxMagic = (bs : expectBytes arboricxMagic bs)
     33 
     34 readArboricxHeader = (bs :
     35   bindResult (readArboricxMagic bs)
     36     (_ afterMagic :
     37       bindResult (readBytes 2 afterMagic)
     38         (majorVersion afterMajor :
     39           bindResult (readBytes 2 afterMajor)
     40             (minorVersion afterMinor :
     41               bindResult (readBytes 4 afterMinor)
     42                 (sectionCount afterSectionCount :
     43                   bindResult (readBytes 8 afterSectionCount)
     44                     (flags afterFlags :
     45                       bindResult (readBytes 8 afterFlags)
     46                         (dirOffset afterDirOffset :
     47                           ok
     48                             (pair majorVersion
     49                               (pair minorVersion
     50                                 (pair sectionCount
     51                                   (pair flags dirOffset))))
     52                             afterDirOffset)))))))
     53 
     54 readSectionRecord = (bs :
     55   bindResult (readBytes 4 bs)
     56     (sectionId afterSectionId :
     57       bindResult (readBytes 2 afterSectionId)
     58         (sectionVersion afterSectionVersion :
     59           bindResult (readBytes 2 afterSectionVersion)
     60             (sectionFlags afterSectionFlags :
     61               bindResult (readBytes 2 afterSectionFlags)
     62                 (compression afterCompression :
     63                   bindResult (readBytes 2 afterCompression)
     64                     (reserved1 afterReserved1 :
     65                       bindResult (readBytes 8 afterReserved1)
     66                         (offset afterOffset :
     67                           bindResult (readBytes 8 afterOffset)
     68                             (length afterLength :
     69                               bindResult (readBytes 4 afterLength)
     70                                 (reserved2 afterReserved2 :
     71                                   ok
     72                                     (pair sectionId
     73                                       (pair sectionVersion
     74                                         (pair sectionFlags
     75                                           (pair compression
     76                                             (pair reserved1
     77                                               (pair offset
     78                                                 (pair length reserved2)))))))
     79                                     afterReserved2)))))))))
     80 
     81 readSectionDirectory_ = y (self bs sectionCount i acc :
     82   matchBool
     83     (ok (reverse acc) bs)
     84     (bindResult (readSectionRecord bs)
     85       (sectionRecord afterSectionRecord :
     86         self afterSectionRecord sectionCount (succ i) (pair sectionRecord acc)))
     87     (equal? i sectionCount))
     88 
     89 readSectionDirectory = (sectionCount bs : readSectionDirectory_ bs sectionCount 0 t)
     90 
     91 sectionRecordId = (sectionRecord :
     92   matchPair
     93     (sectionId _ : sectionId)
     94     sectionRecord)
     95 
     96 sectionRecordVersion = (sectionRecord :
     97   matchPair
     98     (_ payload :
     99       matchPair
    100         (sectionVersion _ : sectionVersion)
    101         payload)
    102     sectionRecord)
    103 
    104 sectionRecordFlags = (sectionRecord :
    105   matchPair
    106     (_ payload :
    107       matchPair
    108         (_ payload2 :
    109           matchPair
    110             (sectionFlags _ : sectionFlags)
    111             payload2)
    112         payload)
    113     sectionRecord)
    114 
    115 sectionRecordCompression = (sectionRecord :
    116   matchPair
    117     (_ payload :
    118       matchPair
    119         (_ payload2 :
    120           matchPair
    121             (_ payload3 :
    122               matchPair
    123                 (compression _ : compression)
    124                 payload3)
    125             payload2)
    126         payload)
    127     sectionRecord)
    128 
    129 sectionRecordReserved1 = (sectionRecord :
    130   matchPair
    131     (_ payload :
    132       matchPair
    133         (_ payload2 :
    134           matchPair
    135             (_ payload3 :
    136               matchPair
    137                 (_ payload4 :
    138                   matchPair
    139                     (reserved1 _ : reserved1)
    140                     payload4)
    141                 payload3)
    142             payload2)
    143         payload)
    144     sectionRecord)
    145 
    146 sectionRecordOffset = (sectionRecord :
    147   matchPair
    148     (_ payload :
    149       matchPair
    150         (_ payload2 :
    151           matchPair
    152             (_ payload3 :
    153               matchPair
    154                 (_ payload4 :
    155                   matchPair
    156                     (_ payload5 :
    157                       matchPair
    158                         (offset _ : offset)
    159                         payload5)
    160                     payload4)
    161                 payload3)
    162             payload2)
    163         payload)
    164     sectionRecord)
    165 
    166 sectionRecordLength = (sectionRecord :
    167   matchPair
    168     (_ payload :
    169       matchPair
    170         (_ payload2 :
    171           matchPair
    172             (_ payload3 :
    173               matchPair
    174                 (_ payload4 :
    175                   matchPair
    176                     (_ payload5 :
    177                       matchPair
    178                         (_ payload6 :
    179                           matchPair
    180                             (length _ : length)
    181                             payload6)
    182                         payload5)
    183                     payload4)
    184                 payload3)
    185             payload2)
    186         payload)
    187     sectionRecord)
    188 
    189 sectionRecordReserved2 = (sectionRecord :
    190   matchPair
    191     (_ payload :
    192       matchPair
    193         (_ payload2 :
    194           matchPair
    195             (_ payload3 :
    196               matchPair
    197                 (_ payload4 :
    198                   matchPair
    199                     (_ payload5 :
    200                       matchPair
    201                         (_ payload6 :
    202                           matchPair
    203                             (_ reserved2 : reserved2)
    204                             payload6)
    205                         payload5)
    206                     payload4)
    207                 payload3)
    208             payload2)
    209         payload)
    210     sectionRecord)
    211 
    212 lookupSectionRecord_ = y (self directory sectionId :
    213   matchList
    214     nothing
    215     (sectionRecord rest :
    216       matchBool
    217         (just sectionRecord)
    218         (self rest sectionId)
    219         (bytesEq? sectionId (sectionRecordId sectionRecord)))
    220     directory)
    221 
    222 lookupSectionRecord = (sectionId directory : lookupSectionRecord_ directory sectionId)
    223 
    224 sectionDirectoryHasId?_ = y (self directory sectionId :
    225   matchList
    226     false
    227     (sectionRecord rest :
    228       or?
    229         (bytesEq? sectionId (sectionRecordId sectionRecord))
    230         (self rest sectionId))
    231     directory)
    232 
    233 sectionDirectoryHasId? = (sectionId directory : sectionDirectoryHasId?_ directory sectionId)
    234 
    235 sectionDirectoryHasDuplicateIds? = y (self directory :
    236   matchList
    237     false
    238     (sectionRecord rest :
    239       or?
    240         (sectionDirectoryHasId?_ rest (sectionRecordId sectionRecord))
    241         (self rest))
    242     directory)
    243 
    244 validateSectionDirectory = (directory rest :
    245   matchBool
    246     (err errDuplicateSection rest)
    247     (ok directory rest)
    248     (sectionDirectoryHasDuplicateIds? directory))
    249 
    250 byteSlice = (offset length bytes : bytesTake length (bytesDrop offset bytes))
    251 
    252 natMake = (bit rest :
    253   matchBool
    254     0
    255     (pair bit rest)
    256     (and? (equal? bit 0) (equal? rest 0)))
    257 
    258 natAdd = y (self a b :
    259   triage
    260     b
    261     (_ : b)
    262     (aBit aRest :
    263       triage
    264         a
    265         (_ : a)
    266         (bBit bRest :
    267           matchBool
    268             (natMake 0 (succ (self aRest bRest)))
    269             (natMake (matchBool (matchBool 0 1 bBit) (matchBool 1 0 bBit) aBit)
    270               (self aRest bRest))
    271             (and? (equal? aBit 1) (equal? bBit 1)))
    272         b)
    273     a)
    274 
    275 natDouble = (n : matchBool 0 (pair 0 n) (equal? n 0))
    276 
    277 natTimes256 = (n :
    278   natDouble
    279     (natDouble
    280       (natDouble
    281         (natDouble
    282           (natDouble
    283             (natDouble
    284               (natDouble
    285                 (natDouble n))))))))
    286 
    287 byteNatShiftAppend_ = y (self byte acc i :
    288   matchBool
    289     acc
    290     (triage
    291       (natMake 0 (self 0 acc (succ i)))
    292       (_ : acc)
    293       (bit rest : natMake bit (self rest acc (succ i)))
    294       byte)
    295     (equal? i 8))
    296 
    297 byteNatShiftAppend = (byte acc : byteNatShiftAppend_ byte acc 0)
    298 
    299 beBytesToNat = (bytes :
    300   foldl
    301     (acc byte : byteNatShiftAppend byte acc)
    302     0
    303     bytes)
    304 
    305 u32BEBytesToNat = beBytesToNat
    306 u64BEBytesToNat = beBytesToNat
    307 
    308 arboricxHeaderMajorVersion = (header :
    309   matchPair
    310     (majorVersion _ : majorVersion)
    311     header)
    312 
    313 arboricxHeaderMinorVersion = (header :
    314   matchPair
    315     (_ payload :
    316       matchPair
    317         (minorVersion _ : minorVersion)
    318         payload)
    319     header)
    320 
    321 arboricxHeaderSectionCount = (header :
    322   matchPair
    323     (_ payload :
    324       matchPair
    325         (_ payload2 :
    326           matchPair
    327             (sectionCount _ : sectionCount)
    328             payload2)
    329         payload)
    330     header)
    331 
    332 arboricxHeaderFlags = (header :
    333   matchPair
    334     (_ payload :
    335       matchPair
    336         (_ payload2 :
    337           matchPair
    338             (_ payload3 :
    339               matchPair
    340                 (flags _ : flags)
    341                 payload3)
    342             payload2)
    343         payload)
    344     header)
    345 
    346 arboricxHeaderDirOffset = (header :
    347   matchPair
    348     (_ payload :
    349       matchPair
    350         (_ payload2 :
    351           matchPair
    352             (_ payload3 :
    353               matchPair
    354                 (_ dirOffset : dirOffset)
    355                 payload3)
    356             payload2)
    357         payload)
    358     header)
    359 
    360 validateArboricxHeader = (header rest :
    361   matchBool
    362     (ok header rest)
    363     (err errUnsupportedVersion rest)
    364     (and?
    365       (bytesEq? arboricxMajorVersion (arboricxHeaderMajorVersion header))
    366       (bytesEq? arboricxMinorVersion (arboricxHeaderMinorVersion header))))
    367 
    368 readArboricxContainer = (bs :
    369   bindResult (readArboricxHeader bs)
    370     (header afterHeader :
    371       bindResult (validateArboricxHeader header afterHeader)
    372         (validHeader afterValidHeader :
    373           bindResult (readSectionDirectory
    374             (u32BEBytesToNat (arboricxHeaderSectionCount validHeader))
    375             (bytesDrop (u64BEBytesToNat (arboricxHeaderDirOffset validHeader)) bs))
    376             (directory afterDirectory :
    377               bindResult (validateSectionDirectory directory afterDirectory)
    378                 (validDirectory afterValidDirectory :
    379                   ok (pair validHeader validDirectory) afterValidDirectory)))))
    380 
    381 sectionRecordOffsetNat = (sectionRecord :
    382   u64BEBytesToNat (sectionRecordOffset sectionRecord))
    383 
    384 sectionRecordLengthNat = (sectionRecord :
    385   u64BEBytesToNat (sectionRecordLength sectionRecord))
    386 
    387 extractSectionBytes = (sectionRecord containerBytes :
    388   byteSlice
    389     (sectionRecordOffsetNat sectionRecord)
    390     (sectionRecordLengthNat sectionRecord)
    391     containerBytes)
    392 
    393 extractSectionBytesResult = (sectionRecord containerBytes rest :
    394   (sectionBytes :
    395     matchBool
    396       (ok sectionBytes rest)
    397       (err errUnexpectedEof rest)
    398       (equal? (bytesLength sectionBytes) (sectionRecordLengthNat sectionRecord)))
    399     (extractSectionBytes sectionRecord containerBytes))
    400 
    401 lookupSectionBytes = (sectionId directory containerBytes :
    402   triage
    403     nothing
    404     (sectionRecord : just (extractSectionBytes sectionRecord containerBytes))
    405     (_ _ : nothing)
    406     (lookupSectionRecord sectionId directory))
    407 
    408 sectionBytesOrErr = (sectionId directory containerBytes rest :
    409   triage
    410     (err errMissingSection rest)
    411     (sectionRecord : extractSectionBytesResult sectionRecord containerBytes rest)
    412     (_ _ : err errMissingSection rest)
    413     (lookupSectionRecord sectionId directory))
    414 
    415 readArboricxSectionBytes = (sectionId bs :
    416   bindResult (readArboricxContainer bs)
    417     (container afterContainer :
    418       matchPair
    419         (_ directory : sectionBytesOrErr sectionId directory bs afterContainer)
    420         container))
    421 
    422 readArboricxRequiredSections = (bs :
    423   bindResult (readArboricxContainer bs)
    424     (container afterContainer :
    425       matchPair
    426         (_ directory :
    427           bindResult (sectionBytesOrErr arboricxManifestSectionId directory bs afterContainer)
    428             (manifestBytes _ :
    429               bindResult (sectionBytesOrErr arboricxNodesSectionId directory bs afterContainer)
    430                 (nodesBytes _ :
    431                   ok (pair manifestBytes nodesBytes) afterContainer)))
    432         container))