Attoparsec.hs

-- | This module provides support for parsing values from 'InputStream's using
-- @attoparsec@.

{-# LANGUAGE BangPatterns       #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts   #-}
{-# LANGUAGE OverloadedStrings  #-}

module System.IO.Streams.Internal.Attoparsec
  ( -- * Parsing
    parseFromStream
  , parseFromStreamInternal
  , parserToInputStream

    -- * Parse Exceptions
  , ParseException(..)

  , eitherResult
  ) where

------------------------------------------------------------------------------
import           Control.Exception                (Exception, throwIO)
import           Control.Monad                    (when)
import           Data.Attoparsec.ByteString.Char8 (Parser, Result, feed, parse)
import           Data.Attoparsec.Types            (IResult (..))
import           Data.ByteString.Char8            (ByteString)
import qualified Data.ByteString.Char8            as S
import           Data.List                        (intercalate)
import           Data.Typeable                    (Typeable)
import           Prelude                          hiding (read)
------------------------------------------------------------------------------
import           System.IO.Streams.Internal       (InputStream)
import qualified System.IO.Streams.Internal       as Streams


------------------------------------------------------------------------------
-- | An exception raised when parsing fails.
data ParseException = ParseException String
  deriving (Typeable)

instance Show ParseException where
    show (ParseException s) = "Parse exception: " ++ s

instance Exception ParseException


------------------------------------------------------------------------------
-- | Supplies an @attoparsec@ 'Parser' with an 'InputStream', returning the
-- final parsed value or throwing a 'ParseException' if parsing fails.
--
-- 'parseFromStream' consumes only as much input as necessary to satisfy the
-- 'Parser': any unconsumed input is pushed back onto the 'InputStream'.
--
-- If the 'Parser' exhausts the 'InputStream', the end-of-stream signal is sent
-- to attoparsec.
--
-- Example:
--
-- @
-- ghci> import "Data.Attoparsec.ByteString.Char8"
-- ghci> is <- 'System.IO.Streams.fromList' [\"12345xxx\" :: 'ByteString']
-- ghci> 'parseFromStream' ('Data.Attoparsec.ByteString.Char8.takeWhile' 'Data.Attoparsec.ByteString.Char8.isDigit') is
-- \"12345\"
-- ghci> 'System.IO.Streams.read' is
-- Just \"xxx\"
-- @
parseFromStream :: Parser r
                -> InputStream ByteString
                -> IO r
parseFromStream = parseFromStreamInternal parse feed
{-# INLINE parseFromStream #-}


------------------------------------------------------------------------------
-- | Internal version of parseFromStream allowing dependency injection of the
-- parse functions for testing.
parseFromStreamInternal :: (Parser r -> ByteString -> Result r)
                        -> (Result r -> ByteString -> Result r)
                        -> Parser r
                        -> InputStream ByteString
                        -> IO r
parseFromStreamInternal parseFunc feedFunc parser is =
    Streams.read is >>=
    maybe (finish $ parseFunc parser "")
          (\s -> if S.null s
                   then parseFromStreamInternal parseFunc feedFunc parser is
                   else go $! parseFunc parser s)
  where
    leftover x = when (not $ S.null x) $ Streams.unRead x is

    finish k = let k' = feedFunc (feedFunc k "") ""
               in case k' of
                    Fail x _ _ -> leftover x >> err k'
                    Partial _  -> err k'                -- should be impossible
                    Done x r   -> leftover x >> return r

    err r = let (Left (!_,c,m)) = eitherResult r
            in throwIO $ ParseException (ctxMsg c ++ m)

    ctxMsg [] = ""
    ctxMsg xs = "[parsing " ++ intercalate "/" xs ++ "] "

    go r@(Fail x _ _) = leftover x >> err r
    go (Done x r)     = leftover x >> return r
    go r              = Streams.read is >>=
                        maybe (finish r)
                              (\s -> if S.null s
                                       then go r
                                       else go $! feedFunc r s)


------------------------------------------------------------------------------
-- | Given a 'Parser' yielding values of type @'Maybe' r@, transforms an
-- 'InputStream' over byte strings to an 'InputStream' yielding values of type
-- @r@.
--
-- If the parser yields @Just x@, then @x@ will be passed along downstream, and
-- if the parser yields @Nothing@, that will be interpreted as end-of-stream.
--
-- Upon a parse error, 'parserToInputStream' will throw a 'ParseException'.
--
-- Example:
--
-- @
-- ghci> import "Control.Applicative"
-- ghci> import "Data.Attoparsec.ByteString.Char8"
-- ghci> is <- 'System.IO.Streams.fromList' [\"1 2 3 4 5\" :: 'ByteString']
-- ghci> let parser = ('Data.Attoparsec.ByteString.Char8.endOfInput' >> 'Control.Applicative.pure' 'Nothing') \<|\> (Just \<$\> ('Data.Attoparsec.ByteString.Char8.skipWhile' 'Data.Attoparsec.ByteString.Char8.isSpace' *> 'Data.Attoparsec.ByteString.Char8.decimal'))
-- ghci> 'parserToInputStream' parser is >>= 'System.IO.Streams.toList'
-- [1,2,3,4,5]
-- ghci> is' \<- 'System.IO.Streams.fromList' [\"1 2xx3 4 5\" :: 'ByteString'] >>= 'parserToInputStream' parser
-- ghci> 'read' is'
-- Just 1
-- ghci> 'read' is'
-- Just 2
-- ghci> 'read' is'
-- *** Exception: Parse exception: Failed reading: takeWhile1
-- @
parserToInputStream :: Parser (Maybe r)
                    -> InputStream ByteString
                    -> IO (InputStream r)
parserToInputStream = (Streams.makeInputStream .) . parseFromStream
{-# INLINE parserToInputStream #-}


------------------------------------------------------------------------------
-- A replacement for attoparsec's 'eitherResult', which discards information
-- about the context of the failed parse.
eitherResult :: Result r -> Either (ByteString, [String], String) r
eitherResult (Done _ r)              = Right r
eitherResult (Fail residual ctx msg) = Left (residual, ctx, msg)
eitherResult _                       = Left ("", [], "Result: incomplete input")