{-# LANGUAGE DeriveFunctor #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Webc.Layouter where

import Control.Applicative (Applicative (..))
import Data.Either (Either (..))
import Data.Eq (Eq (..))
import Data.Function (id, (.))
import Data.Functor (Functor (..), (<$>))
import Data.List qualified as List
import Data.Ord (Ord (..))
import Data.Semigroup (Semigroup (..))
import Data.Tree (Forest, Tree (..), drawForest)
import Network.URI.Slug as URI
import Symantic.Classes (Iso (..), IsoFunctor (..), ProductFunctor (..), SumFunctor ((<+>)))
import Text.Show (Show (..))

import Webc.Classes

-- * The 'Layouter' interpreter

newtype Layouter a = Layouter
  { unLayouter ::
      LayoutBranch (Forest (LayoutNode a))
  }
  deriving (Functor)

layout :: Layouter a -> Forest (LayoutNode a)
layout = collapseLayoutBranch . unLayouter

layouter :: Layouter a -> Layouter a
layouter = id

{- | Keep the path in the 'Tree'
where to append new branches;
in reverse order to simplify appending.
-}
type LayoutBranch = []

{- | Fold 'LayoutBranch' maintained for appending;
to be done when there is no more appending.
-}
collapseLayoutBranch ::
  LayoutBranch (Forest (LayoutNode a)) ->
  Forest (LayoutNode a)
collapseLayoutBranch =
  List.foldr
    (\ts acc -> ((\(Node n ns) -> Node n (ns <> acc)) <$> ts))
    []

instance Show a => Show (Layouter a) where
  show = drawForest . ((show <$>) <$>) . layout

instance IsoFunctor Layouter where
  Iso{..} <%> x = a2b <$> x

-- ** Type 'LayoutNode'
data LayoutNode a
  = LayoutNodeSlug a [Slug]
  deriving (Eq, Ord, Show, Functor)
instance Applicative LayoutNode where
  pure a = LayoutNodeSlug a []
  LayoutNodeSlug f fs <*> LayoutNodeSlug a as =
    LayoutNodeSlug (f a) (fs <> as)

layoutNode :: LayoutNode a -> Layouter a
layoutNode = Layouter . pure . pure . pure

instance ProductFunctor Layouter where
  Layouter x <.> Layouter y =
    Layouter
      ( ( \x1 y1 ->
            ( \x2 y2 ->
                ( \x3 y3 ->
                    (,) <$> x3 <*> y3
                )
                  <$> x2
                  <*> y2
            )
              <$> x1
              <*> y1
        )
          <$> x
          <*> y
      )

{- TODO:
x .> y = undefined
x <. y = undefined
-}
instance SumFunctor Layouter where
  x <+> y =
    Layouter
      [ collapseLayoutBranch (unLayouter (Left <$> x))
          <> collapseLayoutBranch (unLayouter (Right <$> y))
      ]
instance Slugable Layouter where
  literalSlug = layoutNode . LayoutNodeSlug () . pure
  captureSlug n = layoutNode (LayoutNodeSlug placeholder [placeholder])
    where
      placeholder :: URI.Slug
      placeholder = URI.decodeSlug ("<" <> (URI.encodeSlug n) <> ">")