module Text.Parsec.Iteratee.LinkedList
(
Reference(..),
Cursor,
NextCursor,
mkCursor,
parsecIteratee,
safeParsecIteratee,
)
where
import Control.Concurrent.MVar
import Control.Monad
import Control.Monad.ST
import Control.Monad.Trans
import Data.Maybe
import Data.Monoid
import Data.Iteratee
import Data.Iteratee.Base.StreamChunk (StreamChunk)
import Data.IORef
import qualified Data.ListLike as LL
import Data.STRef
import Text.Parsec
import Text.Parsec.Pos
class Monad m => Reference r m where
newRef :: a
-> m (r a)
readRef :: r a
-> m a
writeRef :: r a
-> a
-> m ()
modifyRef :: r a
-> (a -> m (a, b))
-> m b
modifyRef r f = readRef r >>= f >>= \(a, b) -> writeRef r a >> return b
instance Reference IORef IO where
newRef = newIORef
readRef = readIORef
writeRef = writeIORef
instance Reference (STRef s) (ST s) where
newRef = newSTRef
readRef = readSTRef
writeRef = writeSTRef
instance Reference MVar IO where
newRef = newMVar
readRef = readMVar
writeRef = putMVar
data (Monad m, Reference r m, StreamChunk c el) => NextCursor r m c el
= NextCursor (Cursor r m c el)
| None
| Uneval
data (Monad m, Reference r m, StreamChunk c el) => Cursor r m c el =
Cursor (r (NextCursor r m c el)) (c el)
mkCursor :: (Monad m, Reference r m, StreamChunk c el) => m (Cursor r m c el)
mkCursor = newRef Uneval >>= \r -> (return $! Cursor r LL.empty)
instance (Monad m, Reference r m, StreamChunk c el) =>
Stream (Cursor r m c el) (IterateeG c el m) el where
uncons = unconsStream
unconsStream :: (Monad m, Reference r m, StreamChunk c el)
=> Cursor r m c el
-> IterateeG c el m (Maybe (el, Cursor r m c el))
unconsStream p@(Cursor r c)
| LL.null c = IterateeG $ \st -> join $ modifyRef r $ unconsCursor st p
| otherwise = return $! justUnconsCursor p
unconsCursor :: forall r m c el. (Monad m, Reference r m, StreamChunk c el)
=> StreamG c el
-> Cursor r m c el
-> NextCursor r m c el
-> m (NextCursor r m c el,
m (IterGV c el m (Maybe (el, Cursor r m c el))))
unconsCursor st _ rv@(NextCursor p@(Cursor r c))
| LL.null c = return $! (rv, join $ modifyRef r $ unconsCursor st p)
| otherwise = return $! (rv, return $! Done (justUnconsCursor p) st)
unconsCursor st _ rv@None
= return $! (rv, return $! Done Nothing st)
unconsCursor (Chunk c) p rv@Uneval
| LL.null c = return $! (rv, return $! Cont (unconsStream p) Nothing)
| otherwise = do r <- newRef Uneval :: m (r (NextCursor r m c el))
let p' = Cursor r c
ra = Done (justUnconsCursor p') (Chunk LL.empty)
return $! (NextCursor p', return $! ra)
unconsCursor st@(EOF Nothing) _ Uneval
= return $! (None, return $! Done Nothing st)
unconsCursor (EOF (Just e)) _ rv@Uneval
= return $! (rv, return $! Cont (throwErr e) (Just e))
justUnconsCursor :: (Monad m, Reference r m, StreamChunk c el) =>
Cursor r m c el -> Maybe (el, Cursor r m c el)
justUnconsCursor (Cursor r c) = Just $! (LL.head c, Cursor r $ LL.tail c)
concatCursor :: (Monad m, Reference r m, StreamChunk c el)
=> Cursor r m c el -> m (c el)
concatCursor c = liftM mconcat (concatCursor' c)
concatCursor' :: (Monad m, Reference r m, StreamChunk c el)
=> Cursor r m c el -> m [c el]
concatCursor' (Cursor r v) =
liftM2 (:) (return v) (readRef r >>= concatNextCursor')
concatNextCursor' :: (Monad m, Reference r m, StreamChunk c el)
=> NextCursor r m c el -> m [c el]
concatNextCursor' (NextCursor c) = concatCursor' $! c
concatNextCursor' _ = return $! []
parsecIteratee :: (Monad m, Reference r m, StreamChunk c el)
=> ParsecT (Cursor r m c el) u (IterateeG c el m) a
-> u
-> SourceName
-> IterateeG c el m (Either ParseError a)
parsecIteratee p u sn = do
c <- lift mkCursor
res <- runParserT (liftM2 (,) p getInput) u sn c
case res of
Right (a, c') -> do sc <- lift $ concatCursor c'
liftI $! Done (Right a) $! Chunk $! sc
Left err -> return $ Left err
safeParsecIteratee :: (Monad m, Reference r m, StreamChunk c el)
=> ParsecT (Cursor r m c el) u (IterateeG c el m) a
-> u
-> SourceName
-> IterateeG c el m (Either ParseError a)
safeParsecIteratee p u sn = do
c <- lift mkCursor
Right (c', res) <- runParserT (parsecSafe p) u sn c
sc <- lift $ concatCursor c'
liftI $! Done res $! Chunk $! sc
parsecSafe :: Monad m
=> ParsecT s u m a
-> ParsecT s u m (s, Either ParseError a)
parsecSafe (ParsecT p) = ParsecT $ \s -> do
r <- join (unConsume `liftM` p s)
case r of
Error pe -> let rp = Ok (stateInput s, Left pe) s (unknownError s)
in return $! Empty $ return $! rp
Ok v s' _ -> let rp = Ok (stateInput s', Right v) s' (unknownError s')
in return $! Consumed $! return $! rp
where unConsume (Consumed x) = x
unConsume (Empty x) = x