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
  11 import Data.ByteString.Lazy qualified as BSL
  12 import Data.Maybe (Maybe (..))
  13 import Data.Monoid (Endo (..), appEndo)
  14 import Data.Semigroup (Semigroup (..))
  15 import Network.URI.Slug
  16 import Symantic.Classes (Iso (..), IsoFunctor ((<%>)), Optionable (..), ProductFunctor ((<.>)), SumFunctor ((<+>)))
  17
  18 import Webc.Classes
  19 import Webc.Decoder (Request (..))
  20 import Webc.MIME
  21
  22 -- * The 'Encoder' interpreter
  23
  24 -- | Encode a given route to its URL.
  25 newtype Encoder a = Encoder
  26   { unEncoder :: MT.Reader a (Endo [Slug])
  27   }
  28
  29 encode :: Encoder a -> a -> [Slug]
  30 encode (Encoder enc) a = appEndo (MT.runReader enc a) []
  31
  32 instance IsoFunctor Encoder where
  33   Iso{..} <%> Encoder x = Encoder (MT.withReader b2a x)
  34 instance ProductFunctor Encoder where
  35   Encoder x <.> Encoder y = Encoder $
  36     MT.ReaderT $ \(a, b) ->
  37       return $ MT.runReader x a <> MT.runReader y b
  38 instance SumFunctor Encoder where
  39   Encoder x <+> Encoder y = Encoder $
  40     MT.ReaderT $ \case
  41       Left a -> return $ MT.runReader x a
  42       Right b -> return $ MT.runReader y b
  43 instance Repeatable Encoder where
  44   many0 x = Encoder $
  45     MT.ReaderT $ \as ->
  46       return $ Endo (foldMap (encode x) as <>)
  47   many1 = many0
  48 instance Optionable Encoder where
  49   optional (Encoder x) = Encoder $
  50     MT.ReaderT $ \case
  51       Nothing -> return $ Endo id
  52       Just a -> return $ MT.runReader x a
  53 instance Slugable Encoder where
  54   literalSlug s = Encoder $ return $ Endo (s :)
  55   chooseSlug _s = Encoder $ MT.ReaderT $ \s -> return $ Endo (s :)
  56
  57 {-
  58 instance ContentTypeable PlainText BSL.ByteString Encoder where
  59   contentType = Encoder $ MT.ReaderT $ \a ->
  60     return a
  61 -}
  62 -- chooseSlugs _s = Encoder $ MT.ReaderT $ \s -> return $ Endo (List.reverse s <>)
  63 instance Capturable Encoder where
  64   captureSlug _n = Encoder $ MT.ReaderT $ \s -> return $ Endo (s :)
  65 instance Endable Encoder where
  66   end = Encoder $ return $ Endo id
  67
  68 --chooseSlug _cs = Encoder $ MT.ReaderT $ \s -> return $ Endo (s :)
  69 -- instance Fileable Encoder where
  70 --   type FileableConstraint Encoder = Typeable
  71 --   static = Encoder $ MT.ReaderT $ \_a ->
  72 --     return $ Endo (\x -> x)