tricu

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

57393cc4f6684bab60a98387056bf71dc673fcbc10482a3dd16bec270675e8ab.tri (11047B)

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