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

  , ParseData(..)

    -- * Parse Exceptions
  , ParseException(..)

  , eitherResult
  ) where

------------------------------------------------------------------------------
import           Control.Exception                (Exception, throwIO)
import           Control.Monad                    (unless)
import qualified Data.Attoparsec.ByteString.Char8 as S
import qualified Data.Attoparsec.Text             as T
import           Data.Attoparsec.Types            (IResult (..), Parser)
import qualified Data.ByteString                  as S
import           Data.List                        (intercalate)
import           Data.String                      (IsString)
import qualified Data.Text                        as T
import           Data.Typeable                    (Typeable)
import           Prelude                          hiding (null, 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 -> String
show (ParseException String
s) = String
"Parse exception: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s

instance Exception ParseException


------------------------------------------------------------------------------
class (IsString i) => ParseData i where
  parse :: Parser i a -> i -> IResult i a
  feed :: IResult i r -> i -> IResult i r
  null :: i -> Bool


------------------------------------------------------------------------------
instance ParseData S.ByteString where
  parse :: Parser ByteString a -> ByteString -> IResult ByteString a
parse = Parser ByteString a -> ByteString -> IResult ByteString a
forall a. Parser ByteString a -> ByteString -> IResult ByteString a
S.parse
  feed :: IResult ByteString r -> ByteString -> IResult ByteString r
feed = IResult ByteString r -> ByteString -> IResult ByteString r
forall i r. Monoid i => IResult i r -> i -> IResult i r
S.feed
  null :: ByteString -> Bool
null = ByteString -> Bool
S.null


------------------------------------------------------------------------------
instance ParseData T.Text where
  parse :: Parser Text a -> Text -> IResult Text a
parse = Parser Text a -> Text -> IResult Text a
forall a. Parser Text a -> Text -> IResult Text a
T.parse
  feed :: IResult Text r -> Text -> IResult Text r
feed = IResult Text r -> Text -> IResult Text r
forall i r. Monoid i => IResult i r -> i -> IResult i r
T.feed
  null :: Text -> Bool
null = Text -> Bool
T.null


------------------------------------------------------------------------------
-- | Internal version of parseFromStream allowing dependency injection of the
-- parse functions for testing.
parseFromStreamInternal :: ParseData i
                        => (Parser i r -> i -> IResult i r)
                        -> (IResult i r -> i -> IResult i r)
                        -> Parser i r
                        -> InputStream i
                        -> IO r
parseFromStreamInternal :: (Parser i r -> i -> IResult i r)
-> (IResult i r -> i -> IResult i r)
-> Parser i r
-> InputStream i
-> IO r
parseFromStreamInternal Parser i r -> i -> IResult i r
parseFunc IResult i r -> i -> IResult i r
feedFunc Parser i r
parser InputStream i
is =
    InputStream i -> IO (Maybe i)
forall a. InputStream a -> IO (Maybe a)
Streams.read InputStream i
is IO (Maybe i) -> (Maybe i -> IO r) -> IO r
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
    IO r -> (i -> IO r) -> Maybe i -> IO r
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (IResult i r -> IO r
finish (IResult i r -> IO r) -> IResult i r -> IO r
forall a b. (a -> b) -> a -> b
$ Parser i r -> i -> IResult i r
parseFunc Parser i r
parser i
"")
          (\i
s -> if i -> Bool
forall i. ParseData i => i -> Bool
null i
s
                   then (Parser i r -> i -> IResult i r)
-> (IResult i r -> i -> IResult i r)
-> Parser i r
-> InputStream i
-> IO r
forall i r.
ParseData i =>
(Parser i r -> i -> IResult i r)
-> (IResult i r -> i -> IResult i r)
-> Parser i r
-> InputStream i
-> IO r
parseFromStreamInternal Parser i r -> i -> IResult i r
parseFunc IResult i r -> i -> IResult i r
feedFunc Parser i r
parser InputStream i
is
                   else IResult i r -> IO r
go (IResult i r -> IO r) -> IResult i r -> IO r
forall a b. (a -> b) -> a -> b
$! Parser i r -> i -> IResult i r
parseFunc Parser i r
parser i
s)
  where
    leftover :: i -> IO ()
leftover i
x = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (i -> Bool
forall i. ParseData i => i -> Bool
null i
x) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ i -> InputStream i -> IO ()
forall a. a -> InputStream a -> IO ()
Streams.unRead i
x InputStream i
is

    finish :: IResult i r -> IO r
finish IResult i r
k = let k' :: IResult i r
k' = IResult i r -> i -> IResult i r
feedFunc (IResult i r -> i -> IResult i r
feedFunc IResult i r
k i
"") i
""
               in case IResult i r
k' of
                    Fail i
x [String]
_ String
_ -> i -> IO ()
leftover i
x IO () -> IO r -> IO r
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IResult i r -> IO r
forall a b a. IsString a => IResult a b -> IO a
err IResult i r
k'
                    Partial i -> IResult i r
_  -> IResult i r -> IO r
forall a b a. IsString a => IResult a b -> IO a
err IResult i r
k'                -- should be impossible
                    Done i
x r
r   -> i -> IO ()
leftover i
x IO () -> IO r -> IO r
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> r -> IO r
forall (m :: * -> *) a. Monad m => a -> m a
return r
r

    err :: IResult a b -> IO a
err IResult a b
r = let (Left (!a
_,[String]
c,String
m)) = IResult a b -> Either (a, [String], String) b
forall i r.
IsString i =>
IResult i r -> Either (i, [String], String) r
eitherResult IResult a b
r
            in ParseException -> IO a
forall e a. Exception e => e -> IO a
throwIO (ParseException -> IO a) -> ParseException -> IO a
forall a b. (a -> b) -> a -> b
$ String -> ParseException
ParseException ([String] -> String
ctxMsg [String]
c String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
m)

    ctxMsg :: [String] -> String
ctxMsg [] = String
""
    ctxMsg [String]
xs = String
"[parsing " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"/" [String]
xs String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"] "

    go :: IResult i r -> IO r
go r :: IResult i r
r@(Fail i
x [String]
_ String
_) = i -> IO ()
leftover i
x IO () -> IO r -> IO r
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IResult i r -> IO r
forall a b a. IsString a => IResult a b -> IO a
err IResult i r
r
    go (Done i
x r
r)     = i -> IO ()
leftover i
x IO () -> IO r -> IO r
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> r -> IO r
forall (m :: * -> *) a. Monad m => a -> m a
return r
r
    go IResult i r
r              = InputStream i -> IO (Maybe i)
forall a. InputStream a -> IO (Maybe a)
Streams.read InputStream i
is IO (Maybe i) -> (Maybe i -> IO r) -> IO r
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                        IO r -> (i -> IO r) -> Maybe i -> IO r
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (IResult i r -> IO r
finish IResult i r
r)
                              (\i
s -> if i -> Bool
forall i. ParseData i => i -> Bool
null i
s
                                       then IResult i r -> IO r
go IResult i r
r
                                       else IResult i r -> IO r
go (IResult i r -> IO r) -> IResult i r -> IO r
forall a b. (a -> b) -> a -> b
$! IResult i r -> i -> IResult i r
feedFunc IResult i r
r i
s)


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