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)