{-# LANGUAGE MultiParamTypeClasses , FlexibleInstances , GeneralizedNewtypeDeriving , DeriveFunctor , TypeFamilies , TypeOperators , UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.Diagrams.Monoids -- Copyright : (c) 2011 diagrams-core team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- Various monoid-related definitions (monoid actions, split monoids, -- applicative monoids) used in the core diagrams library. -- ----------------------------------------------------------------------------- module Graphics.Rendering.Diagrams.Monoids ( -- * Monoids and semigroups Monoid' -- * Monoid actions , Action(..) -- * Split monoids -- $split , Split(..), split -- * Forgetful monoids -- $forget , Forgetful(..), unForget, forget , Deletable(..), unDelete, toDeletable, deleteL, deleteR -- * Applicative monoids , AM(..), inAM2 -- * Coproduct monoid , (:+:) , inL, inR , mappendL, mappendR , killL, killR , untangle ) where import Graphics.Rendering.Diagrams.V import Data.Semigroup import Data.Foldable import Control.Applicative import Data.Either (lefts, rights) ------------------------------------------------------------ -- Monoids and semigroups ------------------------------------------------------------ -- Poor man's constraint synonym. Eventually, once it becomes -- standard, we can make this a real constraint synonym and get rid of -- the UndecidableInstances flag. Better yet, hopefully the Monoid -- class will eventually have a Semigroup superclass. -- | The @Monoid'@ class is a synonym for things which are instances -- of both 'Semigroup' and 'Monoid'. Ideally, the 'Monoid' class -- itself will eventually include a 'Semigroup' superclass and we -- can get rid of this. class (Semigroup m, Monoid m) => Monoid' m instance (Semigroup m, Monoid m) => Monoid' m ------------------------------------------------------------ -- Monoid actions ------------------------------------------------------------ -- | Type class for monoid actions, where monoidal values of type @m@ -- \"act\" on values of another type @s@. Instances are required to -- satisfy the laws -- -- * @act mempty = id@ -- -- * @act (m1 ``mappend`` m2) = act m1 . act m2@ -- -- Additionally, if the type @s@ has any algebraic structure, @act -- m@ should be a homomorphism. For example, if @s@ is also a -- monoid we should have @act m mempty = mempty@ and @act m (s1 -- ``mappend`` s2) = (act m s1) ``mappend`` (act m s2)@. -- -- By default, @act = const id@, so for a monoidal type @M@ which -- should have no action on anything, it suffices to write -- -- > instance Action M s -- -- with no method implementations. class Action m s where -- | Convert a monoidal value of type @m@ to an action on @s@ values. act :: m -> s -> s act = const id ------------------------------------------------------------ -- Split monoids ------------------------------------------------------------ -- $split -- Sometimes we want to accumulate values from some monoid, but have -- the ability to introduce a \"split\" which separates values on -- either side. For example, this is used when accumulating -- transformations to be applied to primitive diagrams: the 'freeze' -- operation introduces a split, since only transformations occurring -- outside the freeze should be applied to attributes. infix 5 :| -- | A value of type @Split m@ is either a single @m@, or a pair of -- @m@'s separated by a divider. data Split m = M m | m :| m -- | If @m@ is a @Semigroup@, then @Split m@ is a semigroup which -- combines values on either side of a split, keeping only the -- rightmost split. instance Semigroup m => Semigroup (Split m) where (M m1) <> (M m2) = M (m1 <> m2) (M m1) <> (m1' :| m2) = m1 <> m1' :| m2 (m1 :| m2) <> (M m2') = m1 :| m2 <> m2' (m11 :| m12) <> (m21 :| m22) = m11 <> m12 <> m21 :| m22 instance (Semigroup m, Monoid m) => Monoid (Split m) where mempty = M mempty mappend = (<>) -- | A convenient name for @mempty :| mempty@, so @a \<\> split \<\> b == a :| b@. split :: Monoid m => Split m split = mempty :| mempty -- | By default, the action of a split monoid is the same as for -- the underlying monoid, as if the split were removed. instance Action m n => Action (Split m) n where act (M m) n = act m n act (m1 :| m2) n = act m1 (act m2 n) ------------------------------------------------------------ -- Forgetful monoids ------------------------------------------------------------ -- $forget -- Sometimes we want to be able to \"forget\" some information. We -- define two monoid transformers that allow forgetting information. -- @Forgetful@ introduces special values which cause anything to their -- right to be forgotten. @Deletable@ introduces special \"left and -- right bracket\" elements which cause everything inside them to be -- forgotten. -- | A value of type @Forgetful m@ is either a \"normal\" value of -- type @m@, which combines normally with other normal values, or a -- \"forgetful\" value, which combines normally with other values to -- its left but discards values combined on the right. Also, when -- combining a forgetful value with a normal one the result is -- always forgetful. data Forgetful m = Normal m | Forgetful m deriving Functor -- | Project the wrapped value out of a `Forgetful` value. unForget :: Forgetful m -> m unForget (Normal m) = m unForget (Forgetful m) = m -- | If @m@ is a 'Semigroup', then @Forgetful m@ is a semigroup with two -- sorts of values, \"normal\" and \"forgetful\": the normal ones -- combine normally and the forgetful ones discard anything to the -- right. instance Semigroup m => Semigroup (Forgetful m) where (Normal m1) <> (Normal m2) = Normal (m1 <> m2) (Normal m1) <> (Forgetful m2) = Forgetful (m1 <> m2) (Forgetful m1) <> _ = Forgetful m1 instance (Semigroup m, Monoid m) => Monoid (Forgetful m) where mempty = Normal mempty mappend = (<>) -- | A convenient name for @Forgetful mempty@, so @a \<\> forget \<\> -- b == Forgetful a@. forget :: Monoid m => Forgetful m forget = Forgetful mempty instance Action m n => Action (Forgetful m) n where act (Normal m) n = act m n act (Forgetful m) n = act m n type instance V (Forgetful m) = V m -- | If @m@ is a 'Monoid', then @Deletable m@ (intuitively speaking) -- adds two distinguished new elements @[@ and @]@, such that an -- occurrence of [ \"deletes\" everything from it to the next ]. For -- example, -- -- > abc[def]gh == abcgh -- -- This is all you really need to know to /use/ @Deletable m@ -- values; to understand the actual implementation, read on. -- -- To properly deal with nesting and associativity we need to be -- able to assign meanings to things like @[[@, @][@, and so on. (We -- cannot just define, say, @[[ == [@, since then @([[)] == [] == -- id@ but @[([]) == [id == [@.) Formally, elements of @Deletable -- m@ are triples of the form (r, m, l) representing words @]^r m -- [^l@. When combining two triples (r1, m1, l1) and (r2, m2, l2) -- there are three cases: -- -- * If l1 == r2 then the [s from the left and ]s from the right -- exactly cancel, and we are left with (r1, m1 \<\> m2, l2). -- -- * If l1 < r2 then all of the [s cancel with some of the ]s, but -- m1 is still inside the remaining ]s and is deleted, yielding (r1 -- + r2 - l1, m2, l2) -- -- * The remaining case is symmetric with the second. data Deletable m = Deletable Int m Int deriving Functor type instance V (Deletable m) = V m -- | Project the wrapped value out of a `Deletable` value. unDelete :: Deletable m -> m unDelete (Deletable _ m _) = m -- | Inject a value into a `Deletable` wrapper. Satisfies the -- property -- -- > unDelete . toDeletable === id -- toDeletable :: m -> Deletable m toDeletable m = Deletable 0 m 0 instance Semigroup m => Semigroup (Deletable m) where (Deletable r1 m1 l1) <> (Deletable r2 m2 l2) | l1 == r2 = Deletable r1 (m1 <> m2) l2 | l1 < r2 = Deletable (r1 + r2 - l1) m2 l2 | otherwise = Deletable r1 m1 (l2 + l1 - r2) instance (Semigroup m, Monoid m) => Monoid (Deletable m) where mempty = Deletable 0 mempty 0 mappend = (<>) -- | A \"left bracket\", which causes everything between it and the -- next right bracket to be deleted. deleteL :: Monoid m => Deletable m deleteL = Deletable 0 mempty 1 -- | A \"right bracket\", denoting the end of the section that should -- be deleted. deleteR :: Monoid m => Deletable m deleteR = Deletable 1 mempty 0 ------------------------------------------------------------ -- Applicative monoids ------------------------------------------------------------ -- | A wrapper for an 'Applicative' structure containing a monoid. -- Such structures have a @Monoid@ instance based on \"idiomatic\" -- application of 'mappend' within the @Applicative@ context. -- @instance Monoid m => Monoid (e -> m)@ is one well-known special -- case. (However, the standard @Monoid@ instance for @Maybe@ is -- /not/ an instance of this pattern; nor is the standard instance -- for lists.) newtype AM f m = AM (f m) deriving (Functor, Applicative) -- | Apply a binary function inside an 'AM' newtype wrapper. inAM2 :: (f m -> f m -> f m) -> AM f m -> AM f m -> AM f m inAM2 g (AM f1) (AM f2) = AM (g f1 f2) instance (Applicative f, Semigroup m) => Semigroup (AM f m) where (<>) = inAM2 (liftA2 (<>)) -- | @f1 ``mappend`` f2@ is defined as @'mappend' '<$>' f1 '<*>' f2@. instance (Applicative f, Monoid m) => Monoid (AM f m) where mempty = pure mempty mappend = inAM2 (liftA2 mappend) {- See Applicative laws here: http://hackage.haskell.org/packages/archive/base/latest/doc/html/Control-Applicative.html#t:Applicative -} {- left identity: AM (pure mempty) `mappend` AM f = { definition } AM $ fmap mappend (pure mempty) <*> f = { naturality of pure, fmap f . pure = pure . f } AM $ pure (mappend mempty) <*> f = { monoid law (left identity) } AM $ pure id <*> f = { applicative law (identity) } AM f -} {- right identity: AM f `mappend` AM (pure mempty) = { definition } AM $ fmap mappend f <*> pure mempty = { applicative law (interchange) } AM $ pure ($mempty) <*> fmap mappend f = { applicative/functor law } AM $ pure ($mempty) <*> (pure mappend <*> f) = { applicative law (composition) } AM $ pure (.) <*> pure ($mempty) <*> pure mappend <*> f = { applicative law (homomorphism) } AM $ pure ((.) ($mempty)) <*> pure mappend <*> f = { applicative law (homomorphism) } AM $ pure (($mempty) . mappend) <*> f = { monoid law (right identity) } AM $ pure id <*> f = { applicative law (identity) } AM f -} {- associativity: (AM f1 `mappend` AM f2) `mappend` AM f3 = { definition } AM $ fmap mappend (AM f1 `mappend` AM f2) <*> f3 = { definition } AM $ fmap mappend (fmap mappend f1 <*> f2) <*> f3 = { applicative/functor law } AM $ pure mappend <*> (pure mappend <*> f1 <*> f2) <*> f3 = { applicative law (composition) } AM $ pure (.) <*> pure mappend <*> (pure mappend <*> f1) <*> f2 <*> f3 = { applicative law (homomorphism) } AM $ pure (mappend .) <*> (pure mappend <*> f1) <*> f2 <*> f3 = { applicative law (composition) } AM $ pure (.) <*> pure (mappend .) <*> pure mappend <*> f1 <*> f2 <*> f3 = { applicative law (homomorphism) } AM $ pure ((mappend .) . mappend) <*> f1 <*> f2 <*> f3 = { monoid law (associativity) } AM $ pure ((. mappend) . (.) . mappend) <*> f1 <*> f2 <*> f3 = -- XXX finish this proof (although I have no doubt it goes through) = AM f1 `mappend` (AM f2 `mappend` AM f3) -} {- \x y z -> (x `mappend` y) `mappend` z \x y -> mappend (mappend x y) \x -> mappend . (mappend x) (mappend .) . mappend -} {- \x y z -> x `mappend` (y `mappend` z) \x y z -> mappend x (mappend y z) \x y -> mappend x . mappend y \x -> ((.) (mappend x)) . mappend \x -> (.) ((.) (mappend x)) mappend \x -> (.mappend) ((.) (mappend x)) (. mappend) . (.) . mappend -} -- | An applicative monoid acts on a value of a monoidal type by -- having each element in the structure act on the value -- independently, and then folding the resulting structure. instance (Action m n, Foldable f, Functor f, Monoid n) => Action (AM f m) n where act (AM f) n = fold $ fmap (`act` n) f -- XXX need to prove that this satisfies the laws! There are other -- "obvious" instances too. ------------------------------------------------------------ -- Monoid coproduct ------------------------------------------------------------ -- | @m :+: n@ is the coproduct of monoids @m@ and @n@. Values of -- type @m :+: n@ consist of alternating lists of @m@ and @n@ -- values. The empty list is the identity, and composition is list -- concatenation, with appropriate combining of adjacent elements -- when possible. newtype m :+: n = MCo { unMCo :: [Either m n] } -- For efficiency and simplicity, we implement it just as [Either m -- n]: of course, this does not preserve the invariant of strictly -- alternating types, but it doesn't really matter as long as we don't -- let anyone inspect the internal representation. -- | Injection from the left monoid into a coproduct. inL :: m -> m :+: n inL m = MCo [Left m] -- | Injection from the right monoid into a coproduct. inR :: n -> m :+: n inR n = MCo [Right n] -- | Prepend a value from the left monoid. mappendL :: m -> m :+: n -> m :+: n mappendL = mappend . inL -- | Prepend a value from the right monoid. mappendR :: n -> m :+: n -> m :+: n mappendR = mappend . inR {- normalize :: (Monoid m, Monoid n) => m :+: n -> m :+: n normalize (MCo es) = MCo (normalize' es) where normalize' [] = [] normalize' [e] = [e] normalize' (Left e1:Left e2 : es) = normalize' (Left (e1 <> e2) : es) normalize' (Left e1:es) = Left e1 : normalize' es normalize' (Right e1:Right e2:es) = normalize' (Right (e1 <> e2) : es) normalize' (Right e1:es) = Right e1 : normalize' es -} instance Semigroup (m :+: n) where (MCo es1) <> (MCo es2) = MCo (es1 ++ es2) -- | The coproduct of two monoids is itself a monoid. instance Monoid (m :+: n) where mempty = MCo [] mappend = (<>) -- | @killR@ takes a value in a coproduct monoid and sends all the -- values from the right monoid to the identity. killR :: Monoid m => m :+: n -> m killR = mconcat . lefts . unMCo -- | @killL@ takes a value in a coproduct monoid and sends all the -- values from the left monoid to the identity. killL :: Monoid n => m :+: n -> n killL = mconcat . rights . unMCo -- | Take a value from a coproduct monoid where the left monoid has an -- action on the right, and \"untangle\" it into a pair of values. In -- particular, -- -- > m1 <> n1 <> m2 <> n2 <> m3 <> n3 <> ... -- -- is sent to -- -- > (m1 <> m2 <> m3 <> ..., (act m1 n1) <> (act (m1 <> m2) n2) <> (act (m1 <> m2 <> m3) n3) <> ...) -- -- That is, before combining @n@ values, every @n@ value is acted on -- by all the @m@ values to its left. untangle :: (Action m n, Monoid m, Monoid n) => m :+: n -> (m,n) untangle (MCo elts) = untangle' mempty elts where untangle' cur [] = cur untangle' (curM, curN) (Left m : elts') = untangle' (curM `mappend` m, curN) elts' untangle' (curM, curN) (Right n : elts') = untangle' (curM, curN `mappend` act curM n) elts' -- | Coproducts act on other things by having each of the components -- act individually. instance (Action m r, Action n r) => Action (m :+: n) r where act = appEndo . mconcat . map (Endo . either act act) . unMCo