{-# LANGUAGE AllowAmbiguousTypes #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Webc.Classes (
  module Webc.Classes,
  Repeatable (..),
) where

import Data.Function (const, (.))
import Data.Kind (Constraint, Type)
import Network.URI.Slug qualified as URI
import Symantic.Classes (
  Iso (..),
  IsoFunctor (..),
  ProductFunctor (..),
  --SumFunctor (..),
  Repeatable (..),
 )
import Symantic.Data (Data, SomeData (..))
import Symantic.Reader (Reader (..))

-- import Control.Applicative (Applicative (..))
-- import Data.List qualified as List
import Data.Set (Set)
import Data.Set qualified as Set
import Symantic.Derive

--deriving instance Slugable repr => Slugable (Reflector r repr)
--deriving instance Endable repr => Endable (Reflector r repr)
--deriving instance Capturable repr => Capturable (Reflector r repr)

-- * Class 'Slugable'

-- | Syntax (final algebra) for expressing URL paths.
class Slugable repr where
  -- chooseSlugs :: Set [URI.Slug] -> repr [URI.Slug]
  -- default chooseSlugs :: FromDerived Slugable repr => Set [URI.Slug] -> repr [URI.Slug]
  -- chooseSlugs = liftDerived . chooseSlugs

  literalSlug :: URI.Slug -> repr ()
  default literalSlug :: IsoFunctor repr => URI.Slug -> repr ()
  literalSlug s = Iso (const ()) (const s) <%> chooseSlug (Set.singleton s)

  chooseSlug :: Set URI.Slug -> repr URI.Slug
  default chooseSlug :: FromDerived Slugable repr => Set URI.Slug -> repr URI.Slug
  chooseSlug = liftDerived . chooseSlug

-- default chooseSlug :: IsoFunctor repr => Set URI.Slug -> repr URI.Slug
-- chooseSlug s = Iso List.head pure <%> chooseSlugs (Set.mapMonotonic pure s)

instance (Slugable repr, IsoFunctor repr) => Slugable (Reader r repr)

-- | Pattern-matchable encoding (initial algebra) of 'Slugable'.
data instance Data Slugable repr a where
  LiteralSlug :: URI.Slug -> Data Slugable repr ()
  ChooseSlug :: Set URI.Slug -> Data Slugable repr URI.Slug

-- ChooseSlugs :: Set [URI.Slug] -> Data Slugable repr [URI.Slug]

-- | Initial to final algebra.
instance Slugable repr => Derivable (Data Slugable repr) where
  derive = \case
    LiteralSlug x -> literalSlug x
    ChooseSlug x -> chooseSlug x

-- ChooseSlugs x -> chooseSlugs x

-- | Final to initial algebra.
instance Slugable repr => Slugable (SomeData repr) where
  literalSlug = SomeData . LiteralSlug
  chooseSlug = SomeData . ChooseSlug

--chooseSlugs = SomeData . ChooseSlugs

-- | Convenient alias for an @index.html@ page.
index :: Slugable repr => repr ()
index = literalSlug "index.html"

-- | Convenient alias for prefixing with a 'literalSlug'.
(</>) ::
  ProductFunctor repr =>
  Slugable repr =>
  URI.Slug ->
  repr a ->
  repr a
(</>) n = (literalSlug n .>)

infixr 4 </>

-- * Class 'Capturable'
class Capturable repr where
  captureSlug :: URI.Slug -> repr URI.Slug
  default captureSlug :: FromDerived Capturable repr => URI.Slug -> repr URI.Slug
  captureSlug = liftDerived . captureSlug
instance Capturable repr => Capturable (Reader r repr)
data instance Data Capturable repr a where
  CaptureSlug :: URI.Slug -> Data Capturable repr URI.Slug
instance Capturable repr => Derivable (Data Capturable repr) where
  derive = \case
    CaptureSlug n -> captureSlug n
instance Capturable repr => Capturable (SomeData repr) where
  captureSlug = SomeData . CaptureSlug

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

-- * Class 'Endable'
class Endable repr where
  end :: repr ()
  default end :: FromDerived Endable repr => repr ()
  end = liftDerived end
instance Endable repr => Endable (Reader r repr)