-- For Addresser
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}

module Literate.Web.Semantics.Addresser where

import Control.Applicative (Applicative (..))
import Control.Monad (Monad (..), forM, forM_, join, sequence, (>=>), (>>=))
import Control.Monad.Classes qualified as MC
import Control.Monad.Trans.Class qualified as MT
import Control.Monad.Trans.Reader qualified as MT
import Control.Monad.Trans.State qualified as MT
import Control.Monad.Trans.Writer qualified as MT
import Type.Reflection ((:~:) (..))
import Data.Bool
import Data.ByteString.Lazy qualified as BSL
import Data.Either (Either (..))
import Data.Eq (Eq (..))
import Data.Foldable (toList)
import Data.Monoid (Monoid(..))
import Data.Function (const, id, ($), (.))
import Data.Functor (Functor (..), (<$>))
import Data.Kind (Constraint, Type)
import Data.List qualified as List
import Data.Maybe (Maybe (..))
import Data.Ord (Ord (..))
import Data.Proxy (Proxy (..))
import Data.Semigroup (Semigroup (..))
import Data.String (fromString)
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Tuple (curry)
import GHC.Generics (Generic)
import GHC.Stack (HasCallStack)
import Literate.Web.Syntaxes
import Literate.Web.Types.MIME
import Literate.Web.Types.URL
import Symantic qualified as Sym
import System.Directory qualified as Sys
import System.FilePath qualified as Sys
import System.FilePattern.Directory qualified as Sys
import System.IO qualified as Sys
import Text.Show (Show (..))

-- * Type 'Addresser'
data Addresser a = Addresser
  { unAddresser :: forall next. (Address -> next) -> a --> next
  }

-- * Type family '(-->)'
-- | Convenient alias for a Tuples of Functions transformation
type (-->) a next = ToFIf (Sym.IsToF a) a next
infixr 0 -->
type family ToFIf t a next :: Type where
-- For '<.>': curry.
  ToFIf 'True (a, b) next = a --> b --> next
-- For '<+>', request both branches.
  ToFIf 'True (Either l r) next = (l --> next, r --> next)
-- Useless to ask '()' as argument.
  ToFIf 'True () next = next
-- Enable a different return value for each function.
  ToFIf 'True (Sym.Endpoint end a) next = next
-- Everything else becomes a new argument.
  ToFIf 'False a next = a -> next

-- ** Class 'UnToF'
type UnToF a = UnToFIf (Sym.IsToF a) a
class UnToFIf (t :: Bool) a where
  unToF :: ToFIf t a next -> a -> next
instance UnToFIf 'True () where
  unToF = const
instance (UnToF a, UnToF b) => UnToFIf 'True (a, b) where
  unToF hab (a, b) = (unToF @(Sym.IsToF b) (unToF @(Sym.IsToF a) hab a)) b
instance (UnToF a, UnToF b) => UnToFIf 'True (Either a b) where
  unToF (ha, hb) = \case
    Left a -> unToF @(Sym.IsToF a) ha a
    Right b -> unToF @(Sym.IsToF b) hb b
instance UnToFIf 'False a where
  unToF = id


address :: Addresser a -> a --> Address
address router = unAddresser router id

instance PathSegmentable (Addresser) where
  pathSegment s = Addresser \f -> f Address {addressPath = [s]}

instance Sym.SumFunctor Addresser where
  a <+> b = Addresser \n -> (unAddresser a n, unAddresser b n)
instance Sym.ProductFunctor Addresser where
  a <.> b = Addresser \k -> unAddresser a \aA -> unAddresser b \bA -> k (bA <> aA)
  a <. b = Addresser \k -> unAddresser a \aA -> unAddresser b \bA -> k (bA <> aA)
  a .> b = Addresser \k -> unAddresser a \aA -> unAddresser b \bA -> k (bA <> aA)

instance
  ( Generic a
  , Sym.EoTOfRep a
  , sem ~ Addresser
  , Sym.IsToF a ~ 'False
  , e ~ Sym.EoT (Sym.ADT a)
  , UnToF e
  ) => Dataable__ a Addresser where
  data__ :: sem (Sym.EoT (Sym.ADT a)) -> sem a
  data__ a = Addresser (\a2n -> unToF @(Sym.IsToF e) @e (unAddresser a a2n) . Sym.eotOfadt)

instance end ~ Address => Responsable a ts m end (Addresser) where
  response = Addresser ($ mempty)

-- ** Type 'Address'
newtype Address = Address
  { addressPath :: [PathSegment]
  }
  deriving (Show)
instance Semigroup (Address) where
  Address a <> Address b = Address (a <> b)
instance Monoid (Address) where
  mempty = Address []