Skip to content

Commit 5e72f1f

Browse files
wenkokkewenkokke
authored
Merge pull request #637 from IntersectMBO/wenkokke/LSMTreeError
refactor: organize error types
2 parents c16c3aa + 797c864 commit 5e72f1f

File tree

17 files changed

+688
-431
lines changed

17 files changed

+688
-431
lines changed

‎src-control/Control/ActionRegistry.hs‎

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -18,6 +18,7 @@ module Control.ActionRegistry (
1818
, ActionRegistry
1919
, ActionError
2020
, getActionError
21+
, mapActionError
2122
-- * Runners
2223
, withActionRegistry
2324
, unsafeNewActionRegistry
@@ -227,6 +228,7 @@ type ActionError :: Type
227228
mkAction :: HasCallStackIfDebug => m () -> Action m
228229
mkActionError :: SomeException -> Action m -> ActionError
229230
getActionError :: ActionError -> SomeException
231+
mapActionError :: (SomeException -> SomeException) -> ActionError -> ActionError
230232

231233
#ifdef NO_IGNORE_ASSERTS
232234
data Action m = Action {
@@ -251,6 +253,8 @@ mkAction a = Action a callStack
251253
mkActionError e a = ActionError e (actionCallStack a)
252254

253255
getActionError (ActionError e _) = e
256+
257+
mapActionError f (ActionError e s) = ActionError (f e) s
254258
#else
255259
newtype Action m = Action {
256260
runAction :: m ()
@@ -265,6 +269,8 @@ mkAction a = Action a
265269
mkActionError e _ = ActionError e
266270

267271
getActionError (ActionError e) = e
272+
273+
mapActionError f (ActionError e) = ActionError (f e)
268274
#endif
269275

270276
{-------------------------------------------------------------------------------

‎src/Database/LSMTree.hs‎

Lines changed: 27 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -9,7 +9,22 @@
99
-- Until then, the documentation on definitions in this module is omitted.
1010
module Database.LSMTree (
1111
-- * Exceptions
12-
Common.LSMTreeError (..)
12+
Common.SessionDirDoesNotExistError (..)
13+
, Common.SessionDirLockedError (..)
14+
, Common.SessionDirCorruptedError (..)
15+
, Common.SessionClosedError (..)
16+
, Common.TableClosedError (..)
17+
, Common.TableCorruptedError (..)
18+
, Common.TableTooLargeError (..)
19+
, Common.TableNotCompatibleError (..)
20+
, Common.SnapshotExistsError (..)
21+
, Common.SnapshotDoesNotExistError (..)
22+
, Common.SnapshotCorruptedError (..)
23+
, Common.SnapshotNotCompatibleError (..)
24+
, Common.BlobRefInvalidError (..)
25+
, Common.CursorClosedError (..)
26+
, Common.FileFormat (..)
27+
, Common.FileCorruptedError (..)
1328
, Common.InvalidSnapshotNameError (..)
1429

1530
-- * Tracing
@@ -67,7 +82,7 @@ module Database.LSMTree (
6782
, retrieveBlobs
6883

6984
-- * Durability (snapshots)
70-
, SnapshotName
85+
, Common.SnapshotName
7186
, Common.isValidSnapshotName
7287
, Common.toSnapshotName
7388
, Common.SnapshotLabel (..)
@@ -117,16 +132,15 @@ import Data.List.NonEmpty (NonEmpty (..))
117132
import Data.Typeable (Proxy (..), Typeable, eqT, type (:~:) (Refl))
118133
import qualified Data.Vector as V
119134
import Database.LSMTree.Common (BlobRef (BlobRef), IOLike, Range (..),
120-
SerialiseKey, SerialiseValue, Session, SnapshotName,
121-
UnionCredits (..), UnionDebt (..), closeSession,
122-
deleteSnapshot, listSnapshots, openSession, withSession)
135+
SerialiseKey, SerialiseValue, Session, UnionCredits (..),
136+
UnionDebt (..), closeSession, deleteSnapshot,
137+
listSnapshots, openSession, withSession)
123138
import qualified Database.LSMTree.Common as Common
124139
import qualified Database.LSMTree.Internal as Internal
125140
import qualified Database.LSMTree.Internal.BlobRef as Internal
126141
import qualified Database.LSMTree.Internal.Entry as Entry
127142
import qualified Database.LSMTree.Internal.RawBytes as RB
128143
import qualified Database.LSMTree.Internal.Serialise as Internal
129-
import qualified Database.LSMTree.Internal.Snapshot as Internal
130144
import qualified Database.LSMTree.Internal.Vector as V
131145
import Database.LSMTree.Monoidal (ResolveValue (..),
132146
resolveDeserialised, resolveValueAssociativity,
@@ -476,24 +490,24 @@ retrieveBlobs (Internal.Session' (sesh :: Internal.Session m h)) refs =
476490

477491
{-# SPECIALISE createSnapshot ::
478492
Common.SnapshotLabel
479-
-> SnapshotName
493+
-> Common.SnapshotName
480494
-> Table IO k v b
481495
-> IO () #-}
482496
createSnapshot :: forall m k v b.
483497
IOLike m
484498
=> Common.SnapshotLabel
485-
-> SnapshotName
499+
-> Common.SnapshotName
486500
-> Table m k v b
487501
-> m ()
488502
createSnapshot label snap (Internal.Table' t) =
489-
void $ Internal.createSnapshot snap label Internal.SnapFullTable t
503+
void $ Internal.createSnapshot snap label Common.SnapFullTable t
490504

491505
{-# SPECIALISE openSnapshot ::
492506
ResolveValue v
493507
=> Session IO
494508
-> Common.TableConfigOverride
495509
-> Common.SnapshotLabel
496-
-> SnapshotName
510+
-> Common.SnapshotName
497511
-> IO (Table IO k v b ) #-}
498512
openSnapshot :: forall m k v b.
499513
( IOLike m
@@ -502,10 +516,10 @@ openSnapshot :: forall m k v b.
502516
=> Session m
503517
-> Common.TableConfigOverride -- ^ Optional config override
504518
-> Common.SnapshotLabel
505-
-> SnapshotName
519+
-> Common.SnapshotName
506520
-> m (Table m k v b)
507521
openSnapshot (Internal.Session' sesh) override label snap =
508-
Internal.Table' <$!> Internal.openSnapshot sesh label Internal.SnapFullTable override snap (resolve (Proxy @v))
522+
Internal.Table' <$!> Internal.openSnapshot sesh label Common.SnapFullTable override snap (resolve (Proxy @v))
509523

510524
{-------------------------------------------------------------------------------
511525
Mutiple writable tables
@@ -556,7 +570,7 @@ unions (t :| ts) =
556570
-> m (Internal.Table m h)
557571
checkTableType _ i (Internal.Table' (t' :: Internal.Table m h'))
558572
| Just Refl <- eqT @h @h' = pure t'
559-
| otherwise = throwIO (Internal.ErrUnionsTableTypeMismatch 0 i)
573+
| otherwise = throwIO (Common.ErrTableTypeMismatch 0 i)
560574

561575
{-# SPECIALISE remainingUnionDebt :: Table IO k v b -> IO UnionDebt #-}
562576
remainingUnionDebt :: IOLike m => Table m k v b -> m UnionDebt

‎src/Database/LSMTree/Common.hs‎

Lines changed: 25 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -2,7 +2,22 @@ module Database.LSMTree.Common (
22
-- * IOLike
33
IOLike
44
-- * Exceptions
5-
, Internal.LSMTreeError (..)
5+
, Internal.SessionDirDoesNotExistError (..)
6+
, Internal.SessionDirLockedError (..)
7+
, Internal.SessionDirCorruptedError (..)
8+
, Internal.SessionClosedError (..)
9+
, Internal.TableClosedError (..)
10+
, Internal.TableCorruptedError (..)
11+
, Internal.TableTooLargeError (..)
12+
, Internal.TableNotCompatibleError (..)
13+
, Internal.SnapshotExistsError (..)
14+
, Internal.SnapshotDoesNotExistError (..)
15+
, Internal.SnapshotCorruptedError (..)
16+
, Internal.SnapshotNotCompatibleError (..)
17+
, Internal.BlobRefInvalidError (..)
18+
, Internal.CursorClosedError (..)
19+
, Internal.FileFormat (..)
20+
, Internal.FileCorruptedError (..)
621
, Internal.InvalidSnapshotNameError (..)
722
-- * Tracing
823
, Internal.LSMTreeTrace (..)
@@ -19,11 +34,12 @@ module Database.LSMTree.Common (
1934
-- * Small types
2035
, Internal.Range (..)
2136
-- * Snapshots
22-
, SnapshotLabel (..)
37+
, Internal.SnapshotLabel (..)
38+
, Internal.SnapshotTableType (..)
2339
, deleteSnapshot
2440
, listSnapshots
2541
-- ** Snapshot names
26-
, Internal.SnapshotName
42+
, SnapshotName
2743
, Internal.toSnapshotName
2844
, Internal.isValidSnapshotName
2945
-- * Blob references
@@ -64,10 +80,11 @@ import qualified Database.LSMTree.Internal.BlobRef as Internal
6480
import qualified Database.LSMTree.Internal.Config as Internal
6581
import qualified Database.LSMTree.Internal.Entry as Internal
6682
import qualified Database.LSMTree.Internal.MergeSchedule as Internal
83+
import Database.LSMTree.Internal.Paths (SnapshotName)
6784
import qualified Database.LSMTree.Internal.Paths as Internal
6885
import qualified Database.LSMTree.Internal.Range as Internal
6986
import Database.LSMTree.Internal.Serialise.Class
70-
import Database.LSMTree.Internal.Snapshot (SnapshotLabel (..))
87+
import qualified Database.LSMTree.Internal.Snapshot as Internal
7188
import System.FS.API (FsPath, HasFS)
7289
import System.FS.BlockIO.API (HasBlockIO)
7390
import System.FS.IO (HandleIO)
@@ -193,7 +210,7 @@ closeSession (Internal.Session' sesh) = Internal.closeSession sesh
193210

194211
{-# SPECIALISE deleteSnapshot ::
195212
Session IO
196-
-> Internal.SnapshotName
213+
-> SnapshotName
197214
-> IO () #-}
198215
-- | Delete a named snapshot.
199216
--
@@ -205,18 +222,18 @@ closeSession (Internal.Session' sesh) = Internal.closeSession sesh
205222
deleteSnapshot ::
206223
IOLike m
207224
=> Session m
208-
-> Internal.SnapshotName
225+
-> SnapshotName
209226
-> m ()
210227
deleteSnapshot (Internal.Session' sesh) = Internal.deleteSnapshot sesh
211228

212229
{-# SPECIALISE listSnapshots ::
213230
Session IO
214-
-> IO [Internal.SnapshotName] #-}
231+
-> IO [SnapshotName] #-}
215232
-- | List snapshots by name.
216233
listSnapshots ::
217234
IOLike m
218235
=> Session m
219-
-> m [Internal.SnapshotName]
236+
-> m [SnapshotName]
220237
listSnapshots (Internal.Session' sesh) = Internal.listSnapshots sesh
221238

222239
{-------------------------------------------------------------------------------

0 commit comments

Comments
 (0)