Last active
July 26, 2018 13:37
-
-
Save Rydgel/4abcdb6a9a8ca182bce2571ece99685a to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# 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) | |
doStuffWithA :: HasName A | |
doStuffWithA = HasName $ \a -> "A" | |
doStuffWithB :: HasName B | |
doStuffWithB = HasName $ \b -> "B" | |
doStuffWithC :: HasName C | |
doStuffWithC = HasName $ \c -> "C" | |
chooseTask :: HasName Task | |
chooseTask = contraSum $ | |
doStuffWithA >|< | |
doStuffWithB >|< | |
doStuffWithC >|< | |
lost | |
chooseBigTask :: HasName BigTask | |
chooseBigTask = contraProduct $ | |
doStuffWithA >*< | |
doStuffWithB >*< | |
doStuffWithC >*< | |
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) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment