module Data.Monoid.Textual (
TextualMonoid(..)
)
where
import Prelude hiding (all, any, break, concatMap, dropWhile, foldl, foldl1, foldr, foldr1, map, scanl, scanl1, scanr, scanr1,
span, takeWhile)
import qualified Data.Foldable as Foldable
import qualified Data.Traversable as Traversable
import Data.Maybe (fromJust)
import Data.Either (rights)
import qualified Data.List as List
import qualified Data.Text as Text
import qualified Data.Text.Lazy as LazyText
import Data.Text (Text)
import Data.Monoid (Monoid(mappend, mconcat, mempty))
import qualified Data.Sequence as Sequence
import qualified Data.Vector as Vector
import Data.String (IsString(fromString))
import Data.Int (Int64)
import Data.Monoid.Null (MonoidNull (null))
import Data.Monoid.Cancellative (LeftReductiveMonoid, LeftGCDMonoid)
import Data.Monoid.Factorial (FactorialMonoid)
import qualified Data.Monoid.Factorial as Factorial
class (IsString t, LeftReductiveMonoid t, LeftGCDMonoid t, FactorialMonoid t) => TextualMonoid t where
fromText :: Text -> t
singleton :: Char -> t
splitCharacterPrefix :: t -> Maybe (Char, t)
characterPrefix :: t -> Maybe Char
map :: (Char -> Char) -> t -> t
concatMap :: (Char -> t) -> t -> t
any :: (Char -> Bool) -> t -> Bool
all :: (Char -> Bool) -> t -> Bool
foldl :: (a -> t -> a) -> (a -> Char -> a) -> a -> t -> a
foldl' :: (a -> t -> a) -> (a -> Char -> a) -> a -> t -> a
foldr :: (t -> a -> a) -> (Char -> a -> a) -> a -> t -> a
scanl :: (Char -> Char -> Char) -> Char -> t -> t
scanl1 :: (Char -> Char -> Char) -> t -> t
scanr :: (Char -> Char -> Char) -> Char -> t -> t
scanr1 :: (Char -> Char -> Char) -> t -> t
mapAccumL :: (a -> Char -> (a, Char)) -> a -> t -> (a, t)
mapAccumR :: (a -> Char -> (a, Char)) -> a -> t -> (a, t)
takeWhile :: (t -> Bool) -> (Char -> Bool) -> t -> t
dropWhile :: (t -> Bool) -> (Char -> Bool) -> t -> t
break :: (t -> Bool) -> (Char -> Bool) -> t -> (t, t)
span :: (t -> Bool) -> (Char -> Bool) -> t -> (t, t)
spanMaybe :: s -> (s -> t -> Maybe s) -> (s -> Char -> Maybe s) -> t -> (t, t, s)
spanMaybe' :: s -> (s -> t -> Maybe s) -> (s -> Char -> Maybe s) -> t -> (t, t, s)
split :: (Char -> Bool) -> t -> [t]
find :: (Char -> Bool) -> t -> Maybe Char
elem :: Char -> t -> Bool
foldl_ :: (a -> Char -> a) -> a -> t -> a
foldl_' :: (a -> Char -> a) -> a -> t -> a
foldr_ :: (Char -> a -> a) -> a -> t -> a
takeWhile_ :: Bool -> (Char -> Bool) -> t -> t
dropWhile_ :: Bool -> (Char -> Bool) -> t -> t
break_ :: Bool -> (Char -> Bool) -> t -> (t, t)
span_ :: Bool -> (Char -> Bool) -> t -> (t, t)
spanMaybe_ :: s -> (s -> Char -> Maybe s) -> t -> (t, t, s)
spanMaybe_' :: s -> (s -> Char -> Maybe s) -> t -> (t, t, s)
fromText = fromString . Text.unpack
singleton = fromString . (:[])
characterPrefix = fmap fst . splitCharacterPrefix
map f = concatMap (singleton . f)
concatMap f = foldr mappend (mappend . f) mempty
all p = foldr (const id) ((&&) . p) True
any p = foldr (const id) ((||) . p) False
foldl ft fc = Factorial.foldl (\a prime-> maybe (ft a prime) (fc a) (characterPrefix prime))
foldr ft fc = Factorial.foldr (\prime-> maybe (ft prime) fc (characterPrefix prime))
foldl' ft fc = Factorial.foldl' (\a prime-> maybe (ft a prime) (fc a) (characterPrefix prime))
foldl_ = foldl const
foldr_ = foldr (const id)
foldl_' = foldl' const
scanl f c = mappend (singleton c) . fst . foldl foldlOther (foldlChars f) (mempty, c)
scanl1 f t = case (Factorial.splitPrimePrefix t, splitCharacterPrefix t)
of (Nothing, _) -> t
(Just (prefix, suffix), Nothing) -> mappend prefix (scanl1 f suffix)
(Just _, Just (c, suffix)) -> scanl f c suffix
scanr f c = fst . foldr foldrOther (foldrChars f) (singleton c, c)
scanr1 f = fst . foldr foldrOther fc (mempty, Nothing)
where fc c (t, Nothing) = (mappend (singleton c) t, Just c)
fc c1 (t, Just c2) = (mappend (singleton c') t, Just c')
where c' = f c1 c2
mapAccumL f a0 = foldl ft fc (a0, mempty)
where ft (a, t1) t2 = (a, mappend t1 t2)
fc (a, t) c = (a', mappend t (singleton c'))
where (a', c') = f a c
mapAccumR f a0 = foldr ft fc (a0, mempty)
where ft t1 (a, t2) = (a, mappend t1 t2)
fc c (a, t) = (a', mappend (singleton c') t)
where (a', c') = f a c
takeWhile pt pc = fst . span pt pc
dropWhile pt pc = snd . span pt pc
span pt pc = Factorial.span (\prime-> maybe (pt prime) pc (characterPrefix prime))
break pt pc = Factorial.break (\prime-> maybe (pt prime) pc (characterPrefix prime))
spanMaybe s0 ft fc t0 = spanAfter id s0 t0
where spanAfter g s t = case Factorial.splitPrimePrefix t
of Just (prime, rest) | Just s' <- maybe (ft s prime) (fc s) (characterPrefix prime) ->
spanAfter (g . mappend prime) s' rest
| otherwise -> (g mempty, t, s)
Nothing -> (t0, t, s)
spanMaybe' s0 ft fc t0 = spanAfter id s0 t0
where spanAfter g s t = seq s $
case Factorial.splitPrimePrefix t
of Just (prime, rest) | Just s' <- maybe (ft s prime) (fc s) (characterPrefix prime) ->
spanAfter (g . mappend prime) s' rest
| otherwise -> (g mempty, t, s)
Nothing -> (t0, t, s)
takeWhile_ = takeWhile . const
dropWhile_ = dropWhile . const
break_ = break . const
span_ = span . const
spanMaybe_ s = spanMaybe s (const . Just)
spanMaybe_' s = spanMaybe' s (const . Just)
split p m = prefix : splitRest
where (prefix, rest) = break (const False) p m
splitRest = case splitCharacterPrefix rest
of Nothing -> []
Just (_, tail) -> split p tail
find p = foldr (const id) (\c r-> if p c then Just c else r) Nothing
elem c = any (== c)
foldlChars f (t, c1) c2 = (mappend t (singleton c'), c')
where c' = f c1 c2
foldlOther (t1, c) t2 = (mappend t1 t2, c)
foldrChars f c1 (t, c2) = (mappend (singleton c') t, c')
where c' = f c1 c2
foldrOther t1 (t2, c) = (mappend t1 t2, c)
instance TextualMonoid String where
fromText = Text.unpack
singleton c = [c]
splitCharacterPrefix (c:rest) = Just (c, rest)
splitCharacterPrefix [] = Nothing
characterPrefix (c:_) = Just c
characterPrefix [] = Nothing
map = List.map
concatMap = List.concatMap
any = List.any
all = List.all
foldl = const List.foldl
foldl' = const List.foldl'
foldr = const List.foldr
scanl = List.scanl
scanl1 = List.scanl1
scanr = List.scanr
scanr1 = List.scanr1
mapAccumL = List.mapAccumL
mapAccumR = List.mapAccumR
takeWhile _ = List.takeWhile
dropWhile _ = List.dropWhile
break _ = List.break
span _ = List.span
spanMaybe s0 _ft fc l = (prefix' [], suffix' [], s')
where (prefix', suffix', s', live') = List.foldl' g (id, id, s0, True) l
g (prefix, suffix, s, live) c | live, Just s' <- fc s c = (prefix . (c:), id, s', True)
| otherwise = (prefix, suffix . (c:), s, False)
spanMaybe' s0 _ft fc l = (prefix' [], suffix' [], s')
where (prefix', suffix', s', live') = List.foldl' g (id, id, s0, True) l
g (prefix, suffix, s, live) c | live, Just s' <- fc s c = seq s' (prefix . (c:), id, s', True)
| otherwise = (prefix, suffix . (c:), s, False)
find = List.find
elem = List.elem
instance TextualMonoid Text where
fromText = id
singleton = Text.singleton
splitCharacterPrefix = Text.uncons
characterPrefix t = if Text.null t then Nothing else Just (Text.head t)
map = Text.map
concatMap = Text.concatMap
any = Text.any
all = Text.all
foldl = const Text.foldl
foldl' = const Text.foldl'
foldr = const Text.foldr
scanl = Text.scanl
scanl1 = Text.scanl1
scanr = Text.scanr
scanr1 = Text.scanr1
mapAccumL = Text.mapAccumL
mapAccumR = Text.mapAccumR
takeWhile _ = Text.takeWhile
dropWhile _ = Text.dropWhile
break _ = Text.break
span _ = Text.span
spanMaybe s0 _ft fc t = case Text.foldr g id t (0, s0)
of (i, s') | (prefix, suffix) <- Text.splitAt i t -> (prefix, suffix, s')
where g c cont (i, s) | Just s' <- fc s c = let i' = succ i :: Int in seq i' $ cont (i', s')
| otherwise = (i, s)
spanMaybe' s0 _ft fc t = case Text.foldr g id t (0, s0)
of (i, s') | (prefix, suffix) <- Text.splitAt i t -> (prefix, suffix, s')
where g c cont (i, s) | Just s' <- fc s c = let i' = succ i :: Int in seq i' $ seq s' $ cont (i', s')
| otherwise = (i, s)
split = Text.split
find = Text.find
instance TextualMonoid LazyText.Text where
fromText = LazyText.fromStrict
singleton = LazyText.singleton
splitCharacterPrefix = LazyText.uncons
characterPrefix t = if LazyText.null t then Nothing else Just (LazyText.head t)
map = LazyText.map
concatMap = LazyText.concatMap
any = LazyText.any
all = LazyText.all
foldl = const LazyText.foldl
foldl' = const LazyText.foldl'
foldr = const LazyText.foldr
scanl = LazyText.scanl
scanl1 = LazyText.scanl1
scanr = LazyText.scanr
scanr1 = LazyText.scanr1
mapAccumL = LazyText.mapAccumL
mapAccumR = LazyText.mapAccumR
takeWhile _ = LazyText.takeWhile
dropWhile _ = LazyText.dropWhile
break _ = LazyText.break
span _ = LazyText.span
spanMaybe s0 _ft fc t = case LazyText.foldr g id t (0, s0)
of (i, s') | (prefix, suffix) <- LazyText.splitAt i t -> (prefix, suffix, s')
where g c cont (i, s) | Just s' <- fc s c = let i' = succ i :: Int64 in seq i' $ cont (i', s')
| otherwise = (i, s)
spanMaybe' s0 _ft fc t = case LazyText.foldr g id t (0, s0)
of (i, s') | (prefix, suffix) <- LazyText.splitAt i t -> (prefix, suffix, s')
where g c cont (i, s) | Just s' <- fc s c = let i' = succ i :: Int64 in seq i' $ seq s' $ cont (i', s')
| otherwise = (i, s)
split = LazyText.split
find = LazyText.find
instance IsString (Sequence.Seq Char) where
fromString = Sequence.fromList
instance TextualMonoid (Sequence.Seq Char) where
singleton = Sequence.singleton
splitCharacterPrefix s = case Sequence.viewl s
of Sequence.EmptyL -> Nothing
c Sequence.:< rest -> Just (c, rest)
characterPrefix s = case Sequence.viewl s
of Sequence.EmptyL -> Nothing
c Sequence.:< rest -> Just c
map = Traversable.fmapDefault
concatMap = Foldable.foldMap
any = Foldable.any
all = Foldable.all
foldl = const Foldable.foldl
foldl' = const Foldable.foldl'
foldr = const Foldable.foldr
scanl = Sequence.scanl
scanl1 f v | Sequence.null v = Sequence.empty
| otherwise = Sequence.scanl1 f v
scanr = Sequence.scanr
scanr1 f v | Sequence.null v = Sequence.empty
| otherwise = Sequence.scanr1 f v
takeWhile _ = Sequence.takeWhileL
dropWhile _ = Sequence.dropWhileL
break _ = Sequence.breakl
span _ = Sequence.spanl
spanMaybe s0 _ft fc b = case Foldable.foldr g id b (0, s0)
of (i, s') | (prefix, suffix) <- Sequence.splitAt i b -> (prefix, suffix, s')
where g c cont (i, s) | Just s' <- fc s c = let i' = succ i :: Int in seq i' $ cont (i', s')
| otherwise = (i, s)
spanMaybe' s0 _ft fc b = case Foldable.foldr g id b (0, s0)
of (i, s') | (prefix, suffix) <- Sequence.splitAt i b -> (prefix, suffix, s')
where g c cont (i, s) | Just s' <- fc s c = let i' = succ i :: Int in seq i' $ seq s' $ cont (i', s')
| otherwise = (i, s)
find = Foldable.find
elem = Foldable.elem
instance IsString (Vector.Vector Char) where
fromString = Vector.fromList
instance TextualMonoid (Vector.Vector Char) where
singleton = Vector.singleton
splitCharacterPrefix t = if Vector.null t then Nothing else Just (Vector.unsafeHead t, Vector.unsafeTail t)
characterPrefix = (Vector.!? 0)
map = Vector.map
concatMap = Vector.concatMap
any = Vector.any
all = Vector.all
foldl = const Vector.foldl
foldl' = const Vector.foldl'
foldr = const Vector.foldr
scanl = Vector.scanl
scanl1 f v | Vector.null v = Vector.empty
| otherwise = Vector.scanl1 f v
scanr = Vector.scanr
scanr1 f v | Vector.null v = Vector.empty
| otherwise = Vector.scanr1 f v
mapAccumL f a0 t = (a, Vector.reverse $ Vector.fromList l)
where (a, l) = Vector.foldl fc (a0, []) t
fc (a, l) c = (a', c':l)
where (a', c') = f a c
mapAccumR f a0 t = (a, Vector.fromList l)
where (a, l) = Vector.foldr fc (a0, []) t
fc c (a, l) = (a', c':l)
where (a', c') = f a c
takeWhile _ = Vector.takeWhile
dropWhile _ = Vector.dropWhile
break _ = Vector.break
span _ = Vector.span
spanMaybe s0 _ft fc v = case Vector.ifoldr g Left v s0
of Left s' -> (v, Vector.empty, s')
Right (i, s') | (prefix, suffix) <- Vector.splitAt i v -> (prefix, suffix, s')
where g i c cont s | Just s' <- fc s c = cont s'
| otherwise = Right (i, s)
spanMaybe' s0 _ft fc v = case Vector.ifoldr' g Left v s0
of Left s' -> (v, Vector.empty, s')
Right (i, s') | (prefix, suffix) <- Vector.splitAt i v -> (prefix, suffix, s')
where g i c cont s | Just s' <- fc s c = seq s' (cont s')
| otherwise = Right (i, s)
find = Vector.find
elem = Vector.elem