encoder/decoder symmetry

Main.hs

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DerivingStrategies #-}

import Data.List (stripPrefix)

class Contra f where
  comap :: (b -> a) -> (f a -> f b)

(>$<) :: Contra f => (b -> a) -> (f a -> f b)
(>$<) = comap

infixr 4 >$<

infixr 4 >*<

class Contra f => Divisible f where
  divide :: (a -> (b, c)) -> f b -> f c -> f a
  conquer :: f a

divided, (>*<) :: Divisible f => f a -> f b -> f (a, b)
divided = divide id
(>*<) = divided

-- Example, part 1

newtype Encoder a = Encoder (a -> String)

instance Contra Encoder where
  comap f (Encoder s) = Encoder (s . f)

instance Divisible Encoder where
  conquer = Encoder \_ -> ""
  divide f (Encoder sa) (Encoder sb) = Encoder \x ->
    let (a, b) = f x
     in sa a <> sb b

stringE :: String -> Encoder ()
stringE s = Encoder \() -> s

newtype Decoder a = Decoder (String -> Maybe (String, a))
  deriving stock (Functor)

instance Applicative Decoder where
  pure x = Decoder \s -> Just (s, x)
  Decoder df <*> Decoder dx = Decoder \s -> do
    (s, f) <- df s
    (s, x) <- dx s
    pure (s, f x)

stringD :: String -> Decoder ()
stringD x = Decoder \s ->
  case stripPrefix x s of
    Nothing -> Nothing
    Just str -> Just (str, ())

class Encode a where
  encode :: Encoder a

class Decode a where
  decode :: Decoder a

-- Example, part 2

data A = A deriving stock (Show)

data B = B deriving stock (Show)

data C = C deriving stock (Show)

data X = X A B C deriving stock (Show)

instance Encode A where
  encode = (\A -> ()) >$< stringE "A"

instance Encode B where
  encode = (\B -> ()) >$< stringE "B"

instance Encode C where
  encode = (\C -> ()) >$< stringE "C"

instance Decode A where
  decode = (\() -> A) <$> stringD "A"

instance Decode B where
  decode = (\() -> B) <$> stringD "B"

instance Decode C where
  decode = (\() -> C) <$> stringD "C"

instance Encode X where
  encode = split >$< encode >*< encode >*< encode
    where
      split (X a b c) = (a, (b, c))

instance Decode X where
  decode = build <$> decode <*> decode <*> decode
    where
      build a b c = X a b c

encode' :: Encode a => a -> String
encode' x = let Encoder e = encode in e x

decode' :: Decode a => String -> Maybe a
decode' s =
  let Decoder d = decode
   in case d s of
        Just ("", x) -> Just x
        _ -> Nothing

main = do
  let x = encode' (X A B C)
  let y = decode' x
  print x
  print (y :: Maybe X)