incremental-parser-0.1: Data/Monoid/Cancellative.hs

{- 
    Copyright 2011 Mario Blazevic

    This file is part of the Streaming Component Combinators (SCC) project.

    The SCC project is free software: you can redistribute it and/or modify it under the terms of the GNU General Public
    License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later
    version.

    SCC is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty
    of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License for more details.

    You should have received a copy of the GNU General Public License along with SCC.  If not, see
    <http://www.gnu.org/licenses/>.
-}

-- | This module defines the 'Monoid' => 'CancellativeMonoid' => 'GCDMonoid' class hierarchy.
-- 

module Data.Monoid.Cancellative (
   -- * Classes
   CancellativeMonoid, GCDMonoid,
   LeftCancellativeMonoid(..), RightCancellativeMonoid(..),
   LeftGCDMonoid(..), RightGCDMonoid(..)
   ) where

import Data.Monoid (Monoid (mappend))
import qualified Data.List as List
import qualified Data.ByteString as ByteString
import qualified Data.Text as Text
import Data.ByteString (ByteString)
import Data.Text (Text)

-- | Class of monoids with a left inverse of 'mappend', satisfying the following law:
-- 
-- > mstripPrefix a (a `mappend` b) == Just b
-- > maybe b (a `mappend`) (mstripPrefix a b) == b
class Monoid m => LeftCancellativeMonoid m where
   mstripPrefix :: m -> m -> Maybe m

-- | Class of monoids with a right inverse of 'mappend', satisfying the following law:
-- 
-- > mstripSuffix b (a `mappend` b) == Just a
-- > maybe b (`mappend` a) (mstripSuffix a b) == b
class Monoid m => RightCancellativeMonoid m where
   mstripSuffix :: m -> m -> Maybe m

class LeftCancellativeMonoid m => LeftGCDMonoid m where
   commonPrefix :: m -> m -> m

class RightCancellativeMonoid m => RightGCDMonoid m where
   commonSuffix :: m -> m -> m

-- | Class of monoids for which the 'mappend' operation can be reverted while satisfying the following laws:
-- 
-- > mstripPrefix a (a `mappend` b) == Just b
-- > mstripSuffix b (a `mappend` b) == Just a
-- > maybe b (a `mappend`) (mstripPrefix a b) == b
-- > maybe b (`mappend` a) (mstripSuffix a b) == b
class (LeftCancellativeMonoid m, RightCancellativeMonoid m) => CancellativeMonoid m

-- | Class of monoids that allow the greatest common denominator to be found for any two given values. The operations
-- must satisfy the following laws:
-- 
-- > commonPrefix (a `mappend` b) (a `mappend` c) == a `mappend` commonPrefix b c
-- > commonSuffix (a `mappend` c) (b `mappend` c) == commonSuffix a b `mappend` c
class (CancellativeMonoid m, LeftGCDMonoid m, RightGCDMonoid m) => GCDMonoid m

-- List instances

instance Eq x => LeftCancellativeMonoid [x] where
   mstripPrefix = List.stripPrefix

instance Eq x => LeftGCDMonoid [x] where
   commonPrefix (x:xs) (y:ys) | x == y = x : commonPrefix xs ys
   commonPrefix _ _ = []

instance Eq x => RightCancellativeMonoid [x] where
   mstripSuffix s l = fmap List.reverse (mstripPrefix (List.reverse s) (List.reverse l))

instance Eq x => RightGCDMonoid [x] where
   commonSuffix xs ys = List.reverse (commonPrefix (List.reverse xs) (List.reverse ys))

instance Eq x => CancellativeMonoid [x]

instance Eq x => GCDMonoid [x]

-- ByteString instances

instance LeftCancellativeMonoid ByteString where
   mstripPrefix p l = if ByteString.isPrefixOf p l
                      then Just (ByteString.drop (ByteString.length p) l)
                      else Nothing

instance RightCancellativeMonoid ByteString where
   mstripSuffix s l = if ByteString.isSuffixOf s l
                      then Just (ByteString.take (ByteString.length l - ByteString.length s) l)
                      else Nothing

instance CancellativeMonoid ByteString

instance LeftGCDMonoid ByteString where
   commonPrefix x y = ByteString.take maxPrefixLength x
      where maxPrefixLength = prefixLength 0
            prefixLength n | ByteString.index x 0 == ByteString.index y 0 = prefixLength (succ n) 
            prefixLength n = n

instance RightGCDMonoid ByteString where
   commonSuffix x y = ByteString.drop minNonSuffixLength x
      where minNonSuffixLength = nonSuffixLength (ByteString.length x - 1) (ByteString.length y - 1)
            nonSuffixLength m n | ByteString.index x m == ByteString.index y n = nonSuffixLength (pred m) (pred n) 
            nonSuffixLength m n = m + 1

instance GCDMonoid ByteString

-- Text instances

instance LeftCancellativeMonoid Text where
   mstripPrefix p t = Text.stripPrefix p t

instance RightCancellativeMonoid Text where
   mstripSuffix s t = Text.stripSuffix s t

instance CancellativeMonoid Text

instance LeftGCDMonoid Text where
   commonPrefix x y = maybe Text.empty (\(p, _, _)-> p) (Text.commonPrefixes x y)

instance RightGCDMonoid Text where
   commonSuffix x y = Text.reverse $ commonPrefix (Text.reverse x) (Text.reverse y)

instance GCDMonoid Text