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.Exception
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 Data.Typeable
import Text.Parsec hiding (Stream)
import qualified Text.Parsec as P

-- | 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, ListLike s el) => NextCursor r m s el
    -- | Points to next cursor
    = NextCursor (Cursor r m s 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) => Cursor r m s el
    = Cursor (r (NextCursor r m s el)) s

-- | Creates new cursor
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 r (EOF (Just se@(SomeException e)))
    | typeOf e == seekType = throwErr $ unhandled
    | otherwise = throwRecoverableErr se (extendCursor r)
    where seekType = typeOf (undefined :: SeekException)
          unhandled
              = SomeException $! EnumUnhandledIterException (IterException 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

-- | 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, Nullable c, ListLike c el)
               => ParsecT (Cursor r m c el) u (Iteratee c m) a
                  -- ^ Parser to run
               -> u -- ^ A user state
               -> SourceName -- ^ Source name
               -> 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

-- | 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, Nullable c, ListLike c el)
                   => ParsecT (Cursor r m c el) u (Iteratee c m) a
                      -- ^ Parser to run
                   -> u -- ^ A user state
                   -> SourceName -- ^ Source name
                   -> 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