]> Git — Sourcephile - webc.git/blob - src/Webc/Encoder.hs
91264bf7fb4d53e462f4f7f2acfc68251ea86d44
[webc.git] / src / Webc / Encoder.hs
1 module Webc.Encoder where
2
3 import Control.Monad (Monad (..))
4 import Control.Monad.Trans.Reader qualified as MT
5 import Data.Either (Either (..))
6 import Data.Foldable (foldMap)
7 import Data.Function (id, ($))
8
9 -- import Data.List qualified as List
10 import Data.Maybe (Maybe (..))
11 import Data.Monoid (Endo (..), appEndo)
12 import Data.Semigroup (Semigroup (..))
13 import Network.URI.Slug
14 import Symantic.Classes (Iso (..), IsoFunctor ((<%>)), Optionable (..), ProductFunctor ((<.>)), SumFunctor ((<+>)))
15
16 import Webc.Classes
17
18 -- * The 'Encoder' interpreter
19
20 -- | Encode a given route to its URL.
21 newtype Encoder a = Encoder
22 { unEncoder :: MT.Reader a (Endo [Slug])
23 }
24
25 encode :: Encoder a -> a -> [Slug]
26 encode (Encoder enc) a = appEndo (MT.runReader enc a) []
27
28 instance IsoFunctor Encoder where
29 Iso{..} <%> Encoder x = Encoder (MT.withReader b2a x)
30 instance ProductFunctor Encoder where
31 Encoder x <.> Encoder y = Encoder $
32 MT.ReaderT $ \(a, b) ->
33 return $
34 MT.runReader x a
35 <> MT.runReader y b
36 instance SumFunctor Encoder where
37 Encoder x <+> Encoder y = Encoder $
38 MT.ReaderT $ \case
39 Left a -> return $ MT.runReader x a
40 Right b -> return $ MT.runReader y b
41 instance Repeatable Encoder where
42 many0 x = Encoder $
43 MT.ReaderT $ \as ->
44 return $ Endo (foldMap (encode x) as <>)
45 many1 = many0
46 instance Optionable Encoder where
47 optional (Encoder x) = Encoder $
48 MT.ReaderT $ \case
49 Nothing -> return $ Endo id
50 Just a -> return $ MT.runReader x a
51 instance Slugable Encoder where
52 literalSlug s = Encoder $ return $ Endo (s :)
53 chooseSlug _s = Encoder $ MT.ReaderT $ \s -> return $ Endo (s :)
54
55 -- chooseSlugs _s = Encoder $ MT.ReaderT $ \s -> return $ Endo (List.reverse s <>)
56 instance Capturable Encoder where
57 captureSlug _n = Encoder $ MT.ReaderT $ \s -> return $ Endo (s :)
58 instance Endable Encoder where
59 end = Encoder $ return $ Endo id
60
61 --chooseSlug _cs = Encoder $ MT.ReaderT $ \s -> return $ Endo (s :)
62 -- instance Fileable Encoder where
63 -- type FileableConstraint Encoder = Typeable
64 -- static = Encoder $ MT.ReaderT $ \_a ->
65 -- return $ Endo (\x -> x)