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   literalSlug :: URI.Slug -> repr ()
  14   captureSlug {-placeholder name-} :: URI.Slug -> repr URI.Slug
  15
  16 -- | Pattern-matchable encoding (initial algebra) of 'Slugable'.
  17 data instance Data Slugable repr a where
  18   LiteralSlug :: URI.Slug -> Data Slugable repr ()
  19   CaptureSlug :: URI.Slug -> Data Slugable repr URI.Slug
  20
  21 -- | Initial to final algebra.
  22 instance Slugable repr => Derivable (Data Slugable repr) where
  23   derive = \case
  24     LiteralSlug s -> literalSlug s
  25     CaptureSlug n -> captureSlug n
  26
  27 -- | Final to initial algebra.
  28 instance Slugable repr => Slugable (SomeData repr) where
  29   literalSlug = SomeData . LiteralSlug
  30   captureSlug = SomeData . CaptureSlug
  31
  32 -- | Convenient alias for an @index.html@ page.
  33 index :: Slugable repr => repr ()
  34 index = literalSlug "index.html"
  35
  36 -- | Convenient alias for prefixing a 'literalSlug'.
  37 (</>) ::
  38   ProductFunctor repr =>
  39   Slugable repr =>
  40   URI.Slug ->
  41   repr a ->
  42   repr a
  43 (</>) n = (literalSlug n .>)
  44
  45 infixr 4 </>