{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveTraversable #-}
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
-----------------------------------------------------------------------------
-- |
-- Module : Data.Monoid.Deletable
-- Copyright : (c) 2011-2015 diagrams-core team (see LICENSE)
-- License : BSD-style (see LICENSE)
-- Maintainer : diagrams-discuss@googlegroups.com
--
-- A monoid transformer that allows deleting information from a
-- concatenation of monoidal values.
--
-----------------------------------------------------------------------------
module Data.Monoid.Deletable
( Deletable(..)
, unDelete, toDeletable
, deleteL, deleteR
) where
import Data.Data
import Data.Foldable
import Data.Traversable
import Data.Semigroup
-- | 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 (Data, Typeable, Show, Read, Functor, Foldable, Traversable)
-- | 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