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 as URI
  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 a))
  26   }
  27   deriving (Functor)
  28
  29 layout :: Layouter a -> Forest (LayoutNode a)
  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 a)) ->
  46   Forest (LayoutNode a)
  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 a
  60   = LayoutNodeSlug a [Slug]
  61   deriving (Eq, Ord, Show, Functor)
  62 instance Applicative LayoutNode where
  63   pure a = LayoutNodeSlug a []
  64   LayoutNodeSlug f fs <*> LayoutNodeSlug a as =
  65     LayoutNodeSlug (f a) (fs <> as)
  66
  67 layoutNode :: LayoutNode a -> Layouter a
  68 layoutNode = Layouter . pure . pure . pure
  69
  70 instance ProductFunctor Layouter where
  71   Layouter x <.> Layouter y =
  72     Layouter
  73       ( ( \x1 y1 ->
  74             ( \x2 y2 ->
  75                 ( \x3 y3 ->
  76                     (,) <$> x3 <*> y3
  77                 )
  78                   <$> x2
  79                   <*> y2
  80             )
  81               <$> x1
  82               <*> y1
  83         )
  84           <$> x
  85           <*> y
  86       )
  87
  88 {- TODO:
  89 x .> y = undefined
  90 x <. y = undefined
  91 -}
  92 instance SumFunctor Layouter where
  93   x <+> y =
  94     Layouter
  95       [ collapseLayoutBranch (unLayouter (Left <$> x))
  96           <> collapseLayoutBranch (unLayouter (Right <$> y))
  97       ]
  98 instance Slugable Layouter where
  99   literalSlug = layoutNode . LayoutNodeSlug () . pure
 100   captureSlug n = layoutNode (LayoutNodeSlug placeholder [placeholder])
 101     where
 102       placeholder :: URI.Slug
 103       placeholder = URI.decodeSlug ("<" <> (URI.encodeSlug n) <> ">")