-- | 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: " 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 :: forall a. Parser ByteString a -> ByteString -> IResult ByteString a
parse = forall a. Parser ByteString a -> ByteString -> IResult ByteString a
S.parse
  feed :: forall r.
IResult ByteString r -> ByteString -> IResult ByteString r
feed = 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 :: forall a. Parser Text a -> Text -> IResult Text a
parse = forall a. Parser Text a -> Text -> IResult Text a
T.parse
  feed :: forall r. IResult Text r -> Text -> IResult Text r
feed = 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 :: 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 =
    forall a. InputStream a -> IO (Maybe a)
Streams.read InputStream i
is forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe (IResult i r -> IO r
finish forall a b. (a -> b) -> a -> b
$ Parser i r -> i -> IResult i r
parseFunc Parser i r
parser i
"")
          (\i
s -> if forall i. ParseData i => i -> Bool
null i
s
                   then 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 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 = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall i. ParseData i => i -> Bool
null i
x) forall a b. (a -> b) -> a -> b
$ 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 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall {i} {r} {a}. IsString i => IResult i r -> IO a
err IResult i r
k'
                    Partial i -> IResult i r
_  -> forall {i} {r} {a}. IsString i => IResult i r -> IO a
err IResult i r
k'                -- should be impossible
                    Done i
x r
r   -> i -> IO ()
leftover i
x forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return r
r

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

    ctxMsg :: [String] -> String
ctxMsg [] = String
""
    ctxMsg [String]
xs = String
"[parsing " forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
"/" [String]
xs 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 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall {i} {r} {a}. IsString i => IResult i r -> IO a
err IResult i r
r
    go (Done i
x r
r)     = i -> IO ()
leftover i
x forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return r
r
    go IResult i r
r              = forall a. InputStream a -> IO (Maybe a)
Streams.read InputStream i
is forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                        forall b a. b -> (a -> b) -> Maybe a -> b
maybe (IResult i r -> IO r
finish IResult i r
r)
                              (\i
s -> if 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 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 :: forall i r.
IsString i =>
IResult i r -> Either (i, [String], String) r
eitherResult (Done i
_ r
r)              = forall a b. b -> Either a b
Right r
r
eitherResult (Fail i
residual [String]
ctx String
msg) = forall a b. a -> Either a b
Left (i
residual, [String]
ctx, String
msg)
eitherResult IResult i r
_                       = forall a b. a -> Either a b
Left (i
"", [], String
"Result: incomplete input")