Covariant and Contravariant

Pair.hs

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

import Control.Applicative

import GHC.Generics

import Data.Void
import Data.Functor.Invariant
import Data.Functor.Contravariant
import Data.Functor.Contravariant.Divisible

import Generics.Eot

import Data.Char

-- A basic Parser

newtype Parser a = Parser { runParser :: String -> Maybe (String, a) }

defaultParser :: Read a => Parser a
defaultParser = Parser $ \s -> case reads s of
  [] -> Nothing
  ((a, s') : _) -> Just  (s', a)

-- The instances for the Parser

instance Functor Parser where
  fmap f (Parser p) = Parser (fmap (fmap (fmap f)) p)

instance Applicative Parser where
  pure a = Parser (\s -> Just (s, a))
  Parser pf <*> Parser px = Parser $ \s ->
    case pf s of
      Nothing -> Nothing
      Just (s', f) -> case px s' of
        Nothing -> Nothing
        Just (s'', x) -> Just (s'', f x)

instance Alternative Parser where
  empty = Parser $ const Nothing
  Parser px <|> Parser py = Parser $ \s ->
    case px s of
      Nothing -> py s
      Just (s', x) -> Just (s', x)


-- A basic Serializer

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

defaultSerializer :: Show a => Serializer a
defaultSerializer = Serializer show


-- The instances for the Serializer

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)

-- A Pair of a covariant and contravariant functor

data Pair f g a = Pair { co :: f a, contra :: g a}

-- The instances for the Pair

instance (Functor f, Contravariant g) => Invariant (Pair f g) where
  invmap ab ba (Pair fa ga)= Pair (fmap ab fa) (contramap ba ga)

infixr 4 >*<
class Invariant f => Mult f where
  munit :: a -> f a
  (>*<) :: f a -> f b -> f (a, b)

  (>*) :: f a -> f () -> f a
  (>*) fa fu = invmap fst (\x -> (x, ())) (fa >*< fu)

  (*<) :: f () -> f b -> f b
  (*<) fu fb = invmap snd (\x -> ((), x)) (fu >*< fb)

infixr 3 >|<
class Invariant f => Div f where
  dunit :: f Generics.Eot.Void
  (>|<) :: f a -> f b -> f (Either a b)

otherAbsurd :: Generics.Eot.Void -> a
otherAbsurd a = case a of {}

instance (Applicative f, Divisible g) => Mult (Pair f g) where
  munit a = Pair (pure a) conquer
  Pair f1 g1 >*< Pair f2 g2 = Pair ((,) <$> f1 <*> f2) (divide id g1 g2)

instance (Alternative f, Decidable g) => Div (Pair f g) where
  dunit = Pair empty (lose otherAbsurd)
  Pair f1 g1 >|< Pair f2 g2 = Pair (Left <$> f1 <|> Right <$> f2) (choose id g1 g2)

-- The pairing of the parser and the serializer

type StringMe a = Pair Parser Serializer a

defaultStringMe :: (Read a, Show a) => StringMe a
defaultStringMe = Pair defaultParser defaultSerializer

-- Some defaults to work with

smString :: StringMe String
smString = defaultStringMe

smInt :: StringMe Int
smInt = defaultStringMe

smBool :: StringMe Bool
smBool = defaultStringMe

-- A parser / printer for handling spaces

spaces :: StringMe ()
spaces = Pair parseSpaces serializeSpaces
  where
    parseSpaces = Parser $ \s ->
      case break isSpace s of
        (_, ts) -> Just (ts, ())
    serializeSpaces = Serializer $
      const " "

-- Some helpers for working with generics-eot

eotSum :: (HasEot a, Invariant f) => f (Eot a) -> f a
eotSum = invmap fromEot toEot

eotProduct :: (HasEot a, Invariant f, Div f, Eot a ~ Either b Generics.Eot.Void) => f b -> f a
eotProduct x = invmap fromEot toEot (x >|< dunit)

-- An example data type and the serializer / parser pair for it

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

smIdentifier :: StringMe Identifier
smIdentifier =
  eotSum $
    smString >*< munit () >|<
    smInt    >*< munit () >|<
    dunit

data Blob = Blob Int Identifier Bool
  deriving (Eq, Ord, Show, Generic)

smBlob :: StringMe Blob
smBlob =
  eotProduct $
    smInt        >* spaces >*<
    smIdentifier >* spaces >*<
    smBool                 >*<
    munit ()

-- > let s = runSerializer (contra smBlob) (Blob 2 (IntId 4) False)
-- > s
-- "2 4 False"
-- > runParser (co smBlob) s
-- Just ("", Blob 2 (IntId 4) False)