Wire.hs (42548B)
1 {-# LANGUAGE BangPatterns #-} 2 {-# LANGUAGE DeriveGeneric #-} 3 {-# LANGUAGE OverloadedStrings #-} 4 5 module Wire 6 ( Bundle (..) 7 , BundleManifest (..) 8 , TreeSpec (..) 9 , NodeHashSpec (..) 10 , RuntimeSpec (..) 11 , BundleRoot (..) 12 , BundleExport (..) 13 , BundleMetadata 14 , ClosureMode (..) 15 , BundleNode (..) 16 , encodeBundle 17 , decodeBundle 18 , verifyBundle 19 , buildBundle 20 , buildBundleShared 21 , TreeTermBundleBuilder 22 , TreeTermBundleCursor 23 , emptyTreeTermBundle 24 , startTreeTerm 25 , feedTreeTerm 26 , endTreeTerm 27 , finishTreeTermBundle 28 , extractBundleRoot 29 , reconstructBundleTerms 30 , defaultExportNames 31 ) where 32 33 import Runtime hiding (Node) 34 35 import Control.Monad (foldM, forM_, unless, when) 36 import Control.Exception (evaluate) 37 import Data.IORef (newIORef, readIORef, modifyIORef') 38 import System.Mem.StableName (StableName, makeStableName, hashStableName) 39 import qualified Data.IntMap.Strict as IntMap 40 import Data.Bits (shiftL, shiftR, (.|.), (.&.)) 41 import Data.ByteString (ByteString) 42 import Data.Foldable (traverse_) 43 import qualified Data.Foldable as Foldable 44 import Data.List (mapAccumL) 45 import Data.Map (Map) 46 import qualified Data.Map.Strict as Map 47 import Data.Sequence (Seq, (|>)) 48 import qualified Data.Sequence as Seq 49 import Data.Set (Set) 50 import qualified Data.Set as Set 51 import Data.Text (Text, unpack) 52 import Data.Text.Encoding (decodeUtf8', encodeUtf8) 53 import Data.Vector (Vector) 54 import qualified Data.Vector as V 55 import qualified Data.Vector.Mutable as MV 56 import Data.Word (Word16, Word32, Word64, Word8) 57 import GHC.Generics (Generic) 58 59 import qualified Data.ByteString as BS 60 import qualified Data.Text as T 61 62 -- --------------------------------------------------------------------------- 63 -- Container constants 64 -- --------------------------------------------------------------------------- 65 66 bundleMajorVersion :: Word16 67 bundleMajorVersion = 1 68 69 bundleMinorVersion :: Word16 70 bundleMinorVersion = 0 71 72 bundleMagic :: ByteString 73 bundleMagic = BS.pack [0x41, 0x52, 0x42, 0x4f, 0x52, 0x49, 0x43, 0x58] 74 75 headerLength :: Int 76 headerLength = 32 77 78 sectionEntryLength :: Int 79 sectionEntryLength = 32 80 81 sectionManifest, sectionNodes :: Word32 82 sectionManifest = 1 83 sectionNodes = 2 84 85 flagCritical :: Word16 86 flagCritical = 0x0001 87 88 compressionNone :: Word16 89 compressionNone = 0 90 91 -- --------------------------------------------------------------------------- 92 -- Manifest constants 93 -- --------------------------------------------------------------------------- 94 95 manifestMagic :: ByteString 96 manifestMagic = "ARBMNFST" 97 98 manifestMajorVersion :: Word16 99 manifestMajorVersion = 1 100 101 manifestMinorVersion :: Word16 102 manifestMinorVersion = 1 103 104 closureToByte :: ClosureMode -> Word8 105 closureToByte = \case 106 ClosureComplete -> 0 107 ClosurePartial -> 1 108 109 closureFromByte :: Word8 -> Either String ClosureMode 110 closureFromByte = \case 111 0 -> Right ClosureComplete 112 1 -> Right ClosurePartial 113 n -> Left $ "unsupported closure byte: " ++ show n 114 115 tagPackage, tagVersion, tagDescription, tagLicense, tagCreatedBy :: Word16 116 tagPackage = 1 117 tagVersion = 2 118 tagDescription = 3 119 tagLicense = 4 120 tagCreatedBy = 5 121 122 -- --------------------------------------------------------------------------- 123 -- Text encoding helpers 124 -- --------------------------------------------------------------------------- 125 126 encodeLengthPrefixedText :: Text -> ByteString 127 encodeLengthPrefixedText t = encode32 (fromIntegral $ BS.length bs) <> bs 128 where bs = encodeUtf8 t 129 130 decodeLengthPrefixedText :: ByteString -> Either String (Text, ByteString) 131 decodeLengthPrefixedText bs = do 132 (len, rest) <- decode32be "text_length" bs 133 let payloadLen = fromIntegral len 134 when (BS.length rest < payloadLen) $ 135 Left "decodeLengthPrefixedText: string extends beyond input" 136 let (textBytes, after) = BS.splitAt payloadLen rest 137 case decodeUtf8' textBytes of 138 Right txt -> Right (txt, after) 139 Left _ -> Left "decodeLengthPrefixedText: invalid UTF-8" 140 141 encodeMetadataTLV :: Word16 -> ByteString -> ByteString 142 encodeMetadataTLV tag val = encode16 tag <> encode32 (fromIntegral $ BS.length val) <> val 143 144 -- --------------------------------------------------------------------------- 145 -- Manifest encoders 146 -- --------------------------------------------------------------------------- 147 148 encodeManifest :: BundleManifest -> ByteString 149 encodeManifest m = 150 manifestMagic 151 <> encode16 manifestMajorVersion 152 <> encode16 manifestMinorVersion 153 <> encodeLengthPrefixedText (manifestSchema m) 154 <> encodeLengthPrefixedText (manifestBundleType m) 155 <> encodeLengthPrefixedText (treeCalculus (manifestTree m)) 156 <> encodeLengthPrefixedText (nodeHashAlgorithm (treeNodeHash (manifestTree m))) 157 <> encodeLengthPrefixedText (nodeHashDomain (treeNodeHash (manifestTree m))) 158 <> encodeLengthPrefixedText (treeNodePayload (manifestTree m)) 159 <> encodeLengthPrefixedText (runtimeSemantics (manifestRuntime m)) 160 <> encodeLengthPrefixedText (runtimeEvaluation (manifestRuntime m)) 161 <> encodeLengthPrefixedText (runtimeAbi (manifestRuntime m)) 162 <> encode32 (fromIntegral $ length (runtimeCapabilities (manifestRuntime m))) 163 <> encodeCapabilities (runtimeCapabilities (manifestRuntime m)) 164 <> BS.pack [closureToByte (manifestClosure m)] 165 <> encode32 (fromIntegral $ length (manifestRoots m)) 166 <> encodeRoots (manifestRoots m) 167 <> encode32 (fromIntegral $ length (manifestExports m)) 168 <> encodeExports (manifestExports m) 169 <> encodeMetadataTLVs (manifestMetadata m) 170 <> encode32 0 171 172 encodeCapabilities :: [Text] -> ByteString 173 encodeCapabilities = mconcat . map encodeLengthPrefixedText 174 175 encodeRoots :: [BundleRoot] -> ByteString 176 encodeRoots = mconcat . map encodeRoot 177 178 encodeRoot :: BundleRoot -> ByteString 179 encodeRoot root = encode32 (rootIndex root) <> encodeLengthPrefixedText (rootRole root) 180 181 encodeExports :: [BundleExport] -> ByteString 182 encodeExports = mconcat . map encodeExport 183 184 encodeExport :: BundleExport -> ByteString 185 encodeExport exp = 186 encodeLengthPrefixedText (exportName exp) 187 <> encode32 (exportRoot exp) 188 <> encodeLengthPrefixedText (exportKind exp) 189 <> encodeLengthPrefixedText (exportAbi exp) 190 191 encodeMetadataTLVs :: BundleMetadata -> ByteString 192 encodeMetadataTLVs m = 193 let entries = metadataTLVEntries m 194 in encode32 (fromIntegral $ length entries) <> encodeTLVs entries 195 196 metadataTLVEntries :: BundleMetadata -> [(Word16, ByteString)] 197 metadataTLVEntries m = 198 maybeEntry tagPackage (metadataPackage m) 199 ++ maybeEntry tagVersion (metadataVersion m) 200 ++ maybeEntry tagDescription (metadataDescription m) 201 ++ maybeEntry tagLicense (metadataLicense m) 202 ++ maybeEntry tagCreatedBy (metadataCreatedBy m) 203 where 204 maybeEntry _ Nothing = [] 205 maybeEntry tag (Just value) = [(tag, encodeUtf8 value)] 206 207 encodeTLVs :: [(Word16, ByteString)] -> ByteString 208 encodeTLVs = mconcat . map (uncurry encodeMetadataTLV) 209 210 -- --------------------------------------------------------------------------- 211 -- Manifest decoders 212 -- --------------------------------------------------------------------------- 213 214 decodeManifest :: ByteString -> Either String BundleManifest 215 decodeManifest bs = do 216 when (BS.length bs < 8) $ Left "manifest too short for magic" 217 when (BS.take 8 bs /= manifestMagic) $ Left "invalid manifest magic" 218 let rest = BS.drop 8 bs 219 (major, rest') <- decode16be "major" rest 220 (minor, rest'') <- decode16be "minor" rest' 221 when (major /= manifestMajorVersion) $ 222 Left $ "unsupported manifest major version: " ++ show major 223 when (minor /= manifestMinorVersion) $ 224 Left $ "unsupported manifest minor version: " ++ show minor 225 226 (schema, r1) <- decodeLengthPrefixedText rest'' 227 (bundleType, r2) <- decodeLengthPrefixedText r1 228 (calc, r3) <- decodeLengthPrefixedText r2 229 (alg, r4) <- decodeLengthPrefixedText r3 230 (domain, r5) <- decodeLengthPrefixedText r4 231 (payload, r6) <- decodeLengthPrefixedText r5 232 (sem, r7) <- decodeLengthPrefixedText r6 233 (eval, r8) <- decodeLengthPrefixedText r7 234 (abi, r9) <- decodeLengthPrefixedText r8 235 236 (capCount, r10) <- decode32be "capability_count" r9 237 (caps, r11) <- decodeCapabilities (fromIntegral capCount) r10 238 239 when (BS.length r11 < 1) $ Left "manifest truncated: missing closure byte" 240 let (closureByte, r12) = BS.splitAt 1 r11 241 closure <- closureFromByte (head $ BS.unpack closureByte) 242 243 (rootCount, r13) <- decode32be "root_count" r12 244 (roots, r14) <- decodeRoots (fromIntegral rootCount) r13 245 246 (exportCount, r15) <- decode32be "export_count" r14 247 (exports, r16) <- decodeExports (fromIntegral exportCount) r15 248 249 (metadata, _ext) <- decodeMetadataAndExtensions r16 250 251 pure BundleManifest 252 { manifestSchema = schema 253 , manifestBundleType = bundleType 254 , manifestTree = TreeSpec 255 { treeCalculus = calc 256 , treeNodeHash = NodeHashSpec 257 { nodeHashAlgorithm = alg 258 , nodeHashDomain = domain 259 } 260 , treeNodePayload = payload 261 } 262 , manifestRuntime = RuntimeSpec 263 { runtimeSemantics = sem 264 , runtimeEvaluation = eval 265 , runtimeAbi = abi 266 , runtimeCapabilities = caps 267 } 268 , manifestClosure = closure 269 , manifestRoots = roots 270 , manifestExports = exports 271 , manifestMetadata = metadata 272 } 273 274 decodeCapabilities :: Int -> ByteString -> Either String ([Text], ByteString) 275 decodeCapabilities 0 bs = Right ([], bs) 276 decodeCapabilities n bs = do 277 (txt, rest) <- decodeLengthPrefixedText bs 278 (restTxts, restFinal) <- decodeCapabilities (n - 1) rest 279 Right (txt : restTxts, restFinal) 280 281 decodeRoots :: Int -> ByteString -> Either String ([BundleRoot], ByteString) 282 decodeRoots 0 bs = Right ([], bs) 283 decodeRoots n bs = do 284 (idx, rest1) <- decode32be "root_index" bs 285 (role, rest2) <- decodeLengthPrefixedText rest1 286 (restRoots, restFinal) <- decodeRoots (n - 1) rest2 287 Right (BundleRoot idx role : restRoots, restFinal) 288 289 decodeExports :: Int -> ByteString -> Either String ([BundleExport], ByteString) 290 decodeExports 0 bs = Right ([], bs) 291 decodeExports n bs = do 292 (name, r1) <- decodeLengthPrefixedText bs 293 (idx, r2) <- decode32be "export_root" r1 294 (kind, r3) <- decodeLengthPrefixedText r2 295 (abi, r4) <- decodeLengthPrefixedText r3 296 (restExports, restFinal) <- decodeExports (n - 1) r4 297 Right (BundleExport name idx kind abi : restExports, restFinal) 298 299 decodeMetadataAndExtensions :: ByteString -> Either String (BundleMetadata, ByteString) 300 decodeMetadataAndExtensions bs = do 301 (metadataCount, rest1) <- decode32be "metadata_field_count" bs 302 (metadataTlvs, rest2) <- decodeTLVs (fromIntegral metadataCount) rest1 303 metadata <- decodeMetadataTLVs metadataTlvs 304 (extensionCount, rest3) <- decode32be "extension_field_count" rest2 305 (_extensionTlvs, rest4) <- decodeTLVs (fromIntegral extensionCount) rest3 306 unless (BS.null rest4) $ Left "trailing bytes after manifest TLV tail" 307 Right (metadata, rest4) 308 309 decodeTLVs :: Int -> ByteString -> Either String ([TLVEntry], ByteString) 310 decodeTLVs 0 bs = Right ([], bs) 311 decodeTLVs n bs = do 312 (tag, r1) <- decode16be "tlv_tag" bs 313 (len, r2) <- decode32be "tlv_length" r1 314 let payloadLen = fromIntegral len 315 when (BS.length r2 < payloadLen) $ Left "TLV value extends beyond input" 316 let (value, after) = BS.splitAt payloadLen r2 317 (restTlvs, restFinal) <- decodeTLVs (n - 1) after 318 Right ((tag, value) : restTlvs, restFinal) 319 320 decodeMetadataTLVs :: [(Word16, ByteString)] -> Either String BundleMetadata 321 decodeMetadataTLVs tlvs = do 322 pkg <- lookupText tagPackage 323 ver <- lookupText tagVersion 324 desc <- lookupText tagDescription 325 lic <- lookupText tagLicense 326 by <- lookupText tagCreatedBy 327 pure BundleMetadata 328 { metadataPackage = pkg 329 , metadataVersion = ver 330 , metadataDescription = desc 331 , metadataLicense = lic 332 , metadataCreatedBy = by 333 } 334 where 335 lookupTag t = go t tlvs 336 go _ [] = Nothing 337 go t ((tag, val):rest) 338 | tag == t = Just val 339 | otherwise = go t rest 340 lookupText tag = 341 case lookupTag tag of 342 Nothing -> Right Nothing 343 Just raw -> case decodeUtf8' raw of 344 Right txt -> Right (Just txt) 345 Left _ -> Left $ "metadata TLV has invalid UTF-8 for tag " ++ show tag 346 347 type TLVEntry = (Word16, ByteString) 348 349 -- --------------------------------------------------------------------------- 350 -- Data types 351 -- --------------------------------------------------------------------------- 352 353 data ClosureMode = ClosureComplete | ClosurePartial 354 deriving (Show, Eq, Ord, Generic) 355 356 data NodeHashSpec = NodeHashSpec 357 { nodeHashAlgorithm :: Text 358 , nodeHashDomain :: Text 359 } deriving (Show, Eq, Ord, Generic) 360 361 data TreeSpec = TreeSpec 362 { treeCalculus :: Text 363 , treeNodeHash :: NodeHashSpec 364 , treeNodePayload :: Text 365 } deriving (Show, Eq, Ord, Generic) 366 367 data RuntimeSpec = RuntimeSpec 368 { runtimeSemantics :: Text 369 , runtimeEvaluation :: Text 370 , runtimeAbi :: Text 371 , runtimeCapabilities :: [Text] 372 } deriving (Show, Eq, Ord, Generic) 373 374 data BundleRoot = BundleRoot 375 { rootIndex :: Word32 376 , rootRole :: Text 377 } deriving (Show, Eq, Ord, Generic) 378 379 data BundleExport = BundleExport 380 { exportName :: Text 381 , exportRoot :: Word32 382 , exportKind :: Text 383 , exportAbi :: Text 384 } deriving (Show, Eq, Ord, Generic) 385 386 data BundleMetadata = BundleMetadata 387 { metadataPackage :: Maybe Text 388 , metadataVersion :: Maybe Text 389 , metadataDescription :: Maybe Text 390 , metadataLicense :: Maybe Text 391 , metadataCreatedBy :: Maybe Text 392 } deriving (Show, Eq, Ord, Generic) 393 394 data BundleManifest = BundleManifest 395 { manifestSchema :: Text 396 , manifestBundleType :: Text 397 , manifestTree :: TreeSpec 398 , manifestRuntime :: RuntimeSpec 399 , manifestClosure :: ClosureMode 400 , manifestRoots :: [BundleRoot] 401 , manifestExports :: [BundleExport] 402 , manifestMetadata :: BundleMetadata 403 } deriving (Show, Eq, Generic) 404 405 data BundleNode 406 = BNLeaf 407 | BNStem !Word32 408 | BNFork !Word32 !Word32 409 deriving (Show, Eq) 410 411 data Bundle = Bundle 412 { bundleVersion :: Word16 413 , bundleRoots :: [Word32] 414 , bundleNodes :: Seq BundleNode 415 , bundleManifest :: BundleManifest 416 , bundleManifestBytes :: ByteString 417 } deriving (Show, Eq) 418 419 -- --------------------------------------------------------------------------- 420 -- Bundle construction 421 -- --------------------------------------------------------------------------- 422 423 data NodeKey = KeyLeaf | KeyStem !Word32 | KeyFork !Word32 !Word32 424 deriving (Eq, Ord, Show) 425 426 buildBundle :: [(Text, T)] -> Bundle 427 buildBundle namedTerms = 428 let go :: T -> (Seq BundleNode, Map NodeKey Word32) -> (Word32, (Seq BundleNode, Map NodeKey Word32)) 429 go Leaf (nodes, seen) = 430 case Map.lookup KeyLeaf seen of 431 Just idx -> (idx, (nodes, seen)) 432 Nothing -> 433 let idx = fromIntegral (Seq.length nodes) 434 in (idx, (nodes |> BNLeaf, Map.insert KeyLeaf idx seen)) 435 go (Stem child) (nodes, seen) = 436 let (childIdx, state1) = go child (nodes, seen) 437 (nodes1, seen1) = state1 438 in case Map.lookup (KeyStem childIdx) seen1 of 439 Just idx -> (idx, state1) 440 Nothing -> 441 let idx = fromIntegral (Seq.length nodes1) 442 in (idx, (nodes1 |> BNStem childIdx, Map.insert (KeyStem childIdx) idx seen1)) 443 go (Fork left right) (nodes, seen) = 444 let (leftIdx, state1) = go left (nodes, seen) 445 (rightIdx, state2) = go right state1 446 (nodes2, seen2) = state2 447 in case Map.lookup (KeyFork leftIdx rightIdx) seen2 of 448 Just idx -> (idx, state2) 449 Nothing -> 450 let idx = fromIntegral (Seq.length nodes2) 451 in (idx, (nodes2 |> BNFork leftIdx rightIdx, Map.insert (KeyFork leftIdx rightIdx) idx seen2)) 452 453 processExport state (_, t) = let (idx, newState) = go t state in (newState, idx) 454 ((finalNodes, _), rootIndices) = mapAccumL processExport (Seq.empty, Map.empty) namedTerms 455 456 in bundleFromIndexedRoots finalNodes (zip (map fst namedTerms) rootIndices) 457 458 -- Physical sharing is only an acceleration hint. Exact constructor/child-ID 459 -- interning still determines canonical identity and left-before-right order. 460 -- Stable-name hash collisions use equality, never the hash alone. Names are 461 -- taken after WHNF evaluation so a thunk and its value are not separate keys. 462 -- The memo is local to one encoding; no store paths, publication or policy here. 463 buildBundleShared :: [(Text, T)] -> IO Bundle 464 buildBundleShared namedTerms = do 465 memo <- newIORef (IntMap.empty :: IntMap.IntMap [(StableName T, Word32)]) 466 state <- newIORef (Seq.empty, Map.empty) 467 let intern key node = do 468 (nodes, seen) <- readIORef state 469 case Map.lookup key seen of 470 Just index -> pure index 471 Nothing -> do 472 when (toInteger (Seq.length nodes) > toInteger (maxBound :: Word32)) $ 473 fail "indexed tree exceeds 32-bit node index space" 474 let index = fromIntegral (Seq.length nodes) 475 modifyIORef' state (const (nodes |> node, Map.insert key index seen)) 476 pure index 477 visit input = do 478 tree <- evaluate input 479 stable <- makeStableName tree 480 cached <- IntMap.findWithDefault [] (hashStableName stable) <$> readIORef memo 481 case lookup stable cached of 482 Just index -> pure index 483 Nothing -> do 484 index <- case tree of 485 Leaf -> intern KeyLeaf BNLeaf 486 Stem child -> do 487 childIndex <- visit child 488 intern (KeyStem childIndex) (BNStem childIndex) 489 Fork left right -> do 490 leftIndex <- visit left 491 rightIndex <- visit right 492 intern (KeyFork leftIndex rightIndex) (BNFork leftIndex rightIndex) 493 modifyIORef' memo (IntMap.insertWith (++) (hashStableName stable) [(stable, index)]) 494 pure index 495 roots <- mapM (\(name, tree) -> do index <- visit tree; pure (name, index)) namedTerms 496 (nodes, _) <- readIORef state 497 pure (bundleFromIndexedRoots nodes roots) 498 499 -- Both construction paths share exactly the same manifest and node numbering. 500 bundleFromIndexedRoots :: Seq BundleNode -> [(Text, Word32)] -> Bundle 501 bundleFromIndexedRoots finalNodes namedRoots = 502 let rootIndices = map snd namedRoots 503 roots = zipWith mkRoot [0 :: Int ..] rootIndices 504 exports = map (\(name, idx) -> BundleExport name idx "term" "arboricx.abi.tree.v1") namedRoots 505 manifest = makeManifest roots exports 506 manifestBytes = encodeManifest manifest 507 in Bundle 508 { bundleVersion = bundleMajorVersion * 1000 + bundleMinorVersion 509 , bundleRoots = rootIndices 510 , bundleNodes = finalNodes 511 , bundleManifest = manifest 512 , bundleManifestBytes = manifestBytes 513 } 514 where 515 mkRoot 0 idx = BundleRoot idx "default" 516 mkRoot _ idx = BundleRoot idx "root" 517 518 -- Streaming canonical preorder -> postorder DAG. No expanded Runtime.T is 519 -- constructed. Global interning preserves buildBundle's left-before-right, 520 -- first-occurrence numbering, including sharing between separate exports. 521 -- Memory: unique DAG nodes + maximum tree depth + caller's current input chunk. 522 data TreeTermBundleBuilder = TreeTermBundleBuilder 523 !(Seq BundleNode) !(Map NodeKey Word32) ![(Text, Word32)] 524 data TreeTermFrame = TermStem | TermForkLeft | TermForkRight !Word32 525 data TreeTermBundleCursor = TreeTermBundleCursor 526 !TreeTermBundleBuilder ![TreeTermFrame] !(Maybe Word32) 527 528 emptyTreeTermBundle :: TreeTermBundleBuilder 529 emptyTreeTermBundle = TreeTermBundleBuilder Seq.empty Map.empty [] 530 531 startTreeTerm :: TreeTermBundleBuilder -> TreeTermBundleCursor 532 startTreeTerm builder = TreeTermBundleCursor builder [] Nothing 533 534 internTermNode :: NodeKey -> BundleNode -> TreeTermBundleBuilder 535 -> Either String (Word32, TreeTermBundleBuilder) 536 -- Every nonempty canonical tree first completes a leaf. The opaque builder 537 -- therefore always assigns Leaf index 0, across chunks and exports. Avoid a 538 -- balanced-map lookup for each repeated leaf (roughly half of a fork-heavy 539 -- flat payload); retain ordinary interning for the first leaf and all parents. 540 internTermNode KeyLeaf BNLeaf builder@(TreeTermBundleBuilder nodes _ _) 541 | not (Seq.null nodes) = Right (0, builder) 542 internTermNode key node builder@(TreeTermBundleBuilder nodes seen roots) = 543 case Map.lookup key seen of 544 Just idx -> Right (idx, builder) 545 Nothing 546 | toInteger (Seq.length nodes) >= toInteger (maxBound :: Word32) -> 547 Left "tree-term bundle node limit exceeded" 548 | otherwise -> 549 let !idx = fromIntegral (Seq.length nodes) 550 !updated = TreeTermBundleBuilder (nodes |> node) (Map.insert key idx seen) roots 551 in Right (idx, updated) 552 553 feedTreeTerm :: ByteString -> TreeTermBundleCursor -> Either String TreeTermBundleCursor 554 feedTreeTerm bytes = readNode 0 555 where 556 !size = BS.length bytes 557 readNode !offset cursor@(TreeTermBundleCursor builder frames root) 558 | offset == size = Right cursor 559 | Just _ <- root = Left "trailing bytes after tree term" 560 | otherwise = case BS.index bytes offset of 561 0 -> do 562 (idx, updated) <- internTermNode KeyLeaf BNLeaf builder 563 deliver idx (offset + 1) updated frames 564 1 -> readNode (offset + 1) (TreeTermBundleCursor builder (TermStem : frames) Nothing) 565 2 -> readNode (offset + 1) (TreeTermBundleCursor builder (TermForkLeft : frames) Nothing) 566 tag -> Left $ "unknown tree term tag: " ++ show tag 567 deliver !idx !offset !builder [] = 568 readNode offset (TreeTermBundleCursor builder [] (Just idx)) 569 deliver !idx !offset !builder (TermStem : frames) = do 570 (parent, updated) <- internTermNode (KeyStem idx) (BNStem idx) builder 571 deliver parent offset updated frames 572 deliver !idx !offset !builder (TermForkLeft : frames) = 573 readNode offset (TreeTermBundleCursor builder (TermForkRight idx : frames) Nothing) 574 deliver !right !offset !builder (TermForkRight left : frames) = do 575 (parent, updated) <- internTermNode (KeyFork left right) (BNFork left right) builder 576 deliver parent offset updated frames 577 578 endTreeTerm :: Text -> TreeTermBundleCursor -> Either String TreeTermBundleBuilder 579 endTreeTerm name (TreeTermBundleCursor (TreeTermBundleBuilder nodes seen roots) [] (Just root)) = 580 Right (TreeTermBundleBuilder nodes seen ((name, root) : roots)) 581 endTreeTerm _ _ = Left "unexpected end of tree term" 582 583 finishTreeTermBundle :: TreeTermBundleBuilder -> Bundle 584 finishTreeTermBundle (TreeTermBundleBuilder nodes _ roots) = 585 bundleFromIndexedRoots nodes (reverse roots) 586 587 makeManifest :: [BundleRoot] -> [BundleExport] -> BundleManifest 588 makeManifest roots exports = BundleManifest 589 { manifestSchema = "arboricx.bundle.manifest.v1" 590 , manifestBundleType = "tree-calculus-executable-object" 591 , manifestTree = TreeSpec 592 { treeCalculus = "tree-calculus.v1" 593 , treeNodeHash = NodeHashSpec 594 { nodeHashAlgorithm = "indexed" 595 , nodeHashDomain = "arboricx.indexed.node.v1" 596 } 597 , treeNodePayload = "arboricx.indexed.payload.v1" 598 } 599 , manifestRuntime = RuntimeSpec 600 { runtimeSemantics = "tree-calculus.v1" 601 , runtimeEvaluation = "normal-order" 602 , runtimeAbi = "arboricx.abi.tree.v1" 603 , runtimeCapabilities = [] 604 } 605 , manifestClosure = ClosureComplete 606 , manifestRoots = roots 607 , manifestExports = exports 608 , manifestMetadata = BundleMetadata 609 { metadataPackage = Nothing 610 , metadataVersion = Nothing 611 , metadataDescription = Nothing 612 , metadataLicense = Nothing 613 , metadataCreatedBy = Just "arboricx" 614 } 615 } 616 617 -- | Extract one canonical, name-neutral root using indexed edges only. The 618 -- memo table visits each reachable node once; never unfold the logical tree. 619 extractBundleRoot :: Bundle -> Word32 -> Either String Bundle 620 extractBundleRoot bundle root = do 621 verifyBundle bundle 622 when (fromIntegral root >= Seq.length (bundleNodes bundle)) $ 623 Left "extracted root index out of bounds" 624 let visit :: Word32 -> (Seq BundleNode, Map Word32 Word32) 625 -> (Word32, (Seq BundleNode, Map Word32 Word32)) 626 visit old state@(nodes, seen) = case Map.lookup old seen of 627 Just index -> (index, state) 628 Nothing -> 629 let (node, (children, memo)) = case Seq.index (bundleNodes bundle) (fromIntegral old) of 630 BNLeaf -> (BNLeaf, (nodes, seen)) 631 BNStem child -> 632 let (index, next) = visit child state 633 in (BNStem index, next) 634 BNFork left right -> 635 let (l, next) = visit left state 636 (r, final) = visit right next 637 in (BNFork l r, final) 638 index = fromIntegral (Seq.length children) 639 in (index, (children |> node, Map.insert old index memo)) 640 (index, (nodes, _)) = visit root (Seq.empty, Map.empty) 641 manifest = makeManifest [BundleRoot index "default"] 642 [BundleExport "root" index "term" "arboricx.abi.tree.v1"] 643 pure Bundle 644 { bundleVersion = bundleMajorVersion * 1000 + bundleMinorVersion 645 , bundleRoots = [index] 646 , bundleNodes = nodes 647 , bundleManifest = manifest 648 , bundleManifestBytes = encodeManifest manifest 649 } 650 651 -- --------------------------------------------------------------------------- 652 -- Bundle encoding / decoding 653 -- --------------------------------------------------------------------------- 654 655 encodeBundle :: Bundle -> ByteString 656 encodeBundle bundle = 657 let nodeSection = encodeNodeSection (bundleNodes bundle) 658 manifestBytes = bundleManifestBytes bundle 659 sectionCount = 2 660 dirOffset = fromIntegral headerLength 661 sectionDirLength = sectionCount * sectionEntryLength 662 manifestOffset = fromIntegral (headerLength + sectionDirLength) 663 nodesOffset = manifestOffset + fromIntegral (BS.length manifestBytes) 664 manifestEntry = encodeSectionEntry sectionManifest 1 flagCritical compressionNone 665 manifestOffset (fromIntegral $ BS.length manifestBytes) 666 nodesEntry = encodeSectionEntry sectionNodes 1 flagCritical compressionNone 667 nodesOffset (fromIntegral $ BS.length nodeSection) 668 header = encodeHeader bundleMajorVersion bundleMinorVersion 669 (fromIntegral sectionCount) 0 dirOffset 670 in header <> manifestEntry <> nodesEntry <> manifestBytes <> nodeSection 671 672 decodeBundle :: ByteString -> Either String Bundle 673 decodeBundle bs 674 | BS.take (BS.length bundleMagic) bs /= bundleMagic = Left "invalid magic" 675 | otherwise = do 676 (major, minor, sectionCount, _flags, dirOffset) <- decodePortableHeader bs 677 when (major /= bundleMajorVersion) $ 678 Left $ "unsupported bundle major version: " ++ show major 679 let dirStart = fromIntegral dirOffset 680 dirBytes = fromIntegral sectionCount * sectionEntryLength 681 when (BS.length bs < dirStart + dirBytes) $ 682 Left "bundle truncated in section directory" 683 let dirRaw = BS.take dirBytes $ BS.drop dirStart bs 684 entries <- decodeSectionEntries sectionCount dirRaw 685 traverse_ rejectUnknownCritical entries 686 manifestEntry <- requireSection sectionManifest entries 687 nodesEntry <- requireSection sectionNodes entries 688 manifestBytes <- readAndVerifySection bs manifestEntry 689 nodesBytes <- readAndVerifySection bs nodesEntry 690 manifest <- decodeManifest manifestBytes 691 when (treeNodePayload (manifestTree manifest) /= "arboricx.indexed.payload.v1") $ 692 Left "manifest does not use indexed payload" 693 nodes <- decodeNodeSection nodesBytes 694 let rootIndices = map rootIndex (manifestRoots manifest) 695 return Bundle 696 { bundleVersion = major * 1000 + minor 697 , bundleRoots = rootIndices 698 , bundleNodes = nodes 699 , bundleManifest = manifest 700 , bundleManifestBytes = manifestBytes 701 } 702 703 -- --------------------------------------------------------------------------- 704 -- Container encoding / decoding 705 -- --------------------------------------------------------------------------- 706 707 data SectionEntry = SectionEntry 708 { seType :: Word32 709 , seVersion :: Word16 710 , seFlags :: Word16 711 , seCompression :: Word16 712 , seOffset :: Word64 713 , seLength :: Word64 714 } deriving (Show, Eq) 715 716 encodeHeader :: Word16 -> Word16 -> Word32 -> Word64 -> Word64 -> ByteString 717 encodeHeader major minor sectionCount flags dirOffset = 718 bundleMagic 719 <> encode16 major 720 <> encode16 minor 721 <> encode32 sectionCount 722 <> encode64 flags 723 <> encode64 dirOffset 724 725 encodeSectionEntry :: Word32 -> Word16 -> Word16 -> Word16 -> Word64 -> Word64 -> ByteString 726 encodeSectionEntry sectionType sectionVersion sectionFlags compression offset lengthBytes = 727 encode32 sectionType 728 <> encode16 sectionVersion 729 <> encode16 sectionFlags 730 <> encode16 compression 731 <> encode16 0 -- reserved 732 <> encode64 offset 733 <> encode64 lengthBytes 734 <> encode32 0 -- reserved padding 735 736 decodePortableHeader :: ByteString -> Either String (Word16, Word16, Word32, Word64, Word64) 737 decodePortableHeader bs 738 | BS.length bs < headerLength = Left "bundle too short for header" 739 | BS.take 8 bs /= bundleMagic = Left "invalid portable bundle magic" 740 | otherwise = do 741 (major, r1) <- decode16be "major_version" (BS.drop 8 bs) 742 (minor, r2) <- decode16be "minor_version" r1 743 (sectionCount, r3) <- decode32be "section_count" r2 744 (flags, r4) <- decode64be "flags" r3 745 (dirOffset, _) <- decode64be "directory_offset" r4 746 Right (major, minor, sectionCount, flags, dirOffset) 747 748 decodeSectionEntries :: Word32 -> ByteString -> Either String [SectionEntry] 749 decodeSectionEntries count bytes = reverse <$> go count bytes [] 750 where 751 go 0 _ acc = Right acc 752 go n bs acc = do 753 when (BS.length bs < sectionEntryLength) $ 754 Left "section directory truncated" 755 (sectionType, r1) <- decode32be "section_type" bs 756 (sectionVersion, r2) <- decode16be "section_version" r1 757 (sectionFlags, r3) <- decode16be "section_flags" r2 758 (compression, r4) <- decode16be "compression_codec" r3 759 (_reserved, r5) <- decode16be "reserved" r4 760 (offset, r6) <- decode64be "section_offset" r5 761 (len, r7) <- decode64be "section_length" r6 762 (_reserved2, rest) <- decode32be "reserved" r7 763 let entry = SectionEntry sectionType sectionVersion sectionFlags compression offset len 764 go (n - 1) rest (entry : acc) 765 766 rejectUnknownCritical :: SectionEntry -> Either String () 767 rejectUnknownCritical entry = 768 let known = seType entry `elem` [sectionManifest, sectionNodes] 769 critical = seFlags entry .&. flagCritical /= 0 770 in when (critical && not known) $ 771 Left $ "unknown critical section type: " ++ show (seType entry) 772 773 requireSection :: Word32 -> [SectionEntry] -> Either String SectionEntry 774 requireSection sectionType entries = 775 case filter ((== sectionType) . seType) entries of 776 [entry] -> Right entry 777 [] -> Left $ "missing required section type: " ++ show sectionType 778 _ -> Left $ "duplicate section type: " ++ show sectionType 779 780 readAndVerifySection :: ByteString -> SectionEntry -> Either String ByteString 781 readAndVerifySection bs entry = do 782 when (seCompression entry /= compressionNone) $ 783 Left $ "unsupported compression codec in section " ++ show (seType entry) 784 let offset = fromIntegral (seOffset entry) 785 len = fromIntegral (seLength entry) 786 when (offset < 0 || len < 0 || BS.length bs < offset + len) $ 787 Left $ "section extends beyond bundle end: " ++ show (seType entry) 788 Right $ BS.take len $ BS.drop offset bs 789 790 -- --------------------------------------------------------------------------- 791 -- Node section encoding / decoding 792 -- --------------------------------------------------------------------------- 793 794 serializeBundleNode :: BundleNode -> ByteString 795 serializeBundleNode BNLeaf = BS.pack [0x00] 796 serializeBundleNode (BNStem child) = BS.pack [0x01] <> encode32 child 797 serializeBundleNode (BNFork left right) = BS.pack [0x02] <> encode32 left <> encode32 right 798 799 encodeNodeSection :: Seq BundleNode -> ByteString 800 encodeNodeSection nodes = 801 encode64 (fromIntegral $ Seq.length nodes) 802 <> foldMap encodeNodeEntry nodes 803 where 804 encodeNodeEntry node = 805 let payload = serializeBundleNode node 806 in encode32 (fromIntegral $ BS.length payload) <> payload 807 808 decodeNodeSection :: ByteString -> Either String (Seq BundleNode) 809 decodeNodeSection bs = do 810 (nodeCount, rest) <- decode64be "node_count" bs 811 decodeNodeEntries nodeCount rest 812 813 decodeNodeEntries :: Word64 -> ByteString -> Either String (Seq BundleNode) 814 decodeNodeEntries count bs = go count bs Seq.empty 815 where 816 go 0 rest acc 817 | BS.null rest = Right acc 818 | otherwise = Left "trailing bytes after node section" 819 go n bytes acc 820 | BS.length bytes < 4 = 821 Left "not enough bytes for node entry length" 822 | otherwise = do 823 (plen, rest) <- decode32be "payload_len" bytes 824 let payloadLen = fromIntegral plen 825 if BS.length rest < payloadLen 826 then Left "payload extends beyond node section end" 827 else do 828 let (payload, after) = BS.splitAt payloadLen rest 829 node <- deserializeBundleNode payload 830 go (n - 1) after (acc |> node) 831 832 deserializeBundleNode :: ByteString -> Either String BundleNode 833 deserializeBundleNode payload = 834 case BS.uncons payload of 835 Just (0x00, rest) 836 | BS.null rest -> Right BNLeaf 837 | otherwise -> Left "invalid leaf payload length" 838 Just (0x01, rest) 839 | BS.length rest == 4 -> Right $ BNStem (decodeU32 rest) 840 | otherwise -> Left "invalid stem payload length" 841 Just (0x02, rest) 842 | BS.length rest == 8 -> 843 let (leftBytes, rightBytes) = BS.splitAt 4 rest 844 in Right $ BNFork (decodeU32 leftBytes) (decodeU32 rightBytes) 845 | otherwise -> Left "invalid fork payload length" 846 _ -> Left "invalid node payload" 847 848 decodeU32 :: ByteString -> Word32 849 decodeU32 bs = 850 let b0 = fromIntegral (BS.index bs 0) :: Word32 851 b1 = fromIntegral (BS.index bs 1) :: Word32 852 b2 = fromIntegral (BS.index bs 2) :: Word32 853 b3 = fromIntegral (BS.index bs 3) :: Word32 854 in (b0 `shiftL` 24) .|. (b1 `shiftL` 16) .|. (b2 `shiftL` 8) .|. b3 855 856 -- --------------------------------------------------------------------------- 857 -- Bundle verification 858 -- --------------------------------------------------------------------------- 859 860 verifyBundle :: Bundle -> Either String () 861 verifyBundle bundle 862 | bundleVersion bundle < 1 = Left $ "unsupported bundle version: " ++ show (bundleVersion bundle) 863 | Seq.null (bundleNodes bundle) = Left "bundle has no nodes" 864 verifyBundle bundle = do 865 verifyManifestConstraints (bundleManifest bundle) 866 let nodeCount = fromIntegral $ Seq.length (bundleNodes bundle) 867 traverse_ (\idx -> when (idx >= nodeCount) $ Left $ "root index out of bounds: " ++ show idx) 868 (bundleRoots bundle) 869 traverse_ (\exp -> when (exportRoot exp >= nodeCount) $ Left $ "export index out of bounds: " ++ show (exportRoot exp)) 870 (manifestExports $ bundleManifest bundle) 871 872 let verifyNode i node = case node of 873 BNLeaf -> Right () 874 BNStem child -> do 875 when (child >= i) $ Left $ "stem at index " ++ show i ++ " references child " ++ show child 876 when (child >= nodeCount) $ Left $ "stem at index " ++ show i ++ " references child out of bounds" 877 Right () 878 BNFork left right -> do 879 when (left >= i) $ Left $ "fork at index " ++ show i ++ " references left " ++ show left 880 when (right >= i) $ Left $ "fork at index " ++ show i ++ " references right " ++ show right 881 when (left >= nodeCount) $ Left $ "fork at index " ++ show i ++ " references left out of bounds" 882 when (right >= nodeCount) $ Left $ "fork at index " ++ show i ++ " references right out of bounds" 883 Right () 884 885 mapM_ (\i -> case Seq.lookup (fromIntegral i) (bundleNodes bundle) of 886 Nothing -> Left $ "internal error: node " ++ show i ++ " not found" 887 Just node -> verifyNode i node) [0 :: Word32 .. nodeCount - 1] 888 889 let dupCheck = foldM (\seen (i, node) -> case node of 890 BNLeaf -> if Set.member (0 :: Word8, 0 :: Word32, 0 :: Word32) seen 891 then Left $ "duplicate leaf at index " ++ show i 892 else Right $ Set.insert (0, 0, 0) seen 893 BNStem child -> if Set.member (1, child, 0) seen 894 then Left $ "duplicate stem at index " ++ show i 895 else Right $ Set.insert (1, child, 0) seen 896 BNFork left right -> if Set.member (2, left, right) seen 897 then Left $ "duplicate fork at index " ++ show i 898 else Right $ Set.insert (2, left, right) seen) Set.empty (zip [0 :: Word32 ..] (Foldable.toList $ bundleNodes bundle)) 899 _ <- dupCheck 900 Right () 901 902 verifyManifestConstraints :: BundleManifest -> Either String () 903 verifyManifestConstraints manifest = do 904 when (manifestSchema manifest /= "arboricx.bundle.manifest.v1") $ 905 Left $ "unsupported manifest schema: " ++ unpack (manifestSchema manifest) 906 when (manifestBundleType manifest /= "tree-calculus-executable-object") $ 907 Left $ "unsupported bundle type: " ++ unpack (manifestBundleType manifest) 908 let treeSpec = manifestTree manifest 909 hashSpec = treeNodeHash treeSpec 910 runtimeSpec = manifestRuntime manifest 911 when (treeCalculus treeSpec /= "tree-calculus.v1") $ 912 Left $ "unsupported calculus: " ++ unpack (treeCalculus treeSpec) 913 when (nodeHashAlgorithm hashSpec /= "indexed") $ 914 Left $ "unsupported node hash algorithm: " ++ unpack (nodeHashAlgorithm hashSpec) 915 when (nodeHashDomain hashSpec /= "arboricx.indexed.node.v1") $ 916 Left $ "unsupported node hash domain: " ++ unpack (nodeHashDomain hashSpec) 917 when (treeNodePayload treeSpec /= "arboricx.indexed.payload.v1") $ 918 Left $ "unsupported node payload: " ++ unpack (treeNodePayload treeSpec) 919 when (runtimeSemantics runtimeSpec /= "tree-calculus.v1") $ 920 Left $ "unsupported runtime semantics: " ++ unpack (runtimeSemantics runtimeSpec) 921 when (runtimeEvaluation runtimeSpec /= "normal-order") $ 922 Left $ "unsupported runtime evaluation: " ++ unpack (runtimeEvaluation runtimeSpec) 923 when (runtimeAbi runtimeSpec /= "arboricx.abi.tree.v1") $ 924 Left $ "unsupported runtime ABI: " ++ unpack (runtimeAbi runtimeSpec) 925 when (not (null (runtimeCapabilities runtimeSpec))) $ 926 Left "unsupported runtime capabilities" 927 when (manifestClosure manifest /= ClosureComplete) $ 928 Left "bundle requires closure = complete" 929 when (null $ manifestRoots manifest) $ 930 Left "manifest has no roots" 931 when (null $ manifestExports manifest) $ 932 Left "manifest has no exports" 933 traverse_ verifyExport (manifestExports manifest) 934 let names = map exportName (manifestExports manifest) 935 when (Set.size (Set.fromList names) /= length names) $ 936 Left "duplicate export name" 937 where 938 verifyExport exported = do 939 when (T.null $ exportName exported) $ 940 Left "manifest export has empty name" 941 when (exportKind exported /= "term") $ 942 Left $ "unsupported export kind: " ++ unpack (exportKind exported) 943 when (exportAbi exported /= "arboricx.abi.tree.v1") $ 944 Left $ "unsupported export ABI: " ++ unpack (exportAbi exported) 945 946 -- --------------------------------------------------------------------------- 947 -- Bundle reconstruction 948 -- --------------------------------------------------------------------------- 949 950 reconstructBundleTerms :: Seq BundleNode -> Vector T 951 reconstructBundleTerms nodes = V.create $ do 952 let n = Seq.length nodes 953 vec <- MV.new n 954 forM_ (zip [0 :: Int ..] (Foldable.toList nodes)) $ \(i, node) -> do 955 t <- case node of 956 BNLeaf -> return Leaf 957 BNStem child -> Stem <$> MV.read vec (fromIntegral child) 958 BNFork left right -> do 959 l <- MV.read vec (fromIntegral left) 960 r <- MV.read vec (fromIntegral right) 961 return $ Fork l r 962 MV.write vec i t 963 return vec 964 965 -- --------------------------------------------------------------------------- 966 -- Primitive binary helpers 967 -- --------------------------------------------------------------------------- 968 969 encode16 :: Word16 -> ByteString 970 encode16 w = BS.pack 971 [ fromIntegral (shiftR w 8) 972 , fromIntegral w 973 ] 974 975 encode32 :: Word32 -> ByteString 976 encode32 w = BS.pack 977 [ fromIntegral (shiftR w 24) 978 , fromIntegral (shiftR w 16) 979 , fromIntegral (shiftR w 8) 980 , fromIntegral w 981 ] 982 983 encode64 :: Word64 -> ByteString 984 encode64 w = BS.pack 985 [ fromIntegral (shiftR w 56) 986 , fromIntegral (shiftR w 48) 987 , fromIntegral (shiftR w 40) 988 , fromIntegral (shiftR w 32) 989 , fromIntegral (shiftR w 24) 990 , fromIntegral (shiftR w 16) 991 , fromIntegral (shiftR w 8) 992 , fromIntegral w 993 ] 994 995 decode16be :: String -> ByteString -> Either String (Word16, ByteString) 996 decode16be label bs 997 | BS.length bs < 2 = Left (label ++ ": not enough bytes for u16") 998 | otherwise = 999 let b0 = fromIntegral (BS.index bs 0) :: Word16 1000 b1 = fromIntegral (BS.index bs 1) :: Word16 1001 in Right ((b0 `shiftL` 8) .|. b1, BS.drop 2 bs) 1002 1003 decode32be :: String -> ByteString -> Either String (Word32, ByteString) 1004 decode32be label bs 1005 | BS.length bs < 4 = Left (label ++ ": not enough bytes for u32") 1006 | otherwise = 1007 let b0 = fromIntegral (BS.index bs 0) :: Word32 1008 b1 = fromIntegral (BS.index bs 1) :: Word32 1009 b2 = fromIntegral (BS.index bs 2) :: Word32 1010 b3 = fromIntegral (BS.index bs 3) :: Word32 1011 in Right ((b0 `shiftL` 24) .|. (b1 `shiftL` 16) .|. (b2 `shiftL` 8) .|. b3, BS.drop 4 bs) 1012 1013 decode64be :: String -> ByteString -> Either String (Word64, ByteString) 1014 decode64be label bs 1015 | BS.length bs < 8 = Left (label ++ ": not enough bytes for u64") 1016 | otherwise = 1017 let b0 = fromIntegral (BS.index bs 0) :: Word64 1018 b1 = fromIntegral (BS.index bs 1) :: Word64 1019 b2 = fromIntegral (BS.index bs 2) :: Word64 1020 b3 = fromIntegral (BS.index bs 3) :: Word64 1021 b4 = fromIntegral (BS.index bs 4) :: Word64 1022 b5 = fromIntegral (BS.index bs 5) :: Word64 1023 b6 = fromIntegral (BS.index bs 6) :: Word64 1024 b7 = fromIntegral (BS.index bs 7) :: Word64 1025 in Right ((b0 `shiftL` 56) .|. (b1 `shiftL` 48) .|. (b2 `shiftL` 40) .|. (b3 `shiftL` 32) 1026 .|. (b4 `shiftL` 24) .|. (b5 `shiftL` 16) .|. (b6 `shiftL` 8) .|. b7, BS.drop 8 bs) 1027 1028 -- --------------------------------------------------------------------------- 1029 -- Helpers 1030 -- --------------------------------------------------------------------------- 1031 1032 defaultExportNames :: Int -> [Text] 1033 defaultExportNames n = 1034 case n of 1035 0 -> [] 1036 1 -> ["root"] 1037 _ -> ["root" <> T.pack (show i) | i <- [0 :: Int .. n - 1]]