module Webc.Decoder where

import Control.Applicative (Applicative (..))
import Control.Monad (Monad (..))
import Control.Monad.Trans.Class qualified as MT
import Control.Monad.Trans.Except qualified as MT
import Control.Monad.Trans.State qualified as MT
import Data.Bool
import Data.Either (Either (..))
import Data.Eq (Eq (..))
import Data.Foldable (null)
import Data.Function (($))
import Data.Functor ((<$>))
import Network.URI.Slug
import Symantic.Classes (Iso (..), IsoFunctor ((<%>)), ProductFunctor (..), SumFunctor ((<+>)))

import Webc.Classes

-- * The 'Decoder' interpreter

-- | A very very basic parser.
newtype Decoder a = Decoder
  { unDecoder ::
      MT.StateT
        [Slug]
        (MT.Except DecoderError)
        a
  }

decode :: Decoder a -> [Slug] -> Either DecoderError a
decode (Decoder dec) slugs = case MT.runExcept (MT.runStateT dec slugs) of
  Left err -> Left err
  Right (a, st)
    | null st -> Right a
    | otherwise -> Left $ DecoderErrorLeftover st

data DecoderError
  = DecoderErrorMismatch {expectedSlug :: Slug, gotSlug :: Slug}
  | DecoderErrorMissing
  | DecoderErrorLeftover [Slug]

instance IsoFunctor Decoder where
  Iso{..} <%> Decoder x = Decoder (a2b <$> x)
instance ProductFunctor Decoder where
  Decoder x <.> Decoder y = Decoder $ (,) <$> x <*> y
  Decoder x <. Decoder y = Decoder $ x <* y
  Decoder x .> Decoder y = Decoder $ x *> y
instance SumFunctor Decoder where
  Decoder x <+> Decoder y = Decoder $
    MT.StateT $ \st -> do
      case MT.runExcept $ MT.runStateT x st of
        Right (a, ss) -> return (Left a, ss)
        Left _err ->
          -- TODO: better error merging
          case MT.runExcept $ MT.runStateT y st of
            Right (b, ss) -> return (Right b, ss)
            Left err -> MT.throwE err
instance Slugable Decoder where
  slug expectedSlug = Decoder $ do
    slugs <- MT.get
    case slugs of
      [] -> MT.lift $ MT.throwE DecoderErrorMissing
      gotSlug : nextSlugs
        | expectedSlug /= gotSlug ->
          MT.lift $ MT.throwE $ DecoderErrorMismatch{..}
        | otherwise -> MT.put nextSlugs