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 'ContentTypeable'
  91 class ContentTypeable fmt a repr where
  92   contentType :: repr a
  93
  94 -- * Class 'Capturable'
  95 class Capturable repr where
  96   captureSlug :: URI.Slug -> repr URI.Slug
  97   default captureSlug :: FromDerived Capturable repr => URI.Slug -> repr URI.Slug
  98   captureSlug = liftDerived . captureSlug
  99 instance Capturable repr => Capturable (Reader r repr)
 100 data instance Data Capturable repr a where
 101   CaptureSlug :: URI.Slug -> Data Capturable repr URI.Slug
 102 instance Capturable repr => Derivable (Data Capturable repr) where
 103   derive = \case
 104     CaptureSlug n -> captureSlug n
 105 instance Capturable repr => Capturable (SomeData repr) where
 106   captureSlug = SomeData . CaptureSlug
 107
 108 -- * Class 'Fileable'
 109 class Fileable repr where
 110   type FileableConstraint repr :: Type -> Constraint
 111   static :: repr ()
 112   dynamic :: FileableConstraint repr a => repr a
 113
 114 -- * Class 'Endable'
 115 class Endable repr where
 116   end :: repr ()
 117   default end :: FromDerived Endable repr => repr ()
 118   end = liftDerived end
 119 instance Endable repr => Endable (Reader r repr)