module Control.Foldl.Transduce (
Transduction
, Transduction'
, Transducer(..)
, ToTransducer(..)
, TransductionM
, TransductionM'
, TransducerM(..)
, ToTransducerM(..)
, transduce
, transduce'
, transduceM
, transduceM'
, transduceK
, folds
, folds'
, foldsM
, foldsM'
, ReifiedTransduction' (..)
, reify
, reify'
, Moore(..)
, ToTransductions' (..)
, moveHead
, groups
, bisect
, groups'
, ReifiedTransductionM' (..)
, reifyM
, reifyM'
, MooreM(..)
, ToTransductionsM' (..)
, moveHeadM
, groupsM
, bisectM
, groupsM'
, ignore
, surround
, surroundIO
, chunksOf
, split
, splitAt
, chunkedSplitAt
, splitLast
, break
, chunkedStripPrefix
, foldify
, foldifyM
, condense
, condenseM
, hoistTransducer
, hoistFold
, unit
, trip
, quiesce
, Fallible(..)
, ToFold(..)
, ToFoldM(..)
, module Data.Functor.Extend
, module Control.Foldl
, module Control.Comonad.Cofree
) where
import Prelude hiding (split,splitAt,break)
import Data.Functor
import Data.Bifunctor
import Data.Profunctor
import Data.Monoid
import Data.Void
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.Class
import Control.Monad.Trans.Except
import Control.Comonad
import Control.Comonad.Cofree
import Control.Foldl (Fold(..),FoldM(..),hoists)
import qualified Control.Foldl as L
#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)
data Pair a b = Pair !a !b
data Quartet a b c d = Quartet !a !b !c !d
fst3 :: (a,b,c) -> a
fst3 (x,_,_) = x
type Transduction a b = forall x. Fold b x -> Fold a x
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 }
reify :: Transduction a b -> ReifiedTransduction' a b ()
reify t = reify' (fmap (fmap ((,) ())) t)
reify' :: Transduction' a b r -> ReifiedTransduction' a b r
reify' = ReifiedTransduction'
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) = fst3 (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
class ToFold t where
toFold :: t i r -> Fold i r
instance ToFold Fold where
toFold = id
instance ToFold (FoldM Identity) where
toFold = L.simplify
type TransductionM m a b = forall x. Monad m => FoldM m b x -> FoldM m a x
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 }
reifyM :: Monad m => TransductionM m a b -> ReifiedTransductionM' m a b ()
reifyM t = reifyM' (fmap (fmap ((,) ())) t)
reifyM' :: TransductionM' m a b r -> ReifiedTransductionM' m a b r
reifyM' = ReifiedTransductionM'
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
class ToFoldM m t where
toFoldM :: t i r -> FoldM m i r
instance (m ~ m') => ToFoldM m (FoldM m') where
toFoldM = id
instance Monad m => ToFoldM m Fold where
toFoldM = L.generalize
transduce :: ToTransducer t => t i o () -> 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 () -> 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 -> fst3 (step x i)) begin (\x -> fst3 (done x))
foldifyM :: Functor m => TransducerM m i o s -> FoldM m i s
foldifyM (TransducerM step begin done) =
FoldM (\x i -> fmap fst3 (step x i)) begin (\x -> fmap fst3 (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 = Control.Foldl.hoists
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)
newtype Fallible m r i e = Fallible { getFallible :: FoldM (ExceptT e m) i r }
bindFallible :: (Functor m,Monad m) => Fallible m r i e -> (e -> Fallible m r i e') -> Fallible m r i e'
bindFallible (Fallible (FoldM step initial done)) k =
Fallible (FoldM step' (lift (runExceptT (withExceptT (getFallible . k) initial))) done')
where
step' x i = ExceptT (case x of
Left ffold -> do
rx <- runExceptT (L.foldM (duplicated ffold) [i])
case rx of
Left e' -> return (Left e')
Right ffold' -> return (Right (Left ffold'))
Right notyetfail -> do
x' <- runExceptT (step notyetfail i)
case x' of
Left e -> do
return (Right (Left ((getFallible . k) e)))
Right x'' -> return (Right (Right x'')))
done' x = ExceptT (case x of
Left ffold -> do
rx <- runExceptT (L.foldM ffold [])
case rx of
Left e' -> return (Left e')
Right r -> return (Right r)
Right notyetfail -> do
x' <- runExceptT (done notyetfail)
case x' of
Left e -> do
runExceptT (done' (Left (getFallible (k e))))
Right x'' -> return (Right x''))
instance (Functor m, Monad m) => Functor (Fallible m r i) where
fmap g (Fallible fallible) =
Fallible (hoistFold (withExceptT g) fallible)
instance (Functor m,Monad m) => Applicative (Fallible m r i) where
pure e = Fallible (FoldM (\_ _ -> throwE e) (throwE e) (\_ -> throwE e))
u <*> v = u >>= \f -> fmap f v
instance (Functor m, Monad m) => Profunctor (Fallible m r) where
lmap f (Fallible fallible) =
Fallible (L.premapM f fallible)
rmap g (Fallible fallible) =
Fallible (hoistFold (withExceptT g) fallible)
instance (Functor m,Monad m,Monoid r) => Choice (Fallible m r) where
left' (Fallible fallible) =
Fallible (liftA2 mappend (hoistFold (withExceptT Left) (L.handlesM _Left fallible)) (hoistFold (withExceptT Right) (L.handlesM _Right (trip $> mempty))))
_Left :: Applicative f => (a -> f a) -> Either a b -> f (Either a b)
_Left f e = case e of
Right b -> pure (Right b)
Left a -> fmap Left (f a)
_Right :: Applicative f => (b -> f b) -> Either a b -> f (Either a b)
_Right f e = case e of
Left b -> pure (Left b)
Right a -> fmap Right (f a)
instance (Functor m,Monad m) => Monad (Fallible m r i) where
(>>=) = bindFallible
return = pure
unit :: Fold a ()
unit = pure ()
trip :: Monad m => FoldM (ExceptT a m) a ()
trip = FoldM (\_ x -> throwE x) (return ()) (\_ -> return mempty)
newtype Moore a b u = Moore { getMoore :: Cofree ((->) u) (ReifiedTransduction' a b u) }
newtype MooreM m a b u = MooreM { getMooreM :: Cofree ((->) u) (ReifiedTransductionM' m a b u) }
moveHead :: (ToTransductions' h,ToTransductions' t) => h a b u -> t a b u -> Moore a b u
moveHead (toTransductions' -> Moore (theHead :< _)) (toTransductions' -> Moore theTail) = Moore (theHead :< const theTail)
moveHeadM :: (Monad m, ToTransductionsM' m h, ToTransductionsM' m t) => h a b u -> t a b u -> MooreM m a b u
moveHeadM (toTransductionsM' -> MooreM (theHead :< _)) (toTransductionsM' -> MooreM theTail) = MooreM (theHead :< const theTail)
class ToTransductions' t where
toTransductions' :: t a b u -> Moore a b u
instance ToTransductions' Moore where
toTransductions' = id
instance ToTransductions' Transducer where
toTransductions' t = toTransductions' (reify' (transduce' t))
instance ToTransductions' ReifiedTransduction' where
toTransductions' = Moore . coiter const
class Monad m => ToTransductionsM' m t where
toTransductionsM' :: t a b u -> MooreM m a b u
instance (m ~ m', Monad m') => ToTransductionsM' m (MooreM m') where
toTransductionsM' = id
instance (m ~ m', Monad m') => ToTransductionsM' m (TransducerM m') where
toTransductionsM' t = toTransductionsM' (reifyM' (transduceM' t))
instance Monad m => ToTransductionsM' m Transducer where
toTransductionsM' (toTransducerM -> t) = toTransductionsM' (reifyM' (transduceM' t))
instance (m ~ m', Monad m') => ToTransductionsM' m (ReifiedTransductionM' m') where
toTransductionsM' = MooreM . coiter const
groups :: (ToTransducer s, ToTransductions' t)
=> s a b ()
-> t b c ()
-> Transduction a c
groups splitter transductions oldfold =
fmap snd (groups' splitter transductions unit oldfold)
bisect :: (ToTransducer s, ToTransductions' h, ToTransductions' t)
=> s a b ()
-> h b c ()
-> t b c ()
-> Transduction a c
bisect sp t1 t2 = groups sp (moveHead t1 t2)
data StrictSum a b = Left' !a | Right' !b
groups' :: (ToTransducer s, ToTransductions' t, ToFold f)
=> s a b r
-> t b c u
-> f u v
-> Transduction' a c (r,v)
groups' (toTransducer -> Transducer sstep sbegin sdone)
(toTransductions' -> Moore (rt0 :< somemachine))
(toFold -> Fold astep abegin adone)
somefold
=
Fold step (Quartet sbegin somemachine abegin (Left' (rt0,somefold))) done
where
step (Quartet sstate machine astate innerfold) i =
let (sstate',oldSplit,newSplits) = sstep sstate i
in
case (oldSplit,newSplits) of
([],[]) ->
Quartet sstate' machine astate innerfold
_ ->
let actualinnerfold = case innerfold of
Left' (ReifiedTransduction' t0,pristine) -> t0 (duplicated pristine)
Right' touched -> touched
(machine',astate',innerfold') =
foldl'
step'
(machine,astate,feed actualinnerfold oldSplit)
newSplits
in
Quartet sstate' machine' astate' (Right' innerfold')
done (Quartet sstate machine astate innerfold) =
let (s,oldSplit,newSplits) = sdone sstate
in
case (oldSplit,newSplits,innerfold) of
([],[],Left' (_,pristine)) ->
((s,adone astate), extract pristine)
_ ->
let actualinnerfold = case innerfold of
Left' (ReifiedTransduction' t0,pristine) -> t0 (duplicated pristine)
Right' touched -> touched
(_,astate',innerfold') =
foldl'
step'
(machine,astate,feed actualinnerfold oldSplit)
newSplits
(u,finalfold) = extract innerfold'
in
((s,adone (astep astate' u)),extract finalfold)
step' (machine_,astate,innerfold_) somesplit =
let (u,resetted,nextmachine) = reset machine_ innerfold_
in (nextmachine,astep astate u,feed resetted somesplit)
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)
groupsM :: (Monad m, ToTransducerM m s, ToTransductionsM' m t)
=> s a b ()
-> t b c ()
-> TransductionM m a c
groupsM splitter transductions oldfold =
fmap snd (groupsM' splitter transductions unit oldfold)
bisectM :: (Monad m, ToTransducerM m s, ToTransductionsM' m h, ToTransductionsM' m t)
=> s a b ()
-> h b c ()
-> t b c ()
-> TransductionM m a c
bisectM s t1 t2 = groupsM s (moveHeadM t1 t2)
groupsM' :: (Monad m, ToTransducerM m s, ToTransductionsM' m t, ToFoldM m f)
=> s a b r
-> t b c u
-> f u v
-> TransductionM' m a c (r,v)
groupsM' (toTransducerM -> TransducerM sstep sbegin sdone)
(toTransductionsM' -> MooreM (rt0 :< somemachine))
(toFoldM -> FoldM astep abegin adone)
somefold
=
FoldM step
(do sbegin' <- sbegin
abegin' <- abegin
return (Quartet sbegin' somemachine abegin' (Left' (rt0,somefold))))
done
where
step (Quartet sstate machine astate innerfold) i = do
(sstate',oldSplit, newSplits) <- sstep sstate i
case (oldSplit,newSplits) of
([],[]) ->
return $! Quartet sstate' machine astate innerfold
_ -> do
let actualinnerfold = case innerfold of
Left' (ReifiedTransductionM' t0,pristine) -> t0 (duplicated pristine)
Right' touched -> touched
innerfold' <- feed actualinnerfold oldSplit
(machine',astate',innerfold'') <- foldlM step' (machine,astate,innerfold') newSplits
return $! Quartet sstate' machine' astate' (Right' innerfold'')
done (Quartet sstate machine astate innerfold) = do
(s,oldSplit,newSplits) <- sdone sstate
case (oldSplit,newSplits,innerfold) of
([],[],Left' (_,pristine)) -> do
a <- adone astate
p <- L.foldM pristine []
return ((s,a),p)
_ -> do
let actualinnerfold = case innerfold of
Left' (ReifiedTransductionM' t0,pristine) -> t0 (duplicated pristine)
Right' touched -> touched
innerfold' <- feed actualinnerfold oldSplit
(_,astate',innerfold'') <- foldlM step' (machine,astate,innerfold') newSplits
(u,finalfold) <- L.foldM innerfold'' []
v <- adone =<< astep astate' u
r <- L.foldM finalfold []
return ((s,v),r)
step' (machine,astate,innerfold) is = do
(u,innerfold',machine') <- reset machine innerfold
astate' <- astep astate u
innerfold'' <- feed innerfold' is
return $! (machine',astate',innerfold'')
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)
folds :: (ToTransducer t, ToFold f)
=> t a b ()
-> f b c
-> Transduction a c
folds splitter (toFold -> f) = groups splitter (fmap (const ()) (condense f))
folds' :: (ToTransducer t, ToFold f)
=> t a b s
-> f b c
-> Transduction' a c s
folds' splitter (toFold -> innerfold) somefold =
fmap (bimap fst id) (groups' splitter innertrans unit somefold)
where
innertrans = reify' $ \x -> fmap ((,) () . snd) (transduce' (condense innerfold) x)
foldsM :: (Applicative m, Monad m, ToTransducerM m t, ToFoldM m f)
=> t a b ()
-> f b c
-> TransductionM m a c
foldsM splitter (toFoldM -> f) = groupsM splitter (fmap (const ()) (condenseM f))
foldsM' :: (Applicative m,Monad m, ToTransducerM m t, ToFoldM m f)
=> t a b s
-> f b c
-> TransductionM' m a c s
foldsM' splitter (toFoldM -> innerfold) somefold =
fmap (bimap fst id) (groupsM' splitter innertrans unit somefold)
where
innertrans = reifyM' $ \x -> fmap ((,) () . snd) (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 SplitState =
PreviousSeparator
| PreviousNonSeparator
split :: (a -> Bool) -> Transducer a a ()
split predicate =
Transducer step PreviousNonSeparator done
where
step PreviousNonSeparator i =
if predicate i
then (PreviousSeparator,[],[])
else (PreviousNonSeparator,[i],[])
step PreviousSeparator i =
if predicate i
then (PreviousSeparator,[],[[]])
else (PreviousNonSeparator,[],[[i]])
done PreviousNonSeparator = mempty
done PreviousSeparator = ((),[],[[]])
data BreakWhenState =
BreakConditionEncountered
| BreakConditionPending
break :: (a -> Bool) -> Transducer a a ()
break predicate =
Transducer step BreakConditionPending done
where
step BreakConditionPending i =
if predicate i
then (BreakConditionEncountered,[],[[i]])
else (BreakConditionPending,[i],[])
step BreakConditionEncountered i =
(BreakConditionEncountered,[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)