Merge pull request #653 from IntersectMBO/wenkokke/simple

doc: add Database.LSMTree.Simple

Author: wenkokke

lsm-tree.cabal

@@ -286,6 +286,7 @@ library
     Database.LSMTree.Internal.WriteBufferWriter
     Database.LSMTree.Monoidal
     Database.LSMTree.Normal
+    Database.LSMTree.Simple
 
   build-depends:
     , base                    >=4.14      && <4.22

scripts/test-cabal-docspec.sh

@@ -20,7 +20,9 @@ if [ "${SKIP_CABAL_BUILD}" = "" ]; then
     fi
 fi
 cabal-docspec \
+    --extra-package directory \
     --extra-package lsm-tree:prototypes \
-    -XNumericUnderscores \
     -XOverloadedStrings \
-    -XTypeApplications
+    -XNumericUnderscores \
+    -XTypeApplications \
+    -XScopedTypeVariables

src-control/Control/ActionRegistry.hs

@@ -27,6 +27,7 @@ module Control.ActionRegistry (
   , AbortActionRegistryError (..)
   , AbortActionRegistryReason (..)
   , getReasonExitCaseException
+  , mapExceptionWithActionRegistry
     -- * Registering actions #registeringActions#
     -- $registering-actions
   , withRollback
@@ -42,6 +43,8 @@ import           Control.Monad.Primitive
 import           Data.Kind
 import           Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.List.NonEmpty as NE
+import           Data.Maybe (fromMaybe)
+import           Data.Monoid (First (..))
 import           Data.Primitive.MutVar
 
 #ifdef NO_IGNORE_ASSERTS
@@ -408,6 +411,46 @@ runActions = go []
         Left e  -> go (mkActionError e a : es) as
         Right _ -> go es as
 
+{-# SPECIALISE mapExceptionWithActionRegistry ::
+     (Exception e1, Exception e2)
+  => (e1 -> e2)
+  -> IO a
+  -> IO a #-}
+-- | As 'Control.Exception.mapException', but aware of the structure of
+--   'AbortActionRegistryError' and 'CommitActionRegistryError'.
+mapExceptionWithActionRegistry ::
+     (Exception e1, Exception e2, MonadCatch m)
+  => (e1 -> e2)
+  -> m a
+  -> m a
+mapExceptionWithActionRegistry f action = action `catch` (throwIO . mapSomeException)
+  where
+    -- TODO: This erases the `ExceptionContext` of the underlying exception.
+    --       Unfortunately, the API exposed by `io-classes` does not currently
+    --       have the primitives to preserve the `ExceptionContext`.
+    mapSomeException :: SomeException -> SomeException
+    mapSomeException e =
+      fromMaybe e . getFirst . mconcat . fmap First $
+        [ toException . f <$> fromException e
+        , toException . mapAbortActionRegistryError <$> fromException e
+        , toException . mapCommitActionRegistryError <$> fromException e
+        ]
+
+    mapAbortActionRegistryError :: AbortActionRegistryError -> AbortActionRegistryError
+    mapAbortActionRegistryError = \case
+      AbortActionRegistryError reason es ->
+        AbortActionRegistryError (mapAbortActionRegistryReason reason) (mapActionError mapSomeException <$> es)
+
+    mapAbortActionRegistryReason :: AbortActionRegistryReason -> AbortActionRegistryReason
+    mapAbortActionRegistryReason = \case
+      ReasonExitCaseException e -> ReasonExitCaseException (mapSomeException e)
+      ReasonExitCaseAbort -> ReasonExitCaseAbort
+
+    mapCommitActionRegistryError :: CommitActionRegistryError -> CommitActionRegistryError
+    mapCommitActionRegistryError = \case
+      CommitActionRegistryError es ->
+        CommitActionRegistryError (mapActionError mapSomeException <$> es)
+
 {-------------------------------------------------------------------------------
   Registering actions
 -------------------------------------------------------------------------------}

src/Database/LSMTree/Internal.hs

@@ -111,8 +111,7 @@ import           Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.List.NonEmpty as NE
 import           Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
-import           Data.Maybe (catMaybes, fromMaybe, maybeToList)
-import           Data.Monoid (First (..))
+import           Data.Maybe (catMaybes, maybeToList)
 import qualified Data.Set as Set
 import           Data.Typeable
 import qualified Data.Vector as V
@@ -1408,45 +1407,8 @@ wrapFileCorruptedErrorAsSnapshotCorruptedError ::
     => SnapshotName
     -> m a
     -> m a
-wrapFileCorruptedErrorAsSnapshotCorruptedError snapshotName action =
-    action `catches` handlers
-    where
-        handlers :: [Handler m a]
-        handlers =
-            [ Handler $ throwIO . wrapFileCorruptedError
-            , Handler $ throwIO . wrapAbortActionRegistryError
-            , Handler $ throwIO . wrapCommitActionRegistryError
-            ]
-
-        -- TODO: This erases the `ExceptionContext` of the underlying `FileCorruptedError`,
-        --       `AbortActionRegistryError`, or `CommitActionRegistryError`.
-        --       Unfortunately, the API exposed by `io-classes` does not currently expose
-        --       any primitives that could be used to preserve the `ExceptionContext`.
-        wrapSomeException :: SomeException -> SomeException
-        wrapSomeException e =
-            fromMaybe e . getFirst . mconcat . fmap First $
-                [ toException . wrapFileCorruptedError <$> fromException e
-                , toException . wrapAbortActionRegistryError <$> fromException e
-                , toException . wrapCommitActionRegistryError <$> fromException e
-                ]
-
-        wrapFileCorruptedError :: FileCorruptedError -> SnapshotCorruptedError
-        wrapFileCorruptedError = ErrSnapshotCorrupted snapshotName
-
-        wrapAbortActionRegistryError :: AbortActionRegistryError -> AbortActionRegistryError
-        wrapAbortActionRegistryError = \case
-            AbortActionRegistryError reason es ->
-                AbortActionRegistryError (wrapAbortActionRegistryReason reason) (mapActionError wrapSomeException <$> es)
-
-        wrapAbortActionRegistryReason :: AbortActionRegistryReason -> AbortActionRegistryReason
-        wrapAbortActionRegistryReason = \case
-            ReasonExitCaseException e -> ReasonExitCaseException (wrapSomeException e)
-            ReasonExitCaseAbort -> ReasonExitCaseAbort
-
-        wrapCommitActionRegistryError :: CommitActionRegistryError -> CommitActionRegistryError
-        wrapCommitActionRegistryError = \case
-            CommitActionRegistryError es ->
-                CommitActionRegistryError (mapActionError wrapSomeException <$> es)
+wrapFileCorruptedErrorAsSnapshotCorruptedError snapshotName =
+    mapExceptionWithActionRegistry (ErrSnapshotCorrupted snapshotName)
 
 {-# SPECIALISE doesSnapshotExist ::
      Session IO h

src/Database/LSMTree/Internal/Snapshot.hs

@@ -95,13 +95,18 @@ newtype SnapshotLabel = SnapshotLabel Text
   deriving newtype (NFData, IsString)
 
 -- TODO: revisit if we need three table types.
-data SnapshotTableType = SnapNormalTable | SnapMonoidalTable | SnapFullTable
+data SnapshotTableType
+  = SnapSimpleTable
+  | SnapFullTable
+  | SnapNormalTable
+  | SnapMonoidalTable
   deriving stock (Eq, Show)
 
 instance NFData SnapshotTableType where
+  rnf SnapSimpleTable   = ()
+  rnf SnapFullTable     = ()
   rnf SnapNormalTable   = ()
   rnf SnapMonoidalTable = ()
-  rnf SnapFullTable     = ()
 
 data SnapshotMetaData = SnapshotMetaData {
     -- | See 'SnapshotLabel'.

src/Database/LSMTree/Internal/Snapshot/Codec.hs

@@ -247,17 +247,19 @@ instance DecodeVersioned SnapshotLabel where
 -- TableType
 
 instance Encode SnapshotTableType where
-  encode SnapNormalTable   = encodeWord 0
-  encode SnapMonoidalTable = encodeWord 1
-  encode SnapFullTable     = encodeWord 2
+  encode SnapSimpleTable   = encodeWord 0
+  encode SnapFullTable     = encodeWord 1
+  encode SnapNormalTable   = encodeWord 2
+  encode SnapMonoidalTable = encodeWord 3
 
 instance DecodeVersioned SnapshotTableType where
   decodeVersioned V0 = do
       tag <- decodeWord
       case tag of
-        0 -> pure SnapNormalTable
-        1 -> pure SnapMonoidalTable
-        2 -> pure SnapFullTable
+        0 -> pure SnapSimpleTable
+        1 -> pure SnapFullTable
+        2 -> pure SnapNormalTable
+        3 -> pure SnapMonoidalTable
         _ -> fail ("[SnapshotTableType] Unexpected tag: " <> show tag)
 
 instance Encode SnapshotRun where