{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE UndecidableInstances #-}

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.Reader qualified as MT
import Control.Monad.Trans.State qualified as MT
import Data.Bifunctor (first)
import Data.Bool
import Data.ByteString.Lazy qualified as BSL
import Data.Either (Either (..))
import Data.Eq (Eq (..))
import Data.Foldable (null)
import Data.Function (($), (.))
import Data.Functor (Functor, (<$>))
import Data.List qualified as List
import Data.Maybe (Maybe (..))
import Data.Ord (Ord)
import Data.Semigroup (Semigroup (..))
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Text qualified as Text
import Network.URI.Slug
import Symantic.Classes (Iso (..), IsoFunctor ((<%>)), Optionable (..), ProductFunctor (..), SumFunctor ((<+>)))
import System.IO (IO)
import Text.Show (Show)

-- import Prelude (undefined)

import Webc.Classes

-- * The 'Decoder' interpreter

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

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

data DecoderError err
  = DecoderErrorMismatch
      { expectedSlugs :: Set Slug
      , gotSlug :: Slug
      }
  | DecoderErrorMissing
  | DecoderErrorLeftover [Slug]
  | DecoderErrorParser err
  deriving (Eq, Ord, Show)

instance IsoFunctor (Decoder err) where
  (<%>) Iso{..} = (a2b <$>)
instance ProductFunctor (Decoder err) where
  (<.>) = liftA2 (,)
  (<.) = (<*)
  (.>) = (*>)
instance SumFunctor (Decoder err) where
  Decoder x <+> Decoder y = Decoder $
    MT.ReaderT $ \env -> MT.StateT $ \st -> do
      MT.lift (MT.runExceptT (MT.runStateT (MT.runReaderT x env) st)) >>= \case
        Right (a, st') -> return (Left a, st')
        Left _err ->
          -- TODO: better error merging
          MT.lift (MT.runExceptT (MT.runStateT (MT.runReaderT y env) st)) >>= \case
            Right (b, st') -> return (Right b, st')
            Left err -> MT.throwE err
instance Endable (Decoder err) where
  end = Decoder do
    MT.lift MT.get >>= \case
      [] -> return ()
      lo -> MT.lift $ MT.lift $ MT.throwE $ DecoderErrorLeftover lo
instance Repeatable (Decoder err) where
  many0 (Decoder x) = Decoder (MT.ReaderT (MT.StateT . go))
    where
      go env st = do
        MT.lift (MT.runExceptT (MT.runStateT (MT.runReaderT x env) st)) >>= \case
          Left _err -> return ([], st) -- always backtrack
          Right (a, st') -> first (a :) <$> go env st'
  many1 x = (:) <$> x <*> many0 x
instance Optionable (Decoder err) where
  optional (Decoder x) = Decoder $
    MT.ReaderT $ \env -> MT.StateT $ \st -> do
      MT.lift (MT.runExceptT (MT.runStateT (MT.runReaderT x env) st)) >>= \case
        Left{} -> return (Nothing, st)
        Right (a, st') -> return (Just a, st')
instance Slugable (Decoder err) where
  literalSlug expectedSlug = Decoder $ do
    slugs <- MT.lift MT.get
    case slugs of
      [] -> MT.lift $ MT.lift $ MT.throwE DecoderErrorMissing
      gotSlug : nextSlugs
        | expectedSlug /= gotSlug ->
          MT.lift $ MT.lift $ MT.throwE DecoderErrorMismatch{expectedSlugs = Set.singleton expectedSlug, ..}
        | otherwise ->
          MT.local (<> [gotSlug]) $
            MT.lift $ MT.put nextSlugs
  chooseSlug expectedSlugs = Decoder $ do
    slugs <- MT.lift MT.get
    case slugs of
      [] -> MT.lift $ MT.lift $ MT.throwE DecoderErrorMissing
      gotSlug : nextSlugs
        | gotSlug `Set.notMember` expectedSlugs ->
          MT.lift $ MT.lift $ MT.throwE DecoderErrorMismatch{expectedSlugs, ..}
        | otherwise -> do
          MT.local (<> [gotSlug]) $
            MT.lift $ MT.put nextSlugs
          return gotSlug

-- chooseSlugs = undefined
-- chooseSlugs expectedSlugs = Decoder $ do
--   slugs <- MT.lift MT.get
--   case slugs of
--     [] -> MT.lift $ MT.lift $ MT.throwE DecoderErrorMissing
--     gotSlug : nextSlugs
--       | gotSlug `Set.member` expectedSlugs ->
--         MT.lift $ MT.lift $ MT.throwE $ DecoderErrorMismatch{expectedSlugs, ..}
--       | otherwise -> do
--         MT.local (<> [gotSlug]) $
--           MT.lift $ MT.put nextSlugs
--         return gotSlug
instance Capturable (Decoder err) where
  captureSlug _name = Decoder $ do
    slugs <- MT.lift MT.get
    case slugs of
      [] -> MT.lift $ MT.lift $ MT.throwE DecoderErrorMissing
      gotSlug : nextSlugs ->
        MT.local (<> [gotSlug]) do
          MT.lift $ MT.put nextSlugs
          return gotSlug

--chooseSlug expectedSlugs = Decoder $ do
--  slugs <- MT.lift MT.get
--  case slugs of
--    [] -> MT.lift $ MT.lift $ MT.throwE DecoderErrorMissing
--    gotSlug : nextSlugs
--      | gotSlug `Set.member` expectedSlugs ->
--        MT.lift $ MT.lift $ MT.throwE $ DecoderErrorMismatch{..}
--      | otherwise -> do
--        MT.local (<> [gotSlug]) $
--          MT.lift $ MT.put nextSlugs
--        return gotSlug
{-
instance Selectable (Decoder err) where
  select ra a2bs = do
    a <- ra
    case Map.lookup a a2bs of
      Nothing ->
        Decoder $ MT.lift $ MT.lift $ MT.throwE
          DecoderErrorMissing -- FIXME
    where
    go a [] = Decoder $
      MT.lift $ MT.lift $ MT.throwE
        DecoderErrorMissing -- FIXME
    go a ((ca, x):xs) = Decoder $
      MT.ReaderT $ \env -> MT.StateT $ \st -> do
        MT.lift (MT.runExceptT (MT.runStateT (MT.runReaderT (unDecoder x) env) st)) >>= \case
          Right r -> return r
          Left _err ->
            MT.runStateT (MT.runReaderT (unDecoder (choose ra xs)) env) st
-}
instance Fileable (Decoder err) where
  type FileableConstraint (Decoder err) = Parsable err
  static = Decoder do
    return ()
  dynamic = Decoder do
    path <- MT.ask
    content <-
      MT.lift $
        MT.lift $
          MT.lift $
            BSL.readFile $
              List.intercalate "/" $
                Text.unpack . encodeSlug <$> path
    case parse content of
      Right a -> return a
      Left err -> MT.lift $ MT.lift $ MT.throwE $ DecoderErrorParser err

-- * Class 'Parsable'
class Parsable err a where
  parse :: BSL.ByteString -> Either err a