abstract.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ViewPatterns #-}

module Main where

import Data.Monoid
import Control.Lens

-- * Model: goes in the library

-- ** 'Type' of events with accessors to event fields
class A a where
    a1 :: Lens' a Int
    a2 :: Lens' a String

class B b where
    b :: Lens' b Bool


-- ** 'Type' of union of events
class (A a, B b) =>  Event e a b | e -> a, e -> b where
    _EventA :: Getting (First a) e a
    _EventB :: Getting (First b) e b

-- ** 'Implementation' of some dispatcher
doSomething :: Event e a b
            => e
            -> IO ()
doSomething (preview _EventA -> Just e) = print $ e ^. a1
doSomething (preview _EventB -> Just e) = print $ e ^. b
doSomething _ = fail "Impossible"


-- * Implementation: goes with the application
-- ** Concrete types for events, and instances
data VA = VA Int
data VB = VB Bool

instance A VA where
    a1 = lens (\(VA v) -> v) (\_ v -> VA v)
    a2 = lens (const "abc") (\v _ -> v)

instance B VB where b = lens (\(VB v) -> v) (\_ v -> VB v)

-- ** Concrete type for union of events
data E = EA VA | EB VB

instance Event E VA VB where
    -- All we need is a Getting, so no real need to implement a Prism
    -- Doesn't harm though, and can only be used as a Getting anyway
    _EventA = prism' EA (\e -> case e of
                                EA v -> Just v
                                EB _ -> Nothing)
    _EventB = prism' EB (\e -> case e of
                                EA _ -> Nothing
                                EB v -> Just v)

-- * Demo
main :: IO ()
main = do
    doSomething (EA (VA 123))
    doSomething (EB (VB True))