DigitTranscoder.hs

-- | Module      : MultiFormats.MultiBase.DigitTranscoder
--   Description : Implements Data.BaseSystem.DigitTranscoder for MultiBase
--   Copyright   : Zoey McBride (c) 2026
--   License     : AGPL-3.0-or-later
--   Maintainer  : zoeymcbride@mailbox.org
--   Stability   : experimental
module MultiFormats.MultiBase.DigitTranscoder
  ( -- * Methods on MultiBase systems.
    MultiBase (multibasePrefix),
    mkMultiBase,

    -- * Decoders
    decodeFromPrefix,
    decodeCIDv0,

    -- * Query functions for MultiBase information
    hasValidPrefix,
    resolvePrefix,
    resolveTextPrefix,
  )
where

import Data.BaseSystem.Alphabet qualified as Alpha
import Data.BaseSystem.BinaryTranscoder (BinaryTranscoder)
import Data.BaseSystem.DigitSystem qualified as Digits
import Data.BaseSystem.DigitTranscoder (DigitTranscoder (..))
import Data.ByteString (ByteString)
import Data.Char (ord)
import Data.Function (on)
import Data.IntMap.Lazy (IntMap)
import Data.IntMap.Lazy qualified as IntMap
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Data.Text qualified as Text

-- | Stores a multibase basesystem's prefix and its implementations for
-- digitDecoder/digitEncoder from Data.BaseSystem.DigitTranscoder.
data MultiBase bxc = MultiBase
  { -- | The name of the basesystem for displaying in show (prepends "multi").
    multibaseName :: String,
    -- | The basesystem's idenitifying symbol.
    multibasePrefix :: Alpha.Symbol,
    -- | Encodes the binary transcoder to Text.
    multibaseEncoder :: bxc -> Text,
    -- | Decodes the binary transcoder from Text.
    multibaseDecoder :: Text -> Maybe bxc
  }

-- | Implements equality for multibase on prefixes.
instance Eq (MultiBase bxc) where
  (==) = (==) `on` multibasePrefix

-- | Implements ordering for multibase on prefixes.
instance Ord (MultiBase bxc) where
  compare = compare `on` multibasePrefix

-- | Prepends multi to the basesystem name.
instance Show (MultiBase bxc) where
  show mb = "multi" ++ multibaseName mb

-- | Implements a DigitTranscoder for all MulitBases parameterized by
-- BinaryTranscoder.
instance (BinaryTranscoder bxc) => DigitTranscoder (MultiBase bxc) bxc where
  -- digitEncoder: Use the encoder provided in the MultiBase data.
  digitEncoder = multibaseEncoder

  -- digitDecoder: Ignore the argument and try to decode from text prefix.
  digitDecoder _ = decodeFromPrefix

-- | Provides decoder for MultiBase strings with any implemented prefix
-- character.
decodeFromPrefix :: (BinaryTranscoder bxc) => Text -> Maybe bxc
decodeFromPrefix text = do
  (prefix, rest) <- Text.uncons text
  decode <- multibaseDecoder <$> resolvePrefix prefix
  decode rest

-- | Decodes for CIDv0 from base58btc w/o MultiBase prefix.
decodeCIDv0 :: (BinaryTranscoder bxc) => Text -> Maybe bxc
decodeCIDv0 = digitDecoder Digits.base58btc

-- | Checks if the Text has a valid prefix character.
hasValidPrefix :: Text -> Bool
hasValidPrefix text =
  fromMaybe False $ do
    (ch, _) <- Text.uncons text
    return $ ord ch `IntMap.member` lookupTable
  where
    -- Sets the table to lookup, they all share the same keys, but since it's
    -- a generic type the compiler doesn't know which table to look in, so
    -- we set it here.
    lookupTable = prefixSymbolTable :: IntMap (MultiBase ByteString)

-- | Resolves a MultiBase system from the first Symbol in a String.
resolveTextPrefix :: (BinaryTranscoder bxc) => Text -> Maybe (MultiBase bxc)
resolveTextPrefix text = Text.uncons text >>= \(ch, _) -> resolvePrefix ch

-- | Resolves a MultiBase system from a basesystem prefix Symbol.
resolvePrefix :: (BinaryTranscoder bxc) => Alpha.Symbol -> Maybe (MultiBase bxc)
resolvePrefix prefix = ord prefix `IntMap.lookup` prefixSymbolTable

-- | Creates the lookup table between prefix symbols and multibase systems.
-- Lazy IntMaps get better performance than Lazy Maps for Ints, so we convert
-- the Chars to get the boost.
-- Multibase table:
-- https://github.com/multiformats/multibase/blob/master/multibase.csv
-- Data.Map on IntMap performance:
-- https://hackage-content.haskell.org/package/containers-0.8/docs/Data-Map.html
prefixSymbolTable :: (BinaryTranscoder bxc) => IntMap (MultiBase bxc)
prefixSymbolTable =
  IntMap.fromList
    [ mk '0' Digits.base2,
      mk '9' Digits.base10,
      mk 'f' Digits.base16lower,
      mk 'F' Digits.base16upper,
      mk 'b' Digits.base32lowerNP,
      mk 'B' Digits.base32upperNP,
      mk 'c' Digits.base32lower,
      mk 'C' Digits.base32upper,
      mk 'v' Digits.base32hexlowerNP,
      mk 'V' Digits.base32hexupperNP,
      mk 't' Digits.base32hexlower,
      mk 'T' Digits.base32hexupper,
      mk 'z' Digits.base58btc,
      mk 'm' Digits.base64NP,
      mk 'M' Digits.base64,
      mk 'u' Digits.base64urlNP,
      mk 'U' Digits.base64url
    ]
  where
    -- Creates a lookup table entry from prefix.
    mk prefix digits = (ord prefix, mkMultiBase prefix digits)

-- | Creates a multibase system from a prefix and digit transcoder
-- implementation.
mkMultiBase ::
  (BinaryTranscoder bxc, DigitTranscoder dxc bxc, Show dxc) =>
  Alpha.Symbol ->
  dxc ->
  MultiBase bxc
mkMultiBase prefix digits =
  MultiBase
    { multibaseName = show digits,
      multibasePrefix = prefix,
      multibaseEncoder = digitEncoder digits,
      multibaseDecoder = digitDecoder digits
    }