{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
module Data.Conduit.Attoparsec
(
sinkParser
, sinkParserEither
, conduitParser
, conduitParserEither
, ParseError (..)
, Position (..)
, PositionRange (..)
, AttoparsecInput
) where
import Control.Exception (Exception)
import Control.Monad (unless)
import qualified Data.ByteString as B
import qualified Data.Text as T
import qualified Data.Text.Internal as TI
import Data.Typeable (Typeable)
import Prelude hiding (lines)
import qualified Data.Attoparsec.ByteString
import qualified Data.Attoparsec.Text
import qualified Data.Attoparsec.Types as A
import Data.Conduit
import Control.Monad.Trans.Resource (MonadThrow, throwM)
data ParseError = ParseError
{ ParseError -> [String]
errorContexts :: [String]
, ParseError -> String
errorMessage :: String
, ParseError -> Position
errorPosition :: Position
} | DivergentParser
deriving (Int -> ParseError -> ShowS
[ParseError] -> ShowS
ParseError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ParseError] -> ShowS
$cshowList :: [ParseError] -> ShowS
show :: ParseError -> String
$cshow :: ParseError -> String
showsPrec :: Int -> ParseError -> ShowS
$cshowsPrec :: Int -> ParseError -> ShowS
Show, Typeable)
instance Exception ParseError
data Position = Position
{ Position -> Int
posLine :: {-# UNPACK #-} !Int
, Position -> Int
posCol :: {-# UNPACK #-} !Int
, Position -> Int
posOffset :: {-# UNPACK #-} !Int
}
deriving (Position -> Position -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Position -> Position -> Bool
$c/= :: Position -> Position -> Bool
== :: Position -> Position -> Bool
$c== :: Position -> Position -> Bool
Eq, Eq Position
Position -> Position -> Bool
Position -> Position -> Ordering
Position -> Position -> Position
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Position -> Position -> Position
$cmin :: Position -> Position -> Position
max :: Position -> Position -> Position
$cmax :: Position -> Position -> Position
>= :: Position -> Position -> Bool
$c>= :: Position -> Position -> Bool
> :: Position -> Position -> Bool
$c> :: Position -> Position -> Bool
<= :: Position -> Position -> Bool
$c<= :: Position -> Position -> Bool
< :: Position -> Position -> Bool
$c< :: Position -> Position -> Bool
compare :: Position -> Position -> Ordering
$ccompare :: Position -> Position -> Ordering
Ord)
instance Show Position where
show :: Position -> String
show (Position Int
l Int
c Int
off) = forall a. Show a => a -> String
show Int
l forall a. [a] -> [a] -> [a]
++ Char
':' forall a. a -> [a] -> [a]
: forall a. Show a => a -> String
show Int
c forall a. [a] -> [a] -> [a]
++ String
" (" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
off forall a. [a] -> [a] -> [a]
++ String
")"
data PositionRange = PositionRange
{ PositionRange -> Position
posRangeStart :: {-# UNPACK #-} !Position
, PositionRange -> Position
posRangeEnd :: {-# UNPACK #-} !Position
}
deriving (PositionRange -> PositionRange -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PositionRange -> PositionRange -> Bool
$c/= :: PositionRange -> PositionRange -> Bool
== :: PositionRange -> PositionRange -> Bool
$c== :: PositionRange -> PositionRange -> Bool
Eq, Eq PositionRange
PositionRange -> PositionRange -> Bool
PositionRange -> PositionRange -> Ordering
PositionRange -> PositionRange -> PositionRange
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: PositionRange -> PositionRange -> PositionRange
$cmin :: PositionRange -> PositionRange -> PositionRange
max :: PositionRange -> PositionRange -> PositionRange
$cmax :: PositionRange -> PositionRange -> PositionRange
>= :: PositionRange -> PositionRange -> Bool
$c>= :: PositionRange -> PositionRange -> Bool
> :: PositionRange -> PositionRange -> Bool
$c> :: PositionRange -> PositionRange -> Bool
<= :: PositionRange -> PositionRange -> Bool
$c<= :: PositionRange -> PositionRange -> Bool
< :: PositionRange -> PositionRange -> Bool
$c< :: PositionRange -> PositionRange -> Bool
compare :: PositionRange -> PositionRange -> Ordering
$ccompare :: PositionRange -> PositionRange -> Ordering
Ord)
instance Show PositionRange where
show :: PositionRange -> String
show (PositionRange Position
s Position
e) = forall a. Show a => a -> String
show Position
s forall a. [a] -> [a] -> [a]
++ Char
'-' forall a. a -> [a] -> [a]
: forall a. Show a => a -> String
show Position
e
class AttoparsecInput a where
parseA :: A.Parser a b -> a -> A.IResult a b
feedA :: A.IResult a b -> a -> A.IResult a b
empty :: a
isNull :: a -> Bool
getLinesCols :: a -> Position
stripFromEnd :: a -> a -> a
instance AttoparsecInput B.ByteString where
parseA :: forall b. Parser ByteString b -> ByteString -> IResult ByteString b
parseA = forall b. Parser ByteString b -> ByteString -> IResult ByteString b
Data.Attoparsec.ByteString.parse
feedA :: forall b.
IResult ByteString b -> ByteString -> IResult ByteString b
feedA = forall i r. Monoid i => IResult i r -> i -> IResult i r
Data.Attoparsec.ByteString.feed
empty :: ByteString
empty = ByteString
B.empty
isNull :: ByteString -> Bool
isNull = ByteString -> Bool
B.null
getLinesCols :: ByteString -> Position
getLinesCols = forall a. (a -> Word8 -> a) -> a -> ByteString -> a
B.foldl' forall {a}. (Eq a, Num a) => Position -> a -> Position
f (Int -> Int -> Int -> Position
Position Int
0 Int
0 Int
0)
where
f :: Position -> a -> Position
f (Position Int
l Int
c Int
o) a
ch
| a
ch forall a. Eq a => a -> a -> Bool
== a
10 = Int -> Int -> Int -> Position
Position (Int
l forall a. Num a => a -> a -> a
+ Int
1) Int
0 (Int
o forall a. Num a => a -> a -> a
+ Int
1)
| Bool
otherwise = Int -> Int -> Int -> Position
Position Int
l (Int
c forall a. Num a => a -> a -> a
+ Int
1) (Int
o forall a. Num a => a -> a -> a
+ Int
1)
stripFromEnd :: ByteString -> ByteString -> ByteString
stripFromEnd ByteString
b1 ByteString
b2 = Int -> ByteString -> ByteString
B.take (ByteString -> Int
B.length ByteString
b1 forall a. Num a => a -> a -> a
- ByteString -> Int
B.length ByteString
b2) ByteString
b1
instance AttoparsecInput T.Text where
parseA :: forall b. Parser Text b -> Text -> IResult Text b
parseA = forall b. Parser Text b -> Text -> IResult Text b
Data.Attoparsec.Text.parse
feedA :: forall b. IResult Text b -> Text -> IResult Text b
feedA = forall i r. Monoid i => IResult i r -> i -> IResult i r
Data.Attoparsec.Text.feed
empty :: Text
empty = Text
T.empty
isNull :: Text -> Bool
isNull = Text -> Bool
T.null
getLinesCols :: Text -> Position
getLinesCols = forall a. (a -> Char -> a) -> a -> Text -> a
T.foldl' Position -> Char -> Position
f (Int -> Int -> Int -> Position
Position Int
0 Int
0 Int
0)
where
f :: Position -> Char -> Position
f (Position Int
l Int
c Int
o) Char
ch
| Char
ch forall a. Eq a => a -> a -> Bool
== Char
'\n' = Int -> Int -> Int -> Position
Position (Int
l forall a. Num a => a -> a -> a
+ Int
1) Int
0 (Int
o forall a. Num a => a -> a -> a
+ Int
1)
| Bool
otherwise = Int -> Int -> Int -> Position
Position Int
l (Int
c forall a. Num a => a -> a -> a
+ Int
1) (Int
o forall a. Num a => a -> a -> a
+ Int
1)
stripFromEnd :: Text -> Text -> Text
stripFromEnd (TI.Text Array
arr1 Int
off1 Int
len1) (TI.Text Array
_ Int
_ Int
len2) =
Array -> Int -> Int -> Text
TI.text Array
arr1 Int
off1 (Int
len1 forall a. Num a => a -> a -> a
- Int
len2)
sinkParser :: (AttoparsecInput a, MonadThrow m) => A.Parser a b -> ConduitT a o m b
sinkParser :: forall a (m :: * -> *) b o.
(AttoparsecInput a, MonadThrow m) =>
Parser a b -> ConduitT a o m b
sinkParser = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (m :: * -> *) b o.
(AttoparsecInput a, MonadThrow m) =>
Position -> Parser a b -> ConduitT a o m (Position, b)
sinkParserPosErr (Int -> Int -> Int -> Position
Position Int
1 Int
1 Int
0)
sinkParserEither :: (AttoparsecInput a, Monad m) => A.Parser a b -> ConduitT a o m (Either ParseError b)
sinkParserEither :: forall a (m :: * -> *) b o.
(AttoparsecInput a, Monad m) =>
Parser a b -> ConduitT a o m (Either ParseError b)
sinkParserEither = (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmapforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (m :: * -> *) b o.
(AttoparsecInput a, Monad m) =>
Position
-> Parser a b -> ConduitT a o m (Either ParseError (Position, b))
sinkParserPos (Int -> Int -> Int -> Position
Position Int
1 Int
1 Int
0)
conduitParser :: (AttoparsecInput a, MonadThrow m) => A.Parser a b -> ConduitT a (PositionRange, b) m ()
conduitParser :: forall a (m :: * -> *) b.
(AttoparsecInput a, MonadThrow m) =>
Parser a b -> ConduitT a (PositionRange, b) m ()
conduitParser Parser a b
parser =
forall {m :: * -> *}.
MonadThrow m =>
Position -> ConduitT a (PositionRange, b) m ()
conduit forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> Position
Position Int
1 Int
1 Int
0
where
conduit :: Position -> ConduitT a (PositionRange, b) m ()
conduit !Position
pos = forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
await forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) a -> ConduitT a (PositionRange, b) m ()
go
where
go :: a -> ConduitT a (PositionRange, b) m ()
go a
x = do
forall i o (m :: * -> *). i -> ConduitT i o m ()
leftover a
x
(!Position
pos', !b
res) <- forall a (m :: * -> *) b o.
(AttoparsecInput a, MonadThrow m) =>
Position -> Parser a b -> ConduitT a o m (Position, b)
sinkParserPosErr Position
pos Parser a b
parser
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (Position -> Position -> PositionRange
PositionRange Position
pos Position
pos', b
res)
Position -> ConduitT a (PositionRange, b) m ()
conduit Position
pos'
{-# SPECIALIZE conduitParser
:: MonadThrow m
=> A.Parser T.Text b
-> ConduitT T.Text (PositionRange, b) m () #-}
{-# SPECIALIZE conduitParser
:: MonadThrow m
=> A.Parser B.ByteString b
-> ConduitT B.ByteString (PositionRange, b) m () #-}
conduitParserEither
:: (Monad m, AttoparsecInput a)
=> A.Parser a b
-> ConduitT a (Either ParseError (PositionRange, b)) m ()
conduitParserEither :: forall (m :: * -> *) a b.
(Monad m, AttoparsecInput a) =>
Parser a b
-> ConduitT a (Either ParseError (PositionRange, b)) m ()
conduitParserEither Parser a b
parser =
forall {m :: * -> *}.
Monad m =>
Position -> ConduitT a (Either ParseError (PositionRange, b)) m ()
conduit forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> Position
Position Int
1 Int
1 Int
0
where
conduit :: Position -> ConduitT a (Either ParseError (PositionRange, b)) m ()
conduit !Position
pos = forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
await forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) a -> ConduitT a (Either ParseError (PositionRange, b)) m ()
go
where
go :: a -> ConduitT a (Either ParseError (PositionRange, b)) m ()
go a
x = do
forall i o (m :: * -> *). i -> ConduitT i o m ()
leftover a
x
Either ParseError (Position, b)
eres <- forall a (m :: * -> *) b o.
(AttoparsecInput a, Monad m) =>
Position
-> Parser a b -> ConduitT a o m (Either ParseError (Position, b))
sinkParserPos Position
pos Parser a b
parser
case Either ParseError (Position, b)
eres of
Left ParseError
e -> forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left ParseError
e
Right (!Position
pos', !b
res) -> do
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield forall a b. (a -> b) -> a -> b
$! forall a b. b -> Either a b
Right (Position -> Position -> PositionRange
PositionRange Position
pos Position
pos', b
res)
Position -> ConduitT a (Either ParseError (PositionRange, b)) m ()
conduit Position
pos'
{-# SPECIALIZE conduitParserEither
:: Monad m
=> A.Parser T.Text b
-> ConduitT T.Text (Either ParseError (PositionRange, b)) m () #-}
{-# SPECIALIZE conduitParserEither
:: Monad m
=> A.Parser B.ByteString b
-> ConduitT B.ByteString (Either ParseError (PositionRange, b)) m () #-}
sinkParserPosErr
:: (AttoparsecInput a, MonadThrow m)
=> Position
-> A.Parser a b
-> ConduitT a o m (Position, b)
sinkParserPosErr :: forall a (m :: * -> *) b o.
(AttoparsecInput a, MonadThrow m) =>
Position -> Parser a b -> ConduitT a o m (Position, b)
sinkParserPosErr Position
pos0 Parser a b
p = forall a (m :: * -> *) b o.
(AttoparsecInput a, Monad m) =>
Position
-> Parser a b -> ConduitT a o m (Either ParseError (Position, b))
sinkParserPos Position
pos0 Parser a b
p forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {m :: * -> *} {e} {a}.
(MonadThrow m, Exception e) =>
Either e a -> m a
f
where
f :: Either e a -> m a
f (Left e
e) = forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM e
e
f (Right a
a) = forall (m :: * -> *) a. Monad m => a -> m a
return a
a
{-# INLINE sinkParserPosErr #-}
sinkParserPos
:: (AttoparsecInput a, Monad m)
=> Position
-> A.Parser a b
-> ConduitT a o m (Either ParseError (Position, b))
sinkParserPos :: forall a (m :: * -> *) b o.
(AttoparsecInput a, Monad m) =>
Position
-> Parser a b -> ConduitT a o m (Either ParseError (Position, b))
sinkParserPos Position
pos0 Parser a b
p = forall {m :: * -> *} {i} {b} {o}.
(Monad m, AttoparsecInput i) =>
i
-> Position
-> (i -> IResult i b)
-> ConduitT i o m (Either ParseError (Position, b))
sink forall a. AttoparsecInput a => a
empty Position
pos0 (forall a b. AttoparsecInput a => Parser a b -> a -> IResult a b
parseA Parser a b
p)
where
sink :: i
-> Position
-> (i -> IResult i b)
-> ConduitT i o m (Either ParseError (Position, b))
sink i
prev Position
pos i -> IResult i b
parser = forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
await forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe ConduitT i o m (Either ParseError (Position, b))
close i -> ConduitT i o m (Either ParseError (Position, b))
push
where
push :: i -> ConduitT i o m (Either ParseError (Position, b))
push i
c
| forall a. AttoparsecInput a => a -> Bool
isNull i
c = i
-> Position
-> (i -> IResult i b)
-> ConduitT i o m (Either ParseError (Position, b))
sink i
prev Position
pos i -> IResult i b
parser
| Bool
otherwise = Bool
-> i
-> IResult i b
-> ConduitT i o m (Either ParseError (Position, b))
go Bool
False i
c forall a b. (a -> b) -> a -> b
$ i -> IResult i b
parser i
c
close :: ConduitT i o m (Either ParseError (Position, b))
close = Bool
-> i
-> IResult i b
-> ConduitT i o m (Either ParseError (Position, b))
go Bool
True i
prev (forall a b. AttoparsecInput a => IResult a b -> a -> IResult a b
feedA (i -> IResult i b
parser forall a. AttoparsecInput a => a
empty) forall a. AttoparsecInput a => a
empty)
go :: Bool
-> i
-> IResult i b
-> ConduitT i o m (Either ParseError (Position, b))
go Bool
end i
c (A.Done i
lo b
x) = do
let pos' :: Position
pos'
| Bool
end = Position
pos
| Bool
otherwise = forall a. AttoparsecInput a => a -> Position -> Position
addLinesCols i
prev Position
pos
y :: i
y = forall a. AttoparsecInput a => a -> a -> a
stripFromEnd i
c i
lo
pos'' :: Position
pos'' = forall a. AttoparsecInput a => a -> Position -> Position
addLinesCols i
y Position
pos'
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall a. AttoparsecInput a => a -> Bool
isNull i
lo) forall a b. (a -> b) -> a -> b
$ forall i o (m :: * -> *). i -> ConduitT i o m ()
leftover i
lo
Position
pos'' seq :: forall a b. a -> b -> b
`seq` forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a b. b -> Either a b
Right (Position
pos'', b
x)
go Bool
end i
c (A.Fail i
rest [String]
contexts String
msg) =
let x :: i
x = forall a. AttoparsecInput a => a -> a -> a
stripFromEnd i
c i
rest
pos' :: Position
pos'
| Bool
end = Position
pos
| Bool
otherwise = forall a. AttoparsecInput a => a -> Position -> Position
addLinesCols i
prev Position
pos
pos'' :: Position
pos'' = forall a. AttoparsecInput a => a -> Position -> Position
addLinesCols i
x Position
pos'
in Position
pos'' seq :: forall a b. a -> b -> b
`seq` forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a b. a -> Either a b
Left ([String] -> String -> Position -> ParseError
ParseError [String]
contexts String
msg Position
pos'')
go Bool
end i
c (A.Partial i -> IResult i b
parser')
| Bool
end = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a b. a -> Either a b
Left ParseError
DivergentParser
| Bool
otherwise =
Position
pos' seq :: forall a b. a -> b -> b
`seq` i
-> Position
-> (i -> IResult i b)
-> ConduitT i o m (Either ParseError (Position, b))
sink i
c Position
pos' i -> IResult i b
parser'
where
pos' :: Position
pos' = forall a. AttoparsecInput a => a -> Position -> Position
addLinesCols i
prev Position
pos
addLinesCols :: AttoparsecInput a => a -> Position -> Position
addLinesCols :: forall a. AttoparsecInput a => a -> Position -> Position
addLinesCols a
x (Position Int
lines Int
cols Int
off) =
Int
lines' seq :: forall a b. a -> b -> b
`seq` Int
cols' seq :: forall a b. a -> b -> b
`seq` Int
off' seq :: forall a b. a -> b -> b
`seq` Int -> Int -> Int -> Position
Position Int
lines' Int
cols' Int
off'
where
Position Int
dlines Int
dcols Int
doff = forall a. AttoparsecInput a => a -> Position
getLinesCols a
x
lines' :: Int
lines' = Int
lines forall a. Num a => a -> a -> a
+ Int
dlines
cols' :: Int
cols' = (if Int
dlines forall a. Ord a => a -> a -> Bool
> Int
0 then Int
1 else Int
cols) forall a. Num a => a -> a -> a
+ Int
dcols
off' :: Int
off' = Int
off forall a. Num a => a -> a -> a
+ Int
doff
{-# INLINE sinkParserPos #-}