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
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 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 (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