diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,11 +1,30 @@ -[`basesystems`](http://hackage-content.haskell.org/package/basesystems) -change log: -=========== +[`basesystems`](http://hackage.haskell.org/package/basesystems) change log: +=========================================================================== +Major release 1.2 +----------------- + +## Version 1.2 (07-08-2026) + +This version removes the functionality that the [xcodec]( +ihttps://hackage.haskell.org/package/xcodec) package now provides. This change +replaces the `Data.BaseSystem.*Transcoder` modules, so they are no longer part +of this package. + +The `Data.BaseSystem.*` modules has been renamed to `Data.BaseSystems.*` to +match the package name. The `Data.BaseSystem.DigitSystem` module has also been +renamed to `Data.BaseSystems.DigitSystems` to reflect the digit systems (plural) +that it exports. + +The `Data.BaseSystems.DigitSystems` module is exported by the +`Data.BaseSystems`, `Data.BaseSystems.Lazy`, and `Data.BaseSystems.Strict` +packages, so that a single import change be used for simple use cases such as +showing number strings in a fixed basesystem. + Major release 1.1 ----------------- -## Version 1.1.0.0 (05-17-2026) +## Version 1.1 (05-17-2026) ### Cabal - Upgrade major versions for `text` and `containers` versions. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,9 +1,9 @@ basesystems [![hackage.haskell.org]( https://img.shields.io/badge/hackage%2Ehaskell%2Eorg-5C5181?logo=haskell)]( https://hackage.haskell.org/package/basesystems)[![builds.sr.ht status]( -https://builds.sr.ht/~z0/basesystems/commits/main/basesystem-testing.yml.svg)]( -https://builds.sr.ht/~z0/basesystems/commits/main/basesystem-testing.yml?) ------------------------------------------------- +https://builds.sr.ht/~z0/basesystems/commits/main/ipfshs-ci.yml.svg)]( +https://builds.sr.ht/~z0/basesystems/commits/main/ipfshs-ci.yml?) +--------------------------------------------------------------------------- This project contains code for encoding/decoding numeric basesystems in Haskell. It's implemented in a strategy pattern style where `BaseSystem` is a type-class @@ -22,11 +22,6 @@ `decoder` are defined in `Data.BaseSystem.DigitSystem`. See the [*example*]( #example). -`basesystems` is a part of the [ipfshs](https://git.sr.ht/~z0/ipfshs) project -which contains [testing via sourcehut builds]( -https://builds.sr.ht/~z0/basesystems/commits/main/basesystem-testing.yml) and a -[bug ticket tracker](https://todo.sr.ht/~z0/ipfshs). - Coverage -------- @@ -56,8 +51,7 @@ ```haskell λ> {-# LANGUAGE OverloadedStrings #-} -λ> import Data.BaseSystem (encoder, decoder) -λ> import Data.BaseSystem.DigitSystem (base2, base10, base16lower, base32lower) +λ> import Data.BaseSystem (encoder, decoder, base2, base10, base16lower, base32lower) λ> import Data.BaseSystem.BinaryTranscoder (packValue) ``` @@ -88,6 +82,13 @@ λ> encoder base10 <$> decoder base32lower "pm======" Just "123" ``` + +Development +----------- + +Unit tests are provided on the main [ipfshs repo](https://git.sr.ht/~z0/ipfshs), +and bugs can be reported on [ipfshs ticket tracker]( +https://todo.sr.ht/~z0/ipfshs). Licensing --------- diff --git a/basesystems.cabal b/basesystems.cabal --- a/basesystems.cabal +++ b/basesystems.cabal @@ -1,5 +1,5 @@ cabal-version: 3.0 -version: 1.1.0.0 +version: 1.2.0.0 name: basesystems build-type: Simple author: Zoey McBride @@ -39,6 +39,7 @@ common Depends { build-depends: base >= 4.18 && < 5, + xcodec ^>= 1.1, array ^>= 0.5, bytestring >= 0.12 && < 0.13, containers >= 0.7 && < 8, @@ -61,19 +62,18 @@ else { import: BuildUser } exposed-modules: -- * BaseSystems for ShortByteStrings - Data.BaseSystem, + Data.BaseSystems, -- * BaseSystems for LazyByteStrings - Data.BaseSystem.Lazy, + Data.BaseSystems.Lazy, -- * BaseSystems for Strict ByteStrings - Data.BaseSystem.Strict, + Data.BaseSystems.Strict, -- * Defines Alphabet type + instances - Data.BaseSystem.Alphabet, + Data.BaseSystems.Alphabet, -- * Data instances for working with strings of digits - Data.BaseSystem.DigitSystem, + Data.BaseSystems.DigitSystems, -- * Interface for decoding strings of numbers into binary data. - Data.BaseSystem.DigitTranscoder, - -- * Interface for transcoding bitstreams - Data.BaseSystem.BinaryTranscoder, - -- * Provides utility functions - Data.BaseSystem.Internal, + Data.BaseSystems.DigitTranscoder, + other-modules: + -- * Helper functions. + Data.BaseSystems.Internal, } diff --git a/basesystems/Data/BaseSystem.hs b/basesystems/Data/BaseSystem.hs deleted file mode 100644 --- a/basesystems/Data/BaseSystem.hs +++ /dev/null @@ -1,47 +0,0 @@ --- | Module : Data.BaseSystem --- Description : Implements BaseSystems for ShortByteString. --- Copyright : Zoey McBride (c) 2026 --- License : BSD-3-Clause --- Maintainer : zoeymcbride@mailbox.org --- Stability : experimental -module Data.BaseSystem - ( -- * BaseSystems on ShortByteString. - BaseSystem (encoder, decoder), - - -- * Function signatures aliases. - Encoder, - Decoder, - - -- * ByteString implementation for this file. - ByteStr, - ) -where - -import Data.BaseSystem.DigitSystem (BitwiseDigits, RadixDigits) -import Data.BaseSystem.DigitTranscoder qualified as DXC -import Data.ByteString.Short (ShortByteString (ShortByteString)) -import Data.Text (Text) - --- | Sets the bytestring type to use in this file. -type ByteStr = ShortByteString - --- | Alias for curried encoder method. -type Encoder = ByteStr -> Text - --- | Alias for curried decoder method. -type Decoder = Text -> Maybe ByteStr - --- | Configures the BaseSystem for this file's ByteType. -class BaseSystem a where - encoder :: a -> ByteStr -> Text - decoder :: a -> Text -> Maybe ByteStr - --- | BaseSystem for ShortByteString. -instance BaseSystem RadixDigits where - encoder = DXC.digitEncoder - decoder = DXC.digitDecoder - --- | BaseSystem for ShortByteString. -instance BaseSystem BitwiseDigits where - encoder = DXC.digitEncoder - decoder = DXC.digitDecoder diff --git a/basesystems/Data/BaseSystem/Alphabet.hs b/basesystems/Data/BaseSystem/Alphabet.hs deleted file mode 100644 --- a/basesystems/Data/BaseSystem/Alphabet.hs +++ /dev/null @@ -1,177 +0,0 @@ --- | Module : Data.BaseSystem.Alphabet --- Description : Functions for Alphabets on BaseSystems --- Copyright : Zoey McBride (c) 2026 --- License : BSD-3-Clause --- Maintainer : zoeymcbride@mailbox.org --- Stability : experimental --- --- Implements digit alphabets for BaseSystems. -module Data.BaseSystem.Alphabet - ( -- * Symbolic representation of a value - Symbol, - - -- * The value that's given to each digit - Value, - - -- * Abstract Alphabet and functions - Alphabet (alphaRadix, alphaHashId), - mkAlphabet, - resolveValue, - resolveSymbol, - - -- * Available Alphabets - binary, - decimal, - hexlower, - hexupper, - btc58, - b32lower, - b32upper, - b32hexlower, - b32hexupper, - b64, - b64url, - ) -where - -import Data.Array.IArray qualified as Array -import Data.Array.Unboxed (UArray, (!?)) -import Data.Char (ord) -import Data.Function (on) -import Data.Map.Strict (Map) -import Data.Map.Strict qualified as Map -import Data.Text (Text) -import Data.Text qualified as Text -import Data.Word (Word32) - --- TODO: Another module for alphabets with symbols of multiple unicode code --- points should be made. Then a DigitSystem can be built off that for --- basesystems of multipoint symbols. - --- | Represents a symbol to act as a digit in a numbering system. -type Symbol = Char - --- | The value of a symbol in a number system. -type Value = Word32 - --- | Stores the String hash for an Alphabet. Used for comparision. -type HashId = Int - --- | Represents a two-way mapping between symbol's values and values's symbols. -data Alphabet = Alphabet - { alphaRadix :: Int, - alphaHashId :: HashId, - alphaValues :: UArray Value Symbol, - alphaSymbols :: Map Symbol Value - } - -instance Eq Alphabet where - (==) = (==) `on` alphaHashId - -instance Ord Alphabet where - compare = compare `on` alphaHashId - --- | Implements https://cp-algorithms.com/string/string-hashing.html -mkHashId :: Text -> HashId -mkHashId = snd . Text.foldr buildPolynomial (0 :: Integer, 0 :: HashId) - where - -- Should be around of characters in any given alphabet - baseprime = 53 - -- Large prime to prevent most collisions (1/modprime chance) - modprime = 1_000_009 - -- Produces the term for a given character - buildPolynomial ch (expvalue, polysum) = - let term = baseprime ^ expvalue * ord ch - next = polysum + term - in (expvalue + 1, next `mod` modprime) - --- | Creates an Alphabet from Text using its Chars as Symbols. -mkAlphabet :: Text -> Alphabet -mkAlphabet text = - let symbols = Text.unpack text - numsymbols = Text.length text - maxdigit = fromIntegral $ numsymbols - 1 - in Alphabet - { alphaRadix = numsymbols, - alphaHashId = mkHashId text, - alphaValues = Array.listArray (0, maxdigit) symbols, - alphaSymbols = Map.fromList $ zip symbols [0 ..] - } - --- | /O(log n)/ Find a value from a symbol in an alphabet. -resolveValue :: Alphabet -> Symbol -> Maybe Value -resolveValue abc symbol = Map.lookup symbol $ alphaSymbols abc - --- | /O(1)/ Find a symbol from a value in an alphabet. -resolveSymbol :: Alphabet -> Value -> Maybe Symbol -resolveSymbol abc value = alphaValues abc !? value - --- | Constructs an Alphabet from a list of digit symbol strings. -mk :: [[Char]] -> Alphabet -mk = mkAlphabet . Text.pack . concat - --- | Defines base 2. -binary :: Alphabet -binary = mk ["01"] - --- | Defines base 10. -decimal :: Alphabet -decimal = mk ["0", ['1' .. '9']] - --- | Defines base 16 upper-case. -hexupper :: Alphabet -hexupper = mk ["0", ['1' .. '9'], ['A' .. 'F']] - --- | Defines base 16 lower-case. -hexlower :: Alphabet -hexlower = mk ["0", ['1' .. '9'], ['a' .. 'f']] - --- | Defines base 58, bitcoin variant. -btc58 :: Alphabet -btc58 = - mk - [ ['1' .. '9'], - ['A' .. 'H'], - ['J' .. 'N'], - ['P' .. 'Z'], - ['a' .. 'k'], - ['m' .. 'z'] - ] - --- | Defines base32, upper-case. -b32upper :: Alphabet -b32upper = mk [['A' .. 'Z'], ['2' .. '7']] - --- | Defines base32, lower-case. -b32lower :: Alphabet -b32lower = mk [['a' .. 'z'], ['2' .. '7']] - --- | Defines base32 hexadecimal, upper-case. -b32hexupper :: Alphabet -b32hexupper = mk ["0", ['1' .. '9'], ['A' .. 'V']] - --- | Defines base32 hexadecimal, lower-case. -b32hexlower :: Alphabet -b32hexlower = mk ["0", ['1' .. '9'], ['a' .. 'v']] - --- | Defines default base64 with + and /. -b64 :: Alphabet -b64 = - mk - [ ['A' .. 'Z'], - ['a' .. 'z'], - "0", - ['1' .. '9'], - ['+', '/'] - ] - --- | Defines URL-safe base64 with - and _. -b64url :: Alphabet -b64url = - mk - [ ['A' .. 'Z'], - ['a' .. 'z'], - "0", - ['1' .. '9'], - ['-', '_'] - ] diff --git a/basesystems/Data/BaseSystem/BinaryTranscoder.hs b/basesystems/Data/BaseSystem/BinaryTranscoder.hs deleted file mode 100644 --- a/basesystems/Data/BaseSystem/BinaryTranscoder.hs +++ /dev/null @@ -1,238 +0,0 @@ --- | Module : Data.BaseSystem.BinaryTranscoder --- Description : Interfaces for transcoding numeric binary data. --- Copyright : Zoey McBride (c) 2026 --- License : BSD-3-Clause --- Maintainer : zoeymcbride@mailbox.org --- Stability : experimental -module Data.BaseSystem.BinaryTranscoder - ( -- * Interface for implementing generic binary decoders - BinaryTranscoder (..), - - -- * Converts streams of bytes into editable bits - BitSet, - ) -where - -import Data.BaseSystem.Internal -import Data.Bits (Bits, (.&.), (.<<.), (.>>.), (.|.)) -import Data.ByteString (ByteString) -import Data.ByteString qualified as Bytes -import Data.ByteString.Builder (Builder) -import Data.ByteString.Builder qualified as Builder -import Data.ByteString.Lazy (LazyByteString) -import Data.ByteString.Lazy qualified as LBS -import Data.ByteString.Short (ShortByteString) -import Data.ByteString.Short qualified as SBS -import Data.Word (Word8) - --- | Storage for data with bitwise operations. -type BitSet = Integer - --- | Class of functions for working on binary transcoder streams, that is --- streams of bytes that we can easily turn into a bitset, and can partition --- into smaller streams for extracting and parsing data. -class (Monoid bxc) => BinaryTranscoder bxc where - -- This defines basic methods that all BinaryTranscoders share. - {-# MINIMAL - lengthBytes, - unpackValue, - serializeValue, - packBytes, - unpackBytes, - pushByte, - pushByteEnd, - takeBytes, - takeBytesEnd, - dropBytes, - dropBytesEnd, - splitAtByte, - spanBytes, - spanBytesEnd, - replicateByte - #-} - - -- | Gives back the length in bytes of the Transcoder data. - lengthBytes :: bxc -> Int - - -- | Unpacks transcoder data as BitSet, ie, an infinite bitarray. - unpackValue :: bxc -> BitSet - - -- | Places the contents of the transcoder into a ByteString Builder. - serializeValue :: bxc -> Builder - - -- | Packs Word8 values into transcoder data `bxc`. - packBytes :: [Word8] -> bxc - - -- | Unpacks transcoder data into a list of bytes. - unpackBytes :: bxc -> [Word8] - - -- | Prepends a byte value to the top of the transcoder data. - pushByte :: bxc -> Word8 -> bxc - - -- | Appends the byte value to the end of the transcoder data. - pushByteEnd :: bxc -> Word8 -> bxc - - -- | Takes a subsection of bytes from the beginning of the transcoder data. - takeBytes :: Int -> bxc -> bxc - - -- | Removes bytes from the beginning of transcoder data. - dropBytes :: Int -> bxc -> bxc - - -- | Removes bytes from the end of transcoder data. - takeBytesEnd :: Int -> bxc -> bxc - - -- | Removes bytes from the end of transcoder data. - dropBytesEnd :: Int -> bxc -> bxc - - -- | Parititions the binary data at the nth byte. - splitAtByte :: Int -> bxc -> (bxc, bxc) - - -- | Repeats a byte value in binary data. - replicateByte :: Int -> Word8 -> bxc - - -- | Splits byte values based on the first false result from the predicate. - spanBytes :: (Word8 -> Bool) -> bxc -> (bxc, bxc) - - -- | Implements `takeWhile` for byte data in binary transcoder. - takeWhileBytes :: (Word8 -> Bool) -> bxc -> bxc - takeWhileBytes f = fst . spanBytesEnd f - - -- | Implements `dropWhile` for byte data in binary transcoder. - dropWhileBytes :: (Word8 -> Bool) -> bxc -> bxc - dropWhileBytes f = snd . spanBytesEnd f - - -- | Splits the list while the element predicate holds staring from the left - -- side. - spanBytesEnd :: (Word8 -> Bool) -> bxc -> (bxc, bxc) - - -- | Implements `takeWhileEnd` for byte data in binary transcoder. - takeWhileBytesEnd :: (Word8 -> Bool) -> bxc -> bxc - takeWhileBytesEnd f = snd . spanBytesEnd f - - -- | Implements `dropWhileEnd` for byte data in binary transcoder. - dropWhileBytesEnd :: (Word8 -> Bool) -> bxc -> bxc - dropWhileBytesEnd f = fst . spanBytesEnd f - - -- | Represents empty binary transcoder data. - empty :: bxc - empty = mempty - - -- | Appends the contents of two binary transcoders. - append :: bxc -> bxc -> bxc - append = mappend - - -- | Creates a binary transcoder from a single byte. - {-# INLINE singleton #-} - singleton :: Word8 -> bxc - singleton w8 = packBytes [w8] - - -- | Returns True if the binary transcoder data is empty. - {-# INLINE null #-} - null :: bxc -> Bool - null bxc = lengthBytes bxc == 0 - - -- | Returns the first byte removed from the transcoder data, if available. - {-# INLINE uncons #-} - uncons :: bxc -> Maybe (Word8, bxc) - uncons bxc = - let (start, rest) = splitAtByte 1 bxc - in case unpackBytes start of - [top] -> Just (top, rest) - _ -> Nothing - - -- | Returns the last byte removed from the transcoder data, if available. - {-# INLINE usnoc #-} - usnoc :: bxc -> Maybe (bxc, Word8) - usnoc bxc = - let offset = lengthBytes bxc - 1 - (rest, taken) = splitAtByte offset bxc - in case unpackBytes taken of - [final] -> Just (rest, final) - _ -> Nothing - - -- | Packs a bit string value into some bytes data `bxc`. - packValue :: (Integral b, Bits b) => b -> bxc - packValue intdata = - -- This code can be optimized; if we precalculate the length of the BitSet - -- in bits we can mask from the other direction using left shifts, and - -- remove the call to reverse, maybe we can even use a list comprehension to - -- build in place for Bytes.packBytes - packBytes - . replaceNull [0] - . reverse - . map (\(_, byte) -> fromIntegral byte) - . takeWhile (\(rest, byte) -> rest > 0 || byte > 0) - $ iterateInit (\(input, _) -> extractByte input) (,0) intdata - where - -- Gets the byte from LSB in input and shifts the value 8 bits. - extractByte input = (input .>>. 8, input .&. 0xFF) - --- | Implements binary decoder for Bytestrings, best for constant values that --- exist for the lifetime of the program. --- https://hackage-content.haskell.org/package/bytestring-0.12.2.0/docs/Data-ByteString.html#g:2 -instance BinaryTranscoder ByteString where - lengthBytes = Bytes.length - packBytes = Bytes.pack - serializeValue = Builder.byteString - unpackBytes = Bytes.unpack - pushByte = flip Bytes.cons - pushByteEnd = Bytes.snoc - takeBytes = Bytes.take - takeBytesEnd = Bytes.takeEnd - dropBytes = Bytes.drop - dropBytesEnd = Bytes.dropEnd - spanBytes = Bytes.span - spanBytesEnd = Bytes.spanEnd - splitAtByte = Bytes.splitAt - replicateByte k = Bytes.replicate $ fromIntegral k - unpackValue = unpackValue . LBS.fromStrict - --- TODO: we can improve the proformance of unpackBits by examining the current --- bytestring, and loading a range of 1-8 bytes to OR simulaneously - --- | Implements binary decoder for LazyByteString, best for very large data sets --- that can be loaded in and out of memory on demand. --- https://hackage-content.haskell.org/package/bytestring-0.12.2.0/docs/Data-ByteString-Lazy.html -instance BinaryTranscoder LazyByteString where - lengthBytes = fromIntegral . LBS.length - packBytes = LBS.pack - unpackBytes = LBS.unpack - serializeValue = Builder.lazyByteString - pushByte = flip LBS.cons - pushByteEnd = LBS.snoc - takeBytes k = LBS.take $ fromIntegral k - takeBytesEnd k = LBS.takeEnd $ fromIntegral k - dropBytes k = LBS.drop $ fromIntegral k - dropBytesEnd k = LBS.dropEnd $ fromIntegral k - spanBytes = LBS.span - spanBytesEnd = LBS.spanEnd - splitAtByte k = LBS.splitAt $ fromIntegral k - replicateByte k = LBS.replicate $ fromIntegral k - unpackValue = - -- From LSB to MSB, OR the current byte and shift the total bits. - LBS.foldl' (\bits byte -> (bits .<<. 8) .|. fromIntegral byte) 0 - . LBS.dropWhile (== 0) - --- | Implements binary decoder for ShortByteString, best for compact data that --- doesn't exist long in memory. Notably, it packs better in memory than normal --- ByteString (prone to Heap Fragmentation). --- https://hackage-content.haskell.org/package/bytestring-0.12.2.0/docs/Data-ByteString-Short.html#g:1 -instance BinaryTranscoder ShortByteString where - lengthBytes = SBS.length - packBytes = SBS.pack - unpackBytes = SBS.unpack - serializeValue = Builder.shortByteString - pushByte = flip SBS.cons - pushByteEnd = SBS.snoc - takeBytes = SBS.take - takeBytesEnd = SBS.takeEnd - dropBytes = SBS.drop - dropBytesEnd = SBS.dropEnd - spanBytes = SBS.span - spanBytesEnd = SBS.spanEnd - splitAtByte = SBS.splitAt - replicateByte k = SBS.replicate $ fromIntegral k - unpackValue = - -- From LSB to MSB, OR the current byte and shift the total bits. - SBS.foldl' (\bits byte -> (bits .<<. 8) .|. fromIntegral byte) 0 - . SBS.dropWhile (== 0) diff --git a/basesystems/Data/BaseSystem/DigitSystem.hs b/basesystems/Data/BaseSystem/DigitSystem.hs deleted file mode 100644 --- a/basesystems/Data/BaseSystem/DigitSystem.hs +++ /dev/null @@ -1,191 +0,0 @@ --- | Module : Data.BaseSystem.DigitSystem --- Description : Implements DigitSystems for DigitTranscoders --- Copyright : Zoey McBride (c) 2026 --- License : BSD-3-Clause --- Maintainer : zoeymcbride@mailbox.org --- Stability : experimental -module Data.BaseSystem.DigitSystem - ( -- * Abstract DigitSystems data types - RadixDigits (RadixDigits), - BitwiseDigits (BitwiseDigits), - - -- * Data member of BitwiseDigits. Determines how to post process encodings. - PaddingMethod (paddingChar, paddingResolve), - - -- * Concrete instances of DigitSystems - base2, - base10, - base16lower, - base16upper, - base32lower, - base32lowerNP, - base32upper, - base32upperNP, - base32hexlower, - base32hexlowerNP, - base32hexupper, - base32hexupperNP, - base58btc, - base64, - base64NP, - base64url, - base64urlNP, - ) -where - -import Data.BaseSystem.Alphabet (Alphabet) -import Data.BaseSystem.Alphabet qualified as ABCs -import Data.Text (Text) -import Data.Text qualified as Text - --- | Implements BaseSystem over base radix modulus. -data RadixDigits = RadixDigits - { -- | Used to implement instance of Show. - radixShow :: String, - -- | Alphabet for the base system. - radixAlpha :: Alphabet - } - -instance Show RadixDigits where - show = radixShow - --- | Implements padding for encoding BitwiseDigits. -data PaddingMethod = PaddingMethod - { -- | Gives the char to use as padding. - paddingChar :: Char, - -- | Provides the callback to resolve the padding from # of bytes. - paddingResolve :: Int -> Text - } - --- | Implements BaseSystem over series of bit groups. -data BitwiseDigits = BitwiseDigits - { -- | String used to implement instance of Show. - bitwiseShow :: String, - -- | Base system alphabet. - bitwiseAlpha :: Alphabet, - -- | # of bits per symbol - bitwiseSymBits :: Int, - -- | # of bytes to be processed into symbols in encoding. - bitwiseGroupBytes :: Int, - -- | # of bytes forming a group to find padding in decoding. - bitwiseGroupSymbols :: Int, - -- | Gives the method for padding. - bitwisePadMethod :: Maybe PaddingMethod - } - -instance Show BitwiseDigits where - show = bitwiseShow - --- | Provides methods for building a base32 system, with an option to toggle --- padding. -mkBaseSystem32 :: String -> Maybe Char -> Alphabet -> BitwiseDigits -mkBaseSystem32 name padchar abc = - BitwiseDigits name abc symbits groupbytes groupsymbols $ - PaddingMethod <*> padImpl <$> padchar - where - groupbytes = 5 - groupsymbols = 8 - symbits = 5 - padImpl padding bytestotal - | bytestotal > 5 = padImpl padding $ bytestotal `mod` symbits - | bytestotal == 4 = Text.singleton padding - | bytestotal == 3 = Text.pack (replicate 3 padding) - | bytestotal == 2 = Text.pack (replicate 4 padding) - | bytestotal == 1 = Text.pack (replicate 6 padding) - | otherwise = Text.empty - --- | Provides methods for building a base64 system, with an option to toggle --- padding. -mkBaseSystem64 :: String -> Maybe Char -> Alphabet -> BitwiseDigits -mkBaseSystem64 name padchar abc = - BitwiseDigits name abc symbits groupbytes groupsymbols $ - PaddingMethod <*> padImpl <$> padchar - where - groupbytes = 3 - groupsymbols = 4 - symbits = 6 - padImpl padding bytestotal - | bytestotal > 3 = padImpl padding $ bytestotal `mod` groupbytes - | bytestotal == 2 = Text.singleton padding - | bytestotal == 1 = Text.pack [padding, padding] - | otherwise = Text.empty - --- | Defines the BaseSystem for binary. -base2 :: RadixDigits -base2 = RadixDigits "base2" ABCs.binary - --- | Defines base10 as RadixDigits. -base10 :: RadixDigits -base10 = RadixDigits "base10" ABCs.decimal - --- | Defines Bitcoin's base58 implementation. -base58btc :: RadixDigits -base58btc = RadixDigits "base58btc" ABCs.btc58 - --- | Defines uppercase hexidecimal on BitwiseDigits. -base16upper :: RadixDigits -base16upper = RadixDigits "base16upper" ABCs.hexupper - --- | Defines lowercase hexadecimal on BitwiseDigits. -base16lower :: RadixDigits -base16lower = RadixDigits "base16lower" ABCs.hexlower - --- | Defines lowercase base32 from RFC4648, with padding. --- https://datatracker.ietf.org/doc/html/rfc4648.html#section-6 -base32lower :: BitwiseDigits -base32lower = mkBaseSystem32 "base32lower" (Just '=') ABCs.b32lower - --- | Defines lowercase base32 from RFC4648. No padding! --- https://datatracker.ietf.org/doc/html/rfc4648.html#section-6 -base32lowerNP :: BitwiseDigits -base32lowerNP = mkBaseSystem32 "base32lowerNP" Nothing ABCs.b32lower - --- | Defines uppercase base32 from RFC4648, with padding. --- https://datatracker.ietf.org/doc/html/rfc4648.html#section-6 -base32upper :: BitwiseDigits -base32upper = mkBaseSystem32 "base32upper" (Just '=') ABCs.b32upper - --- | Defines uppercase base32 from RFC4648. No padding! --- https://datatracker.ietf.org/doc/html/rfc4648.html#section-6 -base32upperNP :: BitwiseDigits -base32upperNP = mkBaseSystem32 "base32upperNP" Nothing ABCs.b32upper - --- | Defines lowercase base32 from RFC4648, extended hex version, with padding. --- https://datatracker.ietf.org/doc/html/rfc4648.html#section-7 -base32hexlower :: BitwiseDigits -base32hexlower = mkBaseSystem32 "base32hexlower" (Just '=') ABCs.b32hexlower - --- | Defines lowercase base32 from RFC4648, extended hex version. No padding! --- https://datatracker.ietf.org/doc/html/rfc4648.html#section-7 -base32hexlowerNP :: BitwiseDigits -base32hexlowerNP = mkBaseSystem32 "base32hexlowerNP" Nothing ABCs.b32hexlower - --- | Defines lowercase base32 from RFC4648, extended hex version, with padding. --- https://datatracker.ietf.org/doc/html/rfc4648.html#section-7 -base32hexupper :: BitwiseDigits -base32hexupper = mkBaseSystem32 "base32hexupper" (Just '=') ABCs.b32hexupper - --- | Defines uppercase base32 from RFC4648, extended hex version. No padding! --- https://datatracker.ietf.org/doc/html/rfc4648.html#section-7 -base32hexupperNP :: BitwiseDigits -base32hexupperNP = mkBaseSystem32 "base32hexupperNP" Nothing ABCs.b32hexupper - --- | Defines base64 from RFC4648, with padding. --- https://datatracker.ietf.org/doc/html/rfc4648.html#section-4 -base64 :: BitwiseDigits -base64 = mkBaseSystem64 "base64" (Just '=') ABCs.b64 - --- | Defines base64 from RFC4648. No padding! --- https://datatracker.ietf.org/doc/html/rfc4648.html#section-4 -base64NP :: BitwiseDigits -base64NP = mkBaseSystem64 "base64NP" Nothing ABCs.b64 - --- | Defines URL safe base64 from RFC4648, with padding. --- https://datatracker.ietf.org/doc/html/rfc4648.html#section-5 -base64url :: BitwiseDigits -base64url = mkBaseSystem64 "base64url" (Just '=') ABCs.b64url - --- | Defines URL safe base64 from RFC4648. No padding! --- https://datatracker.ietf.org/doc/html/rfc4648.html#section-5 -base64urlNP :: BitwiseDigits -base64urlNP = mkBaseSystem64 "base64urlNP" Nothing ABCs.b64url diff --git a/basesystems/Data/BaseSystem/DigitTranscoder.hs b/basesystems/Data/BaseSystem/DigitTranscoder.hs deleted file mode 100644 --- a/basesystems/Data/BaseSystem/DigitTranscoder.hs +++ /dev/null @@ -1,226 +0,0 @@ --- | Module : Data.BaseSystem.DigitTranscoder --- Description : Implements BaseSystems for strict ByteStrings. --- Copyright : Zoey McBride (c) 2026 --- License : BSD-3-Clause --- Maintainer : zoeymcbride@mailbox.org --- Stability : experimental -module Data.BaseSystem.DigitTranscoder - ( DigitTranscoder (digitEncoder, digitDecoder), - Encoder, - Decoder, - ) -where - -import Control.Monad (foldM) -import Data.BaseSystem.Alphabet (Alphabet) -import Data.BaseSystem.Alphabet qualified as Alpha -import Data.BaseSystem.BinaryTranscoder (BinaryTranscoder, BitSet) -import Data.BaseSystem.BinaryTranscoder qualified as BXC -import Data.BaseSystem.DigitSystem -import Data.BaseSystem.Internal -import Data.Bits ((.&.), (.<<.), (.>>.), (.|.)) -import Data.Maybe (fromJust, fromMaybe) -import Data.Text (Text) -import Data.Text qualified as Text - --- | Functor applies when in context of a BaseSystem decoder implementation that --- requires modifications to the entire bitset before converting to ByteString. -type FinalizeContext = Maybe (BitSet -> BitSet) - --- | Builds symbols from a number in decoding. --- https://en.wikipedia.org/wiki/Finite-state_machine#Mathematical_model -type DeltaFunction = BitSet -> Alpha.Symbol -> Maybe BitSet - --- | Using a transition function `delta`, build an BitSet into bytes data --- `bxc`, and use a final BitSet context to align the BitSet's bit contents. -{-# INLINE binaryDecoder #-} -binaryDecoder :: - (BinaryTranscoder bxc) => - Text -> - FinalizeContext -> - DeltaFunction -> - Maybe bxc -binaryDecoder text finalize delta - | Text.null text = Nothing - | otherwise = do - -- For each symbol, build the bitvalue using the delta function if the - -- symbol is valid. - bitvalue <- foldM delta 0 $ Text.unpack text - -- Apply the finalizer to the bits and put it into a transcoder - return $ BXC.packValue (applyFinalize bitvalue) - where - -- If finalize exists, apply it, otherwise return the unchanged value. - applyFinalize value = fromMaybe value $ finalize <*> Just value - --- | Type alias for curried DigitTranscoder digitEncoder function. -type Encoder t = t -> Text - --- | Type alias for curried DigitTranscoder digitDecoder function. -type Decoder t = Text -> Maybe t - --- | Type-class (interface) for implementing encode/decode functionality for --- some data structure w/ Alphabet `a`. -class (BinaryTranscoder t) => DigitTranscoder a t where - -- | Method signature for encoding some ByteString to String of digits. - digitEncoder :: a -> t -> Text - - -- | Method signature for decoding some String of digits to ByteString, given - -- all digits in String are valid Symbols. - digitDecoder :: a -> Text -> Maybe t - --- | Implements BaseSystem for number systems built by modular arithmetic w/ the --- radix. -instance (BinaryTranscoder t) => DigitTranscoder RadixDigits t where - -- Encodes the value by converting the ByteString to Integer and repeatedly - -- applying `divMod` until the quotient is zero. - digitEncoder (RadixDigits _ abc) = - let radix = fromIntegral $ Alpha.alphaRadix abc - in Text.pack - . divModSymbols - . takeWhile divModContinue - . iterateInit (\(num, _) -> num `divMod` radix) mkDivMod - . BXC.unpackValue - where - -- Initial value to iterate on divMod. - mkDivMod numerator = (numerator, 0) - -- Predicates divMod iteration results. - divModContinue (nextinput, curresult) = nextinput > 0 || curresult > 0 - -- Resolves the symbols from the result of iterating divMod. - divModSymbols = - reverse - . fromJust - . mapM (\(_, digit) -> Alpha.resolveSymbol abc $ fromIntegral digit) - . replaceNull [(undefined, 0)] - - -- Decodes the value by multiplying the radix with the current integer state - -- and adding the value. That value is decode directly, no finalization - -- needed. - digitDecoder (RadixDigits _ abc) text = - let radix = fromIntegral $ Alpha.alphaRadix abc - in binaryDecoder text Nothing $ - \curvalue symbol -> do - value <- fromIntegral <$> Alpha.resolveValue abc symbol - return $ - curvalue * radix + value - --- | Implements encoder/decoder for a BitwiseDigits. -instance (BinaryTranscoder t) => DigitTranscoder BitwiseDigits t where - -- Encodes the input bytes by grouping into `groupsize` sized windows, then - -- batch resolving the String of Symbols from each group, then resolve the - -- correct padding chars from the number of bytes and append that to the - -- encoder result. - digitEncoder (BitwiseDigits _ abc symbits groupsize _ padmethod) input = - let -- Total # of bytes from input. - bytestotal = BXC.lengthBytes input - -- Total # of bits from input. - bitstotal = fromIntegral (8 * bytestotal) :: Double - -- Actual # of symbols for the # of bits in bytes. - numsymbols = ceiling (bitstotal / fromIntegral symbits) - -- Minimum # of symbols to put in the resulting string. - putsymbols = max 2 numsymbols - in paddingAppend (fromIntegral bytestotal) - . take putsymbols - . concatMap groupSyms - . takeWhile (\(group, _) -> BXC.lengthBytes group > 0) - . iterateInit (\(_, rest) -> BXC.splitAtByte groupsize rest) mkSplit - $ minimalBytes bytestotal - where - -- Inits the iteration for Bytes.splitAt. - mkSplit initial = (BXC.empty, initial) - -- Gives the minimal amount of bytes to produce a correct encoding. It's - -- here to maintain compatablity with other encoders. - {-# INLINE minimalBytes #-} - minimalBytes bytestotal - | bytestotal == 0 = BXC.packBytes [0, 0] - | bytestotal == 1 = BXC.pushByteEnd input 0 - | bytesmodulus /= 0 = BXC.append input (BXC.replicateByte zeros 0) - | otherwise = input - where - bytesmodulus = fromIntegral (bytestotal `mod` fromIntegral groupsize) - zeros = groupsize - bytesmodulus - -- Gets the symbols for the byte group. - groupSyms (group, _) = groupSymbols abc group groupsize symbits - -- Appends the padding chars to the end of a list of symbols, when the - -- padding method exists and gives back a string for the bytestotal - paddingAppend bytestotal syms = - let padapply = paddingResolve <$> padmethod <*> Just bytestotal - in Text.append (Text.pack syms) (fromMaybe Text.empty padapply) - - -- Decodes the text by filtering out padding resolving each symbol and then - -- shifting the value by the #bits per symbol and ORing the value in place. - -- Finally, it needs to be aligned to the top of byte in memory so the value - -- is represented correctly. - digitDecoder (BitwiseDigits _ abc symbits _ groupsyms padmethod) text = - let -- Gives just padding char if not nothing. - padsym = paddingChar <$> padmethod - -- Removes the trailing padding chars from the Text of str. - notrailing = Text.dropWhileEnd (\sym -> Just sym == padsym) text - -- Gives the total available characters. - totalsyms = Text.length notrailing - -- Finds the needs # of symbols for the final padding chars. - needsyms = groupsyms - (totalsyms `mod` groupsyms) - in binaryDecoder notrailing (finalizeBits needsyms) $ - \curvalue symbol -> - if Just symbol == padsym - -- When the symbol is the padding char, shift an empty value - then return (curvalue .<<. symbits) - -- Otherwise put the value in place - else do - value <- fromIntegral <$> Alpha.resolveValue abc symbol - return $ (curvalue .<<. symbits) .|. value - where - -- Finds the value for the expected amount of padding regardless if the - -- BaseSystem has a PaddingMethod or not. - {-# INLINE finalizeBits #-} - finalizeBits needsyms - -- If the # of Symbols in last group is the groupsyms size, pass - | needsyms == groupsyms = Nothing - -- Find the needed # of bits and align the output to first byte. - | otherwise = Just $ \final -> final .<<. needbits .>>. pagealign - where - -- Gives the number of bits to correct in missing final padding chars. - needbits = needsyms * symbits - -- Offset to Integer to align the bits in the final ByteString at the - -- start of a byte in memory. - pagealign = 8 * ceiling (fromIntegral needbits / 8 :: Double) - --- | Resolves symbols from Alphabet for a BitwiseSystem's encoder. Partitions --- a ByteString into N sized bitgroups where N is the bitwidth of the --- Alphabet's radix. *IMPORTANT*: this function requires the groupsize to be --- a multiple of two because it generates a mask from subtracting it by 1. -groupSymbols :: - (BinaryTranscoder bxc) => Alphabet -> bxc -> Int -> Int -> [Alpha.Symbol] -groupSymbols abc grouping groupsize symbits = - let groupint = - case BXC.unpackValue grouping of - bits - | fitsBitGroup groupsize grouping bits -> fromIntegral bits - | otherwise -> error "invalid group size" - in -- Crash if the implementation isn't complete - fromJust - -- Extract the value from the shift and resolve its symbol. - . mapM (Alpha.resolveSymbol abc . valueExtract . nextInt groupint) - -- Take all non-zero shifts. - . takeWhile (>= 0) - -- Generate a list of shift values from the # bits in groupbytes. - $ iterateInit shiftValue mkBitLength grouping - where - -- Gets the next int to extract group. - nextInt groupint shift = groupint .>>. shift - -- Extracts the first group from LSB from an Int. - valueExtract int = fromIntegral $ int .&. (Alpha.alphaRadix abc - 1) - -- Finds the length in bits of a ByteString. - mkBitLength bstr = fromIntegral $ 8 * BXC.lengthBytes bstr - -- Gives the current shift value in iteration. - shiftValue bitstotal = bitstotal - symbits - --- Checks if an Integral a fits within a BitwiseSystem's group. -{-# INLINE fitsBitGroup #-} -fitsBitGroup :: (BinaryTranscoder bxc, Integral i) => Int -> bxc -> i -> Bool -fitsBitGroup groupsize bxcdata groupbits = - BXC.lengthBytes bxcdata <= fromIntegral groupsize - && minInt <= groupbits - && groupbits <= maxInt - where - minInt = fromIntegral (minBound :: Int) - maxInt = fromIntegral (maxBound :: Int) diff --git a/basesystems/Data/BaseSystem/Internal.hs b/basesystems/Data/BaseSystem/Internal.hs deleted file mode 100644 --- a/basesystems/Data/BaseSystem/Internal.hs +++ /dev/null @@ -1,25 +0,0 @@ --- | Module : Data.BaseSystem.Internal --- Description : Provides common resources for multibase --- Copyright : Zoey McBride (c) 2026 --- License : BSD-3-Clause --- Maintainer : zoeymcbride@mailbox.org --- Stability : experimental --- --- Common data definitions and helper functions for this library. -module Data.BaseSystem.Internal - ( -- * List utilities - replaceNull, - iterateInit, - ) -where - --- | Return the the first param if the second param is empty. -{-# INLINE replaceNull #-} -replaceNull :: [a] -> [a] -> [a] -replaceNull replace xs - | null xs = replace - | otherwise = xs - --- | Wraps iterate to compose with an intermediary type constructor. -iterateInit :: (b -> b) -> (a -> b) -> a -> [b] -iterateInit f iterinit = drop 1 . iterate f . iterinit diff --git a/basesystems/Data/BaseSystem/Lazy.hs b/basesystems/Data/BaseSystem/Lazy.hs deleted file mode 100644 --- a/basesystems/Data/BaseSystem/Lazy.hs +++ /dev/null @@ -1,47 +0,0 @@ --- | Module : Data.BaseSystem.Lazy --- Description : Implements BaseSystems for LazyByteString. --- Copyright : Zoey McBride (c) 2026 --- License : BSD-3-Clause --- Maintainer : zoeymcbride@mailbox.org --- Stability : experimental -module Data.BaseSystem.Lazy - ( -- * BaseSystems on LazyByteString. - BaseSystem (encoder, decoder), - - -- * Function signatures aliases. - Encoder, - Decoder, - - -- * ByteString implementation for this file. - ByteStr, - ) -where - -import Data.BaseSystem.DigitSystem (BitwiseDigits, RadixDigits) -import Data.BaseSystem.DigitTranscoder qualified as DXC -import Data.ByteString.Lazy (LazyByteString) -import Data.Text (Text) - --- | Sets the bytestring type to use in this file. -type ByteStr = LazyByteString - --- | Alias for curried encoder method. -type Encoder = ByteStr -> Text - --- | Alias for curried decoder method. -type Decoder = Text -> Maybe ByteStr - --- | Configures the BaseSystem for this file's ByteType. -class BaseSystem a where - encoder :: a -> ByteStr -> Text - decoder :: a -> Text -> Maybe ByteStr - --- | BaseSystem for LazyByteString. -instance BaseSystem RadixDigits where - encoder = DXC.digitEncoder - decoder = DXC.digitDecoder - --- | BaseSystem for LazyByteString. -instance BaseSystem BitwiseDigits where - encoder = DXC.digitEncoder - decoder = DXC.digitDecoder diff --git a/basesystems/Data/BaseSystem/Strict.hs b/basesystems/Data/BaseSystem/Strict.hs deleted file mode 100644 --- a/basesystems/Data/BaseSystem/Strict.hs +++ /dev/null @@ -1,47 +0,0 @@ --- | Module : Data.BaseSystem.Strict --- Description : Implements BaseSystems for strict ByteStrings. --- Copyright : Zoey McBride (c) 2026 --- License : BSD-3-Clause --- Maintainer : zoeymcbride@mailbox.org --- Stability : experimental -module Data.BaseSystem.Strict - ( -- * BaseSystems on ByteString - BaseSystem (encoder, decoder), - - -- * Function signatures aliases. - Encoder, - Decoder, - - -- * ByteString implementation for this file - ByteStr, - ) -where - -import Data.BaseSystem.DigitSystem (BitwiseDigits, RadixDigits) -import Data.BaseSystem.DigitTranscoder qualified as DXC -import Data.ByteString (ByteString) -import Data.Text (Text) - --- | Sets the bytestring type to use in this file. -type ByteStr = ByteString - --- | Alias for curried encoder method. -type Encoder = ByteStr -> Text - --- | Alias for curried decoder method. -type Decoder = Text -> Maybe ByteStr - --- | Configures the BaseSystem for this file's ByteType. -class BaseSystem a where - encoder :: a -> ByteStr -> Text - decoder :: a -> Text -> Maybe ByteStr - --- | BaseSystem for ByteString. -instance BaseSystem RadixDigits where - encoder = DXC.digitEncoder - decoder = DXC.digitDecoder - --- | BaseSystem for ByteString. -instance BaseSystem BitwiseDigits where - encoder = DXC.digitEncoder - decoder = DXC.digitDecoder diff --git a/basesystems/Data/BaseSystems.hs b/basesystems/Data/BaseSystems.hs new file mode 100644 --- /dev/null +++ b/basesystems/Data/BaseSystems.hs @@ -0,0 +1,51 @@ +-- | Module : Data.BaseSystems +-- Description : Implements BaseSystems for ShortByteString. +-- Copyright : Zoey McBride (c) 2026 +-- License : BSD-3-Clause +-- Maintainer : zoeymcbride@mailbox.org +-- Stability : experimental +module Data.BaseSystems + ( -- * BaseSystems on ShortByteString. + BaseSystem (encoder, decoder), + + -- * Function signatures aliases. + Encoder, + Decoder, + + -- * ByteString implementation for this file. + ByteStr, + + -- * Exported basesystem defintions + module Data.BaseSystems.DigitSystems, + ) +where + +import Data.BaseSystems.DigitSystems +import Data.BaseSystems.DigitTranscoder (BitwiseDigits, RadixDigits) +import Data.BaseSystems.DigitTranscoder qualified as DXC +import Data.ByteString.Short (ShortByteString) +import Data.Text (Text) + +-- | Sets the bytestring type to use in this file. +type ByteStr = ShortByteString + +-- | Alias for curried encoder method. +type Encoder = ByteStr -> Text + +-- | Alias for curried decoder method. +type Decoder = Text -> Maybe ByteStr + +-- | Configures the BaseSystem for this file's ByteType. +class BaseSystem a where + encoder :: a -> ByteStr -> Text + decoder :: a -> Text -> Maybe ByteStr + +-- | BaseSystem for ShortByteString. +instance BaseSystem RadixDigits where + encoder = DXC.digitEncoder + decoder = DXC.digitDecoder + +-- | BaseSystem for ShortByteString. +instance BaseSystem BitwiseDigits where + encoder = DXC.digitEncoder + decoder = DXC.digitDecoder diff --git a/basesystems/Data/BaseSystems/Alphabet.hs b/basesystems/Data/BaseSystems/Alphabet.hs new file mode 100644 --- /dev/null +++ b/basesystems/Data/BaseSystems/Alphabet.hs @@ -0,0 +1,177 @@ +-- | Module : Data.BaseSystems.Alphabet +-- Description : Functions for Alphabets on BaseSystems +-- Copyright : Zoey McBride (c) 2026 +-- License : BSD-3-Clause +-- Maintainer : zoeymcbride@mailbox.org +-- Stability : experimental +-- +-- Implements digit alphabets for BaseSystems. +module Data.BaseSystems.Alphabet + ( -- * Symbolic representation of a value + Symbol, + + -- * The value that's given to each digit + Value, + + -- * Abstract Alphabet and functions + Alphabet (alphaRadix, alphaHashId), + mkAlphabet, + resolveValue, + resolveSymbol, + + -- * Available Alphabets + binary, + decimal, + hexlower, + hexupper, + btc58, + b32lower, + b32upper, + b32hexlower, + b32hexupper, + b64, + b64url, + ) +where + +import Data.Array.IArray qualified as Array +import Data.Array.Unboxed (UArray, (!?)) +import Data.Char (ord) +import Data.Function (on) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Word (Word32) + +-- TODO: Another module for alphabets with symbols of multiple unicode code +-- points should be made. Then a DigitSystem can be built off that for +-- basesystems of multipoint symbols. + +-- | Represents a symbol to act as a digit in a numbering system. +type Symbol = Char + +-- | The value of a symbol in a number system. +type Value = Word32 + +-- | Stores the String hash for an Alphabet. Used for comparision. +type HashId = Int + +-- | Represents a two-way mapping between symbol's values and values's symbols. +data Alphabet = Alphabet + { alphaRadix :: Int, + alphaHashId :: HashId, + alphaValues :: UArray Value Symbol, + alphaSymbols :: Map Symbol Value + } + +instance Eq Alphabet where + (==) = (==) `on` alphaHashId + +instance Ord Alphabet where + compare = compare `on` alphaHashId + +-- | Implements https://cp-algorithms.com/string/string-hashing.html +mkHashId :: Text -> HashId +mkHashId = snd . Text.foldr buildPolynomial (0 :: Integer, 0 :: HashId) + where + -- Should be around of characters in any given alphabet + baseprime = 53 + -- Large prime to prevent most collisions (1/modprime chance) + modprime = 1_000_009 + -- Produces the term for a given character + buildPolynomial ch (expvalue, polysum) = + let term = baseprime ^ expvalue * ord ch + next = polysum + term + in (expvalue + 1, next `mod` modprime) + +-- | Creates an Alphabet from Text using its Chars as Symbols. +mkAlphabet :: Text -> Alphabet +mkAlphabet text = + let symbols = Text.unpack text + numsymbols = Text.length text + maxdigit = fromIntegral $ numsymbols - 1 + in Alphabet + { alphaRadix = numsymbols, + alphaHashId = mkHashId text, + alphaValues = Array.listArray (0, maxdigit) symbols, + alphaSymbols = Map.fromList $ zip symbols [0 ..] + } + +-- | /O(log n)/ Find a value from a symbol in an alphabet. +resolveValue :: Alphabet -> Symbol -> Maybe Value +resolveValue abc symbol = Map.lookup symbol $ alphaSymbols abc + +-- | /O(1)/ Find a symbol from a value in an alphabet. +resolveSymbol :: Alphabet -> Value -> Maybe Symbol +resolveSymbol abc value = alphaValues abc !? value + +-- | Constructs an Alphabet from a list of digit symbol strings. +mk :: [[Char]] -> Alphabet +mk = mkAlphabet . Text.pack . concat + +-- | Defines base 2. +binary :: Alphabet +binary = mk ["01"] + +-- | Defines base 10. +decimal :: Alphabet +decimal = mk ["0", ['1' .. '9']] + +-- | Defines base 16 upper-case. +hexupper :: Alphabet +hexupper = mk ["0", ['1' .. '9'], ['A' .. 'F']] + +-- | Defines base 16 lower-case. +hexlower :: Alphabet +hexlower = mk ["0", ['1' .. '9'], ['a' .. 'f']] + +-- | Defines base 58, bitcoin variant. +btc58 :: Alphabet +btc58 = + mk + [ ['1' .. '9'], + ['A' .. 'H'], + ['J' .. 'N'], + ['P' .. 'Z'], + ['a' .. 'k'], + ['m' .. 'z'] + ] + +-- | Defines base32, upper-case. +b32upper :: Alphabet +b32upper = mk [['A' .. 'Z'], ['2' .. '7']] + +-- | Defines base32, lower-case. +b32lower :: Alphabet +b32lower = mk [['a' .. 'z'], ['2' .. '7']] + +-- | Defines base32 hexadecimal, upper-case. +b32hexupper :: Alphabet +b32hexupper = mk ["0", ['1' .. '9'], ['A' .. 'V']] + +-- | Defines base32 hexadecimal, lower-case. +b32hexlower :: Alphabet +b32hexlower = mk ["0", ['1' .. '9'], ['a' .. 'v']] + +-- | Defines default base64 with + and /. +b64 :: Alphabet +b64 = + mk + [ ['A' .. 'Z'], + ['a' .. 'z'], + "0", + ['1' .. '9'], + ['+', '/'] + ] + +-- | Defines URL-safe base64 with - and _. +b64url :: Alphabet +b64url = + mk + [ ['A' .. 'Z'], + ['a' .. 'z'], + "0", + ['1' .. '9'], + ['-', '_'] + ] diff --git a/basesystems/Data/BaseSystems/DigitSystems.hs b/basesystems/Data/BaseSystems/DigitSystems.hs new file mode 100644 --- /dev/null +++ b/basesystems/Data/BaseSystems/DigitSystems.hs @@ -0,0 +1,145 @@ +-- | Module : Data.BaseSystems.DigitSystems +-- Description : Implements DigitSystems for DigitTranscoders +-- Copyright : Zoey McBride (c) 2026 +-- License : BSD-3-Clause +-- Maintainer : zoeymcbride@mailbox.org +-- Stability : experimental +module Data.BaseSystems.DigitSystems + ( base2, + base10, + base16lower, + base16upper, + base32lower, + base32lowerNP, + base32upper, + base32upperNP, + base32hexlower, + base32hexlowerNP, + base32hexupper, + base32hexupperNP, + base58btc, + base64, + base64NP, + base64url, + base64urlNP, + ) +where + +import Data.BaseSystems.Alphabet (Alphabet) +import Data.BaseSystems.Alphabet qualified as ABCs +import Data.BaseSystems.DigitTranscoder +import Data.Text qualified as Text + +-- | Provides methods for building a base32 system, with an option to toggle +-- padding. +mkBaseSystem32 :: String -> Maybe Char -> Alphabet -> BitwiseDigits +mkBaseSystem32 name padchar abc = + BitwiseDigits name abc symbits groupbytes groupsymbols $ + PaddingMethod <*> padImpl <$> padchar + where + groupbytes = 5 + groupsymbols = 8 + symbits = 5 + padImpl padding bytestotal + | bytestotal > 5 = padImpl padding $ bytestotal `mod` symbits + | bytestotal == 4 = Text.singleton padding + | bytestotal == 3 = Text.pack (replicate 3 padding) + | bytestotal == 2 = Text.pack (replicate 4 padding) + | bytestotal == 1 = Text.pack (replicate 6 padding) + | otherwise = Text.empty + +-- | Provides methods for building a base64 system, with an option to toggle +-- padding. +mkBaseSystem64 :: String -> Maybe Char -> Alphabet -> BitwiseDigits +mkBaseSystem64 name padchar abc = + BitwiseDigits name abc symbits groupbytes groupsymbols $ + PaddingMethod <*> padImpl <$> padchar + where + groupbytes = 3 + groupsymbols = 4 + symbits = 6 + padImpl padding bytestotal + | bytestotal > 3 = padImpl padding $ bytestotal `mod` groupbytes + | bytestotal == 2 = Text.singleton padding + | bytestotal == 1 = Text.pack [padding, padding] + | otherwise = Text.empty + +-- | Defines the BaseSystem for binary. +base2 :: RadixDigits +base2 = RadixDigits "base2" ABCs.binary + +-- | Defines base10 as RadixDigits. +base10 :: RadixDigits +base10 = RadixDigits "base10" ABCs.decimal + +-- | Defines Bitcoin's base58 implementation. +base58btc :: RadixDigits +base58btc = RadixDigits "base58btc" ABCs.btc58 + +-- | Defines uppercase hexidecimal on BitwiseDigits. +base16upper :: RadixDigits +base16upper = RadixDigits "base16upper" ABCs.hexupper + +-- | Defines lowercase hexadecimal on BitwiseDigits. +base16lower :: RadixDigits +base16lower = RadixDigits "base16lower" ABCs.hexlower + +-- | Defines lowercase base32 from RFC4648, with padding. +-- https://datatracker.ietf.org/doc/html/rfc4648.html#section-6 +base32lower :: BitwiseDigits +base32lower = mkBaseSystem32 "base32lower" (Just '=') ABCs.b32lower + +-- | Defines lowercase base32 from RFC4648. No padding! +-- https://datatracker.ietf.org/doc/html/rfc4648.html#section-6 +base32lowerNP :: BitwiseDigits +base32lowerNP = mkBaseSystem32 "base32lowerNP" Nothing ABCs.b32lower + +-- | Defines uppercase base32 from RFC4648, with padding. +-- https://datatracker.ietf.org/doc/html/rfc4648.html#section-6 +base32upper :: BitwiseDigits +base32upper = mkBaseSystem32 "base32upper" (Just '=') ABCs.b32upper + +-- | Defines uppercase base32 from RFC4648. No padding! +-- https://datatracker.ietf.org/doc/html/rfc4648.html#section-6 +base32upperNP :: BitwiseDigits +base32upperNP = mkBaseSystem32 "base32upperNP" Nothing ABCs.b32upper + +-- | Defines lowercase base32 from RFC4648, extended hex version, with padding. +-- https://datatracker.ietf.org/doc/html/rfc4648.html#section-7 +base32hexlower :: BitwiseDigits +base32hexlower = mkBaseSystem32 "base32hexlower" (Just '=') ABCs.b32hexlower + +-- | Defines lowercase base32 from RFC4648, extended hex version. No padding! +-- https://datatracker.ietf.org/doc/html/rfc4648.html#section-7 +base32hexlowerNP :: BitwiseDigits +base32hexlowerNP = mkBaseSystem32 "base32hexlowerNP" Nothing ABCs.b32hexlower + +-- | Defines lowercase base32 from RFC4648, extended hex version, with padding. +-- https://datatracker.ietf.org/doc/html/rfc4648.html#section-7 +base32hexupper :: BitwiseDigits +base32hexupper = mkBaseSystem32 "base32hexupper" (Just '=') ABCs.b32hexupper + +-- | Defines uppercase base32 from RFC4648, extended hex version. No padding! +-- https://datatracker.ietf.org/doc/html/rfc4648.html#section-7 +base32hexupperNP :: BitwiseDigits +base32hexupperNP = mkBaseSystem32 "base32hexupperNP" Nothing ABCs.b32hexupper + +-- | Defines base64 from RFC4648, with padding. +-- https://datatracker.ietf.org/doc/html/rfc4648.html#section-4 +base64 :: BitwiseDigits +base64 = mkBaseSystem64 "base64" (Just '=') ABCs.b64 + +-- | Defines base64 from RFC4648. No padding! +-- https://datatracker.ietf.org/doc/html/rfc4648.html#section-4 +base64NP :: BitwiseDigits +base64NP = mkBaseSystem64 "base64NP" Nothing ABCs.b64 + +-- | Defines URL safe base64 from RFC4648, with padding. +-- https://datatracker.ietf.org/doc/html/rfc4648.html#section-5 +base64url :: BitwiseDigits +base64url = mkBaseSystem64 "base64url" (Just '=') ABCs.b64url + +-- | Defines URL safe base64 from RFC4648. No padding! +-- https://datatracker.ietf.org/doc/html/rfc4648.html#section-5 +base64urlNP :: BitwiseDigits +base64urlNP = mkBaseSystem64 "base64urlNP" Nothing ABCs.b64url diff --git a/basesystems/Data/BaseSystems/DigitTranscoder.hs b/basesystems/Data/BaseSystems/DigitTranscoder.hs new file mode 100644 --- /dev/null +++ b/basesystems/Data/BaseSystems/DigitTranscoder.hs @@ -0,0 +1,280 @@ +-- | Module : Data.BaseSystems.DigitTranscoder +-- Description : Implements BaseSystems for strict ByteStrings. +-- Copyright : Zoey McBride (c) 2026 +-- License : BSD-3-Clause +-- Maintainer : zoeymcbride@mailbox.org +-- Stability : experimental +module Data.BaseSystems.DigitTranscoder + ( -- * Transcoder interface for encoding/decoding digits from Text. + DigitTranscoder (digitEncoder, digitDecoder), + Encoder, + Decoder, + + -- * Instances of DigitTranscoder + RadixDigits (RadixDigits), + BitwiseDigits (BitwiseDigits), + + -- * Strategy for adding padding for BitwiseDigits in post-processing. + PaddingMethod (PaddingMethod, paddingChar, paddingResolve), + ) +where + +import Control.Monad (foldM) +import Data.BaseSystems.Alphabet (Alphabet) +import Data.BaseSystems.Alphabet qualified as Alpha +import Data.BaseSystems.Internal +import Data.Bits ((.&.), (.<<.), (.>>.), (.|.)) +import Data.Maybe (fromJust, fromMaybe) +import Data.Text (Text) +import Data.Text qualified as Text +import Data.XCodec.BinaryTranscoder (BinaryTranscoder, BitSet) +import Data.XCodec.BinaryTranscoder qualified as BXC +import Data.XCodec.StreamTranscoder (StreamTranscoder (..)) +import Data.XCodec.StreamTranscoder qualified as SXC + +-- | Implements BaseSystem over base radix modulus. +data RadixDigits = RadixDigits + { -- | Used to implement instance of Show. + radixShow :: String, + -- | Alphabet for the base system. + radixAlpha :: Alphabet + } + +instance Show RadixDigits where + show = radixShow + +-- | Implements padding for encoding BitwiseDigits. +data PaddingMethod = PaddingMethod + { -- | Gives the char to use as padding. + paddingChar :: Char, + -- | Provides the callback to resolve the padding from # of bytes. + paddingResolve :: Int -> Text + } + +-- | Implements BaseSystem over series of bit groups. +data BitwiseDigits = BitwiseDigits + { -- | String used to implement instance of Show. + bitwiseShow :: String, + -- | Base system alphabet. + bitwiseAlpha :: Alphabet, + -- | # of bits per symbol + bitwiseSymBits :: Int, + -- | # of bytes to be processed into symbols in encoding. + bitwiseGroupBytes :: Int, + -- | # of bytes forming a group to find padding in decoding. + bitwiseGroupSymbols :: Int, + -- | Gives the method for padding. + bitwisePadMethod :: Maybe PaddingMethod + } + +instance Show BitwiseDigits where + show = bitwiseShow + +-- | Type-alias for curried DigitTranscoder digitEncoder function. +type Encoder bxc = SXC.Encoder bxc Text + +-- | Type-alias for curried DigitTranscoder digitDecoder function. +type Decoder bxc = SXC.Decoder bxc Text + +-- TODO: docstrings +class (BinaryTranscoder bxc) => DigitTranscoder codec bxc where + digitEncoder :: codec -> Encoder bxc + digitDecoder :: codec -> Decoder bxc + +-- TODO: docstrings +instance (BinaryTranscoder bxc) => DigitTranscoder RadixDigits bxc where + digitEncoder = streamEncoder + digitDecoder = streamDecoder + +-- TODO: docstrings +instance (BinaryTranscoder bxc) => DigitTranscoder BitwiseDigits bxc where + digitEncoder = streamEncoder + digitDecoder = streamDecoder + +-- | Functor applies when in context of a BaseSystem decoder implementation that +-- requires modifications to the entire bitset before converting to ByteString. +type FinalizeContext = Maybe (BitSet -> BitSet) + +-- | Builds symbols from a number in decoding. +-- https://en.wikipedia.org/wiki/Finite-state_machine#Mathematical_model +type DeltaFunction = BitSet -> Alpha.Symbol -> Maybe BitSet + +-- | Using a transition function `delta`, build an BitSet into bytes data +-- `bxc`, and use a final BitSet context to align the BitSet's bit contents. +{-# INLINE binaryDecoder #-} +binaryDecoder :: + (BinaryTranscoder bxc) => + Text -> + FinalizeContext -> + DeltaFunction -> + Maybe bxc +binaryDecoder text finalize delta + | Text.null text = Nothing + | otherwise = do + -- For each symbol, build the bitvalue using the delta function if the + -- symbol is valid. + bitvalue <- foldM delta 0 $ Text.unpack text + -- Apply the finalizer to the bits and put it into a transcoder + -- TODO: make endianness a parameter of the decoder + return $ BXC.packValueBE (applyFinalize bitvalue) + where + -- If finalize exists, apply it, otherwise return the unchanged value. + applyFinalize value = fromMaybe value $ finalize <*> Just value + +-- | Implements transcoding binary streams into radix-based number systems, such +-- as base10 or base58btc. +instance (BinaryTranscoder bxc) => StreamTranscoder RadixDigits bxc Text where + -- Encodes the value by converting the ByteString to Integer and repeatedly + -- applying `divMod` until the quotient is zero. + streamEncoder (RadixDigits _ abc) = + let radix = fromIntegral $ Alpha.alphaRadix abc + in Text.pack + . divModSymbols + . takeWhile divModContinue + . iterateInit (\(num, _) -> num `divMod` radix) mkDivMod + . BXC.unpackValueBE + where + -- Initial value to iterate on divMod. + mkDivMod numerator = (numerator, 0) + -- Predicates divMod iteration results. + divModContinue (nextinput, curresult) = nextinput > 0 || curresult > 0 + -- Resolves the symbols from the result of iterating divMod. + divModSymbols = + reverse + . fromJust + . mapM (\(_, digit) -> Alpha.resolveSymbol abc $ fromIntegral digit) + . replaceNull [(undefined, 0)] + + -- Decodes the value by multiplying the radix with the current integer state + -- and adding the value. That value is decode directly, no finalization + -- needed. + streamDecoder (RadixDigits _ abc) text = + let radix = fromIntegral $ Alpha.alphaRadix abc + in binaryDecoder text Nothing $ + \curvalue symbol -> do + value <- fromIntegral <$> Alpha.resolveValue abc symbol + return $ + curvalue * radix + value + +-- | Implements transcoding binary streams into bitwise based number systems, +-- such as base64 and base32 that get digit symbols from grouping bits together. +instance (BinaryTranscoder bxc) => StreamTranscoder BitwiseDigits bxc Text where + -- Encodes the input bytes by grouping into `groupsize` sized windows, then + -- batch resolving the String of Symbols from each group, then resolve the + -- correct padding chars from the number of bytes and append that to the + -- encoder result. + streamEncoder (BitwiseDigits _ abc symbits groupsize _ padmethod) input = + let -- Total # of bytes from input. + bytestotal = BXC.totalOctets input + -- Total # of bits from input. + bitstotal = fromIntegral (8 * bytestotal) :: Double + -- Actual # of symbols for the # of bits in bytes. + numsymbols = ceiling (bitstotal / fromIntegral symbits) + -- Minimum # of symbols to put in the resulting string. + putsymbols = max 2 numsymbols + in paddingAppend (fromIntegral bytestotal) + . take putsymbols + . concatMap groupSyms + . takeWhile (\(group, _) -> BXC.totalOctets group > 0) + . iterateInit (\(_, rest) -> BXC.splitOffset groupsize rest) mkSplit + $ minimalBytes bytestotal + where + -- Inits the iteration for splitOffset. + mkSplit initial = (mempty, initial) + -- Gives the minimal amount of bytes to produce a correct encoding. It's + -- here to maintain compatablity with other encoders. + {-# INLINE minimalBytes #-} + minimalBytes bytestotal + | bytestotal == 0 = BXC.packOctets [0, 0] + | bytestotal == 1 = BXC.pushOctetEnd input 0 + | bytesmodulus /= 0 = input `mappend` BXC.replicateOctet numzeros 0 + | otherwise = input + where + bytesmodulus = fromIntegral (bytestotal `mod` fromIntegral groupsize) + numzeros = groupsize - bytesmodulus + -- Gets the symbols for the byte group. + groupSyms (group, _) = groupSymbols abc group groupsize symbits + -- Appends the padding chars to the end of a list of symbols, when the + -- padding method exists and gives back a string for the bytestotal + paddingAppend bytestotal syms = + let padapply = paddingResolve <$> padmethod <*> Just bytestotal + in Text.append (Text.pack syms) (fromMaybe Text.empty padapply) + + -- Decodes the text by filtering out padding resolving each symbol and then + -- shifting the value by the #bits per symbol and ORing the value in place. + -- Finally, it needs to be aligned to the top of byte in memory so the value + -- is represented correctly. + streamDecoder (BitwiseDigits _ abc symbits _ groupsyms padmethod) text = + let -- Gives just padding char if not nothing. + padsym = paddingChar <$> padmethod + -- Removes the trailing padding chars from the Text of str. + notrailing = Text.dropWhileEnd (\sym -> Just sym == padsym) text + -- Gives the total available characters. + totalsyms = Text.length notrailing + -- Finds the needs # of symbols for the final padding chars. + needsyms = groupsyms - (totalsyms `mod` groupsyms) + in binaryDecoder notrailing (finalizeBits needsyms) $ + \curvalue symbol -> + if Just symbol == padsym + -- When the symbol is the padding char, shift an empty value + then return (curvalue .<<. symbits) + -- Otherwise put the value in place + else do + value <- fromIntegral <$> Alpha.resolveValue abc symbol + return $ (curvalue .<<. symbits) .|. value + where + -- Finds the value for the expected amount of padding regardless if the + -- BaseSystem has a PaddingMethod or not. + {-# INLINE finalizeBits #-} + finalizeBits needsyms + -- If the # of Symbols in last group is the groupsyms size, pass + | needsyms == groupsyms = Nothing + -- Find the needed # of bits and align the output to first byte. + | otherwise = Just $ \final -> final .<<. needbits .>>. pagealign + where + -- Gives the number of bits to correct in missing final padding chars. + needbits = needsyms * symbits + -- Offset to Integer to align the bits in the final ByteString at the + -- start of a byte in memory. + pagealign = 8 * ceiling (fromIntegral needbits / 8 :: Double) + +-- | Resolves symbols from Alphabet for a BitwiseSystem's encoder. Partitions +-- a ByteString into N sized bitgroups where N is the bitwidth of the +-- Alphabet's radix. *IMPORTANT*: this function requires the groupsize to be +-- a multiple of two because it generates a mask from subtracting it by 1. +groupSymbols :: + (BinaryTranscoder bxc) => Alphabet -> bxc -> Int -> Int -> [Alpha.Symbol] +groupSymbols abc grouping groupsize symbits = + let groupint = + case BXC.unpackValueBE grouping of + bits + | fitsBitGroup groupsize grouping bits -> fromIntegral bits + | otherwise -> error "invalid group size" + in -- Crash if the implementation isn't complete + fromJust + -- Extract the value from the shift and resolve its symbol. + . mapM (Alpha.resolveSymbol abc . valueExtract . nextInt groupint) + -- Take all non-zero shifts. + . takeWhile (>= 0) + -- Generate a list of shift values from the # bits in groupbytes. + $ iterateInit shiftValue mkBitLength grouping + where + -- Gets the next int to extract group. + nextInt groupint shift = groupint .>>. shift + -- Extracts the first group from LSB from an Int. + valueExtract int = fromIntegral $ int .&. (Alpha.alphaRadix abc - 1) + -- Finds the length in bits of a ByteString. + mkBitLength bstr = fromIntegral $ 8 * BXC.totalOctets bstr + -- Gives the current shift value in iteration. + shiftValue bitstotal = bitstotal - symbits + +-- Checks if an Integral a fits within a BitwiseSystem's group. +{-# INLINE fitsBitGroup #-} +fitsBitGroup :: (BinaryTranscoder bxc, Integral i) => Int -> bxc -> i -> Bool +fitsBitGroup groupsize bxcdata groupbits = + BXC.totalOctets bxcdata <= fromIntegral groupsize + && minInt <= groupbits + && groupbits <= maxInt + where + minInt = fromIntegral (minBound :: Int) + maxInt = fromIntegral (maxBound :: Int) diff --git a/basesystems/Data/BaseSystems/Internal.hs b/basesystems/Data/BaseSystems/Internal.hs new file mode 100644 --- /dev/null +++ b/basesystems/Data/BaseSystems/Internal.hs @@ -0,0 +1,25 @@ +-- | Module : Data.BaseSystems.Internal +-- Description : Provides common resources for multibase +-- Copyright : Zoey McBride (c) 2026 +-- License : BSD-3-Clause +-- Maintainer : zoeymcbride@mailbox.org +-- Stability : experimental +-- +-- Common data definitions and helper functions for this library. +module Data.BaseSystems.Internal + ( -- * List utilities + replaceNull, + iterateInit, + ) +where + +-- | Return the the first param if the second param is empty. +{-# INLINE replaceNull #-} +replaceNull :: [a] -> [a] -> [a] +replaceNull replace xs + | null xs = replace + | otherwise = xs + +-- | Wraps iterate to compose with an intermediary type constructor. +iterateInit :: (b -> b) -> (a -> b) -> a -> [b] +iterateInit f iterinit = drop 1 . iterate f . iterinit diff --git a/basesystems/Data/BaseSystems/Lazy.hs b/basesystems/Data/BaseSystems/Lazy.hs new file mode 100644 --- /dev/null +++ b/basesystems/Data/BaseSystems/Lazy.hs @@ -0,0 +1,51 @@ +-- | Module : Data.BaseSystems.Lazy +-- Description : Implements BaseSystems for LazyByteString. +-- Copyright : Zoey McBride (c) 2026 +-- License : BSD-3-Clause +-- Maintainer : zoeymcbride@mailbox.org +-- Stability : experimental +module Data.BaseSystems.Lazy + ( -- * BaseSystems on LazyByteString. + BaseSystem (encoder, decoder), + + -- * Function signatures aliases. + Encoder, + Decoder, + + -- * ByteString implementation for this file. + ByteStr, + + -- * Exported basesystem defintions + module Data.BaseSystems.DigitSystems, + ) +where + +import Data.BaseSystems.DigitSystems +import Data.BaseSystems.DigitTranscoder (BitwiseDigits, RadixDigits) +import Data.BaseSystems.DigitTranscoder qualified as DXC +import Data.ByteString.Lazy (LazyByteString) +import Data.Text (Text) + +-- | Sets the bytestring type to use in this file. +type ByteStr = LazyByteString + +-- | Alias for curried encoder method. +type Encoder = ByteStr -> Text + +-- | Alias for curried decoder method. +type Decoder = Text -> Maybe ByteStr + +-- | Configures the BaseSystem for this file's ByteType. +class BaseSystem a where + encoder :: a -> ByteStr -> Text + decoder :: a -> Text -> Maybe ByteStr + +-- | BaseSystem for LazyByteString. +instance BaseSystem RadixDigits where + encoder = DXC.digitEncoder + decoder = DXC.digitDecoder + +-- | BaseSystem for LazyByteString. +instance BaseSystem BitwiseDigits where + encoder = DXC.digitEncoder + decoder = DXC.digitDecoder diff --git a/basesystems/Data/BaseSystems/Strict.hs b/basesystems/Data/BaseSystems/Strict.hs new file mode 100644 --- /dev/null +++ b/basesystems/Data/BaseSystems/Strict.hs @@ -0,0 +1,51 @@ +-- | Module : Data.BaseSystems.Strict +-- Description : Implements BaseSystems for strict ByteStrings. +-- Copyright : Zoey McBride (c) 2026 +-- License : BSD-3-Clause +-- Maintainer : zoeymcbride@mailbox.org +-- Stability : experimental +module Data.BaseSystems.Strict + ( -- * BaseSystems on ByteString + BaseSystem (encoder, decoder), + + -- * Function signatures aliases. + Encoder, + Decoder, + + -- * ByteString implementation for this file + ByteStr, + + -- * Exported basesystem defintions + module Data.BaseSystems.DigitSystems, + ) +where + +import Data.BaseSystems.DigitSystems +import Data.BaseSystems.DigitTranscoder (BitwiseDigits, RadixDigits) +import Data.BaseSystems.DigitTranscoder qualified as DXC +import Data.ByteString (ByteString) +import Data.Text (Text) + +-- | Sets the bytestring type to use in this file. +type ByteStr = ByteString + +-- | Alias for curried encoder method. +type Encoder = ByteStr -> Text + +-- | Alias for curried decoder method. +type Decoder = Text -> Maybe ByteStr + +-- | Configures the BaseSystem for this file's ByteType. +class BaseSystem a where + encoder :: a -> ByteStr -> Text + decoder :: a -> Text -> Maybe ByteStr + +-- | BaseSystem for ByteString. +instance BaseSystem RadixDigits where + encoder = DXC.digitEncoder + decoder = DXC.digitDecoder + +-- | BaseSystem for ByteString. +instance BaseSystem BitwiseDigits where + encoder = DXC.digitEncoder + decoder = DXC.digitDecoder