diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -19,9 +19,7 @@ This implementation allows the number of bits in the id to range from 0 bits to 255^4 bits. The default configuration uses 64 bits, with 40 bits used for time, 10 bits used for the counter, 8 bits used for the node id, and 6 bits for the checksum. The odds of a false positive on the checksum is `1/(2^checkbits)`, so the odds of a false positive in the default configuration -is ~1.5%. This configuration can generate 1024 UIDs per millisecond per node: the 1025th request in a given millisecond -will cause a pause in the thread for one millisecond, and then the counter will reset to 0. (If you need more UID throughput -than that, then create more generators with distinct node ids.) +is ~1.5%. ## Encoding diff --git a/package.yaml b/package.yaml --- a/package.yaml +++ b/package.yaml @@ -1,10 +1,10 @@ name: snowchecked -version: 0.0.1.3 +version: 0.0.2.0 github: robertfischer/hs-snowflake-checked license: Apache-2.0 author: Robert Fischer maintainer: smokejumperit@gmail.com -copyright: 2021 Robert Fischer +copyright: 2021-2023 Robert Fischer extra-source-files: - LICENSE @@ -75,6 +75,7 @@ dependencies: - snowchecked - hedgehog + - unliftio ghc-options: - -threaded diff --git a/snowchecked.cabal b/snowchecked.cabal --- a/snowchecked.cabal +++ b/snowchecked.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: snowchecked -version: 0.0.1.3 +version: 0.0.2.0 synopsis: A checksummed variation on Twitter's Snowflake UID generation algorithm description: See the file ./README.md, which is included in the package and also on GitHub. category: Data @@ -13,7 +13,7 @@ bug-reports: https://github.com/robertfischer/hs-snowflake-checked/issues author: Robert Fischer maintainer: smokejumperit@gmail.com -copyright: 2021 Robert Fischer +copyright: 2021-2023 Robert Fischer license: Apache-2.0 license-file: LICENSE build-type: Simple @@ -78,5 +78,6 @@ , text >=1.2.4.1 , text-conversions >=0.3.1 , time >=1.9.3 + , unliftio , wide-word >=0.1.1.2 default-language: Haskell2010 diff --git a/src/Data/Snowchecked.hs b/src/Data/Snowchecked.hs --- a/src/Data/Snowchecked.hs +++ b/src/Data/Snowchecked.hs @@ -20,12 +20,10 @@ , uniqueFlakeCount ) where -import Control.Concurrent (threadDelay) import Control.Concurrent.MVar import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Snowchecked.Internal.Import import Data.Time.Clock.POSIX (getPOSIXTime) -import GHC.Stack (HasCallStack) currentTimestamp :: IO Word256 @@ -35,18 +33,21 @@ {-# INLINE currentTimestamp #-} currentTimestampBits :: Word8 -> IO Word256 -currentTimestampBits n = (`cutBits` toInt n) <$> currentTimestamp +currentTimestampBits n = + if n == 0 then + return 0 + else + (`cutBits` toInt n) <$> currentTimestamp {-# INLINE currentTimestampBits #-} -- | Create a new generator. Takes a configuration and node id. The node id may be any -- value that fits in a 'Word256', but it will be truncated to the number of bits specified -- in the provided configuration. -newSnowcheckedGen :: (HasCallStack, MonadIO io) => SnowcheckedConfig -> Word256 -> io SnowcheckedGen -newSnowcheckedGen conf@SnowcheckedConfig{..} nodeId = liftIO $ do - startTimeBits <- currentTimestampBits confTimeBits +newSnowcheckedGen :: (MonadIO io) => SnowcheckedConfig -> Word256 -> io SnowcheckedGen +newSnowcheckedGen conf@SnowcheckedConfig{..} nodeId = liftIO $ SnowcheckedGen <$> newMVar Flake - { flakeTime = startTimeBits - , flakeCount = maxBound + { flakeTime = 0 + , flakeCount = 0 , flakeNodeId = cutBits nodeId (toInt confNodeBits) , flakeConfig = conf } @@ -65,35 +66,45 @@ ] where foldFunc :: Word8 -> Word32 -> Word32 - foldFunc nxt memo = memo + toWord32 nxt + foldFunc nxt = (+ toWord32 nxt) {-# INLINEABLE snowcheckedConfigBitCount #-} -- | Generates the next id. -nextFlake :: (HasCallStack, MonadIO io) => SnowcheckedGen -> io Flake +nextFlake :: (MonadIO io) => SnowcheckedGen -> io Flake nextFlake SnowcheckedGen{..} = liftIO $ modifyMVar genLastFlake mkNextFlake where - -- TODO: Special case when confTimeBits is 0. -- TODO: Track the number of flakes generated and error out if we've exhausted them. mkNextFlake flake@Flake{..} = let SnowcheckedConfig{..} = flakeConfig in currentTimestampBits confTimeBits >>= \currentTimeBits -> if flakeTime < currentTimeBits then + let newFlake = flake { + flakeTime = currentTimeBits, + flakeCount = 0 + } in return (newFlake, newFlake) + else if confTimeBits == 0 then let newFlake = flake - { flakeTime = currentTimeBits - , flakeCount = 0 + { flakeTime = 0 + , flakeCount = flakeCount + 1 } in return (newFlake, newFlake) else if confCountBits == 0 then - threadDelay 1000 >> mkNextFlake flake + let newFlake = flake + { flakeTime = flakeTime + 1 + , flakeCount = 0 + } + in return (newFlake, newFlake) else let nextCount = cutBits (flakeCount + 1) (toInt confCountBits) in - if flakeCount < nextCount then - let newFlake = flake { flakeCount = nextCount } + if nextCount == 0 then + let newFlake = flake + { flakeTime = flakeTime + 1 + , flakeCount = 0 + } in return (newFlake, newFlake) else - -- The count wrapped and we need to wait for the time to change. - -- This assumes that the next millisecond will give us a new time. - threadDelay 1000 >> mkNextFlake flake + let newFlake = flake { flakeCount = nextCount } + in return (newFlake, newFlake) {-# INLINEABLE nextFlake #-} {-# SPECIALIZE nextFlake :: SnowcheckedGen -> IO Flake #-} diff --git a/src/Data/Snowchecked/Encoding/ByteString.hs b/src/Data/Snowchecked/Encoding/ByteString.hs --- a/src/Data/Snowchecked/Encoding/ByteString.hs +++ b/src/Data/Snowchecked/Encoding/ByteString.hs @@ -13,9 +13,7 @@ ) where import Data.ByteString -import Data.ByteString.Lazy (fromStrict, - toStrict) -import Data.Snowchecked.Encoding.ByteString.Lazy +import Data.Snowchecked.Encoding.ByteString.Lazy () import Data.Snowchecked.Encoding.Class instance IsFlake ByteString where diff --git a/src/Data/Snowchecked/Encoding/ByteString/Lazy.hs b/src/Data/Snowchecked/Encoding/ByteString/Lazy.hs --- a/src/Data/Snowchecked/Encoding/ByteString/Lazy.hs +++ b/src/Data/Snowchecked/Encoding/ByteString/Lazy.hs @@ -20,8 +20,7 @@ integerToBS = pack . mkBytes where mkBytes 0 = mempty - mkBytes n - = fromIntegral n + mkBytes n = fromIntegral n : mkBytes (n `shiftR` 8) {-# INLINE integerToBS #-} @@ -29,7 +28,7 @@ bsToInteger = foldr mkInteger 0 where mkInteger :: Word8 -> Integer -> Integer - mkInteger nxt memo = memo `shiftL` 8 .|. toInteger nxt + mkInteger nxt memo = (memo `shiftL` 8) .|. toInteger nxt {-# INLINE bsToInteger #-} instance IsFlake ByteString where diff --git a/src/Data/Snowchecked/Encoding/Text.hs b/src/Data/Snowchecked/Encoding/Text.hs --- a/src/Data/Snowchecked/Encoding/Text.hs +++ b/src/Data/Snowchecked/Encoding/Text.hs @@ -1,6 +1,8 @@ {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NamedFieldPuns #-} {-# OPTIONS_GHC -Wno-orphans #-} {-| This module provides a generalized conversion function between a @@ -19,97 +21,64 @@ -} module Data.Snowchecked.Encoding.Text - ( module Data.Snowchecked.Encoding.Class - , module Data.Text.Conversions - ) where + ( module Data.Snowchecked.Encoding.Class + , module Data.Text.Conversions + ) where -import Control.Applicative ((<|>)) -import qualified Data.ByteString.Lazy as LBS import qualified Data.List as L -import Data.Maybe (catMaybes) -import Data.Snowchecked.Encoding.ByteString.Lazy () +import Data.Maybe (fromMaybe) +import Data.Snowchecked.Encoding.Integral import Data.Snowchecked.Encoding.Class import Data.Snowchecked.Internal.Import import qualified Data.Text as T import Data.Text.Conversions -import Text.Read (readMaybe) - --- | Convert a hex value to a character. --- --- WARNING: This function returns the null character ('\0') if you pass in a value > 15. -c :: Word8 -> Char -c 0 = '0' -c 1 = '1' -c 2 = '2' -c 3 = '3' -c 4 = '4' -c 5 = '5' -c 6 = '6' -c 7 = '7' -c 8 = '8' -c 9 = '9' -c 10 = 'a' -c 11 = 'b' -c 12 = 'c' -c 13 = 'd' -c 14 = 'e' -c 15 = 'f' -c _ = '\0' -{-# INLINE c #-} - --- | Converts a character to a hex value (if there is one). -b :: Char -> Maybe Word8 -b ch = readMaybe [ch] <|> chLookup - where - chLookup = case ch of - 'A' -> Just 10 - 'a' -> Just 10 - 'B' -> Just 11 - 'b' -> Just 11 - 'C' -> Just 12 - 'c' -> Just 12 - 'D' -> Just 13 - 'd' -> Just 13 - 'E' -> Just 14 - 'e' -> Just 14 - 'F' -> Just 15 - 'f' -> Just 15 - _ -> Nothing -{-# INLINE b #-} - --- | Converts a byte to two hex characters: low nibble and then high nibble. -byteToHex :: Word8 -> (Char,Char) -byteToHex w8 = (c lowNibble, c highNibble) - where - lowNibble = cutBits w8 4 - highNibble = shiftCutBits w8 4 4 -{-# INLINE byteToHex #-} +import Data.Snowchecked (snowcheckedConfigBitCount) +import Data.Ratio ((%)) +import Data.Char (isHexDigit) instance {-# INCOHERENT #-} (ToText a, FromText a) => IsFlake (Base16 a) where - fromFlake flake = Base16 $ convertText str - where - str = LBS.foldr bytesToChars [] $ fromFlake flake - bytesToChars w8 rest = - let (lowC, highC) = byteToHex w8 in lowC : highC : rest - {-# INLINEABLE fromFlake #-} - {-# SPECIALIZE fromFlake :: Flake -> Base16 String #-} - {-# SPECIALIZE fromFlake :: Flake -> Base16 T.Text #-} + fromFlake flake@Flake{flakeConfig} = Base16 $ convertText str + where + hexLength = ceiling $ + snowcheckedConfigBitCount flakeConfig % 4 + pad0 str' = + if L.length str' < hexLength then + pad0 ('0':str') + else + str' + str = pad0 $ showHex (fromFlake @Integer flake) "" + {-# INLINEABLE fromFlake #-} + {-# SPECIALIZE fromFlake :: Flake -> Base16 String #-} + {-# SPECIALIZE fromFlake :: Flake -> Base16 T.Text #-} - parseFish SnowcheckedConfig{..} (Base16 raw) = return $ Flakeish - { fishCheck = fromIntegral $ cutBits n checkBitsInt - , fishNodeId = fromIntegral $ shiftCutBits n checkBitsInt nodeBitsInt - , fishCount = fromIntegral $ shiftCutBits n (checkBitsInt + nodeBitsInt) countBitsInt - , fishTime = fromIntegral $ shiftCutBits n (checkBitsInt + nodeBitsInt + countBitsInt) timeBitsInt - } - where - nibbles = catMaybes . T.foldr toNibbles [] $ toText raw - n = L.foldr addNibbles 0 nibbles - addNibbles nib total = toInteger nib + ( total `shiftL` 4 ) - toNibbles ch lst = b ch : lst - checkBitsInt = toInt confCheckBits - nodeBitsInt = toInt confNodeBits - timeBitsInt = toInt confTimeBits - countBitsInt = toInt confCountBits - {-# INLINEABLE parseFish #-} - {-# SPECIALIZE parseFish :: (MonadFail m) => SnowcheckedConfig -> Base16 T.Text -> m Flakeish #-} - {-# SPECIALIZE parseFish :: (MonadFail m) => SnowcheckedConfig -> Base16 String -> m Flakeish #-} + parseFish SnowcheckedConfig{..} (Base16 raw) = + calculateN >>= \n -> + return $ Flakeish + { fishCheck = fromIntegral $ cutBits n checkBitsInt + , fishNodeId = fromIntegral $ shiftCutBits n checkBitsInt nodeBitsInt + , fishCount = fromIntegral $ shiftCutBits n (checkBitsInt + nodeBitsInt) countBitsInt + , fishTime = fromIntegral $ shiftCutBits n (checkBitsInt + nodeBitsInt + countBitsInt) timeBitsInt + } + where + str = convertText @_ @String raw + cleaned = + L.dropWhile ('0' ==) . + L.filter isHexDigit $ + fromMaybe str (L.stripPrefix "0x" str) + calculateN = fst <$> findBestResult (readHex @Integer cleaned) + findBestResult [] = fail "Could not find any results" + findBestResult (this@(_,""):_) = return this + findBestResult [onlyResult] = return onlyResult + findBestResult (this@(_,nRest):others) = + findBestResult others >>= \other@(_, mRest) -> + if L.length nRest < L.length mRest then + return this + else + return other + checkBitsInt = toInt confCheckBits + nodeBitsInt = toInt confNodeBits + timeBitsInt = toInt confTimeBits + countBitsInt = toInt confCountBits + {-# INLINEABLE parseFish #-} + {-# SPECIALIZE parseFish :: (MonadFail m) => SnowcheckedConfig -> Base16 T.Text -> m Flakeish #-} + {-# SPECIALIZE parseFish :: (MonadFail m) => SnowcheckedConfig -> Base16 String -> m Flakeish #-} diff --git a/src/Data/Snowchecked/Internal/Import.hs b/src/Data/Snowchecked/Internal/Import.hs --- a/src/Data/Snowchecked/Internal/Import.hs +++ b/src/Data/Snowchecked/Internal/Import.hs @@ -14,17 +14,16 @@ import Data.WideWord.Word256 import Data.Word import Numeric -import GHC.Stack (HasCallStack) -cutBits :: (HasCallStack, Num a, Bits a) => a -> Int -> a +cutBits :: (Num a, Bits a) => a -> Int -> a cutBits n bits = n .&. ((1 `shiftL` bits) - 1) {-# INLINE cutBits #-} -cutShiftBits :: (HasCallStack, Num a, Bits a) => a -> Int -> Int -> a +cutShiftBits :: (Num a, Bits a) => a -> Int -> Int -> a cutShiftBits n cutBitCount shiftBitCount = cutBits n cutBitCount `shiftL` shiftBitCount {-# INLINE cutShiftBits #-} -shiftCutBits :: (HasCallStack, Num a, Bits a) => a -> Int -> Int -> a +shiftCutBits :: (Num a, Bits a) => a -> Int -> Int -> a shiftCutBits n shiftBitCount = cutBits $ n `shiftR` shiftBitCount {-# INLINE shiftCutBits #-} @@ -39,3 +38,4 @@ toWord32 :: (Integral a) => a -> Word32 toWord32 = fromIntegral @_ @Word32 {-# INLINE toWord32 #-} + diff --git a/test/Gens.hs b/test/Gens.hs --- a/test/Gens.hs +++ b/test/Gens.hs @@ -1,7 +1,11 @@ {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE FlexibleInstances #-} module Gens (module Gens) where +import Data.Snowchecked.Encoding.Text +import Data.Snowchecked.Encoding.Integral +import Data.Text (Text) import Control.Monad (unless, void) import Control.Monad.IO.Class (MonadIO) import Data.List (nub) @@ -13,6 +17,19 @@ import Hedgehog.Main (defaultMain) import qualified Hedgehog.Range as Range +genBytes :: (MonadGen m) => m [Word8] +genBytes = strip0 <$> + Gen.list + (Range.linear 1 (fromIntegral $ maxBound @Word8)) + genWord8 + where + strip0 lst = + case lst of + [] -> [0] + [0] -> [0] + (0:rest) -> strip0 rest + _ -> lst + genWord8 :: (MonadGen m) => m Word8 genWord8 = Gen.word8 $ Range.linear (minBound @Word8) (maxBound @Word8) @@ -21,10 +38,10 @@ genConfig :: (MonadGen m) => m SnowcheckedConfig genConfig = SnowcheckedConfig - <$> Gen.integral (Range.linear 2 (maxBound @Word8)) - <*> Gen.integral (Range.linear 2 (maxBound @Word8)) - <*> Gen.integral (Range.linear 2 (maxBound @Word8)) - <*> Gen.integral (Range.linear 2 (maxBound @Word8)) + <$> Gen.integral (Range.linear 4 (maxBound @Word8)) + <*> Gen.integral (Range.linear 0 (maxBound @Word8)) + <*> Gen.integral (Range.linear 0 (maxBound @Word8)) + <*> Gen.integral (Range.linear 0 (maxBound @Word8)) forAllFlake :: (MonadIO m) => PropertyT m Flake forAllFlake = forAll genConfig >>= forAllFlake' @@ -33,3 +50,15 @@ forAllFlake' cfg = do nodeId <- forAll genWord256 newSnowcheckedGen cfg nodeId >>= nextFlake + +annotateFlakeString :: (MonadTest m) => Flake -> m () +annotateFlakeString = annotateShow . fromFlake @(Base16 String) + +annotateFlakeText :: (MonadTest m) => Flake -> m () +annotateFlakeText = annotateShow . fromFlake @(Base16 Text) + +annotateFlakeInteger :: (MonadTest m) => Flake -> m () +annotateFlakeInteger = annotateShow . fromFlake @Integer + +instance MonadFail (Either String) where + fail = Left diff --git a/test/Integer.hs b/test/Integer.hs --- a/test/Integer.hs +++ b/test/Integer.hs @@ -13,8 +13,9 @@ prop_flakeToIntegerToFlake :: Property prop_flakeToIntegerToFlake = property $ do - cfg <- forAll genConfig - flake <- forAllFlake' cfg - let value = fromFlake @Integer flake - let result = parseFlake cfg value - result === Just flake + cfg <- forAll genConfig + flake <- forAllFlake' cfg + let value = fromFlake @Integer flake + annotateShow value + let result = parseFlake cfg value + result === Just flake diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,11 +1,13 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE OverloadedStrings #-} import Control.Monad (unless, void) import Control.Monad.IO.Class (MonadIO) import Data.List (nub) import Data.Snowchecked +import Data.Snowchecked.Encoding.Integral import Data.WideWord.Word256 import Data.Word import Gens @@ -21,53 +23,61 @@ import qualified Word64 main :: IO () -main = do - recheck (Size 4) (Seed 14462958355020818941 14776761114051845121) prop_generatesUniqueValues - recheck (Size 8) (Seed 11763301661976410488 14055395789257366631) prop_generatesUniqueValues - recheck (Size 14) (Seed 6771904241892528611 8532317410904456029) prop_generatesUniqueValues - recheck (Size 14) (Seed 4790609826115340731 8375105224114527375) prop_generatesUniqueValues - defaultMain - [ checkParallel $$(discover) - , Integer.tests - , Word32.tests - , Word64.tests - , Text.tests - , String.tests - ] +main = + defaultMain + [ checkParallel $$(discover) + , Integer.tests + , Word32.tests + , Word64.tests + , Text.tests + , String.tests + ] +prop_confGenerationWorks :: Property +prop_confGenerationWorks = property $ + void (forAll genConfig) + +uniqueGenerationProperty :: (SnowcheckedConfig -> SnowcheckedConfig) -> Property +uniqueGenerationProperty nudge = + property $ do + cfg <- nudge <$> forAll genConfig + flakeGen <- forAll genWord256 >>= newSnowcheckedGen cfg + let flakeCount = min 4096 (fromIntegral $ uniqueFlakeCount cfg) + lst <- forAll $ Gen.list (Range.linear 2 flakeCount) (pure ()) + resultLst <- mapM (const $ nextFlake flakeGen) lst + resultLst === nub resultLst + prop_generatesUniqueValues :: Property -prop_generatesUniqueValues = property $ do - lst <- forAll $ Gen.list (Range.linear 2 8192) (return ()) - cfg <- forAll genConfig - unless ( uniqueFlakeCount cfg > toInteger (length lst) ) discard - nodeId <- forAll genWord256 - flakeGen <- newSnowcheckedGen cfg nodeId - resultLst <- mapM (\_ -> nextFlake flakeGen) lst - resultLst === nub resultLst +prop_generatesUniqueValues = uniqueGenerationProperty id prop_flakeCanBeNFed :: Property -prop_flakeCanBeNFed = property $ do - flake <- forAllFlake - void $ evalNF flake +prop_flakeCanBeNFed = property $ + forAllFlake >>= void . evalNF prop_generatesUniqueValuesWithZeroCheckBits :: Property -prop_generatesUniqueValuesWithZeroCheckBits = property $ do - lst <- forAll $ Gen.list (Range.linear 2 1024) (return ()) - cfgBase <- forAll genConfig - let cfg = cfgBase { confCheckBits = 0 } - unless ( uniqueFlakeCount cfg > toInteger (length lst) ) discard - nodeId <- forAll genWord256 - flakeGen <- newSnowcheckedGen cfg nodeId - resultLst <- mapM (\_ -> nextFlake flakeGen) lst - resultLst === nub resultLst +prop_generatesUniqueValuesWithZeroCheckBits = + uniqueGenerationProperty (\cfg -> cfg { confCheckBits = 0 }) prop_generatesUniqueValuesWithZeroNodeIdBits :: Property -prop_generatesUniqueValuesWithZeroNodeIdBits = property $ do - lst <- forAll $ Gen.list (Range.linear 2 1024) (return ()) - cfgBase <- forAll genConfig - let cfg = cfgBase { confNodeBits = 0 } - unless ( uniqueFlakeCount cfg > toInteger (length lst) ) discard - nodeId <- forAll genWord256 - flakeGen <- newSnowcheckedGen cfg nodeId - resultLst <- mapM (\_ -> nextFlake flakeGen) lst - resultLst === nub resultLst +prop_generatesUniqueValuesWithZeroNodeIdBits = + uniqueGenerationProperty (\cfg -> cfg { confNodeBits = 0 }) + +prop_generatesUniqueValuesWithZeroCountBits :: Property +prop_generatesUniqueValuesWithZeroCountBits = + uniqueGenerationProperty (\cfg -> cfg { confCountBits = 0 }) + +prop_monotonicallyIncreasing :: Property +prop_monotonicallyIncreasing = property $ do + cfg <- forAll genConfig + let flakeCount = min 1024 (fromIntegral $ uniqueFlakeCount cfg) + lst <- forAll $ Gen.list (Range.linear 2 flakeCount) (return ()) + nodeId <- forAll genWord256 + flakeGen <- newSnowcheckedGen cfg nodeId + resultLst <- mapM (\_ -> nextFlake flakeGen) lst + checkResults resultLst + where + checkResults [] = success + checkResults [_] = success + checkResults (a:b:rest) = do + diff a (<) b + checkResults (b:rest) diff --git a/test/String.hs b/test/String.hs --- a/test/String.hs +++ b/test/String.hs @@ -2,7 +2,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} -module String (tests) where +module String (module String) where import Data.Snowchecked import Data.Snowchecked.Encoding.Text @@ -14,8 +14,10 @@ prop_flakeToStringToFlake :: Property prop_flakeToStringToFlake = property $ do - cfg <- forAll genConfig - flake <- forAllFlake' cfg - let (value::Base16 String) = fromFlake flake - let result = parseFlake cfg value - result === Just flake + cfg <- forAll genConfig + flake <- forAllFlake' cfg + annotateFlakeInteger flake + let value = fromFlake @(Base16 String) flake + annotateShow value + let (result::Either String Flake) = parseFlake cfg value + result === Right flake diff --git a/test/Text.hs b/test/Text.hs --- a/test/Text.hs +++ b/test/Text.hs @@ -2,21 +2,38 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} -module Text (tests) where +module Text (module Text) where +import Control.Monad.IO.Class (MonadIO) import Data.Snowchecked import Data.Snowchecked.Encoding.Text import Data.Text (Text) import Gens import Hedgehog +import Data.Bits (shiftR) +import Data.Ratio ( (%) ) +import qualified Data.Text as T +import qualified Hedgehog.Gen as Gen tests :: IO Bool tests = checkParallel $$(discover) prop_flakeToStrictTextToFlake :: Property prop_flakeToStrictTextToFlake = property $ do - cfg <- forAll genConfig - flake <- forAllFlake' cfg - let (value::Base16 Text) = fromFlake flake - let result = parseFlake cfg value - result === Just flake + cfg <- forAll genConfig + flake <- forAllFlake' cfg + annotateFlakeInteger flake + let value = fromFlake @(Base16 Text) flake + annotateShow value + let result = parseFlake cfg value + result === Just flake + +prop_flakeToStrictTextHasRightLength :: Property +prop_flakeToStrictTextHasRightLength = property $ do + cfg <- forAll genConfig + flake <- forAllFlake' cfg + annotateFlakeInteger flake + let Base16 value = fromFlake @(Base16 Text) flake + T.length value === hexDigitCount (snowcheckedConfigBitCount cfg) + where + hexDigitCount = ceiling . ( % 4 )