-- | A fast parser combinators module.
--
-- This module is extremely bare-bones, and provides only very limited
-- functionality.
--
-- Sample usage:
--
-- > module Syslog where
-- >
-- > import ByteString.Parser.Fast
-- > import qualified Data.ByteString as BS
-- > import Data.Thyme.Clock
-- > import Control.Applicative
-- >
-- > data SyslogMsg
-- >     = SyslogMsg
-- >     { _syslogPrio    :: {-# UNPACK #-} !Int
-- >     , _syslogTS      :: {-# UNPACK #-} !UTCTime
-- >     , _syslogHost    :: !BS.ByteString
-- >     , _syslogProgram :: !BS.ByteString
-- >     , _syslogPID     :: !(Maybe Int)
-- >     , _syslogData    :: !BS.ByteString
-- >     } deriving (Show, Eq)
-- >
-- >
-- > syslogMsg :: Parser SyslogMsg
-- > syslogMsg = do
-- >     char '<'
-- >     prio <- decimal
-- >     char '>'
-- >     ts <- rfc3339
-- >     char ' '
-- >     host <- charTakeWhile1 (/= ' ')
-- >     char ' '
-- >     program <- charTakeWhile1 (\x -> x /= ':' && x /= '[')
-- >     pid' <- optional (char '[' *> decimal <* char ']')
-- >     char ':'
-- >     dt <- remaining
-- >     return (SyslogMsg prio ts host program pid' dt)
-- >
-- > test :: BS.ByteString -> Either ParseError SyslogMsg
-- > test = parseOnly syslogMsg
--
{-# LANGUAGE BangPatterns               #-}
{-# LANGUAGE DeriveFunctor              #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE RankNTypes                 #-}
module ByteString.Parser.Fast
  (
  Parser, ParserM(..), parseOnly,
  -- * Error handling
  ParseError(..), ErrorItem(..), ueof, ufail, parseError,
  -- * Parsing numerical values
  decimal, num, hnum, onum, frac, scientific,
  -- * Parsing characters
  satisfy, anyChar, char, anyWord8, word8, string, quotedString,
  -- * Various combinators
  takeN, dropN, remaining, charTakeWhile, charTakeWhile1, ByteString.Parser.Fast.takeWhile, takeWhile1, skipWhile,
  -- * Parsing time-related values
  parseYMD, parseDTime, timestamp, rfc3339,
  -- * Interfacing with other libraries
  wlex, pFold,
  -- * Hacks and bits
  isLower, getOctal, getInt
  ) where

import           Control.Applicative
import           Control.Monad
import           Control.Monad.Codensity        (Codensity, lowerCodensity)
import           Control.Monad.Trans.Class      (lift)
import           Data.AffineSpace               ((.+^), (.-^))
import qualified Data.ByteString                as BS
import qualified Data.ByteString.Char8          as BS8
import qualified Data.ByteString.Lex.Fractional as L
import           Data.Semigroup
import           Data.Set                       (Set)
import qualified Data.Set                       as S
import           Data.Thyme
import           Data.Word
import           Lens.Micro
import           Prelude

-- | A parser, church encoded. The arguments to the wrapped function are:
--
--  * Input "ByteString".
--  * A function that handles parse errors.
--  * A function that handles success, taking as argument the remaining
--  input and the parser result.
newtype ParserM a
  = Parser {
           forall a.
ParserM a
-> forall r.
   ByteString -> (ParseError -> r) -> (ByteString -> a -> r) -> r
runParser :: forall r. BS.ByteString
                     -> (ParseError -> r)
                     -> (BS.ByteString -> a -> r)
                     -> r
  } deriving forall a b. a -> ParserM b -> ParserM a
forall a b. (a -> b) -> ParserM a -> ParserM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> ParserM b -> ParserM a
$c<$ :: forall a b. a -> ParserM b -> ParserM a
fmap :: forall a b. (a -> b) -> ParserM a -> ParserM b
$cfmap :: forall a b. (a -> b) -> ParserM a -> ParserM b
Functor

type Parser = Codensity ParserM

instance Applicative ParserM where
    pure :: forall a. a -> ParserM a
pure a
a = forall a.
(forall r.
 ByteString -> (ParseError -> r) -> (ByteString -> a -> r) -> r)
-> ParserM a
Parser forall a b. (a -> b) -> a -> b
$ \ByteString
b ParseError -> r
_ ByteString -> a -> r
s -> ByteString -> a -> r
s ByteString
b a
a
    {-# INLINE pure #-}
    Parser forall r.
ByteString
-> (ParseError -> r) -> (ByteString -> (a -> b) -> r) -> r
pf <*> :: forall a b. ParserM (a -> b) -> ParserM a -> ParserM b
<*> Parser forall r.
ByteString -> (ParseError -> r) -> (ByteString -> a -> r) -> r
px = forall a.
(forall r.
 ByteString -> (ParseError -> r) -> (ByteString -> a -> r) -> r)
-> ParserM a
Parser forall a b. (a -> b) -> a -> b
$ \ByteString
input ParseError -> r
failure ByteString -> b -> r
success ->
        let succ' :: ByteString -> (a -> b) -> r
succ' ByteString
input' a -> b
f = forall r.
ByteString -> (ParseError -> r) -> (ByteString -> a -> r) -> r
px ByteString
input' ParseError -> r
failure (\ByteString
i a
a -> ByteString -> b -> r
success ByteString
i (a -> b
f a
a))
        in  forall r.
ByteString
-> (ParseError -> r) -> (ByteString -> (a -> b) -> r) -> r
pf ByteString
input ParseError -> r
failure ByteString -> (a -> b) -> r
succ'
    {-# INLINE (<*>) #-}

instance Alternative ParserM where
    empty :: forall a. ParserM a
empty = forall a.
(forall r.
 ByteString -> (ParseError -> r) -> (ByteString -> a -> r) -> r)
-> ParserM a
Parser (\ByteString
_ ParseError -> r
failure ByteString -> a -> r
_ -> ParseError -> r
failure forall a. Monoid a => a
mempty)
    {-# INLINE empty #-}
    Parser forall r.
ByteString -> (ParseError -> r) -> (ByteString -> a -> r) -> r
a <|> :: forall a. ParserM a -> ParserM a -> ParserM a
<|> Parser forall r.
ByteString -> (ParseError -> r) -> (ByteString -> a -> r) -> r
b = forall a.
(forall r.
 ByteString -> (ParseError -> r) -> (ByteString -> a -> r) -> r)
-> ParserM a
Parser forall a b. (a -> b) -> a -> b
$ \ByteString
input ParseError -> r
failure ByteString -> a -> r
success -> forall r.
ByteString -> (ParseError -> r) -> (ByteString -> a -> r) -> r
a ByteString
input (\ParseError
rr ->  forall r.
ByteString -> (ParseError -> r) -> (ByteString -> a -> r) -> r
b ByteString
input (ParseError -> r
failure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Monoid a => a -> a -> a
mappend ParseError
rr) ByteString -> a -> r
success) ByteString -> a -> r
success
    {-# INLINE (<|>) #-}

instance Monad ParserM where
    ParserM a
m >>= :: forall a b. ParserM a -> (a -> ParserM b) -> ParserM b
>>= a -> ParserM b
k = forall a.
(forall r.
 ByteString -> (ParseError -> r) -> (ByteString -> a -> r) -> r)
-> ParserM a
Parser forall a b. (a -> b) -> a -> b
$ \ByteString
input ParseError -> r
failure ByteString -> b -> r
success ->
        let succ' :: ByteString -> a -> r
succ' ByteString
input' a
a = forall a.
ParserM a
-> forall r.
   ByteString -> (ParseError -> r) -> (ByteString -> a -> r) -> r
runParser (a -> ParserM b
k a
a) ByteString
input' ParseError -> r
failure ByteString -> b -> r
success
        in  forall a.
ParserM a
-> forall r.
   ByteString -> (ParseError -> r) -> (ByteString -> a -> r) -> r
runParser ParserM a
m ByteString
input ParseError -> r
failure ByteString -> a -> r
succ'
    {-# INLINE (>>=) #-}

instance MonadFail ParserM where
    fail :: forall a. String -> ParserM a
fail String
s = forall a.
(forall r.
 ByteString -> (ParseError -> r) -> (ByteString -> a -> r) -> r)
-> ParserM a
Parser forall a b. (a -> b) -> a -> b
$ \ByteString
_ ParseError -> r
failure ByteString -> a -> r
_ -> ParseError -> r
failure (String -> ParseError
ufail String
s)

instance MonadPlus ParserM

data ErrorItem
    = Tokens BS.ByteString
    | Label String
    deriving (Int -> ErrorItem -> ShowS
[ErrorItem] -> ShowS
ErrorItem -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ErrorItem] -> ShowS
$cshowList :: [ErrorItem] -> ShowS
show :: ErrorItem -> String
$cshow :: ErrorItem -> String
showsPrec :: Int -> ErrorItem -> ShowS
$cshowsPrec :: Int -> ErrorItem -> ShowS
Show, ErrorItem -> ErrorItem -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ErrorItem -> ErrorItem -> Bool
$c/= :: ErrorItem -> ErrorItem -> Bool
== :: ErrorItem -> ErrorItem -> Bool
$c== :: ErrorItem -> ErrorItem -> Bool
Eq, Eq ErrorItem
ErrorItem -> ErrorItem -> Bool
ErrorItem -> ErrorItem -> Ordering
ErrorItem -> ErrorItem -> ErrorItem
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 :: ErrorItem -> ErrorItem -> ErrorItem
$cmin :: ErrorItem -> ErrorItem -> ErrorItem
max :: ErrorItem -> ErrorItem -> ErrorItem
$cmax :: ErrorItem -> ErrorItem -> ErrorItem
>= :: ErrorItem -> ErrorItem -> Bool
$c>= :: ErrorItem -> ErrorItem -> Bool
> :: ErrorItem -> ErrorItem -> Bool
$c> :: ErrorItem -> ErrorItem -> Bool
<= :: ErrorItem -> ErrorItem -> Bool
$c<= :: ErrorItem -> ErrorItem -> Bool
< :: ErrorItem -> ErrorItem -> Bool
$c< :: ErrorItem -> ErrorItem -> Bool
compare :: ErrorItem -> ErrorItem -> Ordering
$ccompare :: ErrorItem -> ErrorItem -> Ordering
Ord)

data ParseError
  = ParseError
  { ParseError -> Set ErrorItem
errorUnexpected :: !(Set ErrorItem)
  , ParseError -> Set ErrorItem
errorExpected   :: !(Set ErrorItem)
  } 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, ParseError -> ParseError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ParseError -> ParseError -> Bool
$c/= :: ParseError -> ParseError -> Bool
== :: ParseError -> ParseError -> Bool
$c== :: ParseError -> ParseError -> Bool
Eq)

instance Semigroup ParseError where
  <> :: ParseError -> ParseError -> ParseError
(<>) (ParseError Set ErrorItem
u1 Set ErrorItem
e1) (ParseError Set ErrorItem
u2 Set ErrorItem
e2) = Set ErrorItem -> Set ErrorItem -> ParseError
ParseError (forall a. Monoid a => a -> a -> a
mappend Set ErrorItem
u1 Set ErrorItem
u2) (forall a. Monoid a => a -> a -> a
mappend Set ErrorItem
e1 Set ErrorItem
e2)

instance Monoid ParseError where
  mempty :: ParseError
mempty = Set ErrorItem -> Set ErrorItem -> ParseError
ParseError forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty
  mappend :: ParseError -> ParseError -> ParseError
mappend = forall a. Semigroup a => a -> a -> a
(<>)

-- | An error representing the unexpected end of input.
ueof :: ParseError
ueof :: ParseError
ueof = Set ErrorItem -> Set ErrorItem -> ParseError
ParseError (forall a. a -> Set a
S.singleton (String -> ErrorItem
Label String
"end of input")) forall a. Monoid a => a
mempty

-- | A generic error.
ufail :: String -- ^ The expected label.
      -> ParseError
ufail :: String -> ParseError
ufail String
s = Set ErrorItem -> Set ErrorItem -> ParseError
ParseError (forall a. a -> Set a
S.singleton (String -> ErrorItem
Label String
s)) forall a. Monoid a => a
mempty

-- | Creates a generic parse error.
parseError :: BS8.ByteString -- ^ Unexpected content
           -> BS8.ByteString -- ^ Expected content
           -> ParseError
parseError :: ByteString -> ByteString -> ParseError
parseError ByteString
un ByteString
ex = Set ErrorItem -> Set ErrorItem -> ParseError
ParseError (forall a. a -> Set a
S.singleton (ByteString -> ErrorItem
Tokens ByteString
un)) (forall a. a -> Set a
S.singleton (ByteString -> ErrorItem
Tokens ByteString
ex))

-- | Creates a parser from the supplied function.
-- The first argument to the supplied function is the remaining input, and
-- it should return `Nothing` when parsing failes, or `Just` the result
-- along with the non-consumed input.
--
-- It works well with the
-- [bytestring-lexing](https://hackage.haskell.org/package/bytestring-lexing) library.
wlex :: (BS.ByteString -> Maybe (a, BS.ByteString)) -> Parser a
wlex :: forall a. (ByteString -> Maybe (a, ByteString)) -> Parser a
wlex ByteString -> Maybe (a, ByteString)
p = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a.
(forall r.
 ByteString -> (ParseError -> r) -> (ByteString -> a -> r) -> r)
-> ParserM a
Parser forall a b. (a -> b) -> a -> b
$ \ByteString
i ParseError -> r
failure ByteString -> a -> r
success -> case ByteString -> Maybe (a, ByteString)
p ByteString
i of
                                            Maybe (a, ByteString)
Nothing      -> ParseError -> r
failure forall a. Monoid a => a
mempty
                                            Just (a
a, ByteString
i') -> ByteString -> a -> r
success ByteString
i' a
a
{-# INLINABLE wlex #-}

-- | Parses bytestrings as if they were representing a decimal number in ASCII.
getInt :: BS.ByteString -> Int
getInt :: ByteString -> Int
getInt = forall a. (a -> Word8 -> a) -> a -> ByteString -> a
BS.foldl' (\Int
acc Word8
n -> Int
acc forall a. Num a => a -> a -> a
* Int
10 forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
n forall a. Num a => a -> a -> a
- Word8
0x30)) Int
0
{-# INLINE getInt #-}

-- | Parses bytestrings as if they were representing an octal number in
-- ASCII.
getOctal :: BS.ByteString -> Int
getOctal :: ByteString -> Int
getOctal = forall a. (a -> Word8 -> a) -> a -> ByteString -> a
BS.foldl' (\Int
acc Word8
n -> Int
acc forall a. Num a => a -> a -> a
* Int
8 forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
n forall a. Num a => a -> a -> a
- Word8
0x30)) Int
0
{-# INLINE getOctal #-}

isDigit :: Word8 -> Bool
isDigit :: Word8 -> Bool
isDigit !Word8
x = Word8
x forall a. Ord a => a -> a -> Bool
>= Word8
0x30 Bool -> Bool -> Bool
&& Word8
x forall a. Ord a => a -> a -> Bool
<= Word8
0x39
{-# INLINE isDigit #-}

isHexa :: Word8 -> Bool
isHexa :: Word8 -> Bool
isHexa !Word8
x =  (Word8
x forall a. Ord a => a -> a -> Bool
>= Word8
0x30 Bool -> Bool -> Bool
&& Word8
x forall a. Ord a => a -> a -> Bool
<= Word8
0x39)
          Bool -> Bool -> Bool
|| (Word8
x forall a. Ord a => a -> a -> Bool
>= Word8
0x41 Bool -> Bool -> Bool
&& Word8
x forall a. Ord a => a -> a -> Bool
<= Word8
0x46)
          Bool -> Bool -> Bool
|| (Word8
x forall a. Ord a => a -> a -> Bool
>= Word8
0x61 Bool -> Bool -> Bool
&& Word8
x forall a. Ord a => a -> a -> Bool
<= Word8
0x66)
{-# INLINE isHexa #-}

hexToNum :: Num n => Word8 -> n
hexToNum :: forall n. Num n => Word8 -> n
hexToNum Word8
x | Word8
x forall a. Ord a => a -> a -> Bool
>= Word8
0x30 Bool -> Bool -> Bool
&& Word8
x forall a. Ord a => a -> a -> Bool
<= Word8
0x39 = forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
x forall a. Num a => a -> a -> a
- n
0x30
           | Word8
x forall a. Ord a => a -> a -> Bool
>= Word8
0x41 Bool -> Bool -> Bool
&& Word8
x forall a. Ord a => a -> a -> Bool
<= Word8
0x46 = forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
x forall a. Num a => a -> a -> a
- n
0x37
           | Word8
x forall a. Ord a => a -> a -> Bool
>= Word8
0x61 Bool -> Bool -> Bool
&& Word8
x forall a. Ord a => a -> a -> Bool
<= Word8
0x66 = forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
x forall a. Num a => a -> a -> a
- n
0x57
           | Bool
otherwise              = n
0
{-# INLINABLE hexToNum #-}

isUpper :: Word8 -> Bool
isUpper :: Word8 -> Bool
isUpper !Word8
x = Word8
x forall a. Ord a => a -> a -> Bool
>= Word8
0x41 Bool -> Bool -> Bool
&& Word8
x forall a. Ord a => a -> a -> Bool
<= Word8
0x5a
{-# INLINE isUpper #-}

-- | Returns true when the character represents an ASCII lowercase letter.
isLower :: Word8 -> Bool
isLower :: Word8 -> Bool
isLower !Word8
x = Word8
x forall a. Ord a => a -> a -> Bool
>= Word8
0x61 Bool -> Bool -> Bool
&& Word8
x forall a. Ord a => a -> a -> Bool
<= Word8
0x7a
{-# INLINE isLower #-}

-- | parses a decimal integer.
decimal :: Parser Int
decimal :: Parser Int
decimal = ByteString -> Int
getInt forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Word8 -> Bool) -> Parser ByteString
takeWhile1 Word8 -> Bool
isDigit
{-# INLINE decimal #-}

-- | Parses any positive decimal 'Num'.
num :: Num n => Parser n
num :: forall n. Num n => Parser n
num = forall a. (a -> Word8 -> a) -> a -> ByteString -> a
BS.foldl' (\n
acc Word8
n -> n
acc forall a. Num a => a -> a -> a
* n
10 forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
n forall a. Num a => a -> a -> a
- Word8
0x30)) n
0 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Word8 -> Bool) -> Parser ByteString
takeWhile1 Word8 -> Bool
isDigit
{-# INLINABLE num #-}

-- | Parses any positive hexadecimal 'Num'.
hnum :: Num n => Parser n
hnum :: forall n. Num n => Parser n
hnum = forall a. (a -> Word8 -> a) -> a -> ByteString -> a
BS.foldl' (\n
acc Word8
n -> n
acc forall a. Num a => a -> a -> a
* n
16 forall a. Num a => a -> a -> a
+ forall n. Num n => Word8 -> n
hexToNum Word8
n) n
0 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Word8 -> Bool) -> Parser ByteString
takeWhile1 Word8 -> Bool
isHexa
{-# INLINABLE hnum #-}

-- | Parses any positives octal 'Num'.
onum :: Num n => Parser n
onum :: forall n. Num n => Parser n
onum = forall a. (a -> Word8 -> a) -> a -> ByteString -> a
BS.foldl' (\n
acc Word8
n -> n
acc forall a. Num a => a -> a -> a
* n
8 forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
n forall a. Num a => a -> a -> a
- Word8
0x30)) n
0 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Word8 -> Bool) -> Parser ByteString
takeWhile1 Word8 -> Bool
isDigit
{-# INLINABLE onum #-}

-- | Parses 'Fractional' numbers.
frac :: Fractional a => Parser a
frac :: forall a. Fractional a => Parser a
frac = forall a. (ByteString -> Maybe (a, ByteString)) -> Parser a
wlex (forall a.
Num a =>
(ByteString -> Maybe (a, ByteString))
-> ByteString -> Maybe (a, ByteString)
L.readSigned forall a. Fractional a => ByteString -> Maybe (a, ByteString)
L.readDecimal)
{-# INLINABLE frac #-}

-- | Consumes n bytes of input
takeN :: Int -> Parser BS.ByteString
takeN :: Int -> Parser ByteString
takeN Int
n = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a.
(forall r.
 ByteString -> (ParseError -> r) -> (ByteString -> a -> r) -> r)
-> ParserM a
Parser forall a b. (a -> b) -> a -> b
$ \ByteString
input ParseError -> r
failure ByteString -> ByteString -> r
success
    -> if ByteString -> Int
BS.length ByteString
input forall a. Ord a => a -> a -> Bool
< Int
n
         then ParseError -> r
failure ParseError
ueof
         else let (ByteString
a,ByteString
rest) = Int -> ByteString -> (ByteString, ByteString)
BS.splitAt Int
n ByteString
input
              in  ByteString -> ByteString -> r
success ByteString
rest ByteString
a

-- | Drops n bytes of input
dropN :: Int -> Parser ()
dropN :: Int -> Parser ()
dropN Int
n = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a.
(forall r.
 ByteString -> (ParseError -> r) -> (ByteString -> a -> r) -> r)
-> ParserM a
Parser forall a b. (a -> b) -> a -> b
$ \ByteString
input ParseError -> r
failure ByteString -> () -> r
success
    -> if ByteString -> Int
BS.length ByteString
input forall a. Ord a => a -> a -> Bool
< Int
n
         then ParseError -> r
failure ParseError
ueof
         else ByteString -> () -> r
success (Int -> ByteString -> ByteString
BS.drop Int
n ByteString
input) ()

-- | Parses any character.
anyChar :: Parser Char
anyChar :: Parser Char
anyChar = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a.
(forall r.
 ByteString -> (ParseError -> r) -> (ByteString -> a -> r) -> r)
-> ParserM a
Parser forall a b. (a -> b) -> a -> b
$ \ByteString
input ParseError -> r
failure ByteString -> Char -> r
success -> if ByteString -> Bool
BS.null ByteString
input then ParseError -> r
failure ParseError
ueof else ByteString -> Char -> r
success (HasCallStack => ByteString -> ByteString
BS8.tail ByteString
input) (ByteString -> Char
BS8.head ByteString
input)
{-# INLINE anyChar #-}

-- | Parses a specific character.
char :: Char -> Parser ()
char :: Char -> Parser ()
char Char
c = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a.
(forall r.
 ByteString -> (ParseError -> r) -> (ByteString -> a -> r) -> r)
-> ParserM a
Parser forall a b. (a -> b) -> a -> b
$ \ByteString
input ParseError -> r
failure ByteString -> () -> r
success -> if ByteString -> Bool
BS.null ByteString
input then ParseError -> r
failure ParseError
ueof else if ByteString -> Char
BS8.head ByteString
input forall a. Eq a => a -> a -> Bool
== Char
c then ByteString -> () -> r
success (HasCallStack => ByteString -> ByteString
BS.tail ByteString
input) () else ParseError -> r
failure (ByteString -> ByteString -> ParseError
parseError (Int -> ByteString -> ByteString
BS8.take Int
1 ByteString
input) (Char -> ByteString
BS8.singleton Char
c))
{-# INLINE char #-}

-- | Parses any byte.
anyWord8 :: Parser Word8
anyWord8 :: Parser Word8
anyWord8 = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a.
(forall r.
 ByteString -> (ParseError -> r) -> (ByteString -> a -> r) -> r)
-> ParserM a
Parser forall a b. (a -> b) -> a -> b
$ \ByteString
input ParseError -> r
failure ByteString -> Word8 -> r
success -> if ByteString -> Bool
BS.null ByteString
input then ParseError -> r
failure ParseError
ueof else ByteString -> Word8 -> r
success (HasCallStack => ByteString -> ByteString
BS.tail ByteString
input) (HasCallStack => ByteString -> Word8
BS.head ByteString
input)
{-# INLINE anyWord8 #-}

-- | Parses a specific byte.
word8 :: Word8 -> Parser ()
word8 :: Word8 -> Parser ()
word8 Word8
c = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a.
(forall r.
 ByteString -> (ParseError -> r) -> (ByteString -> a -> r) -> r)
-> ParserM a
Parser forall a b. (a -> b) -> a -> b
$ \ByteString
input ParseError -> r
failure ByteString -> () -> r
success -> if ByteString -> Bool
BS.null ByteString
input then ParseError -> r
failure ParseError
ueof else if HasCallStack => ByteString -> Word8
BS.head ByteString
input forall a. Eq a => a -> a -> Bool
== Word8
c then ByteString -> () -> r
success (HasCallStack => ByteString -> ByteString
BS.tail ByteString
input) () else ParseError -> r
failure (ByteString -> ByteString -> ParseError
parseError (Int -> ByteString -> ByteString
BS.take Int
1 ByteString
input) (Word8 -> ByteString
BS.singleton Word8
c))
{-# INLINE word8 #-}

-- | Parses a character satisfying a predicate
satisfy :: (Char -> Bool) -> Parser Char
satisfy :: (Char -> Bool) -> Parser Char
satisfy Char -> Bool
p = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a.
(forall r.
 ByteString -> (ParseError -> r) -> (ByteString -> a -> r) -> r)
-> ParserM a
Parser forall a b. (a -> b) -> a -> b
$ \ByteString
input ParseError -> r
failure ByteString -> Char -> r
success ->
  if ByteString -> Bool
BS.null ByteString
input
    then ParseError -> r
failure ParseError
ueof
    else let c :: Char
c = ByteString -> Char
BS8.head ByteString
input
         in  if Char -> Bool
p Char
c
               then ByteString -> Char -> r
success (HasCallStack => ByteString -> ByteString
BS.tail ByteString
input) Char
c
               else ParseError -> r
failure (ByteString -> ByteString -> ParseError
parseError (Int -> ByteString -> ByteString
BS8.take Int
1 ByteString
input) (Char -> ByteString
BS8.singleton Char
c))

-- | Parses the supplied string.
string :: BS.ByteString -> Parser ()
string :: ByteString -> Parser ()
string ByteString
s = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a.
(forall r.
 ByteString -> (ParseError -> r) -> (ByteString -> a -> r) -> r)
-> ParserM a
Parser forall a b. (a -> b) -> a -> b
$ \ByteString
input ParseError -> r
failure ByteString -> () -> r
success
    -> if ByteString
s ByteString -> ByteString -> Bool
`BS.isPrefixOf` ByteString
input
          then ByteString -> () -> r
success (Int -> ByteString -> ByteString
BS.drop (ByteString -> Int
BS.length ByteString
s) ByteString
input) ()
          else ParseError -> r
failure (ByteString -> ByteString -> ParseError
parseError (Int -> ByteString -> ByteString
BS.take (ByteString -> Int
BS.length ByteString
s) ByteString
input) ByteString
s)

-- | Parses strings between double quotes. This functions handles the
-- following escape sequences: \\r, \\n, \\t, \\a, \\b, \\", \\\\.
quotedString :: Parser BS.ByteString
quotedString :: Parser ByteString
quotedString = Char -> Parser ()
char Char
'"' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString
go forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser ()
char Char
'"'
    where
        go :: Parser ByteString
go = [ByteString] -> ByteString
BS.concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Parser ByteString
normal forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString
escaped)
        normal :: Parser ByteString
normal = (Char -> Bool) -> Parser ByteString
charTakeWhile1 (\Char
x -> Char
x forall a. Eq a => a -> a -> Bool
/= Char
'"' Bool -> Bool -> Bool
&& Char
x forall a. Eq a => a -> a -> Bool
/= Char
'\\')
        escaped :: Parser ByteString
escaped = do
            Char -> Parser ()
char Char
'\\'
            Char
c <- Parser Char
anyChar
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Char
c of
                         Char
'r' -> Char -> ByteString
BS8.singleton Char
'\r'
                         Char
'n' -> Char -> ByteString
BS8.singleton Char
'\n'
                         Char
't' -> Char -> ByteString
BS8.singleton Char
'\t'
                         Char
'a' -> Char -> ByteString
BS8.singleton Char
'\a'
                         Char
'b' -> Char -> ByteString
BS8.singleton Char
'\b'
                         Char
'"' -> Char -> ByteString
BS8.singleton Char
'"'
                         Char
_   -> String -> ByteString
BS8.pack [Char
'\\',Char
c]

-- | A fast parser for numbers of the form 5.123. Contrary to what its name
-- implies, it parses to 'Double'.
scientific :: Parser Double
scientific :: Parser Double
scientific = (Int, Double) -> Double
finalize forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Word8 -> a) -> a -> ByteString -> a
BS.foldl' forall {a} {b} {a}.
(Num b, Num a, Integral a) =>
(a, b) -> a -> (a, b)
step (Int
0,Double
0) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Word8 -> Bool) -> Parser ByteString
takeWhile1 (\Word8
n -> Word8 -> Bool
isDigit Word8
n Bool -> Bool -> Bool
|| Word8
n forall a. Eq a => a -> a -> Bool
== Word8
0x2e)
    where
        finalize :: (Int, Double) -> Double
        finalize :: (Int, Double) -> Double
finalize (!Int
n,!Double
x) = if Double
x forall a. Eq a => a -> a -> Bool
== Double
0
                             then forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n
                             else forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n forall a. Fractional a => a -> a -> a
/ Double
x
        step :: (a, b) -> a -> (a, b)
step (!a
n,!b
x) !a
v = if a
v forall a. Eq a => a -> a -> Bool
== a
0x2e
                              then (a
n,b
1)
                              else (a
n forall a. Num a => a -> a -> a
* a
10 forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral (a
v forall a. Num a => a -> a -> a
- a
0x30), b
x forall a. Num a => a -> a -> a
* b
10)
{-# INLINE scientific #-}

charTakeWhile1 :: (Char -> Bool) -> Parser BS.ByteString
charTakeWhile1 :: (Char -> Bool) -> Parser ByteString
charTakeWhile1 Char -> Bool
prd = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a.
(forall r.
 ByteString -> (ParseError -> r) -> (ByteString -> a -> r) -> r)
-> ParserM a
Parser forall a b. (a -> b) -> a -> b
$ \ByteString
s ParseError -> r
failure ByteString -> ByteString -> r
success ->
    case (Char -> Bool) -> ByteString -> (ByteString, ByteString)
BS8.span Char -> Bool
prd ByteString
s of
      (ByteString
a,ByteString
b) -> if ByteString -> Bool
BS.null ByteString
a then ParseError -> r
failure (Set ErrorItem -> Set ErrorItem -> ParseError
ParseError (forall a. a -> Set a
S.singleton (ByteString -> ErrorItem
Tokens (Int -> ByteString -> ByteString
BS.take Int
1 ByteString
s))) forall a. Monoid a => a
mempty) else ByteString -> ByteString -> r
success ByteString
b ByteString
a
{-# INLINE charTakeWhile1 #-}

takeWhile1 :: (Word8 -> Bool) -> Parser BS.ByteString
takeWhile1 :: (Word8 -> Bool) -> Parser ByteString
takeWhile1 Word8 -> Bool
prd = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a.
(forall r.
 ByteString -> (ParseError -> r) -> (ByteString -> a -> r) -> r)
-> ParserM a
Parser forall a b. (a -> b) -> a -> b
$ \ByteString
s ParseError -> r
failure ByteString -> ByteString -> r
success ->
    case (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
BS.span Word8 -> Bool
prd ByteString
s of
      (ByteString
a,ByteString
b) -> if ByteString -> Bool
BS.null ByteString
a then ParseError -> r
failure (Set ErrorItem -> Set ErrorItem -> ParseError
ParseError (forall a. a -> Set a
S.singleton (ByteString -> ErrorItem
Tokens (Int -> ByteString -> ByteString
BS.take Int
1 ByteString
s))) forall a. Monoid a => a
mempty) else ByteString -> ByteString -> r
success ByteString
b ByteString
a
{-# INLINE takeWhile1 #-}

-- | Consumes the input as long as the predicate remains true.
charTakeWhile :: (Char -> Bool) -> Parser BS.ByteString
charTakeWhile :: (Char -> Bool) -> Parser ByteString
charTakeWhile Char -> Bool
prd = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a.
(forall r.
 ByteString -> (ParseError -> r) -> (ByteString -> a -> r) -> r)
-> ParserM a
Parser forall a b. (a -> b) -> a -> b
$ \ByteString
s ParseError -> r
_ ByteString -> ByteString -> r
success ->
    case (Char -> Bool) -> ByteString -> (ByteString, ByteString)
BS8.span Char -> Bool
prd ByteString
s of
      (ByteString
a,ByteString
b) -> ByteString -> ByteString -> r
success ByteString
b ByteString
a
{-# INLINE charTakeWhile #-}

-- | Consumes the input as long as the predicate remains true.
takeWhile :: (Word8 -> Bool) -> Parser BS.ByteString
takeWhile :: (Word8 -> Bool) -> Parser ByteString
takeWhile Word8 -> Bool
prd = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a.
(forall r.
 ByteString -> (ParseError -> r) -> (ByteString -> a -> r) -> r)
-> ParserM a
Parser forall a b. (a -> b) -> a -> b
$ \ByteString
s ParseError -> r
_ ByteString -> ByteString -> r
success ->
  case (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
BS.span Word8 -> Bool
prd ByteString
s of
    (ByteString
a,ByteString
b) -> ByteString -> ByteString -> r
success ByteString
b ByteString
a
{-# INLINE takeWhile #-}

-- | Discards the input as long as the predicate remains true.
skipWhile :: (Word8 -> Bool) -> Parser ()
skipWhile :: (Word8 -> Bool) -> Parser ()
skipWhile Word8 -> Bool
prd = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a.
(forall r.
 ByteString -> (ParseError -> r) -> (ByteString -> a -> r) -> r)
-> ParserM a
Parser forall a b. (a -> b) -> a -> b
$ \ByteString
s ParseError -> r
_ ByteString -> () -> r
success -> ByteString -> () -> r
success ((Word8 -> Bool) -> ByteString -> ByteString
BS.dropWhile Word8 -> Bool
prd ByteString
s) ()
{-# INLINE skipWhile #-}

-- | Runs the parser. Will return a parse error if the parser fails
-- or if the input is not completely consumed.
parseOnly :: Parser a -> BS.ByteString -> Either ParseError a
parseOnly :: forall a. Parser a -> ByteString -> Either ParseError a
parseOnly Parser a
prs ByteString
s = case forall (f :: * -> *) a. Applicative f => Codensity f a -> f a
lowerCodensity Parser a
prs of
                  Parser forall r.
ByteString -> (ParseError -> r) -> (ByteString -> a -> r) -> r
p -> forall r.
ByteString -> (ParseError -> r) -> (ByteString -> a -> r) -> r
p ByteString
s forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ \ByteString
b a
a -> if ByteString -> Bool
BS.null ByteString
b
                                              then forall a b. b -> Either a b
Right a
a
                                              else forall a b. a -> Either a b
Left (Set ErrorItem -> Set ErrorItem -> ParseError
ParseError (forall a. a -> Set a
S.singleton (ByteString -> ErrorItem
Tokens (Int -> ByteString -> ByteString
BS.take Int
1 ByteString
b))) forall a. Monoid a => a
mempty)

-- | Parses the remaining input.
remaining :: Parser BS.ByteString
remaining :: Parser ByteString
remaining = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a.
(forall r.
 ByteString -> (ParseError -> r) -> (ByteString -> a -> r) -> r)
-> ParserM a
Parser forall a b. (a -> b) -> a -> b
$ \ByteString
input ParseError -> r
_ ByteString -> ByteString -> r
success -> ByteString -> ByteString -> r
success ByteString
BS.empty ByteString
input

-- | Parses days, with format YYYY-MM-DD
parseYMD :: Parser Day
parseYMD :: Parser Day
parseYMD = do
    !Int
y <- Parser Int
decimal forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser ()
char Char
'-'
    !Int
m <- Parser Int
decimal forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser ()
char Char
'-'
    !Int
d <- Parser Int
decimal
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! Int -> Int -> Int -> Day
fromGregorian Int
y Int
m Int
d

-- | Parses a difftime, with format HH:MM:SS
parseDTime :: Parser DiffTime
parseDTime :: Parser DiffTime
parseDTime = do
    !Int
h  <- Parser Int
decimal forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser ()
char Char
':'
    !Int
mi <- Parser Int
decimal forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser ()
char Char
':'
    !Double
s  <- Parser Double
scientific
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall n t. (Real n, TimeDiff t) => n -> t
fromSeconds forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
h forall a. Num a => a -> a -> a
* Int
3600 forall a. Num a => a -> a -> a
+ Int
mi forall a. Num a => a -> a -> a
* Int
60 :: Int) forall a. Num a => a -> a -> a
+ Double
s

-- | Parses a whole timestamp, with format YYYY-MM-DD+HH:MM:SS+CEST.
-- This is very much *not* robust, as it only handles CET and CEST.
timestamp :: Parser UTCTime
timestamp :: Parser UTCTime
timestamp = do
    !Day
day <- Parser Day
parseYMD forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser ()
char Char
'+'
    !DiffTime
difftime <- Parser DiffTime
parseDTime forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser ()
char Char
'+'
    let !tm :: UTCTime
tm = Day -> DiffTime -> UTCTime
UTCTime Day
day DiffTime
difftime
    !ByteString
tz <- (Word8 -> Bool) -> Parser ByteString
takeWhile1 Word8 -> Bool
isUpper
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! case ByteString
tz of
                  ByteString
"CEST" -> UTCTime
tm forall p. AffineSpace p => p -> Diff p -> p
.-^ forall n t. (Real n, TimeDiff t) => n -> t
fromSeconds (Int
7200 :: Int)
                  ByteString
"CET"  -> UTCTime
tm forall p. AffineSpace p => p -> Diff p -> p
.-^ forall n t. (Real n, TimeDiff t) => n -> t
fromSeconds (Int
3600 :: Int)
                  ByteString
_      -> UTCTime
tm

-- | Parses RFC3339 compatible timestamps to UTCTime.
rfc3339 :: Parser UTCTime
rfc3339 :: Parser UTCTime
rfc3339 = do
    !Day
day <- Parser Day
parseYMD forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser ()
char Char
'T'
    !DiffTime
difftime <- Parser DiffTime
parseDTime
    !Char
o <- Parser Char
anyChar
    let !tm :: UTCTime
tm = Day -> DiffTime -> UTCTime
UTCTime Day
day DiffTime
difftime
        suboffset :: Diff UTCTime -> UTCTime
suboffset = (UTCTime
tm forall p. AffineSpace p => p -> Diff p -> p
.-^)
        addoffset :: Diff UTCTime -> UTCTime
addoffset = (UTCTime
tm forall p. AffineSpace p => p -> Diff p -> p
.+^)
        getOffset :: Codensity ParserM NominalDiffTime
getOffset = do
            Int
h <- Parser Int
decimal
            Char -> Parser ()
char Char
':'
            Int
m <- Parser Int
decimal
            forall (m :: * -> *) a. Monad m => a -> m a
return (forall n t. (Real n, TimeDiff t) => n -> t
fromSeconds (Int
hforall a. Num a => a -> a -> a
*Int
3600 forall a. Num a => a -> a -> a
+ Int
mforall a. Num a => a -> a -> a
*Int
60))
    case Char
o of
        Char
'Z' -> forall (m :: * -> *) a. Monad m => a -> m a
return UTCTime
tm
        Char
'+' -> NominalDiffTime -> UTCTime
suboffset forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Codensity ParserM NominalDiffTime
getOffset
        Char
'-' -> NominalDiffTime -> UTCTime
addoffset forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Codensity ParserM NominalDiffTime
getOffset
        Char
_   -> forall (f :: * -> *) a. Alternative f => f a
empty

-- | Turns any parser into a 'SimpleFold'.
pFold :: Parser a -> SimpleFold BS.ByteString a
pFold :: forall a. Parser a -> SimpleFold ByteString a
pFold Parser a
p = forall s a. (s -> a) -> SimpleGetter s a
to (forall a. Parser a -> ByteString -> Either ParseError a
parseOnly Parser a
p) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b b'. Traversal (Either a b) (Either a b') b b'
_Right