Contravariant EOT

Scratch.hs

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE GADTs #-}
module Ops where

import Data.Void
import Data.Functor.Contravariant
import Data.Functor.Contravariant.Divisible hiding (lost)

import Generics.Eot

-- This is all from the `contravariant` docs, with slight modifications

newtype Serializer a = Serializer { runSerializer :: a -> String }

instance Contravariant Serializer where
  contramap f (Serializer g) = Serializer (g . f)

instance Divisible Serializer where
  conquer = Serializer (const mempty)

  divide toBC (Serializer sb) (Serializer sc) = Serializer $ \a ->
    case toBC a of
      (b, c) ->
        let bBytes = sb b
            cBytes = sc c
        in bBytes ++ cBytes

instance Decidable Serializer where
  lose f = Serializer $ \a -> absurd (f a)
  choose split l r = Serializer $ \a ->
    either (runSerializer l) (runSerializer r) (split a)

string :: Serializer String
string = Serializer id

int :: Serializer Int
int = Serializer show

double :: Serializer Double
double = Serializer show

bool :: Serializer Bool
bool = Serializer show

data Identifier = StringId String | IntId Int
  deriving (Eq, Ord, Show, Generic)
  
data Blob = Blog Int Identifier Bool
  deriving (Eq, Ord, Show, Generic)


identifier :: Serializer Identifier
identifier = contraSum $
  string >|<
  int    >|<
  lost

blob :: Serializer Blob
blob = contraProduct $
  int        >*<
  identifier >*<
  bool       >*<
  conquer

-- Here be the dragons that power this hamster wheel

infixr 4 >*<
(>*<) :: Divisible f => f a -> f b -> f (a, b)
(>*<) = divided

infixr 3 >|<
(>|<) :: Decidable f => f a -> f b -> f (Either (a, ()) b)
(>|<) x = chosen (x >*< conquer)

lost :: Decidable f => f Generics.Eot.Void
lost = lose otherAbsurd

-- only until generics-eot uses the Void from base
otherAbsurd :: Generics.Eot.Void -> a
otherAbsurd a = case a of {}

contraSum :: (HasEot a, Contravariant f) => f (Eot a) -> f a
contraSum = contramap toEot

contraProduct :: (HasEot a, Decidable f, Eot a ~ Either b Generics.Eot.Void) => f b -> f a
contraProduct = contramap toEot . flip chosen lost