src/Webc/Classes.hs

   1 {-# LANGUAGE AllowAmbiguousTypes #-}
   2 {-# OPTIONS_GHC -Wno-orphans #-}
   3
   4 module Webc.Classes (
   5   module Webc.Classes,
   6   Repeatable (..),
   7 ) where
   8
   9 import Data.Function (const, (.))
  10 import Data.Kind (Constraint, Type)
  11 import Network.URI.Slug qualified as URI
  12 import Symantic.Classes (
  13   Iso (..),
  14   IsoFunctor (..),
  15   ProductFunctor (..),
  16   --SumFunctor (..),
  17   Repeatable (..),
  18  )
  19 import Symantic.Data (Data, SomeData (..))
  20 import Symantic.Reader (Reader (..))
  21
  22 -- import Control.Applicative (Applicative (..))
  23 -- import Data.List qualified as List
  24 import Data.Set (Set)
  25 import Data.Set qualified as Set
  26 import Symantic.Derive
  27
  28 --deriving instance Slugable repr => Slugable (Reflector r repr)
  29 --deriving instance Endable repr => Endable (Reflector r repr)
  30 --deriving instance Capturable repr => Capturable (Reflector r repr)
  31
  32 -- * Class 'Slugable'
  33
  34 -- | Syntax (final algebra) for expressing URL paths.
  35 class Slugable repr where
  36   -- chooseSlugs :: Set [URI.Slug] -> repr [URI.Slug]
  37   -- default chooseSlugs :: FromDerived Slugable repr => Set [URI.Slug] -> repr [URI.Slug]
  38   -- chooseSlugs = liftDerived . chooseSlugs
  39
  40   literalSlug :: URI.Slug -> repr ()
  41   default literalSlug :: IsoFunctor repr => URI.Slug -> repr ()
  42   literalSlug s = Iso (const ()) (const s) <%> chooseSlug (Set.singleton s)
  43
  44   chooseSlug :: Set URI.Slug -> repr URI.Slug
  45   default chooseSlug :: FromDerived Slugable repr => Set URI.Slug -> repr URI.Slug
  46   chooseSlug = liftDerived . chooseSlug
  47
  48 -- default chooseSlug :: IsoFunctor repr => Set URI.Slug -> repr URI.Slug
  49 -- chooseSlug s = Iso List.head pure <%> chooseSlugs (Set.mapMonotonic pure s)
  50
  51 instance (Slugable repr, IsoFunctor repr) => Slugable (Reader r repr)
  52
  53 -- | Pattern-matchable encoding (initial algebra) of 'Slugable'.
  54 data instance Data Slugable repr a where
  55   LiteralSlug :: URI.Slug -> Data Slugable repr ()
  56   ChooseSlug :: Set URI.Slug -> Data Slugable repr URI.Slug
  57
  58 -- ChooseSlugs :: Set [URI.Slug] -> Data Slugable repr [URI.Slug]
  59
  60 -- | Initial to final algebra.
  61 instance Slugable repr => Derivable (Data Slugable repr) where
  62   derive = \case
  63     LiteralSlug x -> literalSlug x
  64     ChooseSlug x -> chooseSlug x
  65
  66 -- ChooseSlugs x -> chooseSlugs x
  67
  68 -- | Final to initial algebra.
  69 instance Slugable repr => Slugable (SomeData repr) where
  70   literalSlug = SomeData . LiteralSlug
  71   chooseSlug = SomeData . ChooseSlug
  72
  73 --chooseSlugs = SomeData . ChooseSlugs
  74
  75 -- | Convenient alias for an @index.html@ page.
  76 index :: Slugable repr => repr ()
  77 index = literalSlug "index.html"
  78
  79 -- | Convenient alias for prefixing with a 'literalSlug'.
  80 (</>) ::
  81   ProductFunctor repr =>
  82   Slugable repr =>
  83   URI.Slug ->
  84   repr a ->
  85   repr a
  86 (</>) n = (literalSlug n .>)
  87
  88 infixr 4 </>
  89
  90 -- * Class 'Capturable'
  91 class Capturable repr where
  92   captureSlug :: URI.Slug -> repr URI.Slug
  93   default captureSlug :: FromDerived Capturable repr => URI.Slug -> repr URI.Slug
  94   captureSlug = liftDerived . captureSlug
  95 instance Capturable repr => Capturable (Reader r repr)
  96 data instance Data Capturable repr a where
  97   CaptureSlug :: URI.Slug -> Data Capturable repr URI.Slug
  98 instance Capturable repr => Derivable (Data Capturable repr) where
  99   derive = \case
 100     CaptureSlug n -> captureSlug n
 101 instance Capturable repr => Capturable (SomeData repr) where
 102   captureSlug = SomeData . CaptureSlug
 103
 104 -- * Class 'Fileable'
 105 class Fileable repr where
 106   type FileableConstraint repr :: Type -> Constraint
 107   static :: repr ()
 108   dynamic :: FileableConstraint repr a => repr a
 109
 110 -- * Class 'Endable'
 111 class Endable repr where
 112   end :: repr ()
 113   default end :: FromDerived Endable repr => repr ()
 114   end = liftDerived end
 115 instance Endable repr => Endable (Reader r repr)