src/Webc/Classes.hs

   1 module Webc.Classes where
   2
   3 import Data.Function ((.))
   4 import Network.URI.Slug qualified as URI
   5 import Symantic.Classes (ProductFunctor (..))
   6 import Symantic.Data (Data, SomeData (..))
   7 import Symantic.Derive (Derivable (..))
   8
   9 -- * Class 'Slugable'
  10
  11 -- | Syntax (final algebra) for expressing URL paths.
  12 class Slugable repr where
  13   slug :: URI.Slug -> repr ()
  14
  15 -- | Pattern-matchable encoding (initial algebra) of 'Slugable'.
  16 data instance Data Slugable repr a where
  17   Slug :: URI.Slug -> Data Slugable repr ()
  18
  19 -- | Initial to final algebra.
  20 instance Slugable repr => Derivable (Data Slugable repr) where
  21   derive = \case
  22     Slug s -> slug s
  23
  24 -- | Final to initial algebra.
  25 instance Slugable repr => Slugable (SomeData repr) where
  26   slug = SomeData . Slug
  27
  28 -- | Convenient alias for an @index.html@ page.
  29 index :: Slugable repr => repr ()
  30 index = slug "index.html"
  31
  32 -- | Convenient alias for prefixing a 'slug'.
  33 (</>) ::
  34   ProductFunctor repr =>
  35   Slugable repr =>
  36   URI.Slug ->
  37   repr a ->
  38   repr a
  39 (</>) n = (slug n .>)
  40
  41 infixr 4 </>