{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
module System.IO.Streams.Internal.Attoparsec
(
parseFromStreamInternal
, ParseData(..)
, 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
data ParseException = ParseException String
deriving (Typeable)
instance Show ParseException where
show :: ParseException -> String
show (ParseException s :: String
s) = "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
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 parseFunc :: Parser i r -> i -> IResult i r
parseFunc feedFunc :: IResult i r -> i -> IResult i r
feedFunc parser :: Parser i r
parser is :: 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 "")
(\s :: 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 x :: 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 k :: 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 "") ""
in case IResult i r
k' of
Fail x :: i
x _ _ -> 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 _ -> IResult i r -> IO r
forall a b a. IsString a => IResult a b -> IO a
err IResult i r
k'
Done x :: i
x r :: 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 r :: IResult a b
r = let (Left (!a
_,c :: [String]
c,m :: 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 [] = ""
ctxMsg xs :: [String]
xs = "[parsing " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate "/" [String]
xs String -> ShowS
forall a. [a] -> [a] -> [a]
++ "] "
go :: IResult i r -> IO r
go r :: IResult i r
r@(Fail x :: i
x _ _) = 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 x :: i
x r :: 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 r :: 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)
(\s :: 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)
eitherResult :: IsString i => IResult i r -> Either (i, [String], String) r
eitherResult :: IResult i r -> Either (i, [String], String) r
eitherResult (Done _ r :: r
r) = r -> Either (i, [String], String) r
forall a b. b -> Either a b
Right r
r
eitherResult (Fail residual :: i
residual ctx :: [String]
ctx msg :: 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 _ = (i, [String], String) -> Either (i, [String], String) r
forall a b. a -> Either a b
Left ("", [], "Result: incomplete input")