{-# 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
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)
  }
  deriving (Functor)

layout :: Layouter a -> Forest LayoutNode
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) ->
  Forest LayoutNode
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
  = LayoutNodeSlug Slug
  deriving (Eq, Ord, Show)

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

coerceLayout :: Layouter a -> Layouter b
coerceLayout = Layouter . unLayouter

instance ProductFunctor Layouter where
  x <.> y = Layouter $ unLayouter (coerceLayout x) <> unLayouter (coerceLayout y)
  x .> y = Layouter $ unLayouter (coerceLayout x) <> unLayouter y
  x <. y = Layouter $ unLayouter x <> unLayouter (coerceLayout y)
instance SumFunctor Layouter where
  x <+> y =
    Layouter
      [ collapseLayoutBranch (unLayouter (Left <$> x))
          <> collapseLayoutBranch (unLayouter (Right <$> y))
      ]
instance Slugable Layouter where
  slug = layoutNode . LayoutNodeSlug