{-# LANGUAGE AllowAmbiguousTypes #-}
-- For IfSemantic
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Literate.Web.Syntaxes (
  module Literate.Web.Syntaxes,
  ProductFunctor (..),
  SumFunctor (..),
  Repeatable (..),
  Optionable (..),
  Dataable (..),
  Inferable (..),
  IsoFunctor (..),
  dataType,
  pattern (:!:),
) where

import Control.Applicative (Applicative)
import Control.Monad (Monad)
import Control.Monad.Classes qualified as MC
import Control.Monad.Trans.Class as MT
import Data.Either (Either)
import Data.Bool (Bool (..))
import Data.ByteString.Lazy qualified as BSL
import Data.Function ((.))
import Data.Functor as Functor
import Data.Kind (Constraint, Type)
import Data.Typeable (Typeable)
import Literate.Web.Types.URL
import Symantic.Semantics (Reader (..))
import Symantic.Semantics.ToFer (
  ToFer (..),
 )
import Symantic.Syntaxes (
  Dataable (..),
  Endpoint,
  Inferable (..),
  IsToF,
  IsoFunctor (..),
  Optionable (..),
  ProductFunctor (..),
  Repeatable (..),
  SumFunctor (..),
  dataType,
  pattern (:!:),
 )
import Symantic.Syntaxes.Data (Data, SomeData (..))
import Symantic.Syntaxes.Derive
import System.FilePath (FilePath)

--deriving instance PathSegmentable sem => PathSegmentable (Reflector r sem)
--deriving instance Endable sem => Endable (Reflector r sem)
--deriving instance Capturable sem => Capturable (Reflector r sem)

-- * Class 'PathSegmentable'

-- | Syntax (final algebra) for expressing URL paths.
class PathSegmentable sem where
  -- choosePathSegments :: Set [PathSegment] -> sem [PathSegment]
  -- default choosePathSegments :: FromDerived PathSegmentable sem => Set [PathSegment] -> sem [PathSegment]
  -- choosePathSegments = liftDerived . choosePathSegments
  -- pathSegment :: PathSegment -> sem a -> sem a

  pathSegment :: PathSegment -> sem ()
  default pathSegment :: FromDerived PathSegmentable sem => PathSegment -> sem ()
  -- default pathSegment :: IsoFunctor sem => PathSegment -> sem ()
  -- pathSegment s = Iso (const ()) (const s) <%> pathSegments (Set.singleton s)
  pathSegment = liftDerived . pathSegment

instance (PathSegmentable sem, Functor sem) => PathSegmentable (ToFer sem) where
  pathSegment s =
    ToFer
      { tuplesOfFunctions = (Functor.<$ eot)
      , eithersOfTuples = eot
      }
    where
      eot = pathSegment s

-- pathSegments :: Set PathSegment -> sem PathSegment
-- default pathSegments :: FromDerived PathSegmentable sem => Set PathSegment -> sem PathSegment
-- pathSegments = liftDerived . pathSegments

-- default pathSegments :: IsoFunctor sem => Set PathSegment -> sem PathSegment
-- pathSegments s = Iso List.head pure <%> choosePathSegments (Set.mapMonotonic pure s)

instance (PathSegmentable sem, IsoFunctor sem) => PathSegmentable (Reader r sem)

-- | Pattern-matchable encoding (initial algebra) of 'PathSegmentable'.
data instance Data PathSegmentable sem a where
  PathSegment :: PathSegment -> Data PathSegmentable sem ()

-- PathSegments :: Set PathSegment -> Data PathSegmentable sem PathSegment

-- ChoosePathSegments :: Set [PathSegment] -> Data PathSegmentable sem [PathSegment]

-- | Initial to final algebra.
instance PathSegmentable sem => Derivable (Data PathSegmentable sem) where
  derive = \case
    PathSegment x -> pathSegment x

-- PathSegments x -> pathSegments x

-- ChoosePathSegments x -> choosePathSegments x

-- | Final to initial algebra.
instance PathSegmentable sem => PathSegmentable (SomeData sem) where
  pathSegment = SomeData . PathSegment

-- pathSegments = SomeData . PathSegments

--choosePathSegments = SomeData . ChoosePathSegments

-- | Convenient alias for an @index.html@ page.
index :: PathSegmentable sem => sem ()
index = pathSegment "index.html"

-- | Convenient alias for prefixing with a 'pathSegment'.
(</>) ::
  ProductFunctor sem =>
  PathSegmentable sem =>
  PathSegment ->
  sem a ->
  sem a
(</>) n = (pathSegment n .>)

infixr 4 </>

-- * Class 'Copyable'
class Copyable sem where
  copy :: FilePath -> sem ()

-- * Class 'Encodable'
class Encodable fmt a where
  encode :: a -> BSL.ByteString

-- * Class 'Capturable'
class Capturable a sem where
  type Captured a sem :: Type
  type Captured a sem = a
  capturePathSegment :: PathSegment -> sem (Captured a sem)
  default capturePathSegment ::
    Captured a (Derived sem) ~ Captured a sem =>
    FromDerived (Capturable a) sem =>
    PathSegment ->
    sem (Captured a sem)
  capturePathSegment = liftDerived . capturePathSegment @a

-- | The @('IsToF' a ~ 'False)@ constraint
-- disables capturing tuples or functions.
instance
  ( Capturable a sem
  , IsToF (Captured a sem) ~ 'False
  , Functor sem
  ) => Capturable a (ToFer sem) where
  type Captured a (ToFer sem) = Captured a sem
  capturePathSegment _n =
    ToFer
      { tuplesOfFunctions = \next -> next <$> capturePathSegment @a _n
      , eithersOfTuples = capturePathSegment @a _n
      }

-- | @('CapturedExtra' a extra)@ is useful to add @(extra)@ data
-- to a 'Captured' value, eg. when using the 'Compiler' semantic,
-- to add the content of a page whose name was captured
-- directly available when iterating all the pages,
-- hence avoiding to lookup that content as would be done
-- when using the 'Server' semantic.
newtype CapturedExtra a extra = CapturedExtra (Either (a, extra) a)

--instance Capturable sem => Capturable (Reader r sem)
data instance Data (Capturable a) sem r where
  CapturePathSegment ::
    Capturable a sem =>
    PathSegment ->
    Data (Capturable a) sem (Captured a sem)
instance Capturable a sem => Derivable (Data (Capturable a) sem) where
  derive = \case
    CapturePathSegment n -> capturePathSegment @a n
instance (Capturable a sem, Typeable a) => Capturable a (SomeData sem) where
  type Captured a (SomeData sem) = Captured a sem
  capturePathSegment = SomeData . CapturePathSegment @a

-- * Class 'Fileable'
class Fileable sem where
  type FileableConstraint sem :: Type -> Constraint
  static :: sem ()
  dynamic :: FileableConstraint sem a => sem a

-- * Class 'Responsable'
class Responsable a ts m result sem where
  response :: sem (Endpoint result (Response ts m a))

-- ** Type 'Response'
newtype Response (ts :: [Type]) m a = Response {unResponse :: m a}
  deriving (Functor, Applicative, Monad)
type instance MC.CanDo (Response ts m) eff = 'False
instance MT.MonadTrans (Response ts) where lift = Response