ipedb 0.1.0.0 → 0.2.0.0

raw patch · 22 files changed

+2952/−597 lines, 22 filesdep +binarydep +blockiodep +bytestringdep −sqlite-simpledep ~basedep ~directorydep ~filepathnew-component:exe:ccdbnew-uploaderPVP ok

version bump matches the API change (PVP)

Dependencies added: binary, blockio, bytestring, data-default, fs-api, hashable, leb128, lsm-tree, machines, process, tar, vector, zlib

Dependencies removed: sqlite-simple

Dependency ranges changed: base, directory, filepath, ghc-events, optparse-applicative, tasty, tasty-hunit, temporary, text

API changes (from Hackage documentation)

Files

• CHANGELOG.md +12/−4
• LICENSE +28/−0
• README.md +135/−0
• app-ccdb/Main.hs +508/−0
• app-ipedb/Main.hs +508/−0
• app/Main.hs +0/−6
• ipedb.cabal +130/−48
• src-internal/Data/Binary/Text.hs +57/−0
• src/IpeDB/Database.hs +660/−0
• src/IpeDB/Types/CostCentre.hs +116/−0
• src/IpeDB/Types/InfoProv.hs +115/−0
• src/IpeDB/Types/SrcLoc.hs +348/−0
• src/IpeDb/Eventlog/Index.hs +0/−148
• src/IpeDb/InfoProv.hs +0/−42
• src/IpeDb/Main.hs +0/−33
• src/IpeDb/Options.hs +0/−74
• src/IpeDb/Query.hs +0/−40
• src/IpeDb/Table.hs +0/−121
• src/IpeDb/Types.hs +0/−14
• test/Main.hs +244/−67
• test/data/ipedb.eventlog too large to diff
• vendor/leb128-0.1.0.0/src/Codec/LEB128/Generic.hs +91/−0

@@ -1,6 +1,14 @@-# Revision history for eventlog-splittable-ipe+# Revision history for ipedb -## 0.1.0.0 -- 2026.03.02+## 0.2.0.0 -- 2026-07-02 -* Allows to index and query `.eventlog` files-* First version. Released on an unsuspecting world.+This version is a complete reimplementation of the `ipedb` tool and library and adds the new `ccdb` tool.++- The database format is changed to `lsm-tree`, which substantially speeds up indexing.+  For instance, indexing the IPE entries for GHC goes down from 1-1/2 minutes to 7 seconds.+- The library exposes a more stable and database-agnostic API.+- The command-line interface for the `ipedb` tool is redesigned and includes listing all entries.++## 0.1.0.0 -- 2026-03-02++Experimental release of the `ipedb` tool and library, which build IPE databases from eventlog files using SQLite3.

@@ -0,0 +1,28 @@+Copyright (c) 2026, Well-Typed++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of the copyright holder nor the names of its+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,135 @@+## IpeDB++The IpeDB package contains a library for building and using GHC IPE and cost-centre databases, as well as two command-line tools, `ipedb` and `ccdb`, that provide a command-line interface to the library.++- **Working with IPE data using `ipedb`**+  - [What is IPE data?](#what-is-ipe-data)+  - [How to build a binary with IPE data?](#how-to-build-a-binary-with-ipe-data)+  - [How to build an IPE database with `ipedb`?](#how-to-build-an-ipe-database-with-ipedb)+  - [How to query an IPE database with `ipedb`?](#how-to-query-an-ipe-database-with-ipedb)++- **Working with cost-centre data using `ccdb`**+  - [What is cost-centre data?](#what-is-cost-centre-data)+  - [How to build a binary with cost-centre data?](#how-to-build-a-binary-with-cost-centre-data)+  - [How to build a cost-centre database with `ccdb`?](#how-to-build-a-cost-centre-database-with-ccdb)+  - [How to query a cost-centre database with `ccdb`?](#how-to-query-a-cost-centre-database-with-ccdb)++---++### Working with IPE data using `ipedb`++#### What is IPE data?++Broadly speaking, _Info Tables_ are the runtime representation for Haskell symbols—constructors, functions, etc. An IPE, or _Info Table Provenance Entry_—the T is silent—contains provenance information for its Info Table, such as the symbol's name and its source location. This can be useful for analysing heap profiles generated with [`-hi`](https://well-typed.com/blog/2021/01/first-look-at-hi-profiling-mode/) or stack profiles generated by [`ghc-stack-profiler`](https://hackage.haskell.org/package/ghc-stack-profiler), which by themselves only contain Info Table IDs.++An IPE database is a lookup table from _Info Table ID_ to _Info Table_. An _Info Table ID_ is a stable identifier that can be used to look up the _Info Table_. Since GHC 10, these IDs are determined statically at compile-time, which means that an IPE database can only be reused with the same binary.++> ⚠️ **Warning**:+> IPE data is not portable across builds.+> Prior to GHC 10, an _Info Table ID_ was the actual address of the _Info Table_ in memory. Since these were computed by the linker, they would change for every execution, which meant that IPE databases were not portable across _executions of the same binary_. For binaries built using those older GHC versions, you can only use an IPE database built from an eventlog to analyse that eventlog.+> Stable _Info Table IDs_ were introduced in merge request [!14465](https://gitlab.haskell.org/ghc/ghc/-/merge_requests/14465).++#### How to build a binary with IPE data?++To build a package with IPE data, you must pass `-finfo-table-map` and (optionally, but recommended) `-fdistinct-constructor-tables` to GHC.+You can add the following to your `cabal.project` file to instruct Cabal to build all packages with these options:++```+package *+  ghc-options:+    -finfo-table-map+    -fdistinct-constructor-tables+```++Unfortunately, this won't add IPE data to boot libraries that ship with GHC or to GHC builtins. To get this additional information, you must build GHC with the `ipe` flavour, see GHC [Build flavours](https://gitlab.haskell.org/ghc/ghc/blob/master/hadrian/doc/flavours.md).++#### How to build an IPE database with `ipedb`?++The `ipedb` tool extracts IPE data from a binary's _eventlog_. This is produced when the binary is run with the `-l` RTS option. This means your binary must be built with support for RTS options. You can add the following to your `*.cabal` file:++```cabal+executable my-exe+    -- ...+    ghc-options: -rtsopts+    -- ...+```++You can obtain an eventlog by running your binary with the `-l` RTS option.++```sh+my-exe +RTS -l -olmy.eventlog -RTS+```++The `-ol` RTS option controls the output filename. If this is not provided, it defaults to your program's name with the `.eventlog` extension. If you built your program with GHC >=10, you can pass `-l-aI` to generate an eventlog that _only_ contains IPE events.++Your program does not need to run for long to generate IPE events, as these are emitted during RTS initialisation. If your program has a `--version` or `--help` option, that is more than sufficient.++To generate an IPE database, you run `ipedb index` with the eventlog and an output file:++```sh+ipedb index my.eventlog -o my.ipedb+```++Optionally, you can specify the table format with the `--table-format=<fmt>` flag.+The current implementation supports three formats:++- **lsm**: This format creates a _directory_ that contains an `lsm-tree` snapshot. This format is the fastest to write, since it hard links to the runtime database files, but requires that the session root and the target path are on the same filesystem.+- **tar**: This format creates a tar archive of an **lsm** export. This requires copying the database files.+- **tgz**: This format creates a compressed **tar** export. This format is the slowest to write, since it requires compressing the database files, but the it results in significantly smaller files.++The default table format is **tgz**.++#### How to query an IPE database with `ipedb`?++To query an IPE database, you run `ipedb query` with the IPE database and a series of Info Table IDs:++```sh+ipedb query my.ipedb [IPE_ID...]+```++For example, if we create an IPE database from the eventlog in `test/data/oddball.eventlog`, and run `ipedb query` with `0x100000000`, `0x350000050f`, and `0x1e000006c9`, we get:++```+0x100000000: Just (InfoProv {ipName = "I#_Main_1_con_info", ipClosureDesc = 3, ipTyDesc = "Int", ipLabel = "main", ipModule = "Main", ipSrcLoc = SrcLoc {srcFilePath = Just "app/Main.hs", srcRange = Just (Range'MultiLine {line = 13, column = 1, endLine = 16, endColumn = 11})}})+0x350000050f: Just (InfoProv {ipName = "(,)_GHC.Internal.Data.Data_327_con_info", ipClosureDesc = 4, ipTyDesc = "(,)", ipLabel = "gmapMo.k", ipModule = "GHC.Internal.Data.Data", ipSrcLoc = SrcLoc {srcFilePath = Just "libraries/ghc-internal/src/GHC/Internal/Data/Data.hs", srcRange = Just (Range'OneLine {line = 439, column = 30, endColumn = 44})}})+0x1e000006c9: Just (InfoProv {ipName = "block_caBN_info", ipClosureDesc = 53, ipTyDesc = "", ipLabel = "decodeFloat", ipModule = "Data.Complex", ipSrcLoc = SrcLoc {srcFilePath = Just "libraries/ghc-internal/src/GHC/Internal/Float.hs", srcRange = Just (Range'MultiLine {line = 651, column = 5, endLine = 652, endColumn = 52})}})+```++If you wish to list all IPE data in an IPE database, you can run `ipedb list` with the IPE database:++```sh+ipedb list my.ipedb+```++Be warned that this prints _a lot_ of information.++---++### Working with cost-centre data using `ccdb`++#### What is cost-centre data?++_Cost Centres_ are virtual symbols that correspond closely to the Haskell source symbols. A Haskell binary built with [GHC's profiling](https://downloads.haskell.org/ghc/latest/docs/users_guide/profiling.html) maintains a virtual cost-centre stack at runtime. The cost-centre stack contains entries for all functions annotated by the user with a `{-# SCC myFunctionName #-}` pragma or by some annotation strategy (e.g., `-fprof-auto` or `-fprof-late`). The recommended annotation strategy is `-fprof-late`, see [Late Cost Centre Profiling](https://well-typed.com/blog/2023/03/prof-late/).++_Cost Centres_ are useful when analysing heap profiles generated with [`-hc`](https://downloads.haskell.org/ghc/latest/docs/users_guide/profiling.html#profiling-memory-usage) or stack profiles generated by [`-p`](https://downloads.haskell.org/ghc/latest/docs/users_guide/profiling.html#time-and-allocation-profiling), which by themselves only contain Cost Centre IDs.++A cost-centre database is a lookup table from _Cost Centre ID_ to _Cost Centre_. A _Cost Centre ID_ is a stable identifier that can be used to look up the Cost Centre. When building with the GHC option `-fobject-determinism`, the cost-centre data for a binary is deterministic. This means that if `-fobject-determinism` is passed to GHC and the GHC version, package source, and Cabal build plan are all identical, then the generated cost-centre data should be identical.++#### How to build a binary with cost-centre data?++For a detailed overview of how to build a binary with cost-centre data, see [the GHC users guide](https://downloads.haskell.org/ghc/latest/docs/users_guide/profiling.html#cost-centres-and-cost-centre-stacks). At the time of writing, our recommendation is to add the following to your `cabal.project` file to instruct Cabal to build all packages with late cost-centre profiling:++```+profiling: True++package *+    profiling-detail: late+```++#### How to build a cost-centre database with `ccdb`?++The `ccdb` command-line interface follows the same conventions as `ipedb`. Build your binary with cost-centre data and follow the instructions under [How to build an IPE database with `ipedb`?](#how-to-build-an-ipe-database-with-ipedb) using `ccdb` instead of `ipedb`.++#### How to query a cost-centre database with `ccdb`?++The `ccdb` command-line interface follows the same conventions as `ipedb`. Build your binary with cost-centre data and follow the instructions under [How to build an IPE database with `ipedb`?](#how-to-query-an-ipe-database-with-ipedb) using `ccdb` instead of `ipedb`.

@@ -0,0 +1,508 @@+module Main (main) where++import Codec.Compression.GZip qualified as GZip+import Control.Applicative (asum)+import Control.Exception (Exception (..), SomeException)+import Control.Monad (unless)+import Control.Monad.IO.Class (MonadIO (..))+import Data.ByteString qualified as BS+import Data.ByteString.Lazy qualified as BSL+import Data.Default (Default (..))+import Data.Foldable (for_)+import Data.Machine ((~>))+import Data.Machine qualified as M+import Data.Maybe (fromMaybe)+import Data.String (IsString (..))+import Data.Vector qualified as V+import Data.Version qualified as V (showVersion)+import Data.Word (Word32)+import GHC.RTS.Events (Event)+import GHC.RTS.Events.Incremental (Decoder (..), decodeEventLog)+import IpeDB.Database qualified as DB+import IpeDB.Types.CostCentre qualified as CC+import Options.Applicative qualified as O+import Paths_ipedb (version)+import System.Exit (ExitCode (..), exitFailure, exitWith)+import System.IO qualified as IO++main :: IO ()+main = do+  O.execParser ccDBOptionsParserInfo >>= \case+    IndexCommand options -> runIndex options+    QueryCommand options -> runQuery options+    ListCommand options -> runList options+    CheckCommand options -> runCheck options++--------------------------------------------------------------------------------+-- Index++runIndex :: IndexOptions -> IO ()+runIndex IndexOptions{..} = do+  withEventlogSource eventlogSource $ \eventlogSourceHandle -> do+    DB.withNewSession def $ \session ->+      DB.withNewTable @CC.CostCentreId @CC.CostCentre session def $ \table -> do+        M.runT_ $+          fromHandle eventlogEncoding eventlogSourceHandle+            ~> decodeEvent+            ~> DB.indexer CC.toCostCentre def{DB.indexerBufferSize = bufferSize} table+        let saveOptions = def{DB.flatten = fromMaybe (shouldFlatten ccDBTableFormat) ccDBFlatten}+        DB.saveTable saveOptions table ccDBOutputPath ccDBTableFormat++--------------------------------------------------------------------------------+-- Query++runQuery :: QueryOptions -> IO ()+runQuery QueryOptions{..} = do+  DB.withNewSession def $ \session ->+    DB.withTableFrom @CC.CostCentreId @CC.CostCentre session ccDBPath ccDBTableFormat $ \table -> do+      infoProvs <- fmap V.toList . DB.lookups table . V.fromList $ costCentreIds+      for_ (zip costCentreIds infoProvs) $ \(ccId, cc) ->+        putStrLn $ show ccId <> ": " <> show cc++--------------------------------------------------------------------------------+-- List++runList :: ListOptions -> IO ()+runList ListOptions{..} = do+  DB.withNewSession def $ \session ->+    DB.withTableFrom @CC.CostCentreId @CC.CostCentre session ccDBPath ccDBTableFormat $ \table -> do+      DB.withIterator def{DB.iteratorBufferSize = bufferSize} table $ \iterator ->+        M.runT_ $ iterator ~> M.traversing (\(ccId, cc) -> putStrLn $ show ccId <> ": " <> show cc)++--------------------------------------------------------------------------------+-- Check++data MissingCostCentreEntry = MissingCostCentreEntry+  { table1Path :: !FilePath+  , table2Path :: !FilePath+  , costCentreId :: !CC.CostCentreId+  }+  deriving (Show)++instance Exception MissingCostCentreEntry where+  displayException :: MissingCostCentreEntry -> String+  displayException = flip showsException ""+   where+    showsException :: MissingCostCentreEntry -> ShowS+    showsException MissingCostCentreEntry{..} =+      shows costCentreId <> showString ": missing in " <> showString table2Path++data MismatchedCostCentreEntry = MismatchedCostCentreEntry+  { table1Path :: !FilePath+  , table2Path :: !FilePath+  , costCentreId :: !CC.CostCentreId+  , infoProv1 :: !CC.CostCentre+  , infoProv2 :: !CC.CostCentre+  }+  deriving (Show)++instance Exception MismatchedCostCentreEntry where+  displayException :: MismatchedCostCentreEntry -> String+  displayException = flip showsException ""+   where+    showsException :: MismatchedCostCentreEntry -> ShowS+    showsException MismatchedCostCentreEntry{..} =+      shows costCentreId <> showString ": mismatch between " <> showString table1Path <> showString " and " <> showString table2Path++runCheck :: CheckOptions -> IO ()+runCheck CheckOptions{..} = do+  DB.withNewSession def $ \session ->+    DB.withTableFrom @CC.CostCentreId @CC.CostCentre session ccDB1Path ccDB1TableFormat $ \table1 ->+      DB.withTableFrom @CC.CostCentreId @CC.CostCentre session ccDB2Path ccDB2TableFormat $ \table2 -> do+        let runCheck' = \case+              CheckSubset -> checkSubset+              CheckEqual -> checkEqual+        exceptionCount <- runCheck' check (ccDB1Path, table1) (ccDB2Path, table2)+        unless (exceptionCount == 0) $+          exitWith (ExitFailure exceptionCount)+ where+  checkEqual ::+    (FilePath, DB.Table CC.CostCentreId CC.CostCentre) ->+    (FilePath, DB.Table CC.CostCentreId CC.CostCentre) ->+    IO Int+  checkEqual table1Info table2Info = do+    exceptionCount1 <- checkSubset' True table1Info table2Info+    exceptionCount2 <- checkSubset' False table2Info table1Info+    pure (exceptionCount1 + exceptionCount2)++  checkSubset ::+    (FilePath, DB.Table CC.CostCentreId CC.CostCentre) ->+    (FilePath, DB.Table CC.CostCentreId CC.CostCentre) ->+    IO Int+  checkSubset = checkSubset' True++  checkSubset' ::+    Bool ->+    (FilePath, DB.Table CC.CostCentreId CC.CostCentre) ->+    (FilePath, DB.Table CC.CostCentreId CC.CostCentre) ->+    IO Int+  checkSubset' checkPresentAndEqual (table1Path, table1) (table2Path, table2) =+    DB.withIterator def{DB.iteratorBufferSize = bufferSize} table1 $ \iterator1 -> do+      fmap sum . M.runT $+        iterator1+          ~> M.buffered (fromIntegral bufferSize)+          ~> M.traversing resolve+          ~> M.asParts+          ~> M.mapping assertEqual+          ~> M.asParts+          ~> M.traversing (\e -> IO.hPutStr IO.stderr (displayException e) >> pure (1 :: Int))+   where+    resolve :: [(CC.CostCentreId, CC.CostCentre)] -> IO [(CC.CostCentreId, CC.CostCentre, Maybe CC.CostCentre)]+    resolve entries1 = do+      maybeCostCentres2 <- DB.lookups table2 (V.fromList (fst <$> entries1))+      let addToEntry (costCentreId, infoProv1) maybeCostCentre2 = (costCentreId, infoProv1, maybeCostCentre2)+      pure $ zipWith addToEntry entries1 (V.toList maybeCostCentres2)++    assertEqual :: (CC.CostCentreId, CC.CostCentre, Maybe CC.CostCentre) -> Maybe SomeException+    assertEqual (costCentreId, infoProv1, maybeCostCentre2) =+      case maybeCostCentre2 of+        Nothing ->+          Just $ toException MissingCostCentreEntry{..}+        Just infoProv2+          | checkPresentAndEqual && infoProv1 /= infoProv2 ->+              Just $ toException MismatchedCostCentreEntry{..}+          | otherwise -> Nothing++--------------------------------------------------------------------------------+-- Eventlog Processing+--------------------------------------------------------------------------------++{- |+Stream a file as chunks.+-}+fromHandle :: EventlogEncoding -> IO.Handle -> M.SourceT IO BS.ByteString+fromHandle eventlogEncoding h =+  M.MachineT $ do+    chunks <- liftIO (BSL.toChunks . decodeEventlog eventlogEncoding <$> BSL.hGetContents h)+    M.runMachineT $ M.source chunks++{- |+Parse t`Event`s from a stream of `BS.ByteString` chunks.+-}+decodeEvent :: M.Process BS.ByteString Event+decodeEvent = M.construct $ loop decodeEventLog+ where+  loop :: Decoder a -> M.PlanT (M.Is BS.ByteString) a m ()+  loop Done{} = pure ()+  loop (Consume k) = M.await >>= \chunk -> loop (k chunk)+  loop (Produce a d') = M.yield a >> loop d'+  loop (Error _ err) = error err++--------------------------------------------------------------------------------+-- CCDB Options+--------------------------------------------------------------------------------++data CCDBOptions+  = IndexCommand IndexOptions+  | QueryCommand QueryOptions+  | ListCommand ListOptions+  | CheckCommand CheckOptions++ccDBOptionsParserInfo :: O.ParserInfo CCDBOptions+ccDBOptionsParserInfo =+  O.info (ccDBOptionsParser O.<**> O.helper O.<**> ccDBVersioner) . mconcat $+    [ O.progDesc "Build and query cost-centre databases."+    ]++ccDBVersioner :: O.Parser (a -> a)+ccDBVersioner =+  O.simpleVersioner $! "ccdb " <> V.showVersion version++ccDBOptionsParser :: O.Parser CCDBOptions+ccDBOptionsParser =+  O.subparser . mconcat $+    [ O.command "index" (IndexCommand <$> indexOptionsParserInfo)+    , O.command "query" (QueryCommand <$> queryOptionsParserInfo)+    , O.command "list" (ListCommand <$> listOptionsParserInfo)+    , O.command "check" (CheckCommand <$> checkOptionsParserInfo)+    ]++--------------------------------------------------------------------------------+-- Index Options++data IndexOptions = IndexOptions+  { eventlogSource :: EventlogSource+  , eventlogEncoding :: EventlogEncoding+  , ccDBOutputPath :: !FilePath+  , ccDBTableFormat :: !DB.TableFormat+  , ccDBFlatten :: !(Maybe Bool)+  , bufferSize :: !Word32+  }++indexOptionsParserInfo :: O.ParserInfo IndexOptions+indexOptionsParserInfo =+  O.info (indexOptionsParser O.<**> O.helper) . mconcat $+    [ O.progDesc "Build a cost-centre database from an eventlog."+    ]++indexOptionsParser :: O.Parser IndexOptions+indexOptionsParser =+  IndexOptions+    <$> eventlogSourceParser+    <*> eventlogEncodingParser+    <*> ccDBOutputPathParser+    <*> tableFormatParser+    <*> O.optional (ccDBFlattenParser O.<|> ccDBNoFlattenParser)+    <*> indexBufferSizeParser++shouldFlatten :: DB.TableFormat -> Bool+shouldFlatten = \case+  DB.LSMTreeSnapshotV2 -> False+  DB.LSMTreeSnapshotV2Tar -> True+  DB.LSMTreeSnapshotV2TarGz -> True++ccDBFlattenParser :: O.Parser Bool+ccDBFlattenParser =+  O.flag' True . mconcat $+    [ O.long "flatten"+    , O.help "Flatten the lsm-tree database. This improves the speed of lookups. By default, this is disabled for the 'lsm' format and enabled for the 'tar' and 'tgz' formats."+    ]++ccDBNoFlattenParser :: O.Parser Bool+ccDBNoFlattenParser =+  O.flag' False . mconcat $+    [ O.long "no-flatten"+    , O.hidden+    , O.help "Do not flatten the lsm-tree database."+    ]++--------------------------------------------------------------------------------+-- Query Options++data QueryOptions = QueryOptions+  { ccDBPath :: !FilePath+  , ccDBTableFormat :: !DB.TableFormat+  , costCentreIds :: ![CC.CostCentreId]+  }++queryOptionsParserInfo :: O.ParserInfo QueryOptions+queryOptionsParserInfo =+  O.info (queryOptionsParser O.<**> O.helper) . mconcat $+    [ O.progDesc "Query a cost-centre database with cost-centre pointers."+    ]++queryOptionsParser :: O.Parser QueryOptions+queryOptionsParser =+  QueryOptions+    <$> ccDBPathParser+    <*> tableFormatParser+    <*> O.some costCentreIdParser++--------------------------------------------------------------------------------+-- List Options++data ListOptions = ListOptions+  { ccDBPath :: !FilePath+  , ccDBTableFormat :: !DB.TableFormat+  , bufferSize :: !Word32+  }++listOptionsParserInfo :: O.ParserInfo ListOptions+listOptionsParserInfo =+  O.info (listOptionsParser O.<**> O.helper) . mconcat $+    [ O.progDesc "List all cost-centre entries in a cost-centre database."+    ]++listOptionsParser :: O.Parser ListOptions+listOptionsParser =+  ListOptions+    <$> ccDBPathParser+    <*> tableFormatParser+    <*> listBufferSizeParser++--------------------------------------------------------------------------------+-- Check Options++data CheckOptions = CheckOptions+  { check :: !Check+  , ccDB1Path :: !FilePath+  , ccDB1TableFormat :: !DB.TableFormat+  , ccDB2Path :: !FilePath+  , ccDB2TableFormat :: !DB.TableFormat+  , bufferSize :: !Word32+  }++checkOptionsParserInfo :: O.ParserInfo CheckOptions+checkOptionsParserInfo =+  O.info (checkOptionsParser O.<**> O.helper) . mconcat $+    [ O.progDesc "Compare two tables."+    ]++checkOptionsParser :: O.Parser CheckOptions+checkOptionsParser =+  CheckOptions+    <$> checkParser+    <*> ccDBPathParser+    <*> table1FormatParser+    <*> ccDBPathParser+    <*> table2FormatParser+    <*> listBufferSizeParser++data Check+  = CheckSubset+  | CheckEqual++checkParser :: O.Parser Check+checkParser =+  asum+    [ O.flag' CheckSubset . mconcat $+        [ O.long "check-subset"+        , O.help "Check that the first table is a subset of the second table."+        ]+    , O.flag' CheckEqual . mconcat $+        [ O.long "check-equal"+        , O.help "Check that the first table and the second table are equal."+        ]+    , pure CheckEqual+    ]++--------------------------------------------------------------------------------+-- Eventlog Source++data EventlogSource+  = EventlogFromStdin+  | EventlogFromFile {file :: !FilePath}++instance IsString EventlogSource where+  fromString :: String -> EventlogSource+  fromString x = if x == "-" then EventlogFromStdin else EventlogFromFile x++eventlogSourceParser :: O.Parser EventlogSource+eventlogSourceParser =+  O.strArgument . mconcat $+    [ O.metavar "EVENTLOG"+    , O.completer (O.bashCompleter "file")+    ]++withEventlogSource :: EventlogSource -> (IO.Handle -> IO a) -> IO a+withEventlogSource EventlogFromStdin action = do+  stdinIsTerminalDevice <- IO.hIsTerminalDevice IO.stdin+  if stdinIsTerminalDevice+    then do+      putStrLn "Cannot read eventlog from terminal"+      exitFailure+    else do+      IO.hSetBinaryMode IO.stdin True+      action IO.stdin+withEventlogSource EventlogFromFile{..} action =+  IO.withBinaryFile file IO.ReadMode action++--------------------------------------------------------------------------------+-- Eventlog Format++data EventlogEncoding+  = EventlogEncodingNone+  | EventlogEncodingGZip++readEventlogEncoding :: String -> Either String EventlogEncoding+readEventlogEncoding = \case+  "none" -> Right EventlogEncodingNone+  "gzip" -> Right EventlogEncodingGZip+  eventlogEncodingString -> Left $! "Unknown eventlog encoding " <> eventlogEncodingString++eventlogEncodingParser :: O.Parser EventlogEncoding+eventlogEncodingParser =+  O.option (O.eitherReader readEventlogEncoding) . mconcat $+    [ O.short 'e'+    , O.long "eventlog-encoding"+    , O.metavar "FORMAT"+    , O.completeWith ["none", "gzip"]+    , O.help "The eventlog encoding (none, gzip)."+    , O.value EventlogEncodingNone+    ]++decodeEventlog :: EventlogEncoding -> BSL.ByteString -> BSL.ByteString+decodeEventlog = \case+  EventlogEncodingNone -> id+  EventlogEncodingGZip -> GZip.decompress++--------------------------------------------------------------------------------+-- CCDB++ccDBOutputPathParser :: O.Parser FilePath+ccDBOutputPathParser =+  O.strOption . mconcat $+    [ O.short 'o'+    , O.long "output"+    , O.metavar "CCDB_PATH"+    , O.completer (O.bashCompleter "file")+    , O.help "The cost-centre database output path."+    ]++ccDBPathParser :: O.Parser FilePath+ccDBPathParser =+  O.strArgument . mconcat $+    [ O.metavar "CCDB_PATH"+    , O.completer (O.bashCompleter "file")+    ]++--------------------------------------------------------------------------------+-- TableFormat++readTableFormat :: String -> Either String DB.TableFormat+readTableFormat = \case+  "lsm" -> Right DB.LSMTreeSnapshotV2+  "tar" -> Right DB.LSMTreeSnapshotV2Tar+  "tgz" -> Right DB.LSMTreeSnapshotV2TarGz+  tableFormatString -> Left $! "Unknown table format " <> tableFormatString++tableFormatParser :: O.Parser DB.TableFormat+tableFormatParser =+  genericTableFormatParser . mconcat $+    [ O.short 't'+    , O.long "table-format"+    ]++table1FormatParser :: O.Parser DB.TableFormat+table1FormatParser =+  genericTableFormatParser $+    O.long "table1-format"++table2FormatParser :: O.Parser DB.TableFormat+table2FormatParser =+  genericTableFormatParser $+    O.long "table2-format"++genericTableFormatParser :: O.Mod O.OptionFields DB.TableFormat -> O.Parser DB.TableFormat+genericTableFormatParser mods =+  O.option (O.eitherReader readTableFormat) . mconcat $+    [ O.metavar "FORMAT"+    , O.completeWith ["lsm", "tar", "tgz"]+    , O.help "The cost-centre database format (lsm, tar, tgz)."+    , O.value def+    , mods+    ]++--------------------------------------------------------------------------------+-- Buffer Size++indexBufferSizeParser :: O.Parser Word32+indexBufferSizeParser =+  bufferSizeParser . mconcat $+    [ O.help "The size of the index buffer in number of elements."+    , O.value DB.defaultIndexerOptions.indexerBufferSize+    ]++listBufferSizeParser :: O.Parser Word32+listBufferSizeParser =+  bufferSizeParser . mconcat $+    [ O.help "The size of the lookup buffer in number of elements."+    , O.value DB.defaultIteratorOptions.iteratorBufferSize+    ]++bufferSizeParser :: O.Mod O.OptionFields Word32 -> O.Parser Word32+bufferSizeParser mods =+  O.option O.auto . mconcat $+    [ O.long "buffer-size"+    , O.metavar "N"+    , mods+    ]++--------------------------------------------------------------------------------+-- CostCentreId++costCentreIdParser :: O.Parser CC.CostCentreId+costCentreIdParser =+  O.argument O.auto . mconcat $+    [ O.metavar "CCID"+    ]

@@ -0,0 +1,508 @@+module Main (main) where++import Codec.Compression.GZip qualified as GZip+import Control.Applicative (asum)+import Control.Exception (Exception (..), SomeException)+import Control.Monad (unless)+import Control.Monad.IO.Class (MonadIO (..))+import Data.ByteString qualified as BS+import Data.ByteString.Lazy qualified as BSL+import Data.Default (Default (..))+import Data.Foldable (for_)+import Data.Machine ((~>))+import Data.Machine qualified as M+import Data.Maybe (fromMaybe)+import Data.String (IsString (..))+import Data.Vector qualified as V+import Data.Version qualified as V (showVersion)+import Data.Word (Word32)+import GHC.RTS.Events (Event)+import GHC.RTS.Events.Incremental (Decoder (..), decodeEventLog)+import IpeDB.Database qualified as DB+import IpeDB.Types.InfoProv qualified as IP+import Options.Applicative qualified as O+import Paths_ipedb (version)+import System.Exit (ExitCode (..), exitFailure, exitWith)+import System.IO qualified as IO++main :: IO ()+main = do+  O.execParser ipeDBOptionsParserInfo >>= \case+    IndexCommand options -> runIndex options+    QueryCommand options -> runQuery options+    ListCommand options -> runList options+    CheckCommand options -> runCheck options++--------------------------------------------------------------------------------+-- Index++runIndex :: IndexOptions -> IO ()+runIndex IndexOptions{..} = do+  withEventlogSource eventlogSource $ \eventlogSourceHandle -> do+    DB.withNewSession def $ \session ->+      DB.withNewTable @IP.InfoProvId @IP.InfoProv session def $ \table -> do+        M.runT_ $+          fromHandle eventlogEncoding eventlogSourceHandle+            ~> decodeEvent+            ~> DB.indexer IP.toInfoProv def{DB.indexerBufferSize = bufferSize} table+        let saveOptions = def{DB.flatten = fromMaybe (shouldFlatten ipeDBTableFormat) ipeDBFlatten}+        DB.saveTable saveOptions table ipeDBOutputPath ipeDBTableFormat++--------------------------------------------------------------------------------+-- Query++runQuery :: QueryOptions -> IO ()+runQuery QueryOptions{..} = do+  DB.withNewSession def $ \session ->+    DB.withTableFrom @IP.InfoProvId @IP.InfoProv session ipeDBPath ipeDBTableFormat $ \table -> do+      infoProvs <- fmap V.toList . DB.lookups table . V.fromList $ infoProvIds+      for_ (zip infoProvIds infoProvs) $ \(ipId, ip) ->+        putStrLn $ show ipId <> ": " <> show ip++--------------------------------------------------------------------------------+-- List++runList :: ListOptions -> IO ()+runList ListOptions{..} = do+  DB.withNewSession def $ \session ->+    DB.withTableFrom @IP.InfoProvId @IP.InfoProv session ipeDBPath ipeDBTableFormat $ \table -> do+      DB.withIterator def{DB.iteratorBufferSize = bufferSize} table $ \iterator ->+        M.runT_ $ iterator ~> M.traversing (\(ipId, ip) -> putStrLn $ show ipId <> ": " <> show ip)++--------------------------------------------------------------------------------+-- Check++data MissingInfoProvEntry = MissingInfoProvEntry+  { table1Path :: !FilePath+  , table2Path :: !FilePath+  , infoProvId :: !IP.InfoProvId+  }+  deriving (Show)++instance Exception MissingInfoProvEntry where+  displayException :: MissingInfoProvEntry -> String+  displayException = flip showsException ""+   where+    showsException :: MissingInfoProvEntry -> ShowS+    showsException MissingInfoProvEntry{..} =+      shows infoProvId <> showString ": missing in " <> showString table2Path++data MismatchedInfoProvEntry = MismatchedInfoProvEntry+  { table1Path :: !FilePath+  , table2Path :: !FilePath+  , infoProvId :: !IP.InfoProvId+  , infoProv1 :: !IP.InfoProv+  , infoProv2 :: !IP.InfoProv+  }+  deriving (Show)++instance Exception MismatchedInfoProvEntry where+  displayException :: MismatchedInfoProvEntry -> String+  displayException = flip showsException ""+   where+    showsException :: MismatchedInfoProvEntry -> ShowS+    showsException MismatchedInfoProvEntry{..} =+      shows infoProvId <> showString ": mismatch between " <> showString table1Path <> showString " and " <> showString table2Path++runCheck :: CheckOptions -> IO ()+runCheck CheckOptions{..} = do+  DB.withNewSession def $ \session ->+    DB.withTableFrom @IP.InfoProvId @IP.InfoProv session ipeDB1Path ipeDB1TableFormat $ \table1 ->+      DB.withTableFrom @IP.InfoProvId @IP.InfoProv session ipeDB2Path ipeDB2TableFormat $ \table2 -> do+        let runCheck' = \case+              CheckSubset -> checkSubset+              CheckEqual -> checkEqual+        exceptionCount <- runCheck' check (ipeDB1Path, table1) (ipeDB2Path, table2)+        unless (exceptionCount == 0) $+          exitWith (ExitFailure exceptionCount)+ where+  checkEqual ::+    (FilePath, DB.Table IP.InfoProvId IP.InfoProv) ->+    (FilePath, DB.Table IP.InfoProvId IP.InfoProv) ->+    IO Int+  checkEqual table1Info table2Info = do+    exceptionCount1 <- checkSubset' True table1Info table2Info+    exceptionCount2 <- checkSubset' False table2Info table1Info+    pure (exceptionCount1 + exceptionCount2)++  checkSubset ::+    (FilePath, DB.Table IP.InfoProvId IP.InfoProv) ->+    (FilePath, DB.Table IP.InfoProvId IP.InfoProv) ->+    IO Int+  checkSubset = checkSubset' True++  checkSubset' ::+    Bool ->+    (FilePath, DB.Table IP.InfoProvId IP.InfoProv) ->+    (FilePath, DB.Table IP.InfoProvId IP.InfoProv) ->+    IO Int+  checkSubset' checkPresentAndEqual (table1Path, table1) (table2Path, table2) =+    DB.withIterator def{DB.iteratorBufferSize = bufferSize} table1 $ \iterator1 -> do+      fmap sum . M.runT $+        iterator1+          ~> M.buffered (fromIntegral bufferSize)+          ~> M.traversing resolve+          ~> M.asParts+          ~> M.mapping assertEqual+          ~> M.asParts+          ~> M.traversing (\e -> IO.hPutStr IO.stderr (displayException e) >> pure (1 :: Int))+   where+    resolve :: [(IP.InfoProvId, IP.InfoProv)] -> IO [(IP.InfoProvId, IP.InfoProv, Maybe IP.InfoProv)]+    resolve entries1 = do+      maybeInfoProvs2 <- DB.lookups table2 (V.fromList (fst <$> entries1))+      let addToEntry (infoProvId, infoProv1) maybeInfoProv2 = (infoProvId, infoProv1, maybeInfoProv2)+      pure $ zipWith addToEntry entries1 (V.toList maybeInfoProvs2)++    assertEqual :: (IP.InfoProvId, IP.InfoProv, Maybe IP.InfoProv) -> Maybe SomeException+    assertEqual (infoProvId, infoProv1, maybeInfoProv2) =+      case maybeInfoProv2 of+        Nothing ->+          Just $ toException MissingInfoProvEntry{..}+        Just infoProv2+          | checkPresentAndEqual && infoProv1 /= infoProv2 ->+              Just $ toException MismatchedInfoProvEntry{..}+          | otherwise -> Nothing++--------------------------------------------------------------------------------+-- Eventlog Processing+--------------------------------------------------------------------------------++{- |+Stream a file as chunks.+-}+fromHandle :: EventlogEncoding -> IO.Handle -> M.SourceT IO BS.ByteString+fromHandle eventlogEncoding h =+  M.MachineT $ do+    chunks <- liftIO (BSL.toChunks . decodeEventlog eventlogEncoding <$> BSL.hGetContents h)+    M.runMachineT $ M.source chunks++{- |+Parse t`Event`s from a stream of `BS.ByteString` chunks.+-}+decodeEvent :: M.Process BS.ByteString Event+decodeEvent = M.construct $ loop decodeEventLog+ where+  loop :: Decoder a -> M.PlanT (M.Is BS.ByteString) a m ()+  loop Done{} = pure ()+  loop (Consume k) = M.await >>= \chunk -> loop (k chunk)+  loop (Produce a d') = M.yield a >> loop d'+  loop (Error _ err) = error err++--------------------------------------------------------------------------------+-- database Options+--------------------------------------------------------------------------------++data IpeDBOptions+  = IndexCommand IndexOptions+  | QueryCommand QueryOptions+  | ListCommand ListOptions+  | CheckCommand CheckOptions++ipeDBOptionsParserInfo :: O.ParserInfo IpeDBOptions+ipeDBOptionsParserInfo =+  O.info (ipeDBOptionsParser O.<**> O.helper O.<**> ipeDBVersioner) . mconcat $+    [ O.progDesc "Build and query IPE databases."+    ]++ipeDBVersioner :: O.Parser (a -> a)+ipeDBVersioner =+  O.simpleVersioner $! "ipedb " <> V.showVersion version++ipeDBOptionsParser :: O.Parser IpeDBOptions+ipeDBOptionsParser =+  O.subparser . mconcat $+    [ O.command "index" (IndexCommand <$> indexOptionsParserInfo)+    , O.command "query" (QueryCommand <$> queryOptionsParserInfo)+    , O.command "list" (ListCommand <$> listOptionsParserInfo)+    , O.command "check" (CheckCommand <$> checkOptionsParserInfo)+    ]++--------------------------------------------------------------------------------+-- Index Options++data IndexOptions = IndexOptions+  { eventlogSource :: EventlogSource+  , eventlogEncoding :: EventlogEncoding+  , ipeDBOutputPath :: !FilePath+  , ipeDBTableFormat :: !DB.TableFormat+  , ipeDBFlatten :: !(Maybe Bool)+  , bufferSize :: !Word32+  }++indexOptionsParserInfo :: O.ParserInfo IndexOptions+indexOptionsParserInfo =+  O.info (indexOptionsParser O.<**> O.helper) . mconcat $+    [ O.progDesc "Build an IPE database from an eventlog."+    ]++indexOptionsParser :: O.Parser IndexOptions+indexOptionsParser =+  IndexOptions+    <$> eventlogSourceParser+    <*> eventlogEncodingParser+    <*> ipeDBOutputPathParser+    <*> tableFormatParser+    <*> O.optional (ipeDBFlattenParser O.<|> ipeDBNoFlattenParser)+    <*> indexBufferSizeParser++shouldFlatten :: DB.TableFormat -> Bool+shouldFlatten = \case+  DB.LSMTreeSnapshotV2 -> False+  DB.LSMTreeSnapshotV2Tar -> True+  DB.LSMTreeSnapshotV2TarGz -> True++ipeDBFlattenParser :: O.Parser Bool+ipeDBFlattenParser =+  O.flag' True . mconcat $+    [ O.long "flatten"+    , O.help "Flatten the lsm-tree database. This improves the speed of lookups. By default, this is disabled for the 'lsm' format and enabled for the 'tar' and 'tgz' formats."+    ]++ipeDBNoFlattenParser :: O.Parser Bool+ipeDBNoFlattenParser =+  O.flag' False . mconcat $+    [ O.long "no-flatten"+    , O.hidden+    , O.help "Do not flatten the lsm-tree database."+    ]++--------------------------------------------------------------------------------+-- Query Options++data QueryOptions = QueryOptions+  { ipeDBPath :: !FilePath+  , ipeDBTableFormat :: !DB.TableFormat+  , infoProvIds :: ![IP.InfoProvId]+  }++queryOptionsParserInfo :: O.ParserInfo QueryOptions+queryOptionsParserInfo =+  O.info (queryOptionsParser O.<**> O.helper) . mconcat $+    [ O.progDesc "Query an IPE database with IPE pointers."+    ]++queryOptionsParser :: O.Parser QueryOptions+queryOptionsParser =+  QueryOptions+    <$> ipeDBPathParser+    <*> tableFormatParser+    <*> O.some infoProvPtrParser++--------------------------------------------------------------------------------+-- List Options++data ListOptions = ListOptions+  { ipeDBPath :: !FilePath+  , ipeDBTableFormat :: !DB.TableFormat+  , bufferSize :: !Word32+  }++listOptionsParserInfo :: O.ParserInfo ListOptions+listOptionsParserInfo =+  O.info (listOptionsParser O.<**> O.helper) . mconcat $+    [ O.progDesc "List all IPE entries in an IPE database."+    ]++listOptionsParser :: O.Parser ListOptions+listOptionsParser =+  ListOptions+    <$> ipeDBPathParser+    <*> tableFormatParser+    <*> listBufferSizeParser++--------------------------------------------------------------------------------+-- Check Options++data CheckOptions = CheckOptions+  { check :: !Check+  , ipeDB1Path :: !FilePath+  , ipeDB1TableFormat :: !DB.TableFormat+  , ipeDB2Path :: !FilePath+  , ipeDB2TableFormat :: !DB.TableFormat+  , bufferSize :: !Word32+  }++checkOptionsParserInfo :: O.ParserInfo CheckOptions+checkOptionsParserInfo =+  O.info (checkOptionsParser O.<**> O.helper) . mconcat $+    [ O.progDesc "Compare two tables."+    ]++checkOptionsParser :: O.Parser CheckOptions+checkOptionsParser =+  CheckOptions+    <$> checkParser+    <*> ipeDBPathParser+    <*> table1FormatParser+    <*> ipeDBPathParser+    <*> table2FormatParser+    <*> listBufferSizeParser++data Check+  = CheckSubset+  | CheckEqual++checkParser :: O.Parser Check+checkParser =+  asum+    [ O.flag' CheckSubset . mconcat $+        [ O.long "check-subset"+        , O.help "Check that the first table is a subset of the second table."+        ]+    , O.flag' CheckEqual . mconcat $+        [ O.long "check-equal"+        , O.help "Check that the first table and the second table are equal."+        ]+    , pure CheckEqual+    ]++--------------------------------------------------------------------------------+-- Eventlog Source++data EventlogSource+  = EventlogFromStdin+  | EventlogFromFile {file :: !FilePath}++instance IsString EventlogSource where+  fromString :: String -> EventlogSource+  fromString x = if x == "-" then EventlogFromStdin else EventlogFromFile x++eventlogSourceParser :: O.Parser EventlogSource+eventlogSourceParser =+  O.strArgument . mconcat $+    [ O.metavar "EVENTLOG"+    , O.completer (O.bashCompleter "file")+    ]++withEventlogSource :: EventlogSource -> (IO.Handle -> IO a) -> IO a+withEventlogSource EventlogFromStdin action = do+  stdinIsTerminalDevice <- IO.hIsTerminalDevice IO.stdin+  if stdinIsTerminalDevice+    then do+      putStrLn "Cannot read eventlog from terminal"+      exitFailure+    else do+      IO.hSetBinaryMode IO.stdin True+      action IO.stdin+withEventlogSource EventlogFromFile{..} action =+  IO.withBinaryFile file IO.ReadMode action++--------------------------------------------------------------------------------+-- Eventlog Format++data EventlogEncoding+  = EventlogEncodingNone+  | EventlogEncodingGZip++readEventlogEncoding :: String -> Either String EventlogEncoding+readEventlogEncoding = \case+  "none" -> Right EventlogEncodingNone+  "gzip" -> Right EventlogEncodingGZip+  eventlogEncodingString -> Left $! "Unknown eventlog encoding " <> eventlogEncodingString++eventlogEncodingParser :: O.Parser EventlogEncoding+eventlogEncodingParser =+  O.option (O.eitherReader readEventlogEncoding) . mconcat $+    [ O.short 'e'+    , O.long "eventlog-encoding"+    , O.metavar "FORMAT"+    , O.completeWith ["none", "gzip"]+    , O.help "The eventlog encoding (none, gzip)."+    , O.value EventlogEncodingNone+    ]++decodeEventlog :: EventlogEncoding -> BSL.ByteString -> BSL.ByteString+decodeEventlog = \case+  EventlogEncodingNone -> id+  EventlogEncodingGZip -> GZip.decompress++--------------------------------------------------------------------------------+-- database++ipeDBOutputPathParser :: O.Parser FilePath+ipeDBOutputPathParser =+  O.strOption . mconcat $+    [ O.short 'o'+    , O.long "output"+    , O.metavar "IPEDB_PATH"+    , O.completer (O.bashCompleter "file")+    , O.help "The database output path."+    ]++ipeDBPathParser :: O.Parser FilePath+ipeDBPathParser =+  O.strArgument . mconcat $+    [ O.metavar "IPEDB_PATH"+    , O.completer (O.bashCompleter "file")+    ]++--------------------------------------------------------------------------------+-- TableFormat++readTableFormat :: String -> Either String DB.TableFormat+readTableFormat = \case+  "lsm" -> Right DB.LSMTreeSnapshotV2+  "tar" -> Right DB.LSMTreeSnapshotV2Tar+  "tgz" -> Right DB.LSMTreeSnapshotV2TarGz+  tableFormatString -> Left $! "Unknown table format " <> tableFormatString++tableFormatParser :: O.Parser DB.TableFormat+tableFormatParser =+  genericTableFormatParser . mconcat $+    [ O.short 't'+    , O.long "table-format"+    ]++table1FormatParser :: O.Parser DB.TableFormat+table1FormatParser =+  genericTableFormatParser $+    O.long "table1-format"++table2FormatParser :: O.Parser DB.TableFormat+table2FormatParser =+  genericTableFormatParser $+    O.long "table2-format"++genericTableFormatParser :: O.Mod O.OptionFields DB.TableFormat -> O.Parser DB.TableFormat+genericTableFormatParser mods =+  O.option (O.eitherReader readTableFormat) . mconcat $+    [ O.metavar "FORMAT"+    , O.completeWith ["lsm", "tar", "tgz"]+    , O.help "The database table format (lsm, tar, tgz)."+    , O.value def+    , mods+    ]++--------------------------------------------------------------------------------+-- Buffer Size++indexBufferSizeParser :: O.Parser Word32+indexBufferSizeParser =+  bufferSizeParser . mconcat $+    [ O.help "The size of the index buffer in number of elements."+    , O.value DB.defaultIndexerOptions.indexerBufferSize+    ]++listBufferSizeParser :: O.Parser Word32+listBufferSizeParser =+  bufferSizeParser . mconcat $+    [ O.help "The size of the lookup buffer in number of elements."+    , O.value DB.defaultIteratorOptions.iteratorBufferSize+    ]++bufferSizeParser :: O.Mod O.OptionFields Word32 -> O.Parser Word32+bufferSizeParser mods =+  O.option O.auto . mconcat $+    [ O.long "buffer-size"+    , O.metavar "N"+    , mods+    ]++--------------------------------------------------------------------------------+-- InfoProvId++infoProvPtrParser :: O.Parser IP.InfoProvId+infoProvPtrParser =+  O.argument O.auto . mconcat $+    [ O.metavar "IPE_PTR"+    ]

@@ -1,6 +0,0 @@-module Main (main) where--import IpeDb.Main (defaultMain)--main :: IO ()-main = defaultMain

@@ -1,86 +1,168 @@-cabal-version: 3.6+cabal-version: 3.0 name: ipedb-version: 0.1.0.0+version: 0.2.0.0+synopsis: Build databases with IPE data+description: Build databases with IPE data.+homepage: https://github.com/well-typed/ipedb#README license: BSD-3-Clause-author: Hannes Siebenhandl, Matthew Pickering-synopsis: Generate a database for IPE data.-description: Tool and library to index an `.eventlog` file and query IPE data.-maintainer: hannes@well-typed.com-build-type: Simple-extra-doc-files: CHANGELOG.md+license-file: LICENSE+author: Wen Kokke, Matthew Pickering, Hannes Siebenhandl+maintainer: wen@well-typed.com+copyright: (c) 2025-2026 Well-Typed category: Development-tested-with:-  ghc ==9.10.3-  ghc ==9.12.2-  ghc ==9.14.1+build-type: Simple+extra-doc-files:+  CHANGELOG.md+  README.md -extra-source-files:-  test/data/*.eventlog+tested-with: ghc ==9.8.4 || ==9.10.3 || ==9.12.4 || ==9.14.1 -common warnings+source-repository head+  type: git+  location: https://github.com/well-typed/ipedb.git++-- 2026-06-29:+-- This flag should enable switching between leb128 and the vendored copy+-- of the packages.+flag use-leb128+  description: Use leb128 in place of the vendored copy+  default: False+  manual: False++common language   ghc-options:     -Wall+    -Wcompat+    -Widentities+    -Wprepositive-qualified-module+    -Wredundant-constraints+    -Wunticked-promoted-constructors     -Wunused-packages -common defaults-  default-language: GHC2021+  default-language: Haskell2010   default-extensions:     BangPatterns-    DeriveAnyClass+    ConstraintKinds+    DataKinds     DeriveGeneric     DerivingStrategies+    DerivingVia+    DuplicateRecordFields+    FlexibleInstances+    GADTs     GeneralizedNewtypeDeriving+    ImportQualifiedPost+    InstanceSigs     LambdaCase-    NamedFieldPuns     NoFieldSelectors     OverloadedRecordDot+    PatternSynonyms+    RankNTypes+    RecordWildCards+    ScopedTypeVariables+    StandaloneDeriving     TypeApplications+    ViewPatterns  library-  import: warnings, defaults+  import: language+  hs-source-dirs:+    src+    src-internal+   exposed-modules:-    IpeDb.Eventlog.Index-    IpeDb.InfoProv-    IpeDb.Main-    IpeDb.Options-    IpeDb.Query-    IpeDb.Table-    IpeDb.Types+    IpeDB.Database+    IpeDB.Types.CostCentre+    IpeDB.Types.InfoProv+    IpeDB.Types.SrcLoc +  other-modules:+    Data.Binary.Text+   build-depends:-    base >=4.20 && <4.23,-    ghc-events >=0.18 && <0.22,-    optparse-applicative >=0.16.1 && <0.20,-    sqlite-simple ^>=0.4.19.0,-    text ^>=2.1.2,+    base >=4.16 && <4.23,+    binary >=0.8 && <0.9,+    blockio >=0.1 && <0.3,+    bytestring >=0.11 && <0.13,+    data-default >=0.2 && <0.9,+    directory >=1.3 && <1.4,+    filepath >=1.4 && <1.6,+    fs-api >=0.4 && <0.5,+    ghc-events >=0.20 && <0.21,+    hashable >=1.4 && <1.6,+    lsm-tree >=1.1 && <1.2,+    machines >=0.7.4 && <0.8,+    tar >=0.7 && <0.8,+    temporary >=1.1 && <1.4,+    text >=1.2 && <2.2,+    vector >=0.11 && <0.14,+    zlib >=0.7 && <0.8, -  hs-source-dirs: src-  default-language: Haskell2010+  -- 2026-06-29:+  -- This toggles between version 0.1.0.0 of the leb128 package+  -- and a vendored copy of its modules.+  -- and the+  if flag(use-leb128)+    build-depends: leb128 >=0.1 && <0.2+  else+    hs-source-dirs: vendor/leb128-0.1.0.0/src+    other-modules: Codec.LEB128.Generic  executable ipedb-  import: warnings, defaults+  import: language+  hs-source-dirs: app-ipedb   main-is: Main.hs+  other-modules: Paths_ipedb+  autogen-modules: Paths_ipedb   build-depends:-    base >=4.20 && <4.23,+    base >=4.16 && <4.23,+    bytestring >=0.11 && <0.13,+    data-default >=0.2 && <0.9,+    ghc-events >=0.20 && <0.21,     ipedb,+    machines >=0.7.4 && <0.8,+    optparse-applicative >=0.17 && <0.20,+    vector >=0.11 && <0.14,+    zlib >=0.7 && <0.8, -  hs-source-dirs: app-  default-language: Haskell2010+executable ccdb+  import: language+  hs-source-dirs: app-ccdb+  main-is: Main.hs+  other-modules: Paths_ipedb+  autogen-modules: Paths_ipedb+  build-depends:+    base >=4.16 && <4.23,+    bytestring >=0.11 && <0.13,+    data-default >=0.2 && <0.9,+    ghc-events >=0.20 && <0.21,+    ipedb,+    machines >=0.7.4 && <0.8,+    optparse-applicative >=0.17 && <0.20,+    vector >=0.11 && <0.14,+    zlib >=0.7 && <0.8,  test-suite ipedb-test-  import: warnings, defaults+  import: language   type: exitcode-stdio-1.0   hs-source-dirs: test   main-is: Main.hs   build-depends:-    base >=4.20 && <4.23,-    directory >=1.3.8.5 && <1.4,-    filepath >=1.4.300.1 && <1.6,+    base >=4.18 && <4.23,+    directory >=1.2.7 && <1.4,+    filepath >=1 && <1.6,     ipedb,-    tasty ^>=1.5.3,-    tasty-hunit ^>=0.10.2,-    temporary ^>=1.3,+    process >=1.6 && <1.7,+    tasty >=1.5 && <1.6,+    tasty-hunit >=0.10 && <0.11,+    temporary >=1.1 && <1.4, -source-repository head-  type: git-  location: https://github.com/well-typed/ipedb.git+  build-tool-depends:+    ipedb:ccdb,+    ipedb:ipedb,++  other-modules:+    Paths_ipedb++  autogen-modules:+    Paths_ipedb

@@ -0,0 +1,57 @@+module Data.Binary.Text (+  getStringUTF8LEB128,+  putStringUTF8LEB128,+  getTextUTF8LEB128,+  putTextUTF8LEB128,+  getByteStringLEB128,+  putByteStringLEB128,+) where++import Codec.LEB128.Generic (decodeLEB128, encodeLEB128)+import Data.Binary.Get (Get, getByteString, getWord8)+import Data.Binary.Put (Put, putByteString, putWord8)+import Data.ByteString (ByteString)+import Data.ByteString qualified as BS+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Encoding qualified as TE++{- |+Decode `String` from a UTF-8 `ByteString` using a LEB128-encoded length.+-}+getStringUTF8LEB128 :: Get String+getStringUTF8LEB128 = T.unpack <$> getTextUTF8LEB128++{- |+Encode `String` into a UTF-8 `ByteString` using a LEB128-encoded length.+-}+putStringUTF8LEB128 :: String -> Put+putStringUTF8LEB128 = putTextUTF8LEB128 . T.pack++{- |+Decode `Text` from a UTF-8 `ByteString` using a LEB128-encoded length.+-}+getTextUTF8LEB128 :: Get Text+getTextUTF8LEB128 = TE.decodeUtf8 <$> getByteStringLEB128++{- |+Encode `Text` into a UTF-8 `ByteString` using a LEB128-encoded length.+-}+putTextUTF8LEB128 :: Text -> Put+putTextUTF8LEB128 = putByteStringLEB128 . TE.encodeUtf8++{- |+Encode a `ByteString` using a LEB128-encoded length.+-}+getByteStringLEB128 :: Get ByteString+getByteStringLEB128 = do+  n <- decodeLEB128 getWord8+  getByteString n++{- |+Decode a `ByteString` using a LEB128-encoded length.+-}+putByteStringLEB128 :: ByteString -> Put+putByteStringLEB128 bs = do+  encodeLEB128 putWord8 (BS.length bs)+  putByteString bs

@@ -0,0 +1,660 @@+{-# OPTIONS_GHC -Wno-orphans #-}++{- |+Module      : IpeDB.Database+Description : This modules provides a database instance backed by @lsm-tree@.+Stability   : experimental+Portability : portable+-}+module IpeDB.Database (+  -- * Constraints+  Key,+  Value,+  SerialiseVia (..),+  SerialiseViaBinary (..),++  -- * Sessions+  Session,+  SessionOptions (maybeSessionRoot),+  defaultSessionOptions,+  withNewSession,++  -- * Tables+  Table,+  withNewTable,+  inserts,+  lookups,+  insert,+  lookup,++  -- ** Table Options+  TableOptions (..),+  defaultTableOptions,++  -- ** Table Enumerating+  IteratorOptions (iteratorBufferSize),+  defaultIteratorOptions,+  withIterator,++  -- ** Table Indexing+  IndexerOptions (indexerBufferSize),+  defaultIndexerOptions,+  indexer,++  -- ** Table Serialisation+  TargetExistsError (..),+  TableFormat (..),+  defaultTableFormat,+  withTableFrom,+  SaveOptions (flatten),+  defaultSaveOptions,+  saveTable,+) where++import Codec.Archive.Tar qualified as Tar+import Codec.Archive.Tar.Check qualified as Tar+import Codec.Compression.GZip qualified as GZip+import Control.Exception (Exception (..), SomeException (..), bracketOnError, bracket_, catch, throwIO)+import Control.Monad (unless, when)+import Control.Monad.IO.Class (MonadIO (..))+import Data.Binary (Binary)+import Data.Binary qualified as B+import Data.ByteString.Lazy qualified as BSL+import Data.Coerce (Coercible, coerce)+import Data.Default (Default (..))+import Data.Machine ((~>))+import Data.Machine qualified as M+import Data.Maybe (fromJust, fromMaybe)+import Data.Text qualified as T+import Data.Vector (Vector)+import Data.Vector qualified as V+import Data.Void (Void)+import Data.Word (Word32)+import Database.LSMTree qualified as LSMT+import System.Directory qualified as SD+import System.FS.API.Strict qualified as FS+import System.FS.BlockIO.IO qualified as BIO+import System.FilePath qualified as SF+import System.IO.Temp (withSystemTempDirectory, withTempDirectory)+import Prelude hiding (lookup)++--------------------------------------------------------------------------------+-- Constraints+--------------------------------------------------------------------------------++{- |+The constraints needed to use a type as key in a t`Table`.++The types t`SerialiseVia` or t`SerialiseViaBinary` provide default instances.+-}+type Key k = LSMT.SerialiseKey k++{- |+The constraints needed to use a type as value in a t`Table`.++The types t`SerialiseVia` or t`SerialiseViaBinary` provide default instances.+-}+type Value v = (LSMT.SerialiseValue v, LSMT.ResolveValue v)++--------------------------------------------------------------------------------+-- Deriving Via Newtype++{- |+Wrapper that derives the constraints required by the database backend via `Coercible`.+-}+newtype SerialiseVia v u = SerialiseVia {value :: v}++--------------------------------------------------------------------------------+-- Key Via Newtype++instance (Coercible v u, LSMT.SerialiseKey u) => LSMT.SerialiseKey (SerialiseVia v u) where+  serialiseKey :: SerialiseVia v u -> LSMT.RawBytes+  serialiseKey = LSMT.serialiseKey . coerce @v @u . (.value)++  deserialiseKey :: LSMT.RawBytes -> SerialiseVia v u+  deserialiseKey = SerialiseVia . coerce @u @v . LSMT.deserialiseKey++--------------------------------------------------------------------------------+-- Value Via Newtype++instance (Coercible v u, LSMT.SerialiseValue u) => LSMT.SerialiseValue (SerialiseVia v u) where+  serialiseValue :: SerialiseVia v u -> LSMT.RawBytes+  serialiseValue = LSMT.serialiseValue . coerce @_ @u++  deserialiseValue :: LSMT.RawBytes -> SerialiseVia v u+  deserialiseValue = coerce @u @_ . LSMT.deserialiseValue++deriving via LSMT.ResolveAsFirst (SerialiseVia v u) instance LSMT.ResolveValue (SerialiseVia v u)++--------------------------------------------------------------------------------+-- Deriving Via Binary++{- |+Wrapper that derives the constraints required by the database backend via a `Binary` instance.+-}+newtype SerialiseViaBinary v = SerialiseViaBinary {value :: v}++--------------------------------------------------------------------------------+-- Key Via Binary++-- instance (Binary v) => Key (SerialiseViaBinary v)++instance (Binary v) => LSMT.SerialiseKey (SerialiseViaBinary v) where+  serialiseKey :: SerialiseViaBinary v -> LSMT.RawBytes+  serialiseKey = LSMT.serialiseKey . B.encode . (.value)++  deserialiseKey :: LSMT.RawBytes -> SerialiseViaBinary v+  deserialiseKey = SerialiseViaBinary . B.decode . LSMT.deserialiseKey++--------------------------------------------------------------------------------+-- Value Via Binary++instance (Binary v) => LSMT.SerialiseValue (SerialiseViaBinary v) where+  serialiseValue :: SerialiseViaBinary v -> LSMT.RawBytes+  serialiseValue = LSMT.serialiseValue . B.encode . (.value)++  deserialiseValue :: LSMT.RawBytes -> SerialiseViaBinary v+  deserialiseValue = SerialiseViaBinary . B.decode . LSMT.deserialiseValue++deriving via LSMT.ResolveAsFirst (SerialiseViaBinary v) instance LSMT.ResolveValue (SerialiseViaBinary v)++--------------------------------------------------------------------------------+-- Sessions+--------------------------------------------------------------------------------++{- |+Representation of database sessions.+-}+data Session+  = Session+  { mountPoint :: FS.MountPoint+  , sessionRoot :: FS.FsPath+  , session :: LSMT.Session IO+  }++{- |+The options for database sessions.+-}+newtype SessionOptions+  = SessionOptions+  { maybeSessionRoot :: Maybe FilePath+  }++{- |+The default database session options.+-}+defaultSessionOptions :: SessionOptions+defaultSessionOptions =+  SessionOptions+    { maybeSessionRoot = Nothing+    }++instance Default SessionOptions where+  def :: SessionOptions+  def = defaultSessionOptions++{- |+Run an action with a new session.+-}+withNewSession ::+  SessionOptions ->+  (Session -> IO r) ->+  IO r+withNewSession SessionOptions{..} action = do+  -- Create a temporary directory for the database session.+  let withSessionDir :: (FilePath -> IO a) -> IO a+      withSessionDir = case maybeSessionRoot of+        Nothing -> withSystemTempDirectory "eventlog-live"+        Just sessionRoot -> withTempDirectory sessionRoot "eventlog-live"+  withSessionDir $ \sessionRoot -> do+    -- Create the LSM Tree session.+    !sessionAbsRoot <- SD.makeAbsolute sessionRoot+    let (!mountPointPath, !sessionRelRoot) = SF.splitDrive sessionAbsRoot+    let !mountPoint = FS.MountPoint mountPointPath+    let !sessionRelRootDirs = SF.splitDirectories sessionRelRoot+    let !sessionRootFsPath = FS.mkFsPath sessionRelRootDirs+    let !sessionDirFsPath = sessionRootFsPath FS.</> FS.mkFsPath ["session"]+    BIO.withIOHasBlockIO mountPoint BIO.defaultIOCtxParams $ \hasFS hasBlockIO -> do+      -- Create the session directory.+      FS.createDirectoryIfMissing hasFS True sessionDirFsPath+      -- Create the LSM Tree session.+      let sessionSalt = 0+      LSMT.withNewSession mempty hasFS hasBlockIO sessionSalt sessionDirFsPath $ \session ->+        -- Run the action with the session.+        action Session{sessionRoot = sessionRootFsPath, ..}++--------------------------------------------------------------------------------+-- Tables+--------------------------------------------------------------------------------++{- |+A table.++Use `withNewTable`, `withNewTable`, or `withTableFrom` to construct a table.+-}+data Table k v+  = Table+  { session :: !Session+  , table :: !(LSMT.Table IO k v Void)+  }++{- |+Options for `withNewTable`. These can be used for performance tuning.+-}+newtype TableOptions+  = -- | See the @lsm-tree@ documentation for `LSMT.TableConfig`.+    TableOptions+    { tableConfig :: LSMT.TableConfig+    }++{- |+The default options for `withNewTable`.+-}+defaultTableOptions :: TableOptions+defaultTableOptions =+  TableOptions+    { tableConfig = LSMT.defaultTableConfig+    }++instance Default TableOptions where+  def :: TableOptions+  def = defaultTableOptions++{- |+Run an action with a new table.+-}+withNewTable ::+  forall k v a.+  Session ->+  TableOptions ->+  (Table k v -> IO a) ->+  IO a+withNewTable session (TableOptions config) action = do+  -- Create a new LSM Tree table.+  LSMT.withTableWith config session.session $ \table ->+    -- Run the action.+    action Table{..}++{- |+Insert entries into a table.+-}+inserts ::+  (Key k, Value v) =>+  Table k v -> Vector (k, v) -> IO ()+inserts Table{..} =+  LSMT.inserts table . fmap (\(k, v) -> (k, v, Nothing))++{- |+Lookup entries from a table.+-}+lookups ::+  (Key k, Value v) =>+  Table k v -> Vector k -> IO (Vector (Maybe v))+lookups Table{..} =+  fmap (fmap LSMT.getValue) . LSMT.lookups table++{- |+Insert entries into a table.+-}+insert ::+  (Key k, Value v) =>+  Table k v -> k -> v -> IO ()+insert Table{..} k v =+  LSMT.insert table k v Nothing++{- |+Lookup one entry from a table.+-}+lookup ::+  (Key k, Value v) =>+  Table k v ->+  k ->+  IO (Maybe v)+lookup Table{..} =+  fmap LSMT.getValue . LSMT.lookup table++--------------------------------------------------------------------------------+-- Enumerating++{- |+The options for `withIterator`.++[`iteratorBufferSize` :: `Word32`]:+  The size of the elems buffer in number of elements.+  The default is 10.+-}+newtype IteratorOptions = IteratorOptions+  { iteratorBufferSize :: Word32+  }++{- |+The default options for `withIterator`.+-}+defaultIteratorOptions :: IteratorOptions+defaultIteratorOptions =+  IteratorOptions{iteratorBufferSize = 10}++instance Default IteratorOptions where+  def :: IteratorOptions+  def = defaultIteratorOptions++{- |+Stream entries from a table.+-}+withIterator ::+  (Key k, Value v) =>+  IteratorOptions ->+  Table k v ->+  (M.SourceT IO (k, v) -> IO a) ->+  IO a+withIterator options Table{..} action = do+  LSMT.withCursor table $ \cursor ->+    action $ M.MachineT $ do+      -- The plan for a source that repeatedly queries the cursor.+      let entrySourcePlan = do+            let n = fromIntegral options.iteratorBufferSize+            xs <- liftIO (LSMT.take n cursor)+            M.yield xs+            unless (V.length xs < n) entrySourcePlan++      -- Helper to convert LSMT.Entry to a key-value pair.+      let toKeyValue e = (LSMT.getEntryKey e, LSMT.getEntryValue e)++      M.runMachineT $+        M.construct entrySourcePlan ~> M.asParts ~> M.mapping toKeyValue++--------------------------------------------------------------------------------+-- Indexing++{- |+The options for `indexer`.++[`indexerBufferSize` :: `Word32`]:+  The size of the index buffer in number of elements.+  The default is 10.+-}+newtype IndexerOptions = IndexerOptions+  { indexerBufferSize :: Word32+  }++{- |+The default options for `indexer`.+-}+defaultIndexerOptions :: IndexerOptions+defaultIndexerOptions =+  IndexerOptions{indexerBufferSize = 10}++instance Default IndexerOptions where+  def :: IndexerOptions+  def = defaultIndexerOptions++{- |+Index data from a GHC event stream.+-}+indexer ::+  (Key k, Value v) =>+  (e -> Maybe (k, v)) ->+  IndexerOptions ->+  Table k v ->+  M.ProcessT IO e Void+indexer extractKV options table =+  M.mapping extractKV+    ~> M.asParts+    ~> M.buffered (fromIntegral options.indexerBufferSize)+    ~> M.mapping V.fromList+    ~> M.repeatedly (M.await >>= liftIO . inserts table)++--------------------------------------------------------------------------------+-- Serialisation+--------------------------------------------------------------------------------++{- |+The table serialisation formats.+-}+data TableFormat+  = {- |+    This format creates a /directory/ that contains an @lsm-tree@ snapshot.++    This format is the fastest to write, since it hard links to the runtime+    database files, but requires that the session root and the target path+    are on the same filesystem.+    -}+    LSMTreeSnapshotV2+  | {- |+    This format creates a tar archive of an `LSMTreeSnapshotV2` export.++    This requires copying the database files.+    -}+    LSMTreeSnapshotV2Tar+  | {- |+    This format creates a compressed `LSMTreeSnapshotV2Tar` export.++    This format is the slowest to write, since it requires compressing the+    database files, but the it results in significantly smaller files.+    -}+    LSMTreeSnapshotV2TarGz++{- |+The default table format.+-}+defaultTableFormat :: TableFormat+defaultTableFormat = LSMTreeSnapshotV2TarGz++instance Default TableFormat where+  def :: TableFormat+  def = LSMTreeSnapshotV2TarGz++{- |+Run an action with a table.+-}+withTableFrom ::+  forall k v a.+  (LSMT.ResolveValue v) =>+  Session ->+  FilePath ->+  TableFormat ->+  (Table k v -> IO a) ->+  IO a+withTableFrom session inputRelPath inputFormat action = do+  -- Find the absolute file path to the table.+  inputAbsPath <- SD.makeAbsolute inputRelPath++  -- Load a table in the LSMTreeSnapshotV2 format.+  let loadLSMTreeSnapshotV2 :: IO ()+      loadLSMTreeSnapshotV2 = do+        -- Try to represent the target directory as an FsPath.+        let FS.MountPoint mountPointPath = session.mountPoint+        let !targetFsPath =+              fromMaybe (error $ "Cannot hardlink from " <> inputAbsPath <> "; not under mount point " <> mountPointPath <> ".") $+                FS.fsFromFilePath session.mountPoint inputAbsPath+        -- Export the snapshot.+        let snapshotFsPath = targetFsPath FS.</> FS.mkFsPath [snapshotRelPath]+        LSMT.importSnapshot session.session snapshotName snapshotFsPath++  -- Load a table in the LSMTreeSnapshotV2Tar format.+  let loadLSMTreeSnapshotV2Tar :: (BSL.ByteString -> BSL.ByteString) -> IO ()+      loadLSMTreeSnapshotV2Tar decompress = do+        -- Create temporary @active-import@ directory in the database session root.+        let !sessionRootPath = FS.fsToFilePath session.mountPoint session.sessionRoot+        withTempDirectory sessionRootPath "active-import" $ \importDir -> do+          -- Extract the snapshot to @active-import/$tableName@.+          !importAbsDir <- SD.makeAbsolute importDir+          let !importDirFsPath = fromJust (FS.fsFromFilePath session.mountPoint importAbsDir)+          let !snapshotDirFsPath = importDirFsPath FS.</> FS.mkFsPath [snapshotRelPath]+          tarByteString <- BSL.readFile inputAbsPath+          let tarEntries = Tar.read . decompress $ tarByteString+          let tarCheck entry = SomeException <$> Tar.checkEntrySecurity entry+          Tar.unpackAndCheck tarCheck importAbsDir tarEntries+          -- Import the snapshot from @active-import/$tableName@.+          LSMT.importSnapshot session.session snapshotName snapshotDirFsPath++  -- Load a table based on the inferred table format.+  let loadSnapshot :: IO ()+      loadSnapshot = case inputFormat of+        LSMTreeSnapshotV2 -> loadLSMTreeSnapshotV2+        LSMTreeSnapshotV2Tar -> loadLSMTreeSnapshotV2Tar id+        LSMTreeSnapshotV2TarGz -> loadLSMTreeSnapshotV2Tar GZip.decompress++  -- Load the snapshot.+  bracketOnError loadSnapshot (const $ deleteSnapshot session.session) $ \() ->+    -- Open the table from the snapshot.+    LSMT.withTableFromSnapshot session.session snapshotName snapshotLabel $ \table -> do+      -- Delete the snapshot.+      deleteSnapshot session.session+      -- Run the action.+      action Table{..}++{- |+Flatten an @lsm-tree@ t`Table`.+-}+flattenTable ::+  (Value v) =>+  Table k v ->+  IO (Table k v)+flattenTable Table{..} = do+  table' <- LSMT.union table table+  pure $ Table{table = table', ..}++{- |+Options for `saveTable`.++[`flatten` :: `Bool`]:+  Flatten the table before saving. This requires a number of I\/O operations+  that is linear in the number of entries, but makes subsequent lookups faster.+  The default is `False`.+-}+newtype SaveOptions = SaveOptions+  { flatten :: Bool+  }++{- |+The default options for `saveTable`.+-}+defaultSaveOptions :: SaveOptions+defaultSaveOptions =+  SaveOptions{flatten = False}++instance Default SaveOptions where+  def :: SaveOptions+  def = defaultSaveOptions++{- |+Save a table.++The target path must not already exist.+-}+saveTable ::+  (Value v) =>+  SaveOptions ->+  Table k v ->+  FilePath ->+  TableFormat ->+  IO ()+saveTable options table' targetRelPath targetFormat = do+  -- If the target path already exists, throw a TargetExistsError.+  targetExists <- SD.doesPathExist targetRelPath+  when targetExists . throwIO $ TargetExistsError targetRelPath++  -- Flatten an lsm-tree table, if options.flatten is set.+  table <-+    if options.flatten+      then flattenTable table'+      else pure table'++  -- Export the lsm-tree snapshot by hard linking.+  let saveLSMTreeSnapshotV2 :: IO ()+      saveLSMTreeSnapshotV2 = do+        -- Try to represent the target directory as an FsPath.+        let FS.MountPoint mountPointPath = table.session.mountPoint+        targetAbsPath <- SD.makeAbsolute targetRelPath+        let !targetFsPath =+              fromMaybe (error $ "Cannot hardlink to " <> targetRelPath <> "; not under mount point " <> mountPointPath <> ".") $+                FS.fsFromFilePath table.session.mountPoint targetAbsPath++        -- Manage the target directory.+        let createTarget = SD.createDirectory targetAbsPath+        let removeTarget = SD.removeDirectory targetAbsPath+        -- Export the snapshot.+        bracketOnError createTarget (const removeTarget) . const $ do+          let snapshotFsPath = targetFsPath FS.</> FS.mkFsPath [snapshotRelPath]+          LSMT.exportSnapshot table.session.session snapshotName snapshotFsPath++  -- Export the lsm-tree snapshot by compressing and archiving.+  let saveLSMTreeSnapshotV2Tar :: (BSL.ByteString -> BSL.ByteString) -> IO ()+      saveLSMTreeSnapshotV2Tar compress = do+        -- Create temporary @active-export@ directory in the database session root.+        let !sessionRootPath = FS.fsToFilePath table.session.mountPoint table.session.sessionRoot+        withTempDirectory sessionRootPath "active-export" $ \exportRootDir -> do+          -- Export the snapshot to the temporary @active-export@ directory.+          let !snapshotDir = exportRootDir SF.</> snapshotRelPath+          !snapshotAbsDir <- SD.makeAbsolute snapshotDir+          let !snapshotDirFsPath = fromJust (FS.fsFromFilePath table.session.mountPoint snapshotAbsDir)+          LSMT.exportSnapshot table.session.session snapshotName snapshotDirFsPath+          -- Create the output tar archive.+          BSL.writeFile targetRelPath . compress =<< Tar.write' =<< Tar.pack' exportRootDir [snapshotRelPath]++  bracket_ (saveSnapshot table.table) (deleteSnapshot table.session.session) $+    case targetFormat of+      LSMTreeSnapshotV2 -> saveLSMTreeSnapshotV2+      LSMTreeSnapshotV2Tar -> saveLSMTreeSnapshotV2Tar id+      LSMTreeSnapshotV2TarGz -> saveLSMTreeSnapshotV2Tar GZip.compress++--------------------------------------------------------------------------------+-- Internal Helpers++{- |+Internal helper.++Save an LSM Tree snapshot.+-}+saveSnapshot :: LSMT.Table IO k v Void -> IO ()+saveSnapshot = LSMT.saveSnapshot snapshotName snapshotLabel++{- |+Internal helper.++Delete an LSM Tree snapshot, but ignore any `LSMT.ErrSnapshotDoesNotExist` errors.+-}+deleteSnapshot :: LSMT.Session IO -> IO ()+deleteSnapshot session =+  LSMT.deleteSnapshot session snapshotName+    `catch` \LSMT.ErrSnapshotDoesNotExist{} -> pure ()++{- |+Internal helper.++The relative `FilePath` for the snapshot directory used by all databases.+-}+snapshotRelPath :: FilePath+snapshotRelPath = "data"++{- |+Internal helper.++The `LSMT.SnapshotName` used by all databases.+-}+snapshotName :: LSMT.SnapshotName+snapshotName = LSMT.toSnapshotName snapshotRelPath++{- |+Internal helper.++The `LSMT.SnapshotLabel` used by all databases.+-}+snapshotLabel :: LSMT.SnapshotLabel+snapshotLabel = LSMT.SnapshotLabel (T.pack "ipedb:1")++--------------------------------------------------------------------------------+-- Errors+--------------------------------------------------------------------------------++{- |+This error is raised if the target path already exists.+-}+newtype TargetExistsError = TargetExistsError FilePath+  deriving (Show)++instance Exception TargetExistsError where+  displayException :: TargetExistsError -> String+  displayException (TargetExistsError targetPath) =+    "The file " <> targetPath <> " already exists; refusing to overwrite."

@@ -0,0 +1,116 @@+{-# LANGUAGE OverloadedStrings #-}++{- |+Module      : IpeDb.Types.CostCentre+Description : Representation for GHC cost centres.+Stability   : experimental+Portability : portable+-}+module IpeDB.Types.CostCentre (+  CostCentreId (..),+  CostCentre (..),+  toCostCentre,+) where++import Control.Exception (assert)+import Data.Binary (Binary (..), Get, Put)+import Data.Binary.Text (getTextUTF8LEB128, putTextUTF8LEB128)+import Data.Coerce (coerce)+import Data.Either (fromRight, isRight)+import Data.Hashable (Hashable)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Word (Word32)+import Database.LSMTree qualified as LSMT+import Foreign (toBool)+import Foreign.C.Types (CBool (..))+import GHC.Generics (Generic)+import GHC.RTS.Events (Event)+import GHC.RTS.Events qualified as E+import IpeDB.Database qualified as DB (SerialiseViaBinary (..))+import IpeDB.Types.SrcLoc (SrcLoc (..), parseSrcLoc)+import Numeric (showHex)+import Text.ParserCombinators.ReadP qualified as P+import Text.Read.Lex (readHexP)++{- |+The type of cost-centre IDs.+-}+newtype CostCentreId = CostCentreId+  { value :: Word32+  }+  deriving newtype (Hashable, Num)+  deriving stock (Generic, Eq, Ord)++instance Show CostCentreId where+  showsPrec :: Int -> CostCentreId -> ShowS+  showsPrec _ (CostCentreId ipId) = showString "0x" . showHex ipId++instance Read CostCentreId where+  readsPrec :: Int -> ReadS CostCentreId+  readsPrec _ = P.readP_to_S (CostCentreId <$> (P.string "0x" *> readHexP))++{- |+The type of a cost-centre entry, as produced by the v`GHC.RTS.Events.HeapProfCostCentre` event.+-}+data CostCentre = CostCentre+  { ccLabel :: !Text+  , ccModule :: !Text+  , ccSrcLoc :: !SrcLoc+  , ccIsCAF :: !Bool+  }+  deriving stock (Generic, Eq, Ord, Show, Read)++{- |+Extract a t`CostCentre` from a @ghc-events@ t`Event`.+-}+toCostCentre :: Event -> Maybe (CostCentreId, CostCentre)+toCostCentre ev+  -- If the event is an `E.InfoTableProv` event, process it, and set @started@...+  | E.HeapProfCostCentre{..} <- ev.evSpec = do+      let !ccId = CostCentreId heapProfCostCentreId+      let !ccSrcLocOrError+            | heapProfSrcLoc `elem` ["<built-in>", "<entire-module>"] = Right UnhelpfulSrcLoc+            | otherwise = parseSrcLoc . T.unpack $ heapProfSrcLoc+      assert (isRight ccSrcLocOrError) $ do+        let !cc =+              CostCentre+                { ccLabel = heapProfLabel+                , ccModule = heapProfModule+                , ccSrcLoc = fromRight UnhelpfulSrcLoc ccSrcLocOrError+                , ccIsCAF = toBool (coerce @E.HeapProfFlags @CBool heapProfFlags)+                }+        Just (ccId, cc)+  | otherwise = Nothing++--------------------------------------------------------------------------------+-- Instances for binary serialisation of CostCentre+--------------------------------------------------------------------------------++deriving newtype instance Binary CostCentreId++instance Binary CostCentre where+  get :: Get CostCentre+  get = do+    ccLabel <- getTextUTF8LEB128+    ccModule <- getTextUTF8LEB128+    ccSrcLoc <- get+    ccIsCAF <- get+    pure CostCentre{..}++  put :: CostCentre -> Put+  put CostCentre{..} = do+    putTextUTF8LEB128 ccLabel+    putTextUTF8LEB128 ccModule+    put ccSrcLoc+    put ccIsCAF++--------------------------------------------------------------------------------+-- Instances for lsm-tree serialisation of CostCentre+--------------------------------------------------------------------------------++deriving newtype instance LSMT.SerialiseKey CostCentreId++deriving via DB.SerialiseViaBinary CostCentre instance LSMT.SerialiseValue CostCentre++deriving via LSMT.ResolveAsFirst CostCentre instance LSMT.ResolveValue CostCentre

@@ -0,0 +1,115 @@+{- |+Module      : IpeDB.Types.InfoProv+Description : Representation for GHC info table provenance entries.+Stability   : experimental+Portability : portable+-}+module IpeDB.Types.InfoProv (+  InfoProvId (..),+  InfoProv (..),+  toInfoProv,+) where++import Control.Exception (assert)+import Data.Binary (Binary (..), Get, Put)+import Data.Binary.Text (getTextUTF8LEB128, putTextUTF8LEB128)+import Data.Either (fromRight, isRight)+import Data.Hashable (Hashable)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Word (Word64)+import Database.LSMTree qualified as LSMT+import GHC.Generics (Generic)+import GHC.RTS.Events (Event)+import GHC.RTS.Events qualified as E+import IpeDB.Database qualified as DB (SerialiseViaBinary (..))+import IpeDB.Types.SrcLoc (SrcLoc (..), parseSrcLoc)+import Numeric (showHex)+import Text.ParserCombinators.ReadP qualified as P+import Text.Read.Lex (readHexP)++{- |+The type of info table provenance IDs.+-}+newtype InfoProvId = InfoProvId Word64+  deriving newtype (Hashable, Num)+  deriving stock (Generic, Eq, Ord)++instance Show InfoProvId where+  showsPrec :: Int -> InfoProvId -> ShowS+  showsPrec _ (InfoProvId ipId) = showString "0x" . showHex ipId++instance Read InfoProvId where+  readsPrec :: Int -> ReadS InfoProvId+  readsPrec _ = P.readP_to_S (InfoProvId <$> (P.string "0x" *> readHexP))++{- |+The type of an info table provenance entry, as produced by the v`GHC.RTS.Events.InfoTableProv` event.+-}+data InfoProv = InfoProv+  { ipName :: !Text+  , ipClosureDesc :: !Int+  , ipTyDesc :: !Text+  , ipLabel :: !Text+  , ipModule :: !Text+  , ipSrcLoc :: !SrcLoc+  }+  deriving stock (Generic, Eq, Ord, Show, Read)++{- |+Extract an t`InfoProv` from a @ghc-events@ t`Event`.+-}+toInfoProv :: Event -> Maybe (InfoProvId, InfoProv)+toInfoProv ev+  -- If the event is an `E.InfoTableProv` event, process it, and set @started@...+  | E.InfoTableProv{..} <- ev.evSpec = do+      let !ipId = InfoProvId itInfo+      let !ipSrcLocOrError = parseSrcLoc . T.unpack $ itSrcLoc+      assert (isRight ipSrcLocOrError) $ do+        let !ip =+              InfoProv+                { ipName = itTableName+                , ipClosureDesc = itClosureDesc+                , ipTyDesc = itTyDesc+                , ipLabel = itLabel+                , ipModule = itModule+                , ipSrcLoc = fromRight UnhelpfulSrcLoc ipSrcLocOrError+                }+        Just (ipId, ip)+  | otherwise = Nothing++--------------------------------------------------------------------------------+-- Instances for binary serialisation of InfoProv+--------------------------------------------------------------------------------++deriving newtype instance Binary InfoProvId++instance Binary InfoProv where+  get :: Get InfoProv+  get = do+    ipName <- getTextUTF8LEB128+    ipClosureDesc <- get+    ipTyDesc <- getTextUTF8LEB128+    ipLabel <- getTextUTF8LEB128+    ipModule <- getTextUTF8LEB128+    ipSrcLoc <- get+    pure InfoProv{..}++  put :: InfoProv -> Put+  put InfoProv{..} = do+    putTextUTF8LEB128 ipName+    put ipClosureDesc+    putTextUTF8LEB128 ipTyDesc+    putTextUTF8LEB128 ipLabel+    putTextUTF8LEB128 ipModule+    put ipSrcLoc++--------------------------------------------------------------------------------+-- Instances for lsm-tree serialisation of InfoProv+--------------------------------------------------------------------------------++deriving newtype instance LSMT.SerialiseKey InfoProvId++deriving via DB.SerialiseViaBinary InfoProv instance LSMT.SerialiseValue InfoProv++deriving via LSMT.ResolveAsFirst InfoProv instance LSMT.ResolveValue InfoProv

@@ -0,0 +1,348 @@+{-# LANGUAGE OverloadedStrings #-}++{- |+Module      : IpeDB.Types.SrcLoc+Description : Representation for GHC source locations.+Stability   : experimental+Portability : portable+-}+module IpeDB.Types.SrcLoc (+  SrcLoc (SrcLoc, UnhelpfulSrcLoc, srcFilePath, srcRange),+  ppSrcLoc,+  parseSrcLoc,+  Range (Range, start, end, ..),+  ppRange,+  parseRange,+  Point (..),+) where++import Codec.LEB128.Generic (decodeLEB128, encodeLEB128)+import Data.Binary (Binary (..), Get, Put, getWord8, putWord8)+import Data.Binary.Text (getStringUTF8LEB128, putStringUTF8LEB128)+import Data.Char (isDigit)+import Data.List qualified as L+import Data.Word (Word32)+import GHC.Generics (Generic)+import GHC.Records (HasField (..))+import Text.ParserCombinators.ReadP (ReadP)+import Text.ParserCombinators.ReadP qualified as P++--------------------------------------------------------------------------------+-- Source Locations+--------------------------------------------------------------------------------++{- |+The type of source location information.+-}+data SrcLoc = SrcLoc+  { srcFilePath :: !FilePath+  , srcRange :: !(Maybe Range)+  }+  deriving stock (Generic, Eq, Ord, Show, Read)++{- |+Simple constructor for unhelpful source locations.+-}+pattern UnhelpfulSrcLoc :: SrcLoc+pattern UnhelpfulSrcLoc = SrcLoc "" Nothing++{- |+Pretty-printer for GHC source location information+-}+ppSrcLoc :: SrcLoc -> ShowS+ppSrcLoc SrcLoc{..} =+  showString srcFilePath . showString ":" . maybe mempty ppRange srcRange++{- |+Parser for GHC source location information.+-}+parseSrcLoc :: String -> Either String SrcLoc+parseSrcLoc str0 = parseSrcLocRev (reverse str0)+ where+  parseSrcLocRev :: String -> Either String SrcLoc+  parseSrcLocRev strRev0 = do+    let (maybeSrcRangeRevStr0, strRev1) = span (/= ':') strRev0+    let stripColon = \case (':' : str) -> str; str -> str+    let strRev2 = stripColon strRev1+    case maybeSrcRangeRevStr0 of+      -- If this SrcLoc uses the empty range...+      [] | ":" `L.isPrefixOf` strRev1 -> do+        let srcFilePath = reverse strRev2+        let srcRange = Nothing+        pure SrcLoc{..}+      -- If this SrcLoc uses a multiline range...+      ')' : _ -> do+        let srcFilePath = reverse strRev2+        srcRange <- Just <$> parseRange (reverse maybeSrcRangeRevStr0)+        pure SrcLoc{..}+      -- If this SrcLoc uses a oneline or point range...+      (c : _) | isDigit c -> do+        let (maybeSrcRangeRevStr1, strRev3) = span (/= ':') strRev2+        let srcFilePath = reverse (stripColon strRev3)+        srcRange <- Just <$> parseRange (reverse maybeSrcRangeRevStr1 <> ":" <> reverse maybeSrcRangeRevStr0)+        pure SrcLoc{..}+      -- Otherwise, this SrcLoc has an invalid range...+      _otherwise -> do+        Left "parseSrcLoc: no parse"++--------------------------------------------------------------------------------+-- Source Ranges+--------------------------------------------------------------------------------++{- |+A position in a source file.+-}+data Point+  = Point+  { line :: !Word32+  , column :: !Word32+  }+  deriving stock (Generic, Eq, Ord, Show, Read)++{- |+A range in a source file.+-}+data Range+  = Range'Point+      { line :: !Word32+      , column :: !Word32+      }+  | Range'OneLine+      { line :: !Word32+      , column :: !Word32+      , endColumn :: !Word32+      }+  | Range'MultiLine+      { line :: !Word32+      , column :: !Word32+      , endLine :: !Word32+      , endColumn :: !Word32+      }+  deriving stock (Generic, Eq, Ord, Show, Read)++{- |+Smart constructor for ranges.+-}+toRange :: (Point, Point) -> Range+toRange (start@Point{..}, end)+  | start == end = Range'Point{..}+  | line == end.line = Range'OneLine{endColumn = end.column, ..}+  | otherwise = Range'MultiLine{endLine = end.line, endColumn = end.column, ..}++{- |+Smart destructor for ranges.+-}+fromRange :: Range -> (Point, Point)+fromRange r = (r.start, r.end)++{- |+Smart constructor for ranges.+-}+pattern Range :: Point -> Point -> Range+pattern Range{start, end} <- (fromRange -> (start, end))+  where+    Range start end = toRange (start, end)++{-# COMPLETE Range #-}++{- |+Get the start position of a range.+-}+instance HasField "start" Range Point where+  getField :: Range -> Point+  getField = \case+    Range'Point{..} -> Point{..}+    Range'OneLine{..} -> Point{..}+    Range'MultiLine{..} -> Point{..}++{- |+Get the end position of a range.+-}+instance HasField "end" Range Point where+  getField :: Range -> Point+  getField = \case+    Range'Point{..} -> Point{..}+    Range'OneLine{..} -> Point{column = endColumn, ..}+    Range'MultiLine{..} -> Point{line = endLine, column = endColumn}++instance Semigroup Range where+  (<>) :: Range -> Range -> Range+  r1 <> r2 = Range (r1.start `min` r2.start) (r1.end `max` r2.end)++{- Note [Parsing and Pretty-Printing]+The parser and pretty-printer are based on the following pretty-printer for @RealSrcSpan@ in the GHC source:+https://github.com/ghc/ghc/blob/674858e3fb1b7fe644d7ec5d4b0c6d9f18d7bc51/compiler/GHC/Types/SrcLoc.hs#L752-L774+-}++{- |+Pretty-printer for ranges.+-}+ppRange :: Range -> ShowS+ppRange = \case+  Range'Point{..} ->+    shows line . showString ":" . shows column+  Range'OneLine{..} ->+    shows line . showString ":" . shows column . showString "-" . shows endColumn+  Range{..} ->+    ppPoint start . showString "-" . ppPoint end+ where+  ppPoint :: Point -> ShowS+  ppPoint p =+    showParen True (shows p.line . showString "," . shows p.column)++{- |+Internal helper.++Parser for ranges.+-}+pRange :: ReadP Range+pRange = pRange'MultiLine P.<++ (pRange'OneLine P.+++ pPointRange)+ where+  pRange'MultiLine :: ReadP Range+  pRange'MultiLine = Range <$> pPoint <* P.char '-' <*> pPoint++  pRange'OneLine :: ReadP Range+  pRange'OneLine = Range'OneLine <$> pIndex <* P.char ':' <*> pIndex <* P.char '-' <*> pIndex++  pPointRange :: ReadP Range+  pPointRange = Range'Point <$> pIndex <* P.char ':' <*> pIndex++  pIndex :: ReadP Word32+  pIndex = read <$> P.munch1 isDigit++  pPoint :: ReadP Point+  pPoint = Point <$ P.char '(' <*> pIndex <* P.char ',' <*> pIndex <* P.char ')'++{- |+Parse a source range.+-}+parseRange :: String -> Either String Range+parseRange s =+  case [x | (x, "") <- P.readP_to_S pRange s] of+    [x] -> Right x+    [] -> Left "parseSrcLoc: no parse"+    _ -> Left "parseSrcLoc: ambiguous parse"++--------------------------------------------------------------------------------+-- Instances for binary serialisation of SrcLoc+--------------------------------------------------------------------------------++{- |+Internal helper.++Serialise source location information.+-}+putSrcLoc :: SrcLoc -> Put+putSrcLoc SrcLoc{..} = do+  putStringUTF8LEB128 srcFilePath+  putMaybeRange srcRange++{- |+Internal helper.++Deserialise source location information.+-}+getSrcLoc :: Get SrcLoc+getSrcLoc = do+  srcFilePath <- getStringUTF8LEB128+  srcRange <- getMaybeRange+  pure SrcLoc{..}++instance Binary SrcLoc where+  put :: SrcLoc -> Put+  put = putSrcLoc+  get :: Get SrcLoc+  get = getSrcLoc++--------------------------------------------------------------------------------+-- Instances for binary serialisation of optional ranges+--------------------------------------------------------------------------------++{- |+Internal helper.++Constructor tags for binary serialisation of ranges.+-}+data MaybeRangeTag+  = TagNothing+  | TagJustRange'Point+  | TagJustRange'OneLine+  | TagJustRange'MultiLine++{- |+Internal helper.++Serialise a constructor tag for an optional range.+-}+putMaybeRangeTag :: MaybeRangeTag -> Put+putMaybeRangeTag = \case+  TagNothing -> putWord8 0x01+  TagJustRange'Point -> putWord8 0x02+  TagJustRange'OneLine -> putWord8 0x03+  TagJustRange'MultiLine -> putWord8 0x04++{- |+Internal helper.++Deserialise a constructor tag for an optional range.+-}+getMaybeRangeTag :: Get MaybeRangeTag+getMaybeRangeTag = do+  maybeRangeTag <- getWord8+  case maybeRangeTag of+    0x01 -> pure TagNothing+    0x02 -> pure TagJustRange'Point+    0x03 -> pure TagJustRange'OneLine+    0x04 -> pure TagJustRange'MultiLine+    _otherwise -> fail $ "Unexpected tag " <> show maybeRangeTag++{- |+Internal helper.++Serialise an optional range to binary.+-}+putMaybeRange :: Maybe Range -> Put+putMaybeRange = \case+  Nothing ->+    putMaybeRangeTag TagNothing+  Just Range'Point{..} -> do+    putMaybeRangeTag TagJustRange'Point+    encodeLEB128 putWord8 line+    encodeLEB128 putWord8 column+  Just Range'OneLine{..} -> do+    putMaybeRangeTag TagJustRange'OneLine+    encodeLEB128 putWord8 line+    encodeLEB128 putWord8 column+    encodeLEB128 putWord8 endColumn+  Just Range'MultiLine{..} -> do+    putMaybeRangeTag TagJustRange'MultiLine+    encodeLEB128 putWord8 line+    encodeLEB128 putWord8 column+    encodeLEB128 putWord8 endLine+    encodeLEB128 putWord8 endColumn++{- |+Internal helper.++Deserialise an optional range from binary.+-}+getMaybeRange :: Get (Maybe Range)+getMaybeRange =+  getMaybeRangeTag >>= \case+    TagNothing ->+      pure Nothing+    TagJustRange'Point -> do+      line <- decodeLEB128 getWord8+      column <- decodeLEB128 getWord8+      pure . Just $! Range'Point{..}+    TagJustRange'OneLine -> do+      line <- decodeLEB128 getWord8+      column <- decodeLEB128 getWord8+      endColumn <- decodeLEB128 getWord8+      pure . Just $! Range'OneLine{..}+    TagJustRange'MultiLine -> do+      line <- decodeLEB128 getWord8+      column <- decodeLEB128 getWord8+      endLine <- decodeLEB128 getWord8+      endColumn <- decodeLEB128 getWord8+      pure . Just $! Range'MultiLine{..}

@@ -1,148 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module IpeDb.Eventlog.Index (-  -- * High level API for interacting with the database-  withDatabase,-  generateInfoProvDb,-  findOneInfoProv,-  findAllInfoProvs,--  -- * Low level API for interacting with the database-  setupDb,-  setupTables,-  setupIndexing,-  insertInfoProv,-  upsertInfoProvStrings,--  -- * ghc-events specific helpers-  insertInfoProvData,-)-where--import Data.Foldable (traverse_)-import qualified Database.SQLite.Simple as Sqlite-import Database.SQLite.Simple.Types (Only (..))-import qualified GHC.RTS.Events as GhcEvents-import IpeDb.InfoProv as Ipe-import IpeDb.Table as Table-import Data.Text (Text)-import qualified Data.Text as Text--findOneInfoProv :: Sqlite.Connection -> IpeId -> IO (Maybe InfoProv)-findOneInfoProv conn ipeId = do-  r <- Sqlite.query conn findInfoTableQuery (Only ipeId)-  case r of-    [ipe] -> pure $ Just ipe-    _ -> pure $ Nothing--findAllInfoProvs :: Sqlite.Connection -> IO [InfoProv]-findAllInfoProvs conn = do-  Sqlite.query conn findAllInfoTablesQuery ()--generateInfoProvDb :: Sqlite.Connection -> FilePath -> IO ()-generateInfoProvDb conn fp = do-  setupDb conn-  GhcEvents.readEventLogFromFile fp >>= \case-    Left err -> fail err-    Right (GhcEvents.EventLog _h (GhcEvents.Data es)) -> Sqlite.withExclusiveTransaction conn $ do-      insertInfoProvData conn es--setupDb :: Sqlite.Connection -> IO ()-setupDb conn = do-  Sqlite.withExclusiveTransaction conn $ setupTables conn-  setupIndexing conn--withDatabase :: FilePath -> (Sqlite.Connection -> IO a) -> IO a-withDatabase fp act = Sqlite.withConnection fp $ \conn ->-  act conn---- ------------------------------------------------------------------------------- Low Level Sqlite api--- ------------------------------------------------------------------------------setupTables :: Sqlite.Connection -> IO ()-setupTables conn = do-  Sqlite.execute_ conn dropStringTableStmt-  Sqlite.execute_ conn dropInfoProvTableStmt-  Sqlite.execute_ conn dropInfoProvTableViewStmt-  Sqlite.execute_ conn stringTableStmt-  Sqlite.execute_ conn infoProvTableStmt-  Sqlite.execute_ conn infoProvTableViewStmt--setupIndexing :: Sqlite.Connection -> IO ()-setupIndexing conn = do-  Sqlite.execute_ conn "PRAGMA synchronous = OFF;"-  Sqlite.execute_ conn "PRAGMA journal_mode = OFF;"-  Sqlite.execute_ conn "PRAGMA temp_store = MEMORY;"-  Sqlite.execute_ conn "PRAGMA locking_mode = EXCLUSIVE;"--insertInfoProv :: Sqlite.Connection -> InfoProv -> IO ()-insertInfoProv conn prov = do-  row <- upsertInfoProvStrings conn prov-  _ <- Sqlite.execute conn insertInfoTableQuery row-  pure ()--upsertInfoProvStrings :: Sqlite.Connection -> InfoProv -> IO InfoProvRow-upsertInfoProvStrings conn prov = do-  let-    (srcLocFile, srcLocRange) = splitGhcSrcLoc prov.srcLoc-  Sqlite.executeMany-    conn-    insertOrIgnoreString-    [ Only prov.tableName-    , Only prov.typeDesc-    , Only prov.label-    , Only prov.moduleName-    , Only srcLocFile-    ]-  [(taId, tyId, labelId, modId, srcLocId)] <--    Sqlite.query-      conn-      getIpeStrings-      ( prov.typeDesc-      , prov.label-      , prov.moduleName-      , srcLocFile-      , prov.tableName-      )-  pure-    InfoProvRow-      { Table.infoId = prov.infoId-      , Table.tableName = taId-      , Table.closureDesc = prov.closureDesc-      , Table.typeDesc = tyId-      , Table.label = labelId-      , Table.moduleName = modId-      , Table.srcLoc = srcLocId-      , Table.srcLocRange = srcLocRange-      }--splitGhcSrcLoc :: Text -> (Text, Text)-splitGhcSrcLoc srcLoc = Text.break (== ':') srcLoc---- ------------------------------------------------------------------------------- Eventlog processing--- ------------------------------------------------------------------------------insertInfoProvData :: (Foldable t) => Sqlite.Connection -> t GhcEvents.Event -> IO ()-insertInfoProvData conn es = traverse_ (processIpeEvents conn) es--processIpeEvents :: Sqlite.Connection -> GhcEvents.Event -> IO ()-processIpeEvents conn ev = case eventInfoToInfoProv (GhcEvents.evSpec ev) of-  Nothing -> pure ()-  Just infoProv -> insertInfoProv conn infoProv--eventInfoToInfoProv :: GhcEvents.EventInfo -> Maybe InfoProv-eventInfoToInfoProv ev = case ev of-  it@GhcEvents.InfoTableProv{} ->-    Just-      InfoProv-        { Ipe.infoId = IpeId $ GhcEvents.itInfo it-        , Ipe.tableName = GhcEvents.itTableName it-        , Ipe.closureDesc = fromIntegral $ GhcEvents.itClosureDesc it-        , Ipe.typeDesc = GhcEvents.itTyDesc it-        , Ipe.label = GhcEvents.itLabel it-        , Ipe.moduleName = GhcEvents.itModule it-        , Ipe.srcLoc = GhcEvents.itSrcLoc it-        }-  _ -> Nothing

@@ -1,42 +0,0 @@-module IpeDb.InfoProv (-  InfoProv (..),-  IpeId (..),-  prettyIpeId,-) where--import Data.Int-import Data.Text (Text)-import qualified Data.Text as Text-import Data.Word-import qualified Database.SQLite.Simple as Sqlite-import qualified Database.SQLite.Simple.FromField as Sqlite-import qualified Database.SQLite.Simple.ToField as Sqlite-import GHC.Generics (Generic)-import qualified Numeric--data InfoProv = InfoProv-  { infoId :: !IpeId-  , tableName :: !Text-  , closureDesc :: !Int64-  , typeDesc :: !Text-  , label :: !Text-  , moduleName :: !Text-  , srcLoc :: !Text-  }-  deriving (Show, Eq, Ord, Generic)-  deriving anyclass (Sqlite.FromRow, Sqlite.ToRow)--newtype IpeId = IpeId-  { id :: Word64-  }-  deriving (Eq, Ord)-  deriving newtype (Sqlite.FromField, Sqlite.ToField)--instance Show IpeId where-  show ipeId = "IpeId {id = " <> showAsHex (ipeId.id) <> "}"--showAsHex :: (Integral a) => a -> String-showAsHex n = "0x" <> Numeric.showHex n ""--prettyIpeId :: IpeId -> Text-prettyIpeId = Text.pack . showAsHex . (.id)

@@ -1,33 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module IpeDb.Main (defaultMain) where--import Data.Text (Text)-import qualified Data.Text as Text-import qualified Data.Text.IO as Text-import IpeDb.InfoProv-import qualified IpeDb.Options as Opts-import IpeDb.Query--defaultMain :: IO ()-defaultMain = do-  opts <- Opts.parseOptions-  case opts.command of-    Opts.Query query -> withInfoProvDb opts.databaseFp $ \db -> do-      lookupInfoProv db query.ipeId >>= \case-        Nothing -> Text.putStrLn $ "No Info Prov found for " <> Text.show query.ipeId-        Just prov -> Text.putStrLn $ prettyInfoProv prov-    Opts.Index index -> withInfoProvDb opts.databaseFp $ \db -> do-      populateFromEventlog db index.eventlog--prettyInfoProv :: InfoProv -> Text-prettyInfoProv prov =-  Text.unlines-    [ "Info Table  " <> prettyIpeId prov.infoId-    , "  Table Name:      " <> prov.tableName-    , "  Closure Desc:    " <> Text.show prov.closureDesc-    , "  Type Desc:       " <> prov.typeDesc-    , "  Label:           " <> prov.label-    , "  Modulename:      " <> prov.moduleName-    , "  Source Location: " <> prov.srcLoc-    ]

@@ -1,74 +0,0 @@-module IpeDb.Options (-  Options (..),-  Command (..),-  IndexOptions (..),-  QueryOptions (..),-  parseOptions,-  options,-  commands,-  queryCommand,-  indexCommand,-) where--import IpeDb.InfoProv (IpeId (..))-import Options.Applicative--data Options = Options-  { databaseFp :: FilePath-  , command :: Command-  }-  deriving (Show, Eq, Ord)--data Command-  = Index IndexOptions-  | Query QueryOptions-  deriving (Show, Eq, Ord)--data IndexOptions = IndexOptions-  { eventlog :: FilePath-  }-  deriving (Show, Eq, Ord)--data QueryOptions = QueryOptions-  { ipeId :: IpeId-  }-  deriving (Show, Eq, Ord)--parseOptions :: IO Options-parseOptions = execParser opts- where-  opts =-    info-      (options <**> helper)-      ( fullDesc-          <> progDesc "Index for Info Provenance entries"-          <> header "ipedb - A database for info provenance entries"-      )--options :: Parser Options-options =-  Options-    <$> strArgument-      ( metavar "FILENAME"-          <> help "Database location"-      )-    <*> commands--commands :: Parser Command-commands =-  hsubparser-    ( command "index" (info (Index <$> indexCommand) (progDesc "Add a file to the repository"))-        <> command "query" (info (Query <$> queryCommand) (progDesc "Add a file to the repository"))-    )--queryCommand :: Parser QueryOptions-queryCommand =-  QueryOptions-    <$> ( IpeId-            <$> argument auto (help "Find the info table provenance information for the given key" <> metavar "INT")-        )--indexCommand :: Parser IndexOptions-indexCommand =-  IndexOptions-    <$> strArgument (help "Eventlog location to index" <> metavar "FILENAME")

@@ -1,40 +0,0 @@-module IpeDb.Query (-  withInfoProvDb,-  setupInfoProvDb,-  populateFromEventlog,-  lookupInfoProv,-  insertInfoProv,-  listInfoProvs,-) where--import qualified IpeDb.Eventlog.Index as Index-import IpeDb.InfoProv-import IpeDb.Types---- ------------------------------------------------------------------------------- High Level API--- ------------------------------------------------------------------------------withInfoProvDb :: FilePath -> (InfoProvDb -> IO a) -> IO a-withInfoProvDb fp act =-  Index.withDatabase fp (\conn -> act InfoProvDb{conn})--setupInfoProvDb :: InfoProvDb -> IO ()-setupInfoProvDb db =-  Index.setupDb db.conn--populateFromEventlog :: InfoProvDb -> FilePath -> IO ()-populateFromEventlog db fp =-  Index.generateInfoProvDb db.conn fp--lookupInfoProv :: InfoProvDb -> IpeId -> IO (Maybe InfoProv)-lookupInfoProv db ipeId = do-  Index.findOneInfoProv db.conn ipeId--insertInfoProv :: InfoProvDb -> InfoProv -> IO ()-insertInfoProv db ipe = do-  Index.insertInfoProv db.conn ipe--listInfoProvs :: InfoProvDb -> IO [InfoProv]-listInfoProvs db = do-  Index.findAllInfoProvs db.conn

@@ -1,121 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module IpeDb.Table (-  InfoProvRow (..),-  dropStringTableStmt,-  dropInfoProvTableStmt,-  dropInfoProvTableViewStmt,-  stringTableStmt,-  infoProvTableStmt,-  infoProvTableViewStmt,-  findInfoTableQuery,-  findAllInfoTablesQuery,-  insertInfoTableQuery,-  insertOrIgnoreString,-  getStringEntry,-  getIpeStrings,-) where--import Data.Int-import qualified Database.SQLite.Simple as Sqlite-import IpeDb.InfoProv-import GHC.Generics (Generic)-import Data.Text (Text)--data InfoProvRow = InfoProvRow-  { infoId :: !IpeId-  , tableName :: !Int64-  , closureDesc :: !Int64-  , typeDesc :: !Int64-  , label :: !Int64-  , moduleName :: !Int64-  , srcLoc :: !Int64-  , srcLocRange :: !Text-  }-  deriving (Show, Eq, Ord, Generic)-  deriving anyclass (Sqlite.FromRow, Sqlite.ToRow)--dropStringTableStmt :: Sqlite.Query-dropStringTableStmt = "DROP TABLE IF EXISTS strings;"--dropInfoProvTableStmt :: Sqlite.Query-dropInfoProvTableStmt = "DROP TABLE IF EXISTS info_prov;"--dropInfoProvTableViewStmt :: Sqlite.Query-dropInfoProvTableViewStmt = "DROP VIEW IF EXISTS view_info_prov;"--stringTableStmt :: Sqlite.Query-stringTableStmt =-  "\-  \ CREATE TABLE strings (                        \-  \    id INTEGER PRIMARY KEY,                    \-  \    value TEXT NOT NULL UNIQUE                 \-  \);"--infoProvTableStmt :: Sqlite.Query-infoProvTableStmt =-  "\-  \ CREATE TABLE info_prov (                                \-  \    info_id         INTEGER PRIMARY KEY,                    \-  \    table_name      INTEGER NOT NULL REFERENCES strings(id),\-  \    closure_desc    INTEGER NOT NULL,                       \-  \    type_desc       INTEGER NOT NULL REFERENCES strings(id),\-  \    label           INTEGER NOT NULL REFERENCES strings(id),\-  \    module_name     INTEGER NOT NULL REFERENCES strings(id),\-  \    src_loc         INTEGER NOT NULL REFERENCES strings(id),\-  \    src_loc_range   TEXT NOT NULL                           \-  \);"--infoProvTableViewStmt :: Sqlite.Query-infoProvTableViewStmt =-  "\-  \ CREATE VIEW view_info_prov AS                                  \-  \ SELECT                                                         \-  \   i.info_id,                                                   \-  \   table_name.value AS table_name,                              \-  \   i.closure_desc,                                              \-  \   type_desc.value AS type_desc,                                \-  \   label.value AS label,                                        \-  \   module_name.value AS module_name,                            \-  \   concat(src_loc.value, i.src_loc_range) AS src_loc            \-  \ FROM info_prov i                                               \-  \ JOIN strings AS table_name   ON i.table_name = table_name.id   \-  \ JOIN strings AS type_desc    ON i.type_desc = type_desc.id     \-  \ JOIN strings AS label        ON i.label = label.id             \-  \ JOIN strings AS module_name  ON i.module_name = module_name.id \-  \ JOIN strings AS src_loc      ON i.src_loc = src_loc.id;"--findInfoTableQuery :: Sqlite.Query-findInfoTableQuery = "SELECT * FROM view_info_prov WHERE info_id = ?;"--findAllInfoTablesQuery :: Sqlite.Query-findAllInfoTablesQuery = "SELECT * FROM view_info_prov;"--insertInfoTableQuery :: Sqlite.Query-insertInfoTableQuery =-  "\-  \ INSERT INTO info_prov\-  \   (info_id, table_name, closure_desc, type_desc, label, module_name, src_loc, src_loc_range)\-  \ VALUES (?, ?, ?, ?, ?, ?, ?, ?);"--insertOrIgnoreString :: Sqlite.Query-insertOrIgnoreString = "INSERT OR IGNORE INTO strings(value) VALUES (?);"--getIpeStrings :: Sqlite.Query-getIpeStrings =-  "\-  \ SELECT                                             \-  \   table_name.id AS table_name,                     \-  \   type_desc.id AS type_desc,                       \-  \   label.id AS label,                               \-  \   module_name.id AS module_name,                   \-  \   src_loc.id AS src_loc                            \-  \ FROM strings AS table_name    \-  \ JOIN strings AS type_desc    ON ? = type_desc.value   \-  \ JOIN strings AS label        ON ? = label.value       \-  \ JOIN strings AS module_name  ON ? = module_name.value \-  \ JOIN strings AS src_loc      ON ? = src_loc.value     \-  \  WHERE ? = table_name.value ;"--getStringEntry :: Sqlite.Query-getStringEntry = "SELECT id, value FROM strings WHERE value = ?;"

@@ -1,14 +0,0 @@-module IpeDb.Types-  ( InfoProvDb (..),-  )-where--import qualified Database.SQLite.Simple as Sqlite---- ------------------------------------------------------------------------------- Db type--- ------------------------------------------------------------------------------data InfoProvDb = InfoProvDb-  { conn :: Sqlite.Connection-  }

@@ -2,81 +2,258 @@  module Main (main) where -import IpeDb.InfoProv-import IpeDb.Query qualified as Query-import System.Directory (doesFileExist)-import System.FilePath-import System.IO.Temp-import Test.Tasty-import Test.Tasty.HUnit+import Data.Foldable (for_)+import GHC.Records+import IpeDB.Types.SrcLoc (Range (..), SrcLoc (..), parseRange, parseSrcLoc)+import System.Directory (doesPathExist)+import System.FilePath (replaceExtensions, takeFileName, (</>))+import System.IO.Temp (withSystemTempDirectory)+import System.Process (callProcess, readProcess)+import Test.Tasty (TestName, TestTree, defaultMain, testGroup)+import Test.Tasty.HUnit (assertBool, assertEqual, testCase)  main :: IO ()-main = defaultMain tests+main = do+  defaultMain . testGroup "Tests" $+    [ testGroup "ccdb" $+        let+          -- Test indexing the jumpy-jump eventlog.+          testCCDBIndexJumpyJumpWith tableFormat tableFlatten =+            TestIndexOptions+              { executable = "ccdb"+              , eventlog = dataDir </> "jumpy-jump.eventlog.gz"+              , numEntries = 277+              , checkEntries =+                  [+                    ( "0x2"+                    , "0x2: Just (CostCentre {\+                      \ccLabel = \"jumpyJump0\", \+                      \ccModule = \"Main\", \+                      \ccSrcLoc = SrcLoc {srcFilePath = \"app/Main.hs\", \+                      \srcRange = Just (Range'MultiLine {line = 40, column = 1, endLine = 55, endColumn = 23})}, ccIsCAF = False})\n"+                    )+                  ]+              , ..+              }+         in+          [ testIndexWith (testCCDBIndexJumpyJumpWith "lsm" False)+          , testIndexWith (testCCDBIndexJumpyJumpWith "tar" False)+          , testIndexWith (testCCDBIndexJumpyJumpWith "tgz" False)+          , testIndexWith (testCCDBIndexJumpyJumpWith "lsm" True)+          , testIndexWith (testCCDBIndexJumpyJumpWith "tar" True)+          , testIndexWith (testCCDBIndexJumpyJumpWith "tgz" True)+          ]+    , testGroup "ipedb" $+        let+          -- Test indexing the oddball eventlog.+          testIpeDBIndexOddbalWith tableFormat tableFlatten =+            TestIndexOptions+              { executable = "ipedb"+              , eventlog = dataDir </> "oddball.eventlog.gz"+              , numEntries = 157003+              , checkEntries =+                  [+                    ( "0x100000000"+                    , "0x100000000: Just (InfoProv {\+                      \ipName = \"I#_Main_1_con_info\", \+                      \ipClosureDesc = 3, \+                      \ipTyDesc = \"Int\", \+                      \ipLabel = \"main\", \+                      \ipModule = \"Main\", \+                      \ipSrcLoc = SrcLoc {\+                      \srcFilePath = \"app/Main.hs\", \+                      \srcRange = Just (Range'MultiLine {line = 13, column = 1, endLine = 16, endColumn = 11})}})\n"+                    )+                  ]+              , ..+              }+          -- Test stability of indexing fibber-1 and fibber-2.+          testIpeDBEqualFibber =+            TestEqualOptions+              { executable = "ipedb"+              , eventlog1 = dataDir </> "fibber-1.eventlog.gz"+              , eventlog2 = dataDir </> "fibber-2.eventlog.gz"+              , numEntries = 92073+              , tableFormat = "tgz"+              }+         in+          [ testIndexWith (testIpeDBIndexOddbalWith "lsm" False)+          , testIndexWith (testIpeDBIndexOddbalWith "tar" False)+          , testIndexWith (testIpeDBIndexOddbalWith "tgz" False)+          , testIndexWith (testIpeDBIndexOddbalWith "lsm" True)+          , testIndexWith (testIpeDBIndexOddbalWith "tar" True)+          , testIndexWith (testIpeDBIndexOddbalWith "tgz" True)+          , testEqualWith testIpeDBEqualFibber+          ]+    , testGroup "SrcLoc" $+        [ testSrcLoc str maybeSrcLoc+        | (str, maybeSrcLoc) <- srcLocGolden+        ]+    , testGroup "Range" $+        [ testRange str maybeRange+        | (str, maybeRange) <- rangeGolden+        ]+    ] -testdataDir :: FilePath-testdataDir = "test" </> "data"+--------------------------------------------------------------------------------+-- IpeDB+-------------------------------------------------------------------------------- -tests :: TestTree-tests =-  testGroup-    "ipedb"-    [ integrationTests-    ]+dataDir :: FilePath+dataDir = "test" </> "data" -integrationTests :: TestTree-integrationTests =-  testGroup-    "integration"-    [ testGroup-        "index"-        [ testCase "ipedb.eventlog" $-            withSystemTempDirectory "ipedb" $ \tempDir -> do-              let-                db_loc = tempDir </> "ipedb.db"-                eventlog_log = testdataDir </> "ipedb.eventlog"+-- | Get the database filename from an eventlog filename.+toDatabasePath :: FilePath -> String -> FilePath+toDatabasePath eventlog = replaceExtensions (takeFileName eventlog) -              exists_start <- doesFileExist db_loc-              assertBool "Database must not exist before generating it" (not exists_start)+--------------------------------------------------------------------------------+-- IpeDB Indexer -              Query.withInfoProvDb db_loc $ \db ->-                Query.populateFromEventlog db eventlog_log+data TestIndexOptions = TestIndexOptions+  { executable :: String+  , eventlog :: FilePath+  , tableFormat :: String+  , tableFlatten :: Bool+  , numEntries :: Int+  , checkEntries :: [(String, String)]+  } -              exists <- doesFileExist db_loc-              assertBool "Database exists after generating it" exists-        ]-    , testGroup-        "query"-        [ testCase "can insert and find info prov" $-            withSystemTempDirectory "ipedb" $ \tempDir -> do-              let-                db_loc = tempDir </> "ipedb.db"+instance HasField "testName" TestIndexOptions TestName where+  getField :: TestIndexOptions -> TestName+  getField options =+    options.executable+      <> "["+      <> toDatabasePath options.eventlog options.tableFormat+      <> (if options.tableFlatten then ",flatten" else "")+      <> "]" -              Query.withInfoProvDb db_loc $ \db -> do-                Query.setupInfoProvDb db-                let-                  dummyIpe =-                    InfoProv-                      { infoId = IpeId 0xdeadb33f-                      , tableName = "DummyInfo"-                      , closureDesc = 42-                      , typeDesc = "Dummy"-                      , label = "This is a dummy IPE info"-                      , moduleName = "Dummy"-                      , srcLoc = "Dummy.hs:45"-                      }-                Query.insertInfoProv db dummyIpe-                ipe <- Query.lookupInfoProv db dummyIpe.infoId+testIndexWith :: TestIndexOptions -> TestTree+testIndexWith options =+  testCase options.testName $ do+    withSystemTempDirectory ("ipedb-test-" <> options.testName) $ \tempDir -> do+      let databasePath = tempDir </> toDatabasePath options.eventlog options.tableFormat -                ipe @?= Just dummyIpe-        , testCase "list ipedb.eventlog info provs" $-            withSystemTempDirectory "ipedb" $ \tempDir -> do-              let-                db_loc = tempDir </> "ipedb.db"-                eventlog_log = testdataDir </> "ipedb.eventlog"-              Query.withInfoProvDb db_loc $ \db -> do-                Query.populateFromEventlog db eventlog_log-                info_provs <- Query.listInfoProvs db+      -- Create a database.+      let optFlatten = if options.tableFlatten then "--flatten" else "--no-flatten"+      callProcess options.executable ["index", options.eventlog, "--eventlog-encoding=gzip", "--table-format=" <> options.tableFormat, optFlatten, "--output=" <> databasePath]+      assertBool ("Missing output " <> databasePath) =<< doesPathExist databasePath -                assertBool "There must be at least 500 info provs in the table" (length info_provs > 500)-        ]-    ]+      -- Count the number of entries in the database.+      entries <- readProcess options.executable ["list", databasePath, "--table-format=" <> options.tableFormat] ""+      assertEqual ("Database " <> databasePath <> " contains wrong number of entries.") options.numEntries (length $ lines entries)++      -- Query a particular entry.+      for_ options.checkEntries $ \(entryKey, entry) -> do+        actualEntry <- readProcess options.executable ["query", databasePath, "--table-format=" <> options.tableFormat, entryKey] ""+        assertEqual ("Database " <> databasePath <> " contains wrong entry for 0x100000000.") entry actualEntry++--------------------------------------------------------------------------------+-- IpeDB Stability++data TestEqualOptions = TestEqualOptions+  { executable :: String+  , eventlog1 :: FilePath+  , eventlog2 :: FilePath+  , numEntries :: Int+  , tableFormat :: String+  }++instance HasField "testName" TestEqualOptions TestName where+  getField :: TestEqualOptions -> TestName+  getField options =+    options.executable+      <> "["+      <> toDatabasePath options.eventlog1 options.tableFormat+      <> "="+      <> toDatabasePath options.eventlog2 options.tableFormat+      <> "]"++testEqualWith :: TestEqualOptions -> TestTree+testEqualWith options =+  testCase options.testName $ do+    withSystemTempDirectory ("ipedb-test-" <> options.testName) $ \tempDir -> do+      let databasePath1 = tempDir </> toDatabasePath options.eventlog1 options.tableFormat+      let databasePath2 = tempDir </> toDatabasePath options.eventlog2 options.tableFormat++      -- Create two databases.+      callProcess options.executable ["index", options.eventlog1, "--eventlog-encoding=gzip", "--table-format=" <> options.tableFormat, "--output=" <> databasePath1]+      assertBool ("Missing output " <> databasePath1) =<< doesPathExist databasePath1+      callProcess options.executable ["index", options.eventlog2, "--eventlog-encoding=gzip", "--table-format=" <> options.tableFormat, "--output=" <> databasePath2]+      assertBool ("Missing output " <> databasePath2) =<< doesPathExist databasePath2++      -- Count the number of entries in the first database.+      entries <- readProcess options.executable ["list", databasePath1, "--table-format=" <> options.tableFormat] ""+      assertEqual ("Database " <> databasePath1 <> " contains wrong number of entries.") options.numEntries (length $ lines entries)++      -- Test that the two generated databases are equal.+      callProcess options.executable ["check", databasePath1, databasePath2]++--------------------------------------------------------------------------------+-- SrcLoc+--------------------------------------------------------------------------------++srcLocGolden :: [(String, Maybe SrcLoc)]+srcLocGolden =+  [ -- Empty String+    "" |-> Nothing+  , -- Empty SrcLoc+    ":" |-> Just UnhelpfulSrcLoc+  , -- With srcRange = Nothing+    "/path/to/My/Haskell/Module.hs:"+      |-> Just SrcLoc{srcFilePath = "/path/to/My/Haskell/Module.hs", srcRange = Nothing}+  , "C:\\path\\to\\My\\Haskell\\Module.hs:"+      |-> Just SrcLoc{srcFilePath = "C:\\path\\to\\My\\Haskell\\Module.hs", srcRange = Nothing}+  , "/i/am/sneaky/:/::/:::"+      |-> Just SrcLoc{srcFilePath = "/i/am/sneaky/:/::/::", srcRange = Nothing}+  , -- With srcRange = Just Range'Point{line = 1, column = 256}+    "/path/to/My/Haskell/Module.hs:1:256"+      |-> Just SrcLoc{srcFilePath = "/path/to/My/Haskell/Module.hs", srcRange = Just Range'Point{line = 1, column = 256}}+  , "C:\\path\\to\\My\\Haskell\\Module.hs:1:256"+      |-> Just SrcLoc{srcFilePath = "C:\\path\\to\\My\\Haskell\\Module.hs", srcRange = Just Range'Point{line = 1, column = 256}}+  , "/i/am/sneaky/:/::/:::1:256"+      |-> Just SrcLoc{srcFilePath = "/i/am/sneaky/:/::/::", srcRange = Just Range'Point{line = 1, column = 256}}+  , -- With srcRange = Just Range'OneLine {line = 1, column = 3, endColumn = 256}+    "/path/to/My/Haskell/Module.hs:1:3-256"+      |-> Just SrcLoc{srcFilePath = "/path/to/My/Haskell/Module.hs", srcRange = Just Range'OneLine{line = 1, column = 3, endColumn = 256}}+  , "C:\\path\\to\\My\\Haskell\\Module.hs:1:3-256"+      |-> Just SrcLoc{srcFilePath = "C:\\path\\to\\My\\Haskell\\Module.hs", srcRange = Just Range'OneLine{line = 1, column = 3, endColumn = 256}}+  , "/i/am/sneaky/:/::/:::1:3-256"+      |-> Just SrcLoc{srcFilePath = "/i/am/sneaky/:/::/::", srcRange = Just Range'OneLine{line = 1, column = 3, endColumn = 256}}+  , -- With srcRange = Just Range'MultiLine {line = 1, column = 4, endLine = 3, endColumn = 256}+    "/path/to/My/Haskell/Module.hs:(1,4)-(3,256)"+      |-> Just SrcLoc{srcFilePath = "/path/to/My/Haskell/Module.hs", srcRange = Just Range'MultiLine{line = 1, column = 4, endLine = 3, endColumn = 256}}+  , "C:\\path\\to\\My\\Haskell\\Module.hs:(1,4)-(3,256)"+      |-> Just SrcLoc{srcFilePath = "C:\\path\\to\\My\\Haskell\\Module.hs", srcRange = Just Range'MultiLine{line = 1, column = 4, endLine = 3, endColumn = 256}}+  , "/i/am/sneaky/:/::/:::(1,4)-(3,256)"+      |-> Just SrcLoc{srcFilePath = "/i/am/sneaky/:/::/::", srcRange = Just Range'MultiLine{line = 1, column = 4, endLine = 3, endColumn = 256}}+  ]+ where+  (|->) = (,)++testSrcLoc :: String -> Maybe SrcLoc -> TestTree+testSrcLoc str expect =+  testCase ("parseSrcLoc " <> show str) $ do+    let errMsg = "parseSrcLoc returned incorrect result for '" <> str <> "'"+    let actual = either (const Nothing) Just (parseSrcLoc str)+    assertEqual errMsg expect actual++--------------------------------------------------------------------------------+-- Range+--------------------------------------------------------------------------------++rangeGolden :: [(String, Maybe Range)]+rangeGolden =+  [ "" |-> Nothing+  , "1:256" |-> Just Range'Point{line = 1, column = 256}+  , "1:3-256" |-> Just Range'OneLine{line = 1, column = 3, endColumn = 256}+  , "(1,4)-(3,256)" |-> Just Range'MultiLine{line = 1, column = 4, endLine = 3, endColumn = 256}+  ]+ where+  (|->) = (,)++testRange :: String -> Maybe Range -> TestTree+testRange str expect =+  testCase ("parseRange " <> show str) $ do+    let errMsg = "parseRange returned incorrect result for '" <> str <> "'"+    let actual = either (const Nothing) Just (parseRange str)+    assertEqual errMsg expect actual

file too large to diff

@@ -0,0 +1,91 @@+{- HLINT ignore -}+{- FOURMOLU_DISABLE -}+{- |+    Module      : Codec.LEB128.Generic+    Description : Encode values via (S)LEB128+    Copyright   : (c) Andreas Klebinger 2020+    License     : BSD3+    Maintainer  : Andreas Klebinger+    Portability : GHC >= 7.10++     This module provides a generic interface over the encoding+     and decoding algorithm. It can be instantiated to a wide+     variate of types.++     Instantiations based on bytestring and lists are provided in the+     "Codec.LEB128.List" and "Codec.LEB128.Internal.BS" modules.++     Size checks for inputs or output types are not performed by default.+     However they can be included in the put/get functions if desired.+-}+module Codec.LEB128.Generic (+  encodeLEB128,+  decodeLEB128,+) where++import Data.Bits (Bits (clearBit, setBit, testBit, unsafeShiftL, unsafeShiftR, (.|.)))+import Data.Word (Word8)+import GHC.Exts (inline)++-- 2026-06-16:+-- The LEB128 constraint (present in the actual leb128 package) has been inlined.++{- |+LEB128-encode a unsigned value into a sequence of bytes.++For example to encode a integer into a list of words you might use.++> encodeLEB128 pure :: Integer -> [Word8]++To do the same using a serialization library like bytestrings builder:++> encodeLEB128 (B.word8)++For performance reasons it can be important to make sure @encodeLEB128@+is sufficiently specialized. One way to achieve this is to force inlining+using the @inline@ function from GHC.Magic (defined in the ghc-prim package).+For an efficient example generic over the value type this gives us for lists:++@+   toULEB128 :: (Integral a, Bits a) => a -> [Word8]+   toULEB128 = (inline G.encodeLEB128) pure+@++Results are undefined for negative numbers.+-}+encodeLEB128 :: forall a m. (Monoid m, Integral a, Bits a) => (Word8 -> m) -> a -> m+encodeLEB128 !putWord8 = go+ where+  go !i+    | i <= 127 =+        (inline putWord8) $! (fromIntegral i :: Word8)+    | otherwise =+        -- bit 7 (8th bit) indicates more to come.+        let !byte = (setBit (fromIntegral i) 7)+         in (inline putWord8) byte <> go (i `unsafeShiftR` 7)+{-# INLINE encodeLEB128 #-}++{- |+LEB128-decodes a unsigned value given a monadic way to request bytes.++For example a implementation over a state monad might look like:++> execState . decodeLEB128 getByte++This pattern is used by the bytestring based decoder in this package.+See there for a complete example.+-}+decodeLEB128 :: forall a m. (Monad m, Integral a, Bits a) => m Word8 -> m a+decodeLEB128 getWord8 = go 0 0+ where+  go :: Int -> a -> m a+  go !shift !w = do+    byte <- getWord8+    let !byteVal = fromIntegral (clearBit byte 7)+    let !hasMore = testBit byte 7+    let !val = w .|. (byteVal `unsafeShiftL` shift)+    let !shift' = shift + 7+    if hasMore+      then go shift' val+      else return $! val+{-# INLINE decodeLEB128 #-}