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 (($))
   8 import Data.Monoid (Endo (..), appEndo)
   9 import Data.Semigroup (Semigroup (..))
  10 import Network.URI.Slug
  11 import Symantic.Classes (Iso (..), IsoFunctor ((<%>)), ProductFunctor ((<.>)), SumFunctor ((<+>)))
  12
  13 import Webc.Classes
  14
  15 -- * The 'Encoder' interpreter
  16
  17 newtype Encoder a = Encoder
  18   { unEncoder :: MT.Reader a (Endo [Slug])
  19   }
  20
  21 encode :: Encoder a -> a -> [Slug]
  22 encode (Encoder enc) a = appEndo (MT.runReader enc a) []
  23
  24 instance IsoFunctor Encoder where
  25   Iso{..} <%> Encoder x = Encoder (MT.withReader b2a x)
  26 instance ProductFunctor Encoder where
  27   Encoder x <.> Encoder y = Encoder $
  28     MT.ReaderT $ \(a, b) ->
  29       return $
  30         MT.runReader x a
  31           <> MT.runReader y b
  32 instance SumFunctor Encoder where
  33   Encoder x <+> Encoder y = Encoder $
  34     MT.ReaderT $ \case
  35       Left a -> return $ MT.runReader x a
  36       Right b -> return $ MT.runReader y b
  37 instance Repeatable Encoder where
  38   many0 x = Encoder $
  39     MT.ReaderT $ \as ->
  40       return $ Endo (foldMap (encode x) as <>)
  41   many1 = many0
  42 instance Slugable Encoder where
  43   literalSlug s = Encoder $ return $ Endo (s :)
  44   captureSlug _n = Encoder $ MT.ReaderT $ \s -> return $ Endo (s :)