module Data.Transhare where
import Control.Applicative(Applicative(..),(<$>))
import Data.Tree(Tree(..))
data TransResult a = Original { getTrans :: a }
| Transformed { getTrans :: a }
deriving (Show,Eq)
instance Functor TransResult where
fmap f (Original a) = Original (f a)
fmap f (Transformed a) = Transformed (f a)
instance Applicative TransResult where
pure a = Original a
(Original x) <*> (Original y) = Original (x y)
tx <*> ty = Transformed (getTrans tx (getTrans ty))
type TransM a = a -> Maybe a
type TransR a = a -> TransResult a
transMR :: TransM a -> TransR a
transMR t = \a -> maybe (Original a) Transformed (t a)
transRM :: TransR a -> TransM a
transRM t = \a -> case t a of Original _ -> Nothing
Transformed a -> Just a
fromO :: a -> TransResult a -> TransResult a
fromO a (Original _) = Original a
fromO _ b = b
class Transhare f where
transM :: TransM a -> TransM (f a)
transM = transRM . transR . transMR
transR :: TransR a -> TransR (f a)
instance Transhare ((,) a) where
transR t = \ x@(a,b) -> fromO x $ (,) a <$> t b
instance Transhare (Either a) where
transR t = let tE x@(Right b) = fromO x $ Right <$> t b
tE x = Original x
in tE
instance Transhare [] where
transR t = let tL x@((:) v vs) = fromO x $ (:) <$> t v <*> transR t vs
tL x = Original x
in tL
instance Transhare Tree where
transR t = \ a@(Node value children) -> fromO a $ Node <$> t value <*> transR (transR t) children
instance Transhare TransResult where
transR t = let tR x@(Original a) = fromO x $ Original <$> t a
tR x@(Transformed a) = fromO x $ Transformed <$> t a
in tR
transResult_laws :: Bool
transResult_laws = all and $
[
[ (Transformed (error "discarded") *> Original 'q') == Transformed 'q'
, (Original 'q' <* Transformed (error "discarded")) == Transformed 'q'
, (Original (error "discarded") *> Transformed 'q') == Transformed 'q'
, (Transformed 'q' <* Original (error "discarded")) == Transformed 'q'
]
, let fmap_law f x = fmap f x == (pure f <*> x)
in [ fmap_law f x | f <- [succ], x <- [o,t] ]
, let identity_law v = (pure id <*> v) == v
in [ identity_law v | v <- [o,t]]
, let composition_law u v w = (pure (.) <*> u <*> v <*> w) == (u <*> (v <*> w))
uo = Original succ
ut = Transformed succ
vo = Original (pred.pred)
vt = Transformed (pred.pred)
in [ composition_law u v w | u <- [uo,ut], v <- [vo,vt], w <- [o,t]]
, let homomorphism_law f x = (pure f <*> pure x) == (pure (f x) :: TransResult Char)
in [ homomorphism_law f x | f <- [succ], x <- ['x'] ]
, let interchange_law u y = (u <*> pure y) == (pure ($ y) <*> u)
uo = Original succ
ut = Transformed succ
in [ interchange_law u y | u <- [uo,ut], y <- ['y']]
, let ignore_left_value_law u v = (u *> v) == (pure (const id) <*> u <*> v)
uo = Original (error "discard uo")
ut = Transformed (error "discard ut")
in [ ignore_left_value_law u v| u <- [uo,ut], v <- [o,t]]
, let ignore_right_value_law u v = (u <* v) == (pure const <*> u <*> v)
vo = Original (error "discard vo")
vt = Transformed (error "discard vt")
in [ ignore_right_value_law u v| u <- [o,t], v <- [vo,vt]]
]
where
o = Original 'o'
t = Transformed 't'