src/Webc/Classes.hs

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