Encoder.hs

-- | Module      : IPLD.DagCBOR.Encoder
--   Description : Implements DM.Encoder for DAG-CBOR
--   Copyright   : Zoey McBride (c) 2026
--   License     : AGPL-3.0-or-later
--   Maintainer  : zoeymcbride@mailbox.org
--   Stability   : experimental
module IPLD.DagCBOR.Encoder
  ( -- * Encoder output
    DagCBOR,

    -- * Implements `DM.Encoder` class
    Encoder,

    -- * List CBOR encoding
    encodeListKind,
    majorList,

    -- * Key-value pair CBOR encoding
    encodeMapKind,
    majorMap,

    -- * Encoder utilities
    toByteString,
    toDigits,
    toHex,

    -- * Implementing methods
    module IPLD.DM.Encoder,
  )
where

import Control.Applicative (Alternative (..))
import Data.BaseSystems.Lazy (BaseSystem, base16lower)
import Data.BaseSystems.Lazy qualified as Bases
import Data.ByteString.Builder (Builder)
import Data.ByteString.Builder qualified as BSB
import Data.ByteString.Lazy (LazyByteString)
import Data.Text (Text)
import IPLD.DM (Kind (..), ListData, MapData)
import IPLD.DM.Encoder hiding (Encoder)
import IPLD.DM.Encoder qualified as DM
import IPLD.DagCBOR.Encoder.Arguments
import IPLD.DagCBOR.Encoder.CID
import IPLD.DagCBOR.Encoder.Errors
import IPLD.DagCBOR.Encoder.Floats
import IPLD.DagCBOR.Encoder.Ints
import IPLD.DagCBOR.Encoder.SimpleTypes
import IPLD.DagCBOR.Encoder.Strings

-- | Method results from `DM.Encoder`.
type DagCBOR = Encoder Builder

toByteString :: DagCBOR -> Okay LazyByteString
toByteString dagcbor =
  case dagcbor of
    EncoderError err -> Left err
    EncoderValue result -> Right (BSB.toLazyByteString result)

-- | Encodes DagCBOR to a digit string in the provided `BaseSystem`.
toDigits :: (BaseSystem system) => system -> DagCBOR -> Okay Text
toDigits base dagcbor =
  case conv <$> dagcbor of
    EncoderError err -> Left err
    EncoderValue result -> Right result
  where
    conv = Bases.encoder base . BSB.toLazyByteString

-- | Encodes DagCBOR to hexadecimal string.
toHex :: DagCBOR -> Okay Text
toHex = toDigits base16lower

-- | Provides a Encoder implementation for DAG-CBOR.
data Encoder encoded
  = -- | An encoded value result.
    EncoderValue encoded
  | -- | For the `empty` object in the `Alternative` class.
    EncoderError Error
  deriving (Show, Eq)

-- | Pattern synonym for the `Alternative` `empty` object.
pattern EncoderEmpty :: forall encoded. Encoder encoded
pattern EncoderEmpty = EncoderError EmptyAlternative

-- | Converts `Okay` functor into `Encoder` functor.
{-# INLINE okay #-}
okay :: Okay t -> Encoder t
okay = either EncoderError EncoderValue

-- | Encodes the given IPLD node into DAG-CBOR binary format.
-- https://ipld.io/specs/codecs/dag-cbor/spec/
instance DM.Encoder Encoder where
  intKind (IntKind int) = okay (encodeIntKind int)
  intKind _ = empty

  bytesKind (BytesKind bytes) = okay (encodeBytesKind bytes)
  bytesKind _ = empty

  stringKind (StringKind string) = okay (encodeStringKind string)
  stringKind _ = empty

  listKind (ListKind list) = encodeListKind list
  listKind _ = empty

  mapKind (MapKind dict) = encodeMapKind dict
  mapKind _ = empty

  resourceKind (ResourceKind cid) = okay (encodeResourceKind cid)
  resourceKind _ = empty

  floatKind (FloatKind float) = pure (encodeFloatKind float)
  floatKind _ = empty

  boolKind (BoolKind bool) = pure (encodeBoolKind bool)
  boolKind _ = empty

  nullKind NullKind = pure encodeNullKind
  nullKind _ = empty

-- | Implements function injection (fmap) into some encoder process.
instance Functor Encoder where
  -- Applies `f` to the encoded value if it exists
  {-# INLINE fmap #-}
  f `fmap` EncoderValue value = pure (f value)
  _ `fmap` EncoderError err = EncoderError err

-- | Implements value injection in encoder context (pure) and applying some
-- process derived from encoding (<*>).
instance Applicative Encoder where
  -- Wraps a Haskell type into an EncoderValue.
  {-# INLINE pure #-}
  pure = EncoderValue

  -- Resolve an encoded function and encoded value and apply the function to the
  -- value.
  {-# INLINE (<*>) #-}
  -- Extract the function from its context and apply it in value's context
  EncoderValue func <*> value = func <$> value
  EncoderError err <*> _ = EncoderError err

-- | Implements chaining encoders together in steps using binds (>>=).
instance Monad Encoder where
  {-# INLINE (>>=) #-}
  (EncoderValue value) >>= next = next value
  (EncoderError err) >>= _ = EncoderError err

-- | Defines alternative code paths (<|>) and default failure element (empty).
instance Alternative Encoder where
  -- For inputs that don't have the expected node type.
  empty = EncoderEmpty

  -- Tries the second code branch if the first fails
  {-# INLINE (<|>) #-}
  -- If the first branch is Just, return it
  EncoderValue ok1 <|> _ = pure ok1
  -- If the first branch is empty, return the second branch
  EncoderEmpty <|> EncoderValue ok2 = pure ok2
  -- If both branches are Nothing, return empty
  EncoderEmpty <|> EncoderEmpty = empty
  -- Otherwise, report the error that happened.
  _ <|> EncoderError err = EncoderError err
  EncoderError err <|> _ = EncoderError err

-- | Implements joining the results of two Encoders via semigroup adding (<>),
-- for Builders this would be concatinating the two bytestring contents.
instance (Semigroup s) => Semigroup (Encoder s) where
  -- This should only return an empty value when both the results are empty.
  {-# INLINE (<>) #-}
  -- Concat the values within DagCBOR context
  EncoderValue v1 <> EncoderValue v2 = pure (v1 <> v2)
  EncoderValue v1 <> EncoderEmpty = pure v1
  EncoderEmpty <> EncoderValue v2 = pure v2
  EncoderEmpty <> EncoderEmpty = empty
  -- Otherwise, report the error that happened
  _ <> EncoderError err = EncoderError err
  EncoderError err <> _ = EncoderError err

-- | Provides zero element `mempty` for encoder concatination. Applying (<>) to
-- this value will result an identity function.
instance (Semigroup s) => Monoid (Encoder s) where
  mempty = empty

-- | Major id for CBOR lists.
majorList :: MajorArg
majorList = 4

-- | Recursively encodes the list of CBOR objects.
{-# INLINE encodeListKind #-}
encodeListKind :: ListData Kind -> Encoder Builder
encodeListKind listdata =
  let -- Get the #elements in the list
      len = length listdata
      -- Encode the argument with the with the list's length
      arg = encodeIntArgument majorList len
      -- Initializes a Builder in the Encoder Monoid
      initobj = pure mempty
      -- Recursively encode the elements of the arguments
      objs = foldr (\item acc -> DM.encoder item <> acc) initobj listdata
   in -- Concat arg as DAG-CBOR data and the CBOR list objects
      okay arg <> objs

-- | Major id for CBOR maps.
majorMap :: MajorArg
majorMap = 5

-- | Recursively encodes the key-value pairs of CBOR objects.
{-# INLINE encodeMapKind #-}
encodeMapKind :: MapData Kind Kind -> Encoder Builder
encodeMapKind mapdata =
  let -- Get the #keys in the map
      len = length mapdata
      -- Encode the argument with only the #keys (#values is implied)
      arg = encodeIntArgument majorMap len
      -- Initializes a Builder in the Encoder Monoid
      initobj = pure mempty
      -- Recursively encode each key/value pair in the map.
      objs = foldr (\pair acc -> encodeMapPair pair <> acc) initobj mapdata
   in -- Concat the arg as DAG-CBOR and concat the encoded map.
      okay arg <<>> objs
  where
    -- Encodes a single map pair from tuple into Builder.
    {-# INLINE encodeMapPair #-}
    encodeMapPair (key, val) = DM.encoder key <> DM.encoder val