Decoder.hs

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

    -- * Evaluates the major parts of CBOR data.
    evalMajorType,
    evalMajorId,

    -- * Evaulating DAG-CBOR binaries into `DM.Node`.
    evalNode,

    -- * Implements each `DM.Kind` for the decoder.
    evalNullKind,
    evalBoolKind,
    evalIntKind,
    evalFloatKind,
    evalBytesKind,
    evalStringKind,
    evalResourceKind,
    evalListKind,
    evalMapKind,
  )
where

import Control.Applicative (Alternative (..))
import Control.Monad ((>=>))
import Data.Bifunctor (Bifunctor (first))
import Data.XCodec.BinaryTranscoder (BinaryTranscoder)
import IPLD.DM qualified as DM
import IPLD.DM.Decoder qualified as DM
import IPLD.DagCBOR.Decoder.Errors
import IPLD.DagCBOR.Decoder.MajorTypes
import IPLD.DagCBOR.Decoder.Objects

-- | Implements `DM.Decoder` for DAG-CBOR binaries.
newtype DagCBOR bxc item = DagCBOR
  { -- | Provides the `DecoderMethod` for the `item` type.
    decoderMethod :: DecoderMethod item bxc
  }

-- | Evaluates the first byte's major-type in the given transcoder.
evalMajorType :: (BinaryTranscoder bxc) => MajorId -> DagCBOR bxc MajorType
evalMajorType typeid = DagCBOR decodeMajorType >>= matchTypeId
  where
    -- Fails with `EmptyAlternative` if the `MajorType` doesn't have the correct
    -- `MajorId`.
    matchTypeId majortype
      | majorTypeId majortype /= typeid = pure majortype
      | otherwise = empty

-- | Evaluates a well-formed CBOR binary object into the IPLD data model and
-- removes it from the transcoder.
evalNode :: (BinaryTranscoder bxc) => DagCBOR bxc DM.Node
evalNode = DagCBOR decodeObject

-- | Evaluates a `DM.Node` from DAG-CBOR when the major ID in the transcoder
-- matches the given param, and then removes the object from the binary.
-- Otherwise it fails with `EmptyAlternative`.
evalMajorId :: (BinaryTranscoder bxc) => MajorId -> DagCBOR bxc DM.Node
evalMajorId idtype = evalMajorType idtype >> evalNode

-- | Evaluates a `DM.IntKind` from DAG-CBOR. Fails with `EmptyAlternative`
-- when the binary doesn't contain the correct `DM.Kind`.
evalIntKind :: (BinaryTranscoder bxc) => DagCBOR bxc DM.Node
evalIntKind = evalMajorId idPositive <|> evalMajorId idNegative

-- | Evaluates a `DM.BytesKind` from DAG-CBOR. Fails with `EmptyAlternative`
-- when the binary doesn't contain the correct `DM.Kind`.
evalBytesKind :: (BinaryTranscoder bxc) => DagCBOR bxc DM.Node
evalBytesKind = evalMajorId idBytes

-- | Evaluates a `DM.StringKind` from DAG-CBOR. Fails with `EmptyAlternative`
-- when the binary doesn't contain the correct `DM.Kind`.
evalStringKind :: (BinaryTranscoder bxc) => DagCBOR bxc DM.Node
evalStringKind = evalMajorId idUTF8

-- | Evaluates a `DM.ListKind` from DAG-CBOR. Fails with `EmptyAlternative`
-- when the binary doesn't contain the correct `DM.Kind`.
evalListKind :: (BinaryTranscoder bxc) => DagCBOR bxc DM.Node
evalListKind = evalMajorId idList

-- | Evaluates a `DM.MapKind` from DAG-CBOR. Fails with `EmptyAlternative`
-- when the binary doesn't contain the correct `DM.Kind`.
evalMapKind :: (BinaryTranscoder bxc) => DagCBOR bxc DM.Node
evalMapKind = evalMajorId idMap

-- | Evaluates a `DM.ResourceKind` from DAG-CBOR. Fails with `EmptyAlternative`
-- when the binary doesn't contain the correct `DM.Kind`.
evalResourceKind :: (BinaryTranscoder bxc) => DagCBOR bxc DM.Node
evalResourceKind = evalMajorId idResource

-- | Evaluates a `DM.FloatKind` from DAG-CBOR. Fails with `EmptyAlternative`
-- when the binary doesn't contain the correct `DM.Kind`.
evalFloatKind :: (BinaryTranscoder bxc) => DagCBOR bxc DM.Node
evalFloatKind = evalMajorId idFloat >>= matchFloatKind
  where
    -- Fails with `EmptyAlternative` if the node isn't `DM.FloatKind`.
    matchFloatKind node@(DM.FloatKind _) = pure node
    matchFloatKind _ = empty

-- | Evaluates a `DM.BoolKind` from a DAG-CBOR. Fails with `EmptyAlternative`
-- when the binary doesn't contain the correct `DM.Kind`.
evalBoolKind :: (BinaryTranscoder bxc) => DagCBOR bxc DM.Node
evalBoolKind = evalMajorId idBool >>= matchBoolKind
  where
    -- Fails with `EmptyAlternative` if the node isn't `DM.BoolKind`.
    matchBoolKind node@(DM.BoolKind _) = pure node
    matchBoolKind _ = empty

-- | Evaluates a `DM.NullKind` from a DAG-CBOR. Fails with `EmptyAlternative`
-- when the binary doesn't contain the correct `DM.Kind`.
evalNullKind :: (BinaryTranscoder bxc) => DagCBOR bxc DM.Node
evalNullKind = evalMajorId idNull >>= matchNullKind
  where
    -- Fails with `EmptyAlternative` if the node isn't `DM.NullKind`.
    matchNullKind node@DM.NullKind = pure node
    matchNullKind _ = empty

-- | Parses the DM from some DAG-CBOR encoded bytestring.
-- https://ipld.io/specs/codecs/dag-cbor/spec/
instance (BinaryTranscoder bxc) => DM.Decoder (DagCBOR bxc) where
  intKind = evalIntKind
  bytesKind = evalBytesKind
  stringKind = evalStringKind
  listKind = evalListKind
  mapKind = evalMapKind
  resourceKind = evalResourceKind
  floatKind = evalFloatKind
  boolKind = evalBoolKind
  nullKind = evalNullKind

-- | Implements function injection (fmap) into some decoder process.
instance (BinaryTranscoder bxc) => Functor (DagCBOR bxc) where
  -- Decode the result and apply f to the first item in the struct
  fmap f (DagCBOR decoder) = DagCBOR $ decoder >=> pure . first f

-- | Implements value injection in decoder context (pure) and applying some
-- process derived from parsing (<*>).
instance (BinaryTranscoder bxc) => Applicative (DagCBOR bxc) where
  -- Push the value into the functor, keeping the original bytestring
  pure value = DagCBOR $ pure . Result value

  -- Composing functor wrapped functions
  (DagCBOR step1) <*> (DagCBOR step2) =
    DagCBOR $ \bytes -> do
      -- Perform the 2 steps on the data
      Result funcpart inner <- step1 bytes
      Result datapart rest <- step2 inner
      -- Apply the function and return the values from step2
      Right $ Result (funcpart datapart) rest

-- | Binds next operation (>>=) in the DagCBOR context.
instance (BinaryTranscoder bxc) => Monad (DagCBOR bxc) where
  (DagCBOR step1) >>= next =
    DagCBOR $ \bytes -> do
      Result input rest <- step1 bytes
      let (DagCBOR step2) = next input
      step2 rest

-- | Defines alternative code paths (<|>) and default failure element (empty).
instance (BinaryTranscoder bxc) => Alternative (DagCBOR bxc) where
  -- Returns the special value marking a functor as an invalid code path
  empty = DagCBOR $ const (Left EmptyAlternative)

  -- Implements code branch selection
  (DagCBOR step1) <|> (DagCBOR step2) =
    DagCBOR $ \bytes ->
      case step1 bytes of
        -- Try the other branch if empty is called
        Left EmptyAlternative -> step2 bytes
        -- For other errors, return them to the caller
        Left err -> Left err
        -- Return the result if the first code branch works
        Right result -> Right result