{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

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 Data.Text.Encoding qualified as Text
import Data.Text.Encoding.Error qualified as Text

--import Data.Text.Lazy qualified as TextL
--import Data.Text.Lazy.Encoding qualified as TextL
import Network.URI.Slug
import Symantic.Classes (Iso (..), IsoFunctor ((<%>)), Optionable (..), ProductFunctor (..), SumFunctor ((<+>)))
import System.IO (IO)
import Text.Show (Show (..))

--import Network.Wai qualified as Wai

-- import Prelude (undefined)

import Webc.Classes
import Webc.MIME

-- * The 'Decoder' interpreter

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

-- ** Type 'Request'
data Request = Request
  { requestSlugs :: [Slug]
  , requestBody :: BSL.ByteString
  }

{-
data Decoders err a = Decoders
  { decodersPath :: [Slug] -> a
  , decodersMethod :: [Slug] -> Bool
  --, decodersBasicAuth ::
  , decodersAccept :: Bool
  , decodersContentType :: Bool
  , decodersQuery :: Bool
  , decodersHeader :: Bool
  , decodersBody :: BSL.ByteString -> a
  }
-}

data DecoderState = DecoderState
  { decoderStateSlugs :: [Slug]
  }

decode :: Decoder err a -> Request -> IO (Either (DecoderError err) a)
decode (Decoder dec) req =
  MT.runExceptT (MT.runStateT (MT.runReaderT dec req) st) >>= \case
    Left err -> return $ Left err
    Right (a, DecoderState{..})
      | null decoderStateSlugs -> return $ Right a
      | otherwise -> return $ Left $ DecoderErrorPathLeftover decoderStateSlugs
  where
    st =
      DecoderState
        { decoderStateSlugs = requestSlugs req
        }

data DecoderError err
  = -- 1st checks, 404 error
    DecoderErrorPathMismatch
      { expectedSlugs :: Set Slug
      , gotSlug :: Slug
      }
  | DecoderErrorPathMissing
  | DecoderErrorPathLeftover [Slug]
  | -- 2nd check, 405 error
    DecoderErrorMethod
  | -- 3rd check, 401 or 403 error
    DecoderErrorBasicAuth
  | -- 4th check, 406 error
    DecoderErrorAccept
  | -- 5th check, 415 error
    DecoderErrorContentType
  | -- 6th check, 400 error
    DecoderErrorQuery
  | -- 7th check, 400 error
    DecoderErrorHeader
  | -- 8th check, 400 error
    DecoderErrorUnicode Text.UnicodeException
  | -- 9th check, custom
    DecoderErrorParser err
  deriving (Eq, Show)
deriving instance Ord Text.UnicodeException

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.gets decoderStateSlugs) >>= \case
      [] -> return ()
      lo -> MT.lift $ MT.lift $ MT.throwE $ DecoderErrorPathLeftover 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.gets decoderStateSlugs)
    case slugs of
      [] -> MT.lift $ MT.lift $ MT.throwE DecoderErrorPathMissing
      gotSlug : nextSlugs
        | expectedSlug /= gotSlug ->
          MT.lift $ MT.lift $ MT.throwE DecoderErrorPathMismatch{expectedSlugs = Set.singleton expectedSlug, ..}
        | otherwise ->
          MT.local (\req -> req{requestSlugs = requestSlugs req <> [gotSlug]}) $
            MT.lift $ MT.modify' $ \st -> st{decoderStateSlugs = nextSlugs}
  chooseSlug expectedSlugs = Decoder $ do
    slugs <- MT.lift (MT.gets decoderStateSlugs)
    case slugs of
      [] -> MT.lift $ MT.lift $ MT.throwE DecoderErrorPathMissing
      gotSlug : nextSlugs
        | gotSlug `Set.notMember` expectedSlugs ->
          MT.lift $ MT.lift $ MT.throwE DecoderErrorPathMismatch{expectedSlugs, ..}
        | otherwise -> do
          MT.local (\req -> req{requestSlugs = requestSlugs req <> [gotSlug]}) $
            MT.lift $ MT.modify' $ \st -> st{decoderStateSlugs = nextSlugs}
          return gotSlug
instance ContentTypeable PlainText BSL.ByteString (Decoder err) where
  contentType = Decoder do
    Request{..} <- MT.ask
    return requestBody
instance ContentTypeable PlainText Text.Text (Decoder err) where
  contentType = Decoder do
    Request{..} <- MT.ask
    case Text.decodeUtf8' (BSL.toStrict requestBody) of
      Right a -> return a
      Left err -> MT.lift $ MT.lift $ MT.throwE $ DecoderErrorUnicode err

-- chooseSlugs = undefined
-- chooseSlugs expectedSlugs = Decoder $ do
--   slugs <- MT.lift MT.get
--   case slugs of
--     [] -> MT.lift $ MT.lift $ MT.throwE DecoderErrorPathMissing
--     gotSlug : nextSlugs
--       | gotSlug `Set.member` expectedSlugs ->
--         MT.lift $ MT.lift $ MT.throwE $ DecoderErrorPathMismatch{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.gets decoderStateSlugs)
    case slugs of
      [] -> MT.lift $ MT.lift $ MT.throwE DecoderErrorPathMissing
      gotSlug : nextSlugs ->
        MT.local (\req -> req{requestSlugs = requestSlugs req <> [gotSlug]}) do
          MT.lift $ MT.modify' $ \st -> st{decoderStateSlugs = nextSlugs}
          return gotSlug

--chooseSlug expectedSlugs = Decoder $ do
--  slugs <- MT.lift MT.get
--  case slugs of
--    [] -> MT.lift $ MT.lift $ MT.throwE DecoderErrorPathMissing
--    gotSlug : nextSlugs
--      | gotSlug `Set.member` expectedSlugs ->
--        MT.lift $ MT.lift $ MT.throwE $ DecoderErrorPathMismatch{..}
--      | 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
          DecoderErrorPathMissing -- FIXME
    where
    go a [] = Decoder $
      MT.lift $ MT.lift $ MT.throwE
        DecoderErrorPathMissing -- 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
    Request{..} <- MT.ask
    content <-
      MT.lift $
        MT.lift $
          MT.lift $
            BSL.readFile $
              List.intercalate "/" $
                Text.unpack . encodeSlug <$> requestSlugs
    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