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.Class
import Data.Monoid
import Data.Iteratee
import Data.IORef
import Data.ListLike as LL
import Data.STRef
import Text.Parsec hiding (Stream)
import qualified Text.Parsec as P
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, ListLike s el) => NextCursor r m s el
= NextCursor (Cursor r m s el)
| None
| Uneval
data (Monad m, Reference r m) => Cursor r m s el
= Cursor (r (NextCursor r m s el)) s
mkCursor :: (Monad m, Reference r m, ListLike s el) => m (Cursor r m s el)
mkCursor = (\r -> return $! Cursor r LL.empty) =<< newRef Uneval
instance (Monad m, Nullable s, Reference r m, ListLike s el) =>
P.Stream (Cursor r m s el) (Iteratee s m) el where
uncons = unconsStream
unconsStream :: (Monad m, Nullable s, Reference r m, ListLike s el)
=> Cursor r m s el
-> Iteratee s m (Maybe (el, Cursor r m s el))
unconsStream p@(Cursor r c)
| LL.null c = unconsCursor r =<< lift (readRef r)
| otherwise = return $! unconsChunk p
unconsCursor :: (Monad m, Nullable s, Reference r m, ListLike s el)
=> r (NextCursor r m s el)
-> NextCursor r m s el
-> Iteratee s m (Maybe (el, Cursor r m s el))
unconsCursor _ (NextCursor c) = return $! unconsChunk c
unconsCursor _ None = return $! Nothing
unconsCursor r Uneval = icont (extendCursor r) Nothing
insertCursor :: (Monad m, Reference r m, ListLike s el)
=> r (NextCursor r m s el)
-> s
-> m (Cursor r m s el)
insertCursor r s = do
r' <- newRef Uneval
let c = Cursor r' s
writeRef r (NextCursor c)
return c
extendCursor :: (Monad m, Nullable s, Reference r m, ListLike s el)
=> r (NextCursor r m s el)
-> Stream s
-> Iteratee s m (Maybe (el, Cursor r m s el))
extendCursor r (Chunk s)
| LL.null s = liftI (extendCursor r)
| otherwise = return . unconsChunk =<< lift (insertCursor r s)
extendCursor r (EOF Nothing)
= const (return Nothing) =<< lift (writeRef r None)
extendCursor _ (EOF (Just e))
= throwErr e
unconsChunk :: (Monad m, Reference r m, ListLike s el)
=> Cursor r m s el -> Maybe (el, Cursor r m s el)
unconsChunk (Cursor r s) = Just (LL.head s, Cursor r $ LL.tail s)
concatCursor :: (Monad m, Reference r m, ListLike s el)
=> Cursor r m s el -> m s
concatCursor (Cursor r s) = liftM (s `mappend`) (concatCursor' =<< readRef r)
concatCursor' :: (Monad m, Reference r m, ListLike s el)
=> NextCursor r m s el -> m s
concatCursor' (NextCursor n) = concatCursor n
concatCursor' _ = return $! mempty
parsecIteratee :: (Monad m, Reference r m, Nullable c, ListLike c el)
=> ParsecT (Cursor r m c el) u (Iteratee c m) a
-> u
-> SourceName
-> Iteratee c 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'
idone (Right a) (Chunk sc)
Left err -> return $! Left err
safeParsecIteratee :: (Monad m, Reference r m, Nullable c, ListLike c el)
=> ParsecT (Cursor r m c el) u (Iteratee c m) a
-> u
-> SourceName
-> Iteratee c 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'
idone res (Chunk sc)
parsecSafe :: Monad m
=> ParsecT s u m a
-> ParsecT s u m (s, Either ParseError a)
parsecSafe p = mkPT $ \s -> do
r <- unConsume =<< runParsecT 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