Add voidEncoder/HasInitialObject

obsidiansystems · Oct 6, 2024 · e679f18 · e679f18
1 parent a294a75
commit e679f18
Show file tree

Hide file tree

Showing 2 changed files with 16 additions and 5 deletions.
diff --git a/lib/route/src/Obelisk/Route.hs b/lib/route/src/Obelisk/Route.hs
@@ -117,6 +117,7 @@ module Obelisk.Route
   , handleEncoder
   , someSumEncoder
   , Void1
+  , voidEncoder
   , void1Encoder
   , pathSegmentsTextEncoder
   , queryParametersTextEncoder
@@ -136,6 +137,7 @@ import Control.Applicative
 import Control.Category (Category (..))
 import qualified Control.Categorical.Functor as Cat
 import Control.Categorical.Bifunctor
+import Control.Categorical.Object
 import Control.Category.Associative
 import Control.Category.Monoidal
 import Control.Category.Braided
@@ -201,6 +203,7 @@ import Data.Text.Lens (IsText, packed, unpacked)
 import Data.Type.Equality
 import Data.Universe
 import Data.Universe.Some
+import Data.Void
 import Network.HTTP.Types.URI
 import qualified Numeric.Lens
 import Obelisk.Route.TH
@@ -388,6 +391,10 @@ instance (Applicative check, Monad parse) => Category (Encoder check parse) wher
   id = Encoder $ pure id
   (.) = o
 
+instance (Applicative check, MonadError Text parse) => HasInitialObject (Encoder check parse) where
+  type Initial (Encoder check parse) = Void
+  initiate = voidEncoder
+
 instance Monad parse => Category (EncoderImpl parse) where
   id = EncoderImpl
     { _encoderImpl_decode = pure
@@ -1107,12 +1114,15 @@ instance UniverseSome Void1 where
   universeSome = []
 instance FiniteSome Void1
 
-void1Encoder :: (Applicative check, MonadError Text parse) => Encoder check parse (Some Void1) a
-void1Encoder = Encoder $ pure $ EncoderImpl
-  { _encoderImpl_encode = foldSome $ \case
-  , _encoderImpl_decode = \_ -> throwError "void1Encoder: can't decode anything"
+voidEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse Void a
+voidEncoder = Encoder $ pure $ EncoderImpl
+  { _encoderImpl_encode = \case
+  , _encoderImpl_decode = \_ -> throwError "voidEncoder: can't decode anything"
   }
 
+void1Encoder :: (Applicative check, MonadError Text parse) => Encoder check parse (Some Void1) a
+void1Encoder = voidEncoder . viewEncoder (iso (foldSome (\case)) (\case))
+
 instance GShow Void1 where
   gshowsPrec _ = \case {}
 

diff --git a/lib/route/test/Main.hs b/lib/route/test/Main.hs
@@ -257,7 +257,8 @@ exhaustive =
     prop f = f $ \lbl e -> testProperty lbl $ withCheckedEncoder e $ flip all universeF . roundtripsProp
   in
     testGroup "Roundtrip" $ prop $ \t ->
-      [ t "void1Encoder" void1Encoder
+      [ t "voidEncoder" voidEncoder
+      , t "void1Encoder" void1Encoder
       , t "id (Word8)" $ id @_ @Word8
       , t "enumEncoder" $ enumEncoder @_ @_ @Word8 (+1)
       ]