    -- | 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 :: forall a. Parser ByteString a -> ByteString -> IResult ByteString a
    parse = Parser a -> ByteString -> Result a
    forall a. Parser ByteString a -> ByteString -> IResult ByteString a
    S.parse
      feed :: forall r.
    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 :: forall a. Parser Text a -> Text -> IResult Text a
    parse = Parser a -> Text -> Result a
    forall a. Parser Text a -> Text -> IResult Text a
    T.parse
      feed :: forall r. 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 :: 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 =
        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 a b. IO a -> (a -> IO b) -> IO b
    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 a b. IO a -> IO b -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> IResult i r -> IO r
    forall {i} {r} {a}. IsString i => IResult i r -> IO a
    err IResult i r
    k'
                        Partial i -> IResult i r
    _  -> IResult i r -> IO 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 IO () -> IO r -> IO r
    forall a b. IO a -> IO b -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> r -> IO r
    forall a. a -> IO a
    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)) = IResult i r -> Either (i, [String], String) r
    forall i r.
    IsString i =>
    IResult i r -> Either (i, [String], String) r
    eitherResult IResult i r
    r
                in ParseException -> IO a
    forall e a. (HasCallStack, 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 a b. IO a -> IO b -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> IResult i r -> IO r
    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 IO () -> IO r -> IO r
    forall a b. IO a -> IO b -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> r -> IO r
    forall a. a -> IO a
    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 a b. IO a -> (a -> IO b) -> IO b
    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 :: forall i r.
    IsString i =>
    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")