Transhare (empty) → 0.9

raw patch · 4 files changed

+211/−0 lines, 4 filesdep +basedep +containerssetup-changed

Dependencies added: base, containers

Files

Data/Transhare.hs +121/−0
LICENSE +30/−0
Setup.hs +2/−0
Transhare.cabal +58/−0

+ Data/Transhare.hs view

@@ -0,0 +1,121 @@+-- | 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'

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright (c)2011, Chris Kuklewicz++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Chris Kuklewicz nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ Transhare.cabal view

@@ -0,0 +1,58 @@+-- Transhare.cabal auto-generated by cabal init. For additional+-- options, see+-- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr.+-- The name of the package.+Name:                Transhare++-- The package version. See the Haskell package versioning policy+-- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for+-- standards guiding when and how versions should be incremented.+Version:             0.9++-- A short (one-line) description of the package.+Synopsis:            A library to apply transformation to containers so as to maximize sharing of unchanged subcomponents.++-- A longer description of the package.+-- Description:         ++-- The license under which the package is released.+License:             BSD3++-- The file containing the license text.+License-file:        LICENSE++-- The package author(s).+Author:              Chris Kuklewicz++-- An email address to which users can send suggestions, bug reports,+-- and patches.+Maintainer:          <haskell@list.mightyreason.com>++-- A copyright notice.+-- Copyright:           ++Category:            Data++Build-type:          Simple++-- Extra files to be distributed with the package, such as examples or+-- a README.+-- Extra-source-files:  ++-- Constraint on the version of Cabal needed to build this package.+Cabal-version:       >=1.2+++Library+  -- Modules exported by the library.+  Exposed-modules:     Data.Transhare+  +  -- Packages needed in order to build this package.+  Build-depends:       base >=3 && < 5, containers+  +  -- Modules not exported by this package.+  -- Other-modules:       +  +  -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.+  -- Build-tools:         +