Measured.hs

{- 
    Copyright 2013-2019 Mario Blazevic

    License: BSD3 (see BSD3-LICENSE.txt file)
-}

-- | This module defines the monoid transformer data type 'Measured'.
-- 

{-# LANGUAGE Haskell2010 #-}

module Data.Monoid.Instances.Measured (
   Measured, measure, extract
   )
where

import Data.Functor -- ((<$>))
import qualified Data.List as List
import Data.String (IsString(..))
import Data.Semigroup (Semigroup(..))
import Data.Monoid (Monoid(..))
import Data.Semigroup.Cancellative (LeftReductive(..), RightReductive(..))
import Data.Semigroup.Factorial (Factorial(..), StableFactorial)
import Data.Monoid.GCD (LeftGCDMonoid(..), RightGCDMonoid(..))
import Data.Monoid.Null (MonoidNull(null), PositiveMonoid)
import Data.Monoid.Factorial (FactorialMonoid(..))
import Data.Monoid.Textual (TextualMonoid(..))
import qualified Data.Monoid.Factorial as Factorial
import qualified Data.Monoid.Textual as Textual

import Prelude hiding (all, any, break, filter, foldl, foldl1, foldr, foldr1, map, concatMap,
                       length, null, reverse, scanl, scanr, scanl1, scanr1, span, splitAt)

-- | @'Measured' a@ is a wrapper around the 'FactorialMonoid' @a@ that memoizes the monoid's 'length' so it becomes a
-- constant-time operation. The parameter is restricted to the 'StableFactorial' class, which guarantees that
-- @'length' (a <> b) == 'length' a + 'length' b@.

data Measured a = Measured{_measuredLength :: Int, extract :: a} deriving (Eq, Show)

-- | Create a new 'Measured' value.
measure :: Factorial a => a -> Measured a
measure x = Measured (length x) x

instance Ord a => Ord (Measured a) where
   compare (Measured _ x) (Measured _ y) = compare x y

instance StableFactorial a => Semigroup (Measured a) where
   Measured m a <> Measured n b = Measured (m + n) (a <> b)

instance (StableFactorial a, Monoid a) => Monoid (Measured a) where
   mempty = Measured 0 mempty
   mappend = (<>)

instance (StableFactorial a, Monoid a) => MonoidNull (Measured a) where
   null (Measured n _) = n == 0

instance (StableFactorial a, Monoid a) => PositiveMonoid (Measured a)

instance (LeftReductive a, StableFactorial a) => LeftReductive (Measured a) where
   stripPrefix (Measured m x) (Measured n y) = fmap (Measured (n - m)) (stripPrefix x y)

instance (RightReductive a, StableFactorial a) => RightReductive (Measured a) where
   stripSuffix (Measured m x) (Measured n y) = fmap (Measured (n - m)) (stripSuffix x y)

instance (LeftGCDMonoid a, StableFactorial a) => LeftGCDMonoid (Measured a) where
   commonPrefix (Measured _ x) (Measured _ y) = measure (commonPrefix x y)

instance (RightGCDMonoid a, StableFactorial a) => RightGCDMonoid (Measured a) where
   commonSuffix (Measured _ x) (Measured _ y) = measure (commonSuffix x y)

instance (StableFactorial a, MonoidNull a) => Factorial (Measured a) where
   factors (Measured _ x) = List.map (Measured 1) (factors x)
   primePrefix m@(Measured _ x) = if null x then m else Measured 1 (primePrefix x)
   primeSuffix m@(Measured _ x) = if null x then m else Measured 1 (primeSuffix x)
   foldl f a0 (Measured _ x) = Factorial.foldl g a0 x
      where g a = f a . Measured 1
   foldl' f a0 (Measured _ x) = Factorial.foldl' g a0 x
      where g a = f a . Measured 1
   foldr f a0 (Measured _ x) = Factorial.foldr g a0 x
      where g = f . Measured 1
   foldMap f (Measured _ x) = Factorial.foldMap (f . Measured 1) x
   length (Measured n _) = n
   reverse (Measured n x) = Measured n (reverse x)

instance (StableFactorial a, FactorialMonoid a) => FactorialMonoid (Measured a) where
   splitPrimePrefix (Measured n x) = case splitPrimePrefix x
                                     of Nothing -> Nothing
                                        Just (p, s) -> Just (Measured 1 p, Measured (n - 1) s)
   splitPrimeSuffix (Measured n x) = case splitPrimeSuffix x
                                     of Nothing -> Nothing
                                        Just (p, s) -> Just (Measured (n - 1) p, Measured 1 s)
   span p (Measured n x) = (xp', xs')
      where (xp, xs) = Factorial.span (p . Measured 1) x
            xp' = measure xp
            xs' = Measured (n - length xp') xs
   split p (Measured _ x) = measure <$> Factorial.split (p . Measured 1) x
   splitAt m (Measured n x) | m <= 0 = (mempty, Measured n x)
                            | m >= n = (Measured n x, mempty)
                            | otherwise = (Measured m xp, Measured (n - m) xs)
      where (xp, xs) = splitAt m x

instance (StableFactorial a, MonoidNull a) => StableFactorial (Measured a)

instance (FactorialMonoid a, IsString a) => IsString (Measured a) where
   fromString = measure . fromString

instance (Eq a, StableFactorial a, TextualMonoid a) => TextualMonoid (Measured a) where
   fromText = measure . fromText
   singleton = Measured 1 . singleton
   splitCharacterPrefix (Measured n x) = (Measured (n - 1) <$>) <$> splitCharacterPrefix x
   characterPrefix (Measured _ x) = characterPrefix x
   map f (Measured n x) = Measured n (map f x)
   any p (Measured _ x) = any p x
   all p (Measured _ x) = all p x

   foldl ft fc a0 (Measured _ x) = Textual.foldl (\a-> ft a . Measured 1) fc a0 x
   foldl' ft fc a0 (Measured _ x) = Textual.foldl' (\a-> ft a . Measured 1) fc a0 x
   foldr ft fc a0 (Measured _ x) = Textual.foldr (ft . Measured 1) fc a0 x
   toString ft (Measured _ x) = toString (ft . Measured 1) x

   span pt pc (Measured n x) = (xp', xs')
      where (xp, xs) = Textual.span (pt . Measured 1) pc x
            xp' = measure xp
            xs' = Measured (n - length xp') xs
   break pt pc = Textual.span (not . pt) (not . pc)

   find p (Measured _ x) = find p x