{-# LANGUAGE GeneralisedNewtypeDeriving #-}

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.Bifunctor (first)
import Data.Bool
import Data.Either (Either (..))
import Data.Eq (Eq (..))
import Data.Foldable (null)
import Data.Function (($), (.))
import Data.Functor (Functor, (<$>))
import Data.Ord (Ord)
import Network.URI.Slug
import Symantic.Classes (Iso (..), IsoFunctor ((<%>)), ProductFunctor (..), SumFunctor ((<+>)))
import Text.Show (Show)

import Webc.Classes

-- * The 'Decoder' interpreter

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

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]
  deriving (Eq, Ord, Show)

instance IsoFunctor Decoder where
  (<%>) Iso{..} = (a2b <$>)
instance ProductFunctor Decoder where
  (<.>) = liftA2 (,)
  (<.) = (<*)
  (.>) = (*>)
instance SumFunctor Decoder where
  Decoder x <+> Decoder y = Decoder $
    MT.StateT $ \st -> do
      case MT.runExcept $ MT.runStateT x st of
        Right (a, st') -> return (Left a, st')
        Left _err ->
          -- TODO: better error merging
          case MT.runExcept $ MT.runStateT y st of
            Right (b, st') -> return (Right b, st')
            Left err -> MT.throwE err
instance Repeatable Decoder where
  many0 (Decoder x) = Decoder (MT.StateT (return . go))
    where
      go st = do
        case MT.runExcept $ MT.runStateT x st of
          Left _err -> ([], st) -- always backtrack
          Right (a, st') -> first (a :) (go st')
  many1 x = (:) <$> x <*> many0 x
instance Slugable Decoder where
  literalSlug 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
  captureSlug _name = Decoder $ do
    slugs <- MT.get
    case slugs of
      [] -> MT.lift $ MT.throwE DecoderErrorMissing
      gotSlug : nextSlugs -> do
        MT.put nextSlugs
        return gotSlug