module Data.Iteratee.Base (
ErrMsg (..),
StreamG (..),
IterGV (..),
IterateeG (..),
EnumeratorN,
EnumeratorGM,
EnumeratorGMM,
joinI,
liftI,
isFinished,
run,
joinIM,
stream2list,
stream2stream,
checkIfDone,
liftInner,
setEOF,
throwErr,
checkErr,
break,
dropWhile,
drop,
identity,
head,
heads,
peek,
skipToEof,
length,
take,
takeR,
mapStream,
rigidMapStream,
looseMapStream,
convStream,
filter,
foldl,
foldl',
foldl1,
sum,
product,
enumEof,
enumErr,
enumPure1Chunk,
enumPureNChunk,
(>.),
enumPair,
seek,
FileOffset,
module Data.Iteratee.Base.LooseMap
)
where
import Prelude hiding (head, drop, dropWhile, take, break, foldl, foldl1, length, filter, sum, product)
import qualified Prelude as P
import qualified Data.Iteratee.Base.StreamChunk as SC
import qualified Data.ListLike as LL
import qualified Data.ListLike.FoldableLL as FLL
import Data.Iteratee.Base.LooseMap
import Data.Iteratee.IO.Base
import Control.Monad
import Control.Applicative
import Control.Monad.Trans.Class
import Control.Monad.IO.Class
import Data.Monoid
import Data.Maybe (fromMaybe)
data StreamG c el =
EOF (Maybe ErrMsg)
| Chunk (c el)
instance Eq (c el) => Eq (StreamG c el) where
EOF mErr1 == EOF mErr2 = mErr1 == mErr2
Chunk xs == Chunk ys = xs == ys
_ == _ = False
instance Show (c el) => Show (StreamG c el) where
show (EOF mErr) = "StreamG: EOF " ++ show mErr
show (Chunk xs) = "StreamG: Chunk " ++ show xs
instance Functor c => Functor (StreamG c) where
fmap _ (EOF mErr) = EOF mErr
fmap f (Chunk xs) = Chunk $ fmap f xs
instance Monoid (c el) => Monoid (StreamG c el) where
mempty = Chunk mempty
mappend (EOF mErr) _ = EOF mErr
mappend _ (EOF mErr) = EOF mErr
mappend (Chunk s1) (Chunk s2) = Chunk (s1 `mappend` s2)
strMap :: (c el -> c' el') -> StreamG c el -> StreamG c' el'
strMap f (Chunk xs) = Chunk $ f xs
strMap _ (EOF mErr) = EOF mErr
data ErrMsg = Err String
| Seek FileOffset
deriving (Show, Eq)
instance Monoid ErrMsg where
mempty = Err ""
mappend (Err s1) (Err s2) = Err (s1 ++ s2)
mappend e@(Err _) _ = e
mappend _ e@(Err _) = e
mappend (Seek _) (Seek b) = Seek b
data IterGV c el m a =
Done a (StreamG c el)
| Cont (IterateeG c el m a) (Maybe ErrMsg)
instance (Show (c el), Show a) => Show (IterGV c el m a) where
show (Done a str) = "IterGV Done <<" ++ show a ++ ">> : <<" ++ show str ++ ">>"
show (Cont _ mErr) = "IterGV Cont :: " ++ show mErr
newtype IterateeG c el m a = IterateeG{
runIter :: StreamG c el -> m (IterGV c el m a)
}
liftI :: (Monad m, SC.StreamChunk s el) => IterGV s el m a -> IterateeG s el m a
liftI (Cont k Nothing) = k
liftI (Cont _k (Just err)) = throwErr err
liftI i@(Done _ (EOF _ )) = IterateeG (const (return i))
liftI (Done a (Chunk st )) = IterateeG (check st)
where
check str (Chunk str') = return $ Done a (Chunk $ str `mappend` str')
check _str e@(EOF _) = return $ Done a e
run :: (Monad m, SC.StreamChunk s el) => IterateeG s el m a -> m a
run iter = runIter iter (EOF Nothing) >>= \res ->
case res of
Done x _ -> return x
Cont _ e -> error $ "control message: " ++ show e
isFinished :: (SC.StreamChunk s el, Monad m) =>
IterateeG s el m (Maybe ErrMsg)
isFinished = IterateeG check
where
check s@(EOF e) = return $ Done (Just $ fromMaybe (Err "EOF") e) s
check s = return $ Done Nothing s
checkIfDone :: (SC.StreamChunk s el, Monad m) =>
(IterateeG s el m a -> m (IterateeG s el m a)) ->
IterGV s el m a ->
m (IterateeG s el m a)
checkIfDone _ (Done x _) = return . return $ x
checkIfDone k (Cont x Nothing) = k x
checkIfDone _ (Cont _ (Just e)) = return . throwErr $ e
joinI :: (SC.StreamChunk s el, SC.StreamChunk s' el', Monad m) =>
IterateeG s el m (IterateeG s' el' m a) ->
IterateeG s el m a
joinI m = IterateeG (docase <=< runIter m)
where
docase (Done ma str) = liftM (flip Done str) (run ma)
docase (Cont k mErr) = return $ Cont (joinI k) mErr
liftInner :: (Monad m, MonadTrans t, Monad (t m)) =>
IterateeG s el m a ->
IterateeG s el (t m) a
liftInner iter = IterateeG step
where
step str = do
igv <- lift $ runIter iter str
case igv of
Done a res -> return $ Done a res
Cont k mErr -> return $ Cont (liftInner k) mErr
instance (Monad m) => Monad (IterateeG s el m) where
return x = IterateeG (return . Done x)
(>>=) = iterBind
iterBind :: (Monad m ) =>
IterateeG s el m a ->
(a -> IterateeG s el m b) ->
IterateeG s el m b
iterBind m f = IterateeG (docase <=< runIter m)
where
docase (Done a str) = runIter (f a) str
docase (Cont k mErr) = return $ Cont (k `iterBind` f) mErr
instance (Monad m, Functor m) =>
Functor (IterateeG s el m) where
fmap f m = IterateeG (docase <=< runIter m)
where
docase (Done a stream) = return $ Done (f a) stream
docase (Cont k mErr) = return $ Cont (fmap f k) mErr
instance (Monad m, Functor m) => Applicative (IterateeG s el m) where
pure = return
m <*> a = m >>= flip fmap a
instance MonadTrans (IterateeG s el) where
lift m = IterateeG $ \str -> liftM (flip Done str) m
instance (MonadIO m) => MonadIO (IterateeG s el m) where
liftIO = lift . liftIO
stream2list :: (SC.StreamChunk s el, Monad m) => IterateeG s el m [el]
stream2list = IterateeG (step mempty)
where
step acc (Chunk ls)
| SC.null ls = return $ Cont (IterateeG (step acc)) Nothing
step acc (Chunk ls) = return $ Cont
(IterateeG (step (acc `mappend` ls)))
Nothing
step acc str = return $ Done (SC.toList acc) str
stream2stream :: (SC.StreamChunk s el, Monad m) => IterateeG s el m (s el)
stream2stream = IterateeG (step mempty)
where
step acc (Chunk ls)
| SC.null ls = return $ Cont (IterateeG (step acc)) Nothing
step acc (Chunk ls) = return $ Cont
(IterateeG (step (acc `mappend` ls)))
Nothing
step acc str = return $ Done acc str
throwErr :: (Monad m) => ErrMsg -> IterateeG s el m a
throwErr e = IterateeG (\_ -> return $ Cont (throwErr e) (Just e))
setEOF :: StreamG c el -> ErrMsg
setEOF (EOF (Just e)) = e
setEOF _ = Err "EOF"
checkErr :: (Monad m, SC.StreamChunk s el) =>
IterateeG s el m a ->
IterateeG s el m (Either ErrMsg a)
checkErr iter = IterateeG (check <=< runIter iter)
where
check (Done a str) = return $ Done (Right a) str
check (Cont _ (Just err)) = return $ Done (Left err) mempty
check (Cont k Nothing) = return $ Cont (checkErr k) Nothing
break :: (SC.StreamChunk s el, Monad m) =>
(el -> Bool) ->
IterateeG s el m (s el)
break cpred = IterateeG (step mempty)
where
step before (Chunk str) | SC.null str = return $
Cont (IterateeG (step before)) Nothing
step before (Chunk str) =
case LL.break cpred str of
(_, tail') | SC.null tail' -> return $ Cont
(IterateeG (step (before `mappend` str)))
Nothing
(str', tail') -> return $ Done (before `mappend` str') (Chunk tail')
step before stream = return $ Done before stream
identity :: (Monad m) => IterateeG s el m ()
identity = return ()
head :: (SC.StreamChunk s el, Monad m) => IterateeG s el m el
head = IterateeG step
where
step (Chunk vec)
| SC.null vec = return $ Cont head Nothing
| otherwise = return $ Done (SC.head vec) (Chunk $ SC.tail vec)
step stream = return $ Cont head (Just (setEOF stream))
heads :: (SC.StreamChunk s el, Monad m, Eq el) =>
s el ->
IterateeG s el m Int
heads st | SC.null st = return 0
heads st = loop 0 st
where
loop cnt xs | SC.null xs = return cnt
loop cnt xs = IterateeG (step cnt xs)
step cnt str (Chunk xs) | SC.null xs = return $ Cont (loop cnt str) Nothing
step cnt str stream | SC.null str = return $ Done cnt stream
step cnt str s@(Chunk xs) =
if SC.head str == SC.head xs
then step (succ cnt) (SC.tail str) (Chunk $ SC.tail xs)
else return $ Done cnt s
step cnt _ stream = return $ Done cnt stream
peek :: (SC.StreamChunk s el, Monad m) => IterateeG s el m (Maybe el)
peek = IterateeG step
where
step s@(Chunk vec)
| SC.null vec = return $ Cont peek Nothing
| otherwise = return $ Done (Just $ SC.head vec) s
step stream = return $ Done Nothing stream
skipToEof :: (Monad m) => IterateeG s el m ()
skipToEof = IterateeG step
where
step (Chunk _) = return $ Cont skipToEof Nothing
step s = return $ Done () s
seek :: (Monad m) => FileOffset -> IterateeG s el m ()
seek n = IterateeG step
where
step (Chunk _) = return $ Cont identity (Just (Seek n))
step s = return $ Done () s
drop :: (SC.StreamChunk s el, Monad m) => Int -> IterateeG s el m ()
drop 0 = return ()
drop n = IterateeG step
where
step (Chunk str)
| SC.length str <= n = return $ Cont (drop (n SC.length str)) Nothing
step (Chunk str) = return $ Done () (Chunk (LL.drop n str))
step stream = return $ Done () stream
dropWhile :: (SC.StreamChunk s el, Monad m) =>
(el -> Bool) ->
IterateeG s el m ()
dropWhile p = IterateeG step
where
step (Chunk str) = let dropped = LL.dropWhile p str
in if LL.null dropped
then return $ Cont (dropWhile p) Nothing
else return $ Done () (Chunk dropped)
step stream = return $ Done () stream
length :: (Num a, LL.ListLike (s el) el, Monad m) => IterateeG s el m a
length = length' 0
where
length' = IterateeG . step
step i (Chunk xs) = let a = i + (LL.length xs)
in a `seq` return $ Cont (length' a) Nothing
step i stream = return $ Done (fromIntegral i) stream
type EnumeratorN s_outer el_outer s_inner el_inner m a =
IterateeG s_inner el_inner m a ->
IterateeG s_outer el_outer m (IterateeG s_inner el_inner m a)
take :: (SC.StreamChunk s el, Monad m) =>
Int -> EnumeratorN s el s el m a
take 0 iter = return iter
take n iter = IterateeG step
where
step s@(Chunk str)
| LL.null str = return $ Cont (take n iter) Nothing
| LL.length str < n = liftM (flip Cont Nothing) inner
where inner = check (n LL.length str) `liftM` runIter iter s
step (Chunk str) = done (Chunk s1) (Chunk s2)
where (s1, s2) = LL.splitAt n str
step str = done str str
check n' (Done x _) = drop n' >> return (return x)
check n' (Cont x Nothing) = take n' x
check n' (Cont _ (Just e)) = drop n' >> throwErr e
done s1 s2 = liftM (flip Done s2) (runIter iter s1 >>= checkIfDone return)
takeR :: (SC.StreamChunk s el, Monad m) =>
Int -> EnumeratorN s el s el m a
takeR 0 iter = return iter
takeR n iter = IterateeG step
where
step s@(Chunk str)
| LL.null str = return $ Cont (takeR n iter) Nothing
| LL.length str <= n = runIter iter s >>= check (n LL.length str)
| otherwise = done (Chunk str1) (Chunk str2)
where (str1, str2) = LL.splitAt n str
step str = done str str
check _ (Done a str) = return $ Done (return a) str
check n' (Cont k mErr) = return $ Cont (takeR n' k) mErr
done s1 s2 = liftM (flip Done s2) (runIter iter s1 >>= checkIfDone return)
mapStream :: (SC.StreamChunk s el, SC.StreamChunk s el', Monad m) =>
(el -> el')
-> EnumeratorN s el s el' m a
mapStream f i = step i
where
step iter = IterateeG ((check <=< runIter iter) . strMap (SC.cMap f))
check (Done a _) = return $ Done (return a) (Chunk LL.empty)
check (Cont k mErr) = return $ Cont (step k) mErr
rigidMapStream :: (SC.StreamChunk s el, Monad m) =>
(el -> el)
-> EnumeratorN s el s el m a
rigidMapStream f i = step i
where
step iter = IterateeG ((check <=< runIter iter) . strMap (LL.rigidMap f))
check (Done a _) = return $ Done (return a) (Chunk LL.empty)
check (Cont k mErr) = return $ Cont (step k) mErr
looseMapStream :: (SC.StreamChunk s el,
SC.StreamChunk s el',
LooseMap s el el',
Monad m) =>
(el -> el')
-> EnumeratorN s el s el' m a
looseMapStream f i = step i
where
step iter = IterateeG ((check <=< runIter iter) . strMap (looseMap f))
check (Done a _) = return $ Done (return a) (Chunk LL.empty)
check (Cont x mErr) = return $ Cont (step x) mErr
convStream :: Monad m =>
IterateeG s el m (Maybe (s' el')) ->
EnumeratorN s el s' el' m a
convStream fi iter = fi >>= check
where
check (Just xs) = lift (runIter iter (Chunk xs)) >>= docase
check (Nothing) = return iter
docase (Done a _) = return . return $ a
docase (Cont k Nothing) = convStream fi k
docase (Cont _ (Just e)) = return $ throwErr e
filter :: (LL.ListLike (s el) el, Monad m) =>
(el -> Bool) ->
EnumeratorN s el s el m a
filter p = convStream f'
where
f' = IterateeG step
step (Chunk xs) | LL.null xs = return $ Cont f' Nothing
step (Chunk xs) = return $ Done (Just $ LL.filter p xs) mempty
step stream = return $ Done Nothing stream
foldl :: (LL.ListLike (s el) el, FLL.FoldableLL (s el) el, Monad m) =>
(a -> el -> a) ->
a ->
IterateeG s el m a
foldl f i = iter i
where
iter ac = IterateeG step
where
step (Chunk xs) | LL.null xs = return $ Cont (iter ac) Nothing
step (Chunk xs) = return $ Cont (iter (FLL.foldl f ac xs)) Nothing
step stream = return $ Done ac stream
foldl' :: (LL.ListLike (s el) el, FLL.FoldableLL (s el) el, Monad m) =>
(a -> el -> a) ->
a ->
IterateeG s el m a
foldl' f i = IterateeG (step i)
where
step ac (Chunk xs) | LL.null xs = return $ Cont (IterateeG (step ac))
Nothing
step ac (Chunk xs) = return $ Cont (IterateeG (step $! FLL.foldl' f ac xs))
Nothing
step ac stream = return $ Done ac stream
foldl1 :: (LL.ListLike (s el) el, FLL.FoldableLL (s el) el, Monad m) =>
(el -> el -> el) ->
IterateeG s el m el
foldl1 f = IterateeG step
where
step (Chunk xs) | LL.null xs = return $ Cont (foldl1 f) Nothing
step (Chunk xs) = return $ Cont (foldl f (FLL.foldl1 f xs)) Nothing
step stream = return $ Cont (foldl1 f) (Just (setEOF stream))
sum :: (LL.ListLike (s el) el, Num el, Monad m) =>
IterateeG s el m el
sum = IterateeG (step 0)
where
step acc (Chunk xs)
| LL.null xs = return $ Cont (IterateeG (step acc)) Nothing
step acc (Chunk xs) = return $ Cont (IterateeG . step $! acc + (LL.sum xs))
Nothing
step acc str = return $ Done acc str
product :: (LL.ListLike (s el) el, Num el, Monad m) =>
IterateeG s el m el
product = IterateeG (step 1)
where
step acc (Chunk xs)
| LL.null xs = return $ Cont (IterateeG (step acc)) Nothing
step acc (Chunk xs) = return $ Cont (IterateeG . step $! acc *
(LL.product xs))
Nothing
step acc str = return $ Done acc str
enumPair :: (LL.ListLike (s el) el, Monad m) =>
IterateeG s el m a ->
IterateeG s el m b ->
IterateeG s el m (a,b)
enumPair i1 i2 = IterateeG step
where
longest c1@(Chunk xs) c2@(Chunk ys) = if LL.length xs > LL.length ys
then c1 else c2
longest e@(EOF _) _ = e
longest _ e@(EOF _) = e
step (Chunk xs) | LL.null xs = return $ Cont (IterateeG step) Nothing
step str = do
ia <- runIter i1 str
ib <- runIter i2 str
case (ia, ib) of
(Done a astr, Done b bstr) -> return $ Done (a,b) $ longest astr bstr
(Done a _astr, Cont k mErr) -> return $ Cont (enumPair (return a) k) mErr
(Cont k mErr, Done b _bstr) -> return $ Cont (enumPair k (return b)) mErr
(Cont a aEr, Cont b bEr) -> return $ Cont (enumPair a b)
(aEr `mappend` bEr)
type EnumeratorGM s el m a = IterateeG s el m a -> m (IterateeG s el m a)
type EnumeratorGMM sfrom elfrom sto elto m a =
IterateeG sto elto m a -> m (IterateeG sfrom elfrom m a)
enumEof :: Monad m =>
EnumeratorGM s el m a
enumEof iter = runIter iter (EOF Nothing) >>= check
where
check (Done x _) = return $ IterateeG $ return . Done x
check (Cont _ e) = return $ throwErr (fromMaybe (Err "Divergent Iteratee") e)
enumErr :: (SC.StreamChunk s el, Monad m) =>
String ->
EnumeratorGM s el m a
enumErr e iter = runIter iter (EOF (Just (Err e))) >>= check
where
check (Done x _) = return $ IterateeG (return . Done x)
check (Cont _ e') = return $ throwErr
(fromMaybe (Err "Divergent Iteratee") e')
(>.):: (SC.StreamChunk s el, Monad m) =>
EnumeratorGM s el m a -> EnumeratorGM s el m a -> EnumeratorGM s el m a
(>.) e1 e2 = e2 <=< e1
enumPure1Chunk :: (SC.StreamChunk s el, Monad m) =>
s el ->
EnumeratorGM s el m a
enumPure1Chunk str iter = runIter iter (Chunk str) >>= checkIfDone return
enumPureNChunk :: (SC.StreamChunk s el, Monad m) =>
s el ->
Int ->
EnumeratorGM s el m a
enumPureNChunk str _ iter | SC.null str = return iter
enumPureNChunk str n iter | n > 0 = runIter iter (Chunk s1) >>=
checkIfDone (enumPureNChunk s2 n)
where
(s1, s2) = SC.splitAt n str
enumPureNChunk _ n _ = error $ "enumPureNChunk called with n==" ++ show n
joinIM :: (Monad m) => m (IterateeG s el m a) -> IterateeG s el m a
joinIM m = IterateeG (\str -> m >>= flip runIter str)