]> Git — Sourcephile - webc.git/blob - src/Webc/Classes.hs
727d48713605034f641c7ae1a9e220c2d665cbaf
[webc.git] / 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)