src/Webc/Layouter.hs

   1 {-# LANGUAGE DeriveFunctor #-}
   2 {-# OPTIONS_GHC -fno-warn-orphans #-}
   3
   4 module Webc.Layouter where
   5
   6 import Control.Applicative (Applicative (..))
   7 import Data.Either (Either (..))
   8 import Data.Eq (Eq (..))
   9 import Data.Function (id, ($), (.))
  10 import Data.Functor (Functor, (<$>))
  11 import Data.List qualified as List
  12 import Data.Ord (Ord (..))
  13 import Data.Semigroup (Semigroup (..))
  14 import Data.Tree (Forest, Tree (..), drawForest)
  15 import Network.URI.Slug
  16 import Symantic.Classes (Iso (..), IsoFunctor (..), ProductFunctor (..), SumFunctor ((<+>)))
  17 import Text.Show (Show (..))
  18
  19 import Webc.Classes
  20
  21 -- * The 'Layouter' interpreter
  22
  23 newtype Layouter a = Layouter
  24   { unLayouter ::
  25       LayoutBranch (Forest LayoutNode)
  26   }
  27   deriving (Functor)
  28
  29 layout :: Layouter a -> Forest LayoutNode
  30 layout = collapseLayoutBranch . unLayouter
  31
  32 layouter :: Layouter a -> Layouter a
  33 layouter = id
  34
  35 {- | Keep the path in the 'Tree'
  36  where to append new branches;
  37  in reverse order to simplify appending.
  38 -}
  39 type LayoutBranch = []
  40
  41 {- | Fold 'LayoutBranch' maintained for appending;
  42  to be done when there is no more appending.
  43 -}
  44 collapseLayoutBranch ::
  45   LayoutBranch (Forest LayoutNode) ->
  46   Forest LayoutNode
  47 collapseLayoutBranch =
  48   List.foldr
  49     (\ts acc -> ((\(Node n ns) -> Node n (ns <> acc)) <$> ts))
  50     []
  51
  52 instance Show a => Show (Layouter a) where
  53   show = drawForest . ((show <$>) <$>) . layout
  54
  55 instance IsoFunctor Layouter where
  56   Iso{..} <%> x = a2b <$> x
  57
  58 -- ** Type 'LayoutNode'
  59 data LayoutNode
  60   = LayoutNodeSlug Slug
  61   deriving (Eq, Ord, Show)
  62
  63 layoutNode :: LayoutNode -> Layouter a
  64 layoutNode = Layouter . pure . pure . pure
  65
  66 coerceLayout :: Layouter a -> Layouter b
  67 coerceLayout = Layouter . unLayouter
  68
  69 instance ProductFunctor Layouter where
  70   x <.> y = Layouter $ unLayouter (coerceLayout x) <> unLayouter (coerceLayout y)
  71   x .> y = Layouter $ unLayouter (coerceLayout x) <> unLayouter y
  72   x <. y = Layouter $ unLayouter x <> unLayouter (coerceLayout y)
  73 instance SumFunctor Layouter where
  74   x <+> y =
  75     Layouter
  76       [ collapseLayoutBranch (unLayouter (Left <$> x))
  77           <> collapseLayoutBranch (unLayouter (Right <$> y))
  78       ]
  79 instance Slugable Layouter where
  80   slug = layoutNode . LayoutNodeSlug