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