inter.hs

{-# LANGUAGE TypeOperators #-}
module Main where
import Data.Bifunctor (first)

type (~>?) s a = (Either a s) -> (Either s a)

data Inter s a = Inter { getE        :: s ~>? a
                       , reverseGetE :: a ~>? s }

composeS :: (a ~>? b) -> (b ~>? c) -> (a ~>? c)
composeS _ _ (Left c)  = Right c
composeS f g (Right a) = first (const a) . g . Right =<< f (Right a)

(<->) :: Inter a b -> Inter b c -> Inter a c
(<->) (Inter f g) (Inter m n) = Inter (composeS f m) (composeS n g)

reverseI (Inter a b) = Inter b a

get i s = getE i $ Right s

maybeToEither a Nothing = Left a
maybeToEither _ (Just b) = Right b

slice' :: (s -> Maybe a) -> s ~>? a
slice' _ (Left a) = Right a
slice' f (Right s) = maybeToEither s $ f s

inter' :: (s -> Maybe a) -> (a -> Maybe s) -> Inter s a
inter' f g = Inter (slice' f) (slice' g)

------------------------------------------------------------------------------------------------------------------------------
-- Test

data X = X1 | X2 | X3      deriving Show
data Y =      Y2 | Y3 | Y4 deriving Show
data Z =      Z2 |      Z4 deriving Show

xy X1 = Nothing
xy X2 = Just Y2
xy X3 = Just Y3

yx Y2 = Just X2
yx Y3 = Just X3
yx Y4 = Nothing

yz Y2 = Just Z2
yz Y3 = Nothing
yz Y4 = Just Z4

zy Z2 = Just Y2
zy Z4 = Just Y4

ixy = inter' xy yx
iyz = inter' yz zy
ixyz = ixy <-> iyz

getRevGet i s = (reverseGetE i) . (getE i) $ Right s
test i s = (show s) ++
           " --> " ++ (show $ get i s) ++
           " --> " ++ (show $ getRevGet i s)

main :: IO ()
main = do
  putStrLn $ test ixy X1
  putStrLn $ test ixy X2
  putStrLn $ test ixy X3
  putStrLn $ test ixyz X1
  putStrLn $ test ixyz X2
  putStrLn $ test ixyz X3

Right X1 --> Left X1  --> Right X1
Right X2 --> Right Y2 --> Right X2
Right X3 --> Right Y3 --> Right X3

Right X1 --> Left X1  --> Right X1
Right X2 --> Right Z2 --> Right X2
Right X3 --> Left X3  --> Right X3