Make SnapshotLabel a newtype

Author: jorisdral

lsm-tree.cabal

@@ -179,6 +179,7 @@ library
     , lsm-tree:kmerge
     , lsm-tree:monkey
     , primitive               ^>=0.9
+    , text                    ^>=2.1.1
     , vector                  ^>=0.13
     , vector-algorithms       ^>=0.9
 

src/Database/LSMTree/Internal.hs

@@ -1077,12 +1077,10 @@ readCursorWhile resolve keyIsWanted n Cursor {..} fromEntry = do
   Snapshots
 -------------------------------------------------------------------------------}
 
-type SnapshotLabel = String
-
 {-# SPECIALISE snapshot ::
      ResolveSerialisedValue
   -> SnapshotName
-  -> String
+  -> SnapshotLabel
   -> Table IO h
   -> IO Int #-}
 -- |  See 'Database.LSMTree.Normal.snapshot''.

src/Database/LSMTree/Internal/Snapshot.hs

@@ -2,8 +2,9 @@
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 module Database.LSMTree.Internal.Snapshot (
+    SnapshotLabel (..)
     -- * Snapshot format
-    numSnapRuns
+  , numSnapRuns
   , SnapLevels
   , SnapLevel (..)
   , SnapMergingRun (..)
@@ -23,6 +24,8 @@ import           Control.Monad.Primitive (PrimMonad)
 import           Control.TempRegistry
 import           Data.Foldable (forM_)
 import           Data.Primitive.PrimVar
+import           Data.String
+import           Data.Text (Text)
 import qualified Data.Vector as V
 import           Database.LSMTree.Internal.Config
 import           Database.LSMTree.Internal.Entry
@@ -39,6 +42,11 @@ import           Database.LSMTree.Internal.UniqCounter (UniqCounter,
 import           System.FS.API (HasFS)
 import           System.FS.BlockIO.API (HasBlockIO)
 
+-- | Custom text to include in a snapshot file
+newtype SnapshotLabel = SnapshotLabel Text
+  deriving stock (Show, Eq, Read)
+  deriving newtype (Semigroup, IsString)
+
 {-------------------------------------------------------------------------------
   Levels snapshot format
 -------------------------------------------------------------------------------}

src/Database/LSMTree/Monoidal.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 -- TODO: remove once the API is implemented.
 {-# OPTIONS_GHC -Wno-redundant-constraints #-}
 

src/Database/LSMTree/Normal.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 -- TODO: remove once the API is implemented.
 {-# OPTIONS_GHC -Wno-redundant-constraints #-}
 

test/Test/Database/LSMTree/Class/Monoidal.hs

@@ -1,4 +1,5 @@
-{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE BlockArguments    #-}
+{-# LANGUAGE OverloadedStrings #-}
 
 module Test.Database.LSMTree.Class.Monoidal (tests) where
 

test/Test/Database/LSMTree/Class/Normal.hs

@@ -1,4 +1,5 @@
-{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE BlockArguments    #-}
+{-# LANGUAGE OverloadedStrings #-}
 
 module Test.Database.LSMTree.Class.Normal (
     tests

test/Test/Database/LSMTree/Internal.hs

@@ -1,5 +1,6 @@
-{-# LANGUAGE LambdaCase      #-}
-{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE LambdaCase        #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards   #-}
 
 {- HLINT ignore "Use <=<" -}
 

test/Test/Database/LSMTree/Normal/StateMachine.hs

@@ -10,6 +10,7 @@
 {-# LANGUAGE LambdaCase               #-}
 {-# LANGUAGE MultiParamTypeClasses    #-}
 {-# LANGUAGE NamedFieldPuns           #-}
+{-# LANGUAGE OverloadedStrings        #-}
 {-# LANGUAGE QuantifiedConstraints    #-}
 {-# LANGUAGE RankNTypes               #-}
 {-# LANGUAGE ScopedTypeVariables      #-}