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