Transhare-0.9: Data/Transhare.hs

-- | 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'