module Control.Foldl.Transduce (
Transduction
, Transduction'
, Transducer(..)
, ToTransducer(..)
, TransductionM
, TransductionM'
, TransducerM(..)
, ToTransducerM(..)
, transduce
, transduce'
, transduceM
, transduceM'
, transduceK
, folds
, folds'
, foldsM
, foldsM'
, Infinite
, ReifiedTransduction (..)
, groups
, evenly
, bisect
, Moore
, ReifiedTransduction' (..)
, groups'
, evenly'
, ReifiedTransductionM (..)
, groupsM
, evenlyM
, bisectM
, ReifiedTransductionM' (..)
, groupsM'
, evenlyM'
, ignore
, surround
, surroundIO
, chunksOf
, splitAt
, chunkedSplitAt
, splitWhen
, splitLast
, chunkedStripPrefix
, foldify
, foldifyM
, condense
, condenseM
, hoistTransducer
, quiesce
, quiesceWith
, hoistFold
, module Data.Functor.Extend
, module Control.Foldl
, module Control.Comonad.Cofree
) where
import Prelude hiding (take,drop,splitAt,dropWhile)
import Data.Bifunctor
import Data.Monoid
import qualified Data.Monoid.Cancellative as CM
import qualified Data.Monoid.Null as NM
import qualified Data.Monoid.Factorial as SFM
import Data.Functor.Identity
import Data.Functor.Extend
import Data.Foldable (Foldable,foldlM,foldl',toList)
import Data.Traversable
import Control.Applicative
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Except
import Control.Comonad
import Control.Comonad.Cofree
import Control.Foldl (Fold(..),FoldM(..))
import qualified Control.Foldl as L
import Control.Foldl.Transduce.Internal (Pair(..),Quartet(..),_1of3)
#if !(MIN_VERSION_foldl(1,1,2))
instance Comonad (Fold a) where
extract (Fold _ begin done) = done begin
duplicate (Fold step begin done) = Fold step begin (\x -> Fold step x done)
#endif
instance Extend (Fold a) where
duplicated f = duplicate f
instance Monad m => Extend (FoldM m a) where
duplicated (FoldM step begin done) =
FoldM step begin (\x -> return $! FoldM step (return x) done)
type Transduction a b = forall x. Fold b x -> Fold a x
newtype ReifiedTransduction a b = ReifiedTransduction { getTransduction :: Transduction a b }
type Transduction' a b r = forall x. Fold b x -> Fold a (r,x)
newtype ReifiedTransduction' a b r = ReifiedTransduction' { getTransduction' :: Transduction' a b r }
data Transducer i o r
= forall x. Transducer (x -> i -> (x,[o],[[o]])) x (x -> (r,[o],[[o]]))
instance Comonad (Transducer i o) where
extract (Transducer _ begin done) = _1of3 (done begin)
duplicate (Transducer step begin done) = Transducer step begin (\x -> (Transducer step x done,[],[]))
instance Extend (Transducer i o) where
duplicated f = duplicate f
instance Functor (Transducer i o) where
fmap f (Transducer step begin done) =
Transducer
step
begin
((\(x,xs,xss) -> (f x,xs,xss)) . done)
instance Bifunctor (Transducer i) where
first f (Transducer step begin done) =
Transducer
(fmap (\(x,xs,xss) -> (x,map f xs, map (map f) xss)) . step)
begin
((\(x,xs,xss) -> (x,map f xs, map (map f) xss)) . done)
second f w = fmap f w
class ToTransducer t where
toTransducer :: t i o r -> Transducer i o r
instance ToTransducer Transducer where
toTransducer = id
instance ToTransducer (TransducerM Identity) where
toTransducer = _simplify
type TransductionM m a b = forall x. Monad m => FoldM m b x -> FoldM m a x
newtype ReifiedTransductionM m a b = ReifiedTransductionM { getTransductionM :: TransductionM m a b }
type TransductionM' m a b r = forall x. FoldM m b x -> FoldM m a (r,x)
newtype ReifiedTransductionM' m a b r = ReifiedTransductionM' { getTransductionM' :: TransductionM' m a b r }
data TransducerM m i o r
= forall x. TransducerM (x -> i -> m (x,[o],[[o]])) (m x) (x -> m (r,[o],[[o]]))
instance Monad m => Functor (TransducerM m i o) where
fmap f (TransducerM step begin done) = TransducerM step begin done'
where
done' x = do
(r,os,oss) <- done x
let r' = f r
return $! (r' `seq` (r',os,oss))
instance (Functor m, Monad m) => Bifunctor (TransducerM m i) where
first f (TransducerM step begin done) =
TransducerM
(fmap (fmap (\(x,xs,xss) -> (x,map f xs, map (map f) xss))) . step)
begin
(fmap (\(x,xs,xss) -> (x,map f xs, map (map f) xss)) . done)
second f w = fmap f w
instance Monad m => Extend (TransducerM m i o) where
duplicated (TransducerM step begin done) =
TransducerM step begin (\x -> return $! (TransducerM step (return x) done,[],[]))
class ToTransducerM m t where
toTransducerM :: t i o r -> TransducerM m i o r
instance (m ~ m') => ToTransducerM m (TransducerM m') where
toTransducerM = id
instance Monad m => ToTransducerM m Transducer where
toTransducerM = _generalize
transduce :: ToTransducer t => t i o s -> Transduction i o
transduce t = fmap snd . (transduce' t)
transduce' :: ToTransducer t => t i o s -> Transduction' i o s
transduce' (toTransducer -> Transducer wstep wstate wdone) (Fold fstep fstate fdone) =
Fold step (Pair wstate fstate) done
where
step (Pair ws fs) i =
let (ws',os,oss) = wstep ws i
in
Pair ws' (foldl' fstep fs (os ++ mconcat oss))
done (Pair ws fs) =
let (wr,os,oss) = wdone ws
in
(,) wr (fdone (foldl' fstep fs (os ++ mconcat oss)))
transduceM :: (Monad m, ToTransducerM m t) => t i o s -> TransductionM m i o
transduceM t = fmap snd . (transduceM' t)
transduceM' :: (Monad m, ToTransducerM m t) => t i o s -> TransductionM' m i o s
transduceM' (toTransducerM -> TransducerM wstep wstate wdone) (FoldM fstep fstate fdone) =
FoldM step (liftM2 Pair wstate fstate) done
where
step (Pair ws fs) i = do
(ws',os,oss) <- wstep ws i
fs' <- foldlM fstep fs (os ++ mconcat oss)
return $! Pair ws' fs'
done (Pair ws fs) = do
(wr,os,oss) <- wdone ws
fr <- fdone =<< foldlM fstep fs (os ++ mconcat oss)
return $! (,) wr fr
transduceK :: (Monad m) => (i -> m [o]) -> TransductionM m i o
transduceK k = transduceM (TransducerM step (return ()) (\_ -> return ((),[],[])))
where
step _ i = liftM (\os -> ((),os,[])) (k i)
ignore :: Transducer a b ()
ignore =
Transducer step () done
where
step _ _ =
((),[],[])
done =
const ((),[],[])
data SurroundState = PrefixAdded | PrefixPending
surround :: (Traversable p, Traversable s) => p a -> s a -> Transducer a a ()
surround (toList -> ps) (toList -> ss) =
Transducer step PrefixPending done
where
step PrefixPending a =
(PrefixAdded, ps,[[a]])
step PrefixAdded a =
(PrefixAdded, [a],[])
done PrefixPending =
((), ps, [[],ss])
done PrefixAdded =
((), [], [ss])
surroundIO :: (Traversable p, Traversable s, Functor m, MonadIO m)
=> m (p a)
-> m (s a)
-> TransducerM m a a ()
surroundIO prefixa suffixa =
TransducerM step (return PrefixPending) done
where
step PrefixPending a = do
ps <- fmap toList prefixa
return (PrefixAdded, ps, [[a]])
step PrefixAdded a =
return (PrefixAdded, [a], [])
done PrefixPending = do
ps <- fmap toList prefixa
ss <- fmap toList suffixa
return ((), ps, [[],ss])
done PrefixAdded = do
ss <- fmap toList suffixa
return ((), [], [ss])
_generalize :: Monad m => Transducer i o s -> TransducerM m i o s
_generalize (Transducer step begin done) = TransducerM step' begin' done'
where
step' x a = return (step x a)
begin' = return begin
done' x = return (done x)
_simplify :: TransducerM Identity i o s -> Transducer i o s
_simplify (TransducerM step begin done) = Transducer step' begin' done'
where
step' x a = runIdentity (step x a)
begin' = runIdentity begin
done' x = runIdentity (done x)
foldify :: Transducer i o s -> Fold i s
foldify (Transducer step begin done) =
Fold (\x i -> _1of3 (step x i)) begin (\x -> _1of3 (done x))
foldifyM :: Functor m => TransducerM m i o s -> FoldM m i s
foldifyM (TransducerM step begin done) =
FoldM (\x i -> fmap _1of3 (step x i)) begin (\x -> fmap _1of3 (done x))
condense :: Fold a r -> Transducer a r r
condense (Fold fstep fstate fdone) =
(Transducer wstep fstate wdone)
where
wstep = \fstate' i -> (fstep fstate' i,[],[])
wdone = \fstate' -> (\r -> (r,[r],[])) (fdone fstate')
condenseM :: Applicative m => FoldM m a r -> TransducerM m a r r
condenseM (FoldM fstep fstate fdone) =
(TransducerM wstep fstate wdone)
where
wstep = \fstate' i -> fmap (\s -> (s,[],[])) (fstep fstate' i)
wdone = \fstate' -> fmap (\r -> (r,[r],[])) (fdone fstate')
hoistTransducer :: Monad m => (forall a. m a -> n a) -> TransducerM m i o s -> TransducerM n i o s
hoistTransducer g (TransducerM step begin done) = TransducerM (\s i -> g (step s i)) (g begin) (g . done)
hoistFold :: Monad m => (forall a. m a -> n a) -> FoldM m i r -> FoldM n i r
hoistFold g (FoldM step begin done) = FoldM (\s i -> g (step s i)) (g begin) (g . done)
quiesce :: Monad m => FoldM (ExceptT e m) a r -> FoldM m a (Either e r)
quiesce (FoldM step initial done) =
FoldM step' (runExceptT initial) done'
where
step' x i = do
case x of
Left _ -> return x
Right notyetfail -> runExceptT (step notyetfail i)
done' x = do
case x of
Left e -> return (Left e)
Right notyetfail -> do
result <- runExceptT (done notyetfail)
case result of
Left e -> return (Left e)
Right r -> return (Right r)
quiesceWith :: (Functor m,Monad m) => FoldM m a v -> FoldM (ExceptT e m) a r -> FoldM m a (Either (e,v) r)
quiesceWith fallbackFold (FoldM step initial done) =
FoldM step' (runExceptT (withExceptT (Pair fallbackFold) initial)) done'
where
step' x i = do
case x of
Left (Pair ffold e) -> do
ffold' <- L.foldM (duplicated ffold) [i]
return (Left (Pair ffold' e))
Right notyetfail -> do
x' <- runExceptT (step notyetfail i)
case x' of
Left e -> do
ffold <- L.foldM (duplicated fallbackFold) [i]
return (Left (Pair ffold e))
Right x'' -> return (Right x'')
done' x = case x of
Left (Pair ffold e) -> do
alternativeResult <- L.foldM ffold []
return (Left (e,alternativeResult))
Right notyetfail -> do
x' <- runExceptT (done notyetfail)
case x' of
Left e -> do
alternativeResult <- L.foldM fallbackFold []
return (Left (e,alternativeResult))
Right x'' -> return (Right x'')
type Infinite e = Cofree Identity e
type Moore a b = Cofree ((->) a) b
groups :: ToTransducer t
=> t a b s
-> Infinite (ReifiedTransduction b c)
-> Transduction a c
groups splitter transductions oldfold =
let transductions' =
fmap (\rt ->
(ReifiedTransduction' (fmap (fmap ((,) ())) (getTransduction rt))))
. hoistCofree (const . runIdentity)
$ transductions
newfold = groups' splitter L.mconcat transductions' oldfold
in
fmap snd newfold
evenly :: Transduction b c -> Infinite (ReifiedTransduction b c)
evenly = coiter Identity . ReifiedTransduction
bisect :: ToTransducer t
=> t a b s
-> Transduction b c
-> Transduction b c
-> Transduction a c
bisect t t0 t1 = groups t (ReifiedTransduction t0 :< Identity (evenly t1))
groups' :: ToTransducer t
=> t a b s
-> Fold u v
-> Moore u (ReifiedTransduction' b c u)
-> Transduction' a c (s,v)
groups' (toTransducer -> Transducer sstep sbegin sdone) somesummarizer (ReifiedTransduction' t0 :< somemachine) somefold =
Fold step (Quartet sbegin somesummarizer (t0 (duplicated somefold)) somemachine) done
where
step (Quartet sstate summarizer innerfold machine) i =
let
(sstate', oldSplit, newSplits) = sstep sstate i
(summarizer',innerfold',machine') =
foldl'
step'
(summarizer, feed innerfold oldSplit,machine)
newSplits
in
Quartet sstate' summarizer' innerfold' machine'
step' (summarizer_,innerfold_,machine_) somesplit =
let (u,resetted,nextmachine) = reset machine_ innerfold_
in (L.fold (duplicated summarizer_) [u], feed resetted somesplit,nextmachine)
feed = L.fold . duplicated
reset machine (Fold _ fstate fdone) =
let (u,nextfold) = fdone fstate
ReifiedTransduction' t1 :< nextmachine = machine u
in (u,t1 (duplicated nextfold),nextmachine)
done (Quartet sstate summarizer innerfold machine) =
let
(s,oldSplit,newSplits) = sdone sstate
(summarizer',innerfold',_) =
foldl'
step'
(summarizer,feed innerfold oldSplit,machine)
newSplits
(u,finalfold) = extract innerfold'
in ((s,L.fold summarizer' [u]),extract finalfold)
evenly' :: Transduction' b c u -> Moore u (ReifiedTransduction' b c u)
evenly' = coiter const . ReifiedTransduction'
groupsM :: (Monad m, ToTransducerM m t)
=> t a b s
-> Infinite (ReifiedTransductionM m b c)
-> TransductionM m a c
groupsM splitter transductions oldfold =
let transductions' =
fmap (\rt ->
ReifiedTransductionM'
(fmap (fmap ((,) ())) (getTransductionM rt)))
. hoistCofree (const . runIdentity)
$ transductions
newfold = groupsM' splitter (L.generalize L.mconcat) transductions' oldfold
in
fmap snd newfold
evenlyM :: TransductionM m b c -> Infinite (ReifiedTransductionM m b c)
evenlyM = coiter Identity . ReifiedTransductionM
bisectM :: ToTransducerM m t
=> t a b s
-> TransductionM m b c
-> TransductionM m b c
-> TransductionM m a c
bisectM t t0 t1 = groupsM t (ReifiedTransductionM t0 :< Identity (evenlyM t1))
groupsM' :: (Monad m, ToTransducerM m t)
=> t a b s
-> FoldM m u v
-> Moore u (ReifiedTransductionM' m b c u)
-> TransductionM' m a c (s,v)
groupsM' (toTransducerM -> TransducerM sstep sbegin sdone) somesummarizer (ReifiedTransductionM' t0 :< somemachine) somefold =
FoldM step (sbegin >>= \x -> return (Quartet x somesummarizer (t0 (duplicated somefold)) somemachine)) done
where
step (Quartet sstate summarizer innerfold machine) i = do
(sstate', oldSplit, newSplits) <- sstep sstate i
innerfold' <- feed innerfold oldSplit
(summarizer',innerfold'',machine') <- foldlM step' (summarizer,innerfold',machine) newSplits
return $! Quartet sstate' summarizer' innerfold'' machine'
step' = \(summarizer,innerfold,machine) is -> do
(u,innerfold',machine') <- reset machine innerfold
summarizer' <- L.foldM (duplicated summarizer) [u]
innerfold'' <- feed innerfold' is
return $! (summarizer',innerfold'',machine')
feed = L.foldM . duplicated
reset machine (FoldM _ fstate fdone) = do
(u,nextfold) <- fdone =<< fstate
let
ReifiedTransductionM' t1 :< nextmachine = machine u
return (u,t1 (duplicated nextfold),nextmachine)
done (Quartet sstate summarizer innerfold machine) = do
(s,oldSplit,newSplits) <- sdone sstate
innerfold' <- feed innerfold oldSplit
(summarizer',innerfold'',_) <- foldlM step' (summarizer,innerfold',machine) newSplits
(u,finalfold) <- L.foldM innerfold'' []
v <- L.foldM summarizer' [u]
r <- L.foldM finalfold []
return ((s,v),r)
evenlyM' :: TransductionM' m b c u -> Moore u (ReifiedTransductionM' m b c u)
evenlyM' = coiter const . ReifiedTransductionM'
folds :: ToTransducer t => t a b s -> Fold b c -> Transduction a c
folds splitter f = groups splitter (evenly (transduce (condense f)))
folds' :: ToTransducer t => t a b s -> Fold b c -> Transduction' a c s
folds' splitter innerfold somefold =
fmap (bimap fst id) (groups' splitter L.mconcat innertrans somefold)
where
innertrans = evenly' $ \x -> fmap ((,) ()) (transduce (condense innerfold) x)
foldsM :: (Applicative m, Monad m, ToTransducerM m t) => t a b s -> FoldM m b c -> TransductionM m a c
foldsM splitter f = groupsM splitter (evenlyM (transduceM (condenseM f)))
foldsM' :: (Applicative m,Monad m, ToTransducerM m t) => t a b s -> FoldM m b c -> TransductionM' m a c s
foldsM' splitter innerfold somefold =
fmap (bimap fst id) (groupsM' splitter (L.generalize L.mconcat) innertrans somefold)
where
innertrans = evenlyM' $ \x -> fmap ((,) ()) (transduceM (condenseM innerfold) x)
chunksOf :: Int -> Transducer a a ()
chunksOf 0 = Transducer (\_ _ -> ((),[],repeat [])) () (error "never happens")
chunksOf groupSize = Transducer step groupSize done
where
step 0 a = (pred groupSize, [], [[a]])
step i a = (pred i, [a], [])
done _ = ((),[],[])
splitAt :: Int -> Transducer a a ()
splitAt howmany =
Transducer step (Just howmany) done
where
step Nothing i =
(Nothing,[i],[])
step (Just howmanypending) i
| howmanypending == 0 =
(Nothing,[],[[i]])
| otherwise =
(Just (pred howmanypending),[i],[])
done = mempty
chunkedSplitAt :: SFM.StableFactorialMonoid m => Int -> Transducer m m ()
chunkedSplitAt howmany =
Transducer step (Just howmany) done
where
step Nothing m =
(Nothing,[m],[])
step (Just howmanypending) m
| NM.null m =
(Just howmanypending,[],[])
| howmanypending == 0 =
(Nothing,[],[[m]])
| howmanypending >= SFM.length m =
(Just (howmanypending SFM.length m),[m],[])
| otherwise =
let (prefix,suffix) = SFM.splitAt howmanypending m
in
(Nothing,[prefix],[[suffix]])
done = mempty
data SplitWhenWhenState =
SplitWhenConditionEncountered
| SplitWhenConditionPending
splitWhen :: (a -> Bool) -> Transducer a a ()
splitWhen predicate =
Transducer step SplitWhenConditionPending done
where
step SplitWhenConditionPending i =
if predicate i
then (SplitWhenConditionEncountered,[],[[i]])
else (SplitWhenConditionPending,[i],[])
step SplitWhenConditionEncountered i =
(SplitWhenConditionEncountered,[i],[])
done = mempty
splitLast :: Transducer a a (Maybe a)
splitLast =
Transducer step Nothing done
where
step Nothing i =
(Just i,[],[])
step (Just oldi) i =
(Just i,[oldi],[])
done Nothing =
(Nothing,[],[])
done (Just lasti) = (Just lasti, [], [[lasti]])
chunkedStripPrefix :: (CM.LeftGCDMonoid i,SFM.StableFactorialMonoid i,Traversable t,Monad m)
=> t i
-> TransducerM (ExceptT ([i],Maybe i) m) i i ()
chunkedStripPrefix (filter (not . NM.null) . toList -> chunks) =
TransducerM step (return chunks) done
where
step [] i =
return ([],[i],[])
step (x:xs) i =
let (prefix',i',x') = CM.stripCommonPrefix i x
in
if NM.null prefix'
then throwE (x:xs,Just i)
else
if NM.null x'
then step xs i'
else step (x':xs) i'
done [] =
return mempty
done (x:xs) =
throwE (x:xs, Nothing)