```-- | This module is my answer to the pattern discussed in
-- http://blog.ezyang.com/2011/06/a-pattern-for-increasing-sharing/ about maximizing sharing when
-- transforming an algebraic data type.
--
-- The' 'Transhare' class is a kind of degerate case of 'Traverse' building on a new 'Applicative'
-- data type called 'TransResult' defined below.  The result 'transM' is a way to lift a
-- parsimonious transformer 'a -> Maybe a', which indicates identity with 'Nothing', to work on a
-- container with maximized sharing.
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)         -- needed for default implementation of (*>) to pass ignore_left_value_law
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))

-- | 'TransM' is a parsimonious transformer that can return 'Nothing' when the transformation is an identity.
--
-- If the result is 'Just' 't' then the result 't' might or might not be identical to the argument.
type TransM a = a -> Maybe a

-- | 'TransR' is a parsimonious transformer that returns (Original x) only if x is the original argument.
--
-- This must follow the law that TransMR . TransRM . t = t
--
-- The disadvantage of 'TransR' compared to 'TransM' is ensuring the above law and that sharing for
-- Original results is actually being done.
--
-- 'TransR' which implement sharing correctly are "proper implementations" of 'TransR'
type TransR a = a -> TransResult a

-- | 'transMR' creates a proper implementation of 'transR' from any 'transM'
transMR :: TransM a -> TransR a
transMR t = \a -> maybe (Original a) Transformed (t a)

-- | 'transRM' creates a proper implementation of 'transM' only from a proper implementation of 'transR'
transRM :: TransR a -> TransM a
transRM t = \a -> case t a of Original _ -> Nothing
Transformed a -> Just a

-- | 'fromO' is a helper function used with Applicative to ensure the 'TransR' computed by 'transR'
-- are proper implementations.
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' checks that the Functor and Applicative instances do what they are supposed to
-- do.
transResult_laws :: Bool
transResult_laws = all and \$
[ -- Check the tainting of Transformed
[ (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'
```