divisible.hs

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE GADTs #-}

module Main where

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

import Generics.Eot

newtype HasName a =
  HasName { runHasName :: a -> String }

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

instance Divisible HasName where
  conquer = HasName (const mempty)
  divide toBC (HasName sb) (HasName sc) = HasName $ \a ->
    case toBC a of
      (b, c) ->
        let bBytes = sb b
            cBytes = sc c
        in bBytes ++ cBytes

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

data A =
  A deriving (Eq, Ord, Show)

data B =
  B deriving (Eq, Ord, Show)

data C =
  C deriving (Eq, Ord, Show)

data Task
  = TaskA A
  | TaskB B
  | TaskC C
  deriving (Eq, Ord, Show, Generic)

data BigTask =
  BigTask A B C
  deriving (Eq, Ord, Show, Generic)

chooseTask :: HasName Task
chooseTask = contraSum $
  HasName (const "A") >|<
  HasName (const "B") >|<
  HasName (const "C") >|<
  lost

chooseBigTask :: HasName BigTask
chooseBigTask = contraProduct $
  HasName (const "A") >*<
  HasName (const "B") >*<
  HasName (const "C") >*<
  conquer

dispatch :: Task -> String
dispatch = runHasName chooseTask

dispatchBigTask :: BigTask -> String
dispatchBigTask = runHasName chooseBigTask

-- helpers

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)

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

main
  :: IO ()
main
  = do
    print $ dispatch (TaskA A)
    print $ dispatch (TaskC C)
    print $ dispatchBigTask (BigTask A B C)