{-# LANGUAGE Haskell2010, FlexibleInstances #-}
module Data.Monoid.Textual (
TextualMonoid(..)
)
where
import qualified Data.Foldable as Foldable
import qualified Data.Traversable as Traversable
import Data.Functor
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
import qualified Data.Sequence as Sequence
import Data.String (IsString(fromString))
import Data.Int (Int64)
import Data.Semigroup.Cancellative (LeftReductive)
import Data.Monoid.GCD (LeftGCDMonoid)
import Data.Monoid.Factorial (FactorialMonoid)
import qualified Data.Monoid.Factorial as Factorial
import Prelude hiding (all, any, break, concatMap, dropWhile, foldl, foldl1, foldr, foldr1, map,
scanl, scanl1, scanr, scanr1, span, takeWhile)
class (IsString t, LeftReductive 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
toString :: (t -> String) -> t -> String
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
toString f = foldr (mappend . f) (:) []
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 (_, tl) -> split p tl
find p = foldr (const id) (\c r-> if p c then Just c else r) Nothing
elem c = any (== c)
{-# INLINE characterPrefix #-}
{-# INLINE concatMap #-}
{-# INLINE dropWhile #-}
{-# INLINE fromText #-}
{-# INLINE map #-}
{-# INLINE mapAccumL #-}
{-# INLINE mapAccumR #-}
{-# INLINE scanl #-}
{-# INLINE scanl1 #-}
{-# INLINE scanr #-}
{-# INLINE scanr1 #-}
{-# INLINE singleton #-}
{-# INLINE spanMaybe #-}
{-# INLINE spanMaybe' #-}
{-# INLINE split #-}
{-# INLINE takeWhile #-}
{-# INLINE foldl_ #-}
{-# INLINE foldl_' #-}
{-# INLINE foldr_ #-}
{-# INLINE spanMaybe_ #-}
{-# INLINE spanMaybe_' #-}
{-# INLINE span_ #-}
{-# INLINE break_ #-}
{-# INLINE takeWhile_ #-}
{-# INLINE dropWhile_ #-}
{-# MINIMAL splitCharacterPrefix #-}
foldlChars :: TextualMonoid t => (Char -> Char -> Char) -> (t, Char) -> Char -> (t, Char)
foldlOther :: Monoid t => (t, Char) -> t -> (t, Char)
foldrChars :: TextualMonoid t => (Char -> Char -> Char) -> Char -> (t, Char) -> (t, Char)
foldrOther :: Monoid t => t -> (t, a) -> (t, a)
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
toString = const id
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', _) = List.foldl' g (id, id, s0, True) l
g (prefix, suffix, s, live) c | live, Just s1 <- fc s c = (prefix . (c:), id, s1, True)
| otherwise = (prefix, suffix . (c:), s, False)
spanMaybe' s0 _ft fc l = (prefix' [], suffix' [], s')
where (prefix', suffix', s', _) = List.foldl' g (id, id, s0, True) l
g (prefix, suffix, s, live) c | live, Just s1 <- fc s c = seq s1 (prefix . (c:), id, s1, True)
| otherwise = (prefix, suffix . (c:), s, False)
find = List.find
elem = List.elem
{-# INLINE all #-}
{-# INLINE any #-}
{-# INLINE break #-}
{-# INLINE characterPrefix #-}
{-# INLINE concatMap #-}
{-# INLINE dropWhile #-}
{-# INLINE elem #-}
{-# INLINE find #-}
{-# INLINE foldl #-}
{-# INLINE foldl' #-}
{-# INLINE foldr #-}
{-# INLINE fromText #-}
{-# INLINE map #-}
{-# INLINE mapAccumL #-}
{-# INLINE mapAccumR #-}
{-# INLINE scanl #-}
{-# INLINE scanl1 #-}
{-# INLINE scanr #-}
{-# INLINE scanr1 #-}
{-# INLINE singleton #-}
{-# INLINE span #-}
{-# INLINE spanMaybe #-}
{-# INLINE spanMaybe' #-}
{-# INLINE splitCharacterPrefix #-}
{-# INLINE takeWhile #-}
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
toString = const Text.unpack
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
{-# INLINE all #-}
{-# INLINE any #-}
{-# INLINE break #-}
{-# INLINE characterPrefix #-}
{-# INLINE concatMap #-}
{-# INLINE dropWhile #-}
{-# INLINE find #-}
{-# INLINE foldl #-}
{-# INLINE foldl' #-}
{-# INLINE foldr #-}
{-# INLINE fromText #-}
{-# INLINE map #-}
{-# INLINE mapAccumL #-}
{-# INLINE mapAccumR #-}
{-# INLINE scanl #-}
{-# INLINE scanl1 #-}
{-# INLINE scanr #-}
{-# INLINE scanr1 #-}
{-# INLINE singleton #-}
{-# INLINE span #-}
{-# INLINE spanMaybe #-}
{-# INLINE spanMaybe' #-}
{-# INLINE split #-}
{-# INLINE splitCharacterPrefix #-}
{-# INLINE takeWhile #-}
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
toString = const LazyText.unpack
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
{-# INLINE all #-}
{-# INLINE any #-}
{-# INLINE break #-}
{-# INLINE characterPrefix #-}
{-# INLINE concatMap #-}
{-# INLINE dropWhile #-}
{-# INLINE find #-}
{-# INLINE foldl #-}
{-# INLINE foldl' #-}
{-# INLINE foldr #-}
{-# INLINE fromText #-}
{-# INLINE map #-}
{-# INLINE mapAccumL #-}
{-# INLINE mapAccumR #-}
{-# INLINE scanl #-}
{-# INLINE scanl1 #-}
{-# INLINE scanr #-}
{-# INLINE scanr1 #-}
{-# INLINE singleton #-}
{-# INLINE span #-}
{-# INLINE spanMaybe #-}
{-# INLINE spanMaybe' #-}
{-# INLINE split #-}
{-# INLINE splitCharacterPrefix #-}
{-# INLINE takeWhile #-}
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.:< _ -> Just c
map = Traversable.fmapDefault
concatMap = Foldable.foldMap
toString = const Foldable.toList
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
{-# INLINE all #-}
{-# INLINE any #-}
{-# INLINE break #-}
{-# INLINE characterPrefix #-}
{-# INLINE concatMap #-}
{-# INLINE dropWhile #-}
{-# INLINE elem #-}
{-# INLINE find #-}
{-# INLINE foldl #-}
{-# INLINE foldl' #-}
{-# INLINE foldr #-}
{-# INLINE map #-}
{-# INLINE scanl #-}
{-# INLINE scanl1 #-}
{-# INLINE scanr #-}
{-# INLINE scanr1 #-}
{-# INLINE singleton #-}
{-# INLINE span #-}
{-# INLINE spanMaybe #-}
{-# INLINE spanMaybe' #-}
{-# INLINE splitCharacterPrefix #-}
{-# INLINE takeWhile #-}