LinkedList.hs

{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{- |
Module      : $Header$
Description : Module providing simple implementation based on mutable linked
              list.
Copyright   : (c) Maciej Piechotka
License     : MIT

Maintainer  : uzytkownik2@gmail.com
Stability   : none
Portability : portable

Module providing simple implementation based on mutable linked list.
It is optimised for longer parsers.
-}
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.Iteratee.Base.StreamChunk (StreamChunk)
import Data.IORef
import qualified Data.ListLike as LL
import Data.STRef
import Text.Parsec

-- | Class notifing a reference in monad.
-- Probably should be in separate module.
class Monad m => Reference r m where
  -- | Create new reference
  newRef :: a -- ^ An initial value
         -> m (r a) -- ^ A new reference
  -- | Reads a reference
  readRef :: r a -- ^ Reference
          -> m a -- ^ Value hold by reference
  -- | Write to reference
  writeRef :: r a -- ^ Reference
           -> a -- ^ New value
           -> m ()
  -- | Modify the reference. Default implementation is provided but it MUST be
  -- overloaded if the reference is atomic to provide an atomic write
  modifyRef :: r a -- ^ Reference
            -> (a -> m (a, b)) -- ^ Computation
            -> m b -- ^ Result of computation
  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

-- | Specify the 3 possible states of next cursor - existence, non-existence
-- and not being evaluated
data (Monad m, Reference r m, StreamChunk c el) => NextCursor r m c el
  -- | Points to next cursor
  = NextCursor (Cursor r m c el)
  -- | States that next cursor does not exists
  | None
  -- | Next cursor is not evaluated
  | Uneval

-- | Cursor holds current value and reference to possible next cursor
data (Monad m, Reference r m, StreamChunk c el) => Cursor r m c el = 
  Cursor (r (NextCursor r m c el)) (c el)

-- | Creates new cursor
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 $! []

-- | Runs parser. If it suceed the remaining part of stream stands in stream,
-- however if it fails the stream is not in defined state.
parsecIteratee :: (Monad m, Reference r m, StreamChunk c el)
               => ParsecT (Cursor r m c el) u (IterateeG c el m) a
                  -- ^ Parser to run
               -> u -- ^ A user state
               -> SourceName -- ^ Source name
               -> 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

-- | Runs parser. If it suceed the remaining part of stream stands in stream,
-- however if it fails everything stands in stream.
safeParsecIteratee :: (Monad m, Reference r m, StreamChunk c el)
                   => ParsecT (Cursor r m c el) u (IterateeG c el m) a
                      -- ^ Parser to run
                   -> u -- ^ A user state
                   -> SourceName -- ^ Source name
                   -> 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 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