-- This file is part of purebred-email
-- Copyright (C) 2017-2021  Fraser Tweedale and Róman Joost
--
-- purebred-email is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program.  If not, see <http://www.gnu.org/licenses/>.

{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

{- |

Parsers for low-level productions in the Internet Message Format.
These parsers are used throughout this library and may be useful
to other programs.

-}
module Data.IMF.Syntax
  (
  -- * Case-insensitive value parsers
    ci
  , CI
  , mk
  , original

  -- * Abstract character parsers
  , wsp
  , fws
  , optionalFWS
  , optionalCFWS
  , crlf
  , vchar
  , word
  , quotedString
  , dotAtomText
  , dotAtom
  , localPart
  , domainLiteral
  , IsChar(..)
  , char
  , CharParsing(..)
  , SM

  -- ** Helpers for building parsers
  , isAtext
  , isQtext
  , isVchar
  , isWsp

  -- * Semigroup and monoid folding combinators
  , (<<>>)
  , foldMany
  , foldMany1
  , foldMany1Sep

  -- * General parsers and combinators
  , skipTill
  , takeTill'

  -- * Efficient string search
  , skipTillString
  , takeTillString

  ) where

import Prelude hiding (takeWhile)
import Control.Applicative ((<|>), Alternative, liftA2, many, optional, some)
import Control.Monad (void)
import qualified Data.Attoparsec.ByteString as A
import qualified Data.Attoparsec.Internal as A
import qualified Data.Attoparsec.Internal.Types as AT
import qualified Data.Attoparsec.Text as AText
import qualified Data.ByteString as B
import Data.ByteString.Internal (c2w, w2c)
import Data.ByteString.Search (indices)
import Data.CaseInsensitive (CI, FoldCase, mk, original)
import Data.Char (chr)
import Data.Foldable (fold)
import Data.Functor (($>))
import Data.List.NonEmpty (NonEmpty, fromList, intersperse)
import Data.Semigroup.Foldable (fold1)
import qualified Data.Text as T
import Data.Word (Word8)


-- | Constraint synonym to handle the Semigroup Monoid Proposal
-- transition gracefully.
type SM a = Monoid a

class IsChar a where
  toChar :: a -> Char
  fromChar :: Char -> a

instance IsChar Char where
  toChar :: Char -> Char
toChar = forall a. a -> a
id
  fromChar :: Char -> Char
fromChar = forall a. a -> a
id

instance IsChar Word8 where
  toChar :: Word8 -> Char
toChar = Word8 -> Char
w2c
  fromChar :: Char -> Word8
fromChar = Char -> Word8
c2w

class IsChar a => CharParsing f s a | s -> a, a -> f s where
  singleton :: Char -> s
  satisfy :: (Char -> Bool) -> (f s) a
  takeWhile :: (Char -> Bool) -> (f s) s
  takeWhile1 :: (Char -> Bool) -> (f s) s

instance CharParsing AT.Parser B.ByteString Word8 where
  singleton :: Char -> ByteString
singleton = Word8 -> ByteString
B.singleton forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Word8
c2w
  satisfy :: (Char -> Bool) -> Parser ByteString Word8
satisfy Char -> Bool
f = (Word8 -> Bool) -> Parser ByteString Word8
A.satisfy (Char -> Bool
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Char
w2c)
  takeWhile :: (Char -> Bool) -> Parser ByteString ByteString
takeWhile Char -> Bool
f = (Word8 -> Bool) -> Parser ByteString ByteString
A.takeWhile (Char -> Bool
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Char
w2c)
  takeWhile1 :: (Char -> Bool) -> Parser ByteString ByteString
takeWhile1 Char -> Bool
f = (Word8 -> Bool) -> Parser ByteString ByteString
A.takeWhile1 (Char -> Bool
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Char
w2c)

instance CharParsing AT.Parser T.Text Char where
  singleton :: Char -> Text
singleton = Char -> Text
T.singleton
  satisfy :: (Char -> Bool) -> Parser Text Char
satisfy = (Char -> Bool) -> Parser Text Char
AText.satisfy
  takeWhile :: (Char -> Bool) -> Parser Text Text
takeWhile = (Char -> Bool) -> Parser Text Text
AText.takeWhile
  takeWhile1 :: (Char -> Bool) -> Parser Text Text
takeWhile1 = (Char -> Bool) -> Parser Text Text
AText.takeWhile1

char :: CharParsing f s a => Char -> (f s) a
char :: forall (f :: * -> * -> *) s a. CharParsing f s a => Char -> f s a
char Char
c = forall (f :: * -> * -> *) s a.
CharParsing f s a =>
(Char -> Bool) -> f s a
satisfy (forall a. Eq a => a -> a -> Bool
== Char
c)

isWsp :: IsChar c => c -> Bool
isWsp :: forall c. IsChar c => c -> Bool
isWsp = String -> Char -> Bool
AText.inClass String
"\t " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsChar a => a -> Char
toChar

wsp :: CharParsing f s a => (f s) a
wsp :: forall (f :: * -> * -> *) s a. CharParsing f s a => f s a
wsp = forall (f :: * -> * -> *) s a.
CharParsing f s a =>
(Char -> Bool) -> f s a
satisfy forall c. IsChar c => c -> Bool
isWsp

isVchar :: IsChar c => c -> Bool
isVchar :: forall c. IsChar c => c -> Bool
isVchar c
c =
  let c' :: Char
c' = forall a. IsChar a => a -> Char
toChar c
c
  in Char
c' forall a. Ord a => a -> a -> Bool
>= Int -> Char
chr Int
0x21 Bool -> Bool -> Bool
&& Char
c' forall a. Ord a => a -> a -> Bool
<= Int -> Char
chr Int
0x7e

vchar :: CharParsing f s a => (f s) a
vchar :: forall (f :: * -> * -> *) s a. CharParsing f s a => f s a
vchar = forall (f :: * -> * -> *) s a.
CharParsing f s a =>
(Char -> Bool) -> f s a
satisfy forall c. IsChar c => c -> Bool
isVchar

dquote :: CharParsing f s a => (f s) a
dquote :: forall (f :: * -> * -> *) s a. CharParsing f s a => f s a
dquote = forall (f :: * -> * -> *) s a. CharParsing f s a => Char -> f s a
char Char
'"'

quotedPair :: (Alternative (f s)) => CharParsing f s a => (f s) a
quotedPair :: forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a) =>
f s a
quotedPair = forall (f :: * -> * -> *) s a. CharParsing f s a => Char -> f s a
char Char
'\\' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (forall (f :: * -> * -> *) s a. CharParsing f s a => f s a
vchar forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> * -> *) s a. CharParsing f s a => f s a
wsp)

-- §3.2.4.  Quoted Strings

isQtext :: IsChar c => c -> Bool
isQtext :: forall c. IsChar c => c -> Bool
isQtext c
c' =
  let c :: Char
c = forall a. IsChar a => a -> Char
toChar c
c'
  in
    Char
c forall a. Eq a => a -> a -> Bool
== Int -> Char
chr Int
33
    Bool -> Bool -> Bool
|| (Char
c forall a. Ord a => a -> a -> Bool
>= Int -> Char
chr Int
35 Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Int -> Char
chr Int
91)
    Bool -> Bool -> Bool
|| (Char
c forall a. Ord a => a -> a -> Bool
>= Int -> Char
chr Int
93 Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Int -> Char
chr Int
126)

quotedString :: (Alternative (f s), CharParsing f s a, SM s) => (f s) s
quotedString :: forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a, SM s) =>
f s s
quotedString =
  forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a, SM s) =>
f s s
optionalCFWS forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> * -> *) s a. CharParsing f s a => f s a
dquote
  forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall m (f :: * -> *). (Monoid m, Alternative f) => f m -> f m
foldMany (forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a, SM s) =>
f s s
optionalFWS forall m (f :: * -> *).
(Semigroup m, Applicative f) =>
f m -> f m -> f m
<<>> f s s
qcontent) forall m (f :: * -> *).
(Semigroup m, Applicative f) =>
f m -> f m -> f m
<<>> forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a, SM s) =>
f s s
optionalFWS
  forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (f :: * -> * -> *) s a. CharParsing f s a => f s a
dquote forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a, SM s) =>
f s s
optionalCFWS
  where
    qcontent :: f s s
qcontent =
      (forall (f :: * -> * -> *) s a. CharParsing f s a => Char -> s
singleton forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsChar a => a -> Char
toChar forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> * -> *) s a.
CharParsing f s a =>
(Char -> Bool) -> f s a
satisfy forall c. IsChar c => c -> Bool
isQtext)
      forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (forall (f :: * -> * -> *) s a. CharParsing f s a => Char -> s
singleton forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsChar a => a -> Char
toChar forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a) =>
f s a
quotedPair)

isAtext :: IsChar c => c -> Bool
isAtext :: forall c. IsChar c => c -> Bool
isAtext = String -> Char -> Bool
AText.inClass String
"-A-Za-z0-9!#$%&'*+/=?^_`{|}~" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsChar a => a -> Char
toChar

atext :: CharParsing f s a => (f s) a
atext :: forall (f :: * -> * -> *) s a. CharParsing f s a => f s a
atext = forall (f :: * -> * -> *) s a.
CharParsing f s a =>
(Char -> Bool) -> f s a
satisfy forall c. IsChar c => c -> Bool
isAtext

-- | Either CRLF or LF (lots of mail programs transform CRLF to LF)
crlf :: (Alternative (f s)) => CharParsing f s a => (f s) ()
crlf :: forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a) =>
f s ()
crlf = forall (f :: * -> *) a. Functor f => f a -> f ()
void ((forall (f :: * -> * -> *) s a. CharParsing f s a => Char -> f s a
char Char
'\r' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> * -> *) s a. CharParsing f s a => Char -> f s a
char Char
'\n') forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> * -> *) s a. CharParsing f s a => Char -> f s a
char Char
'\n')

-- §3.2.2.  Folding White Space and Comments
--
-- "The general rule is that wherever this specification allows for folding
-- white space (not simply WSP characters), a CRLF may be inserted before any
-- WSP."

-- | Folding white space (FWS).  A run of one or more whitespace
-- characters.  Returns a single SPACE character.
fws :: (Alternative (f s), CharParsing f s a) => (f s) s
fws :: forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a) =>
f s s
fws =
  -- obs-FWS is more permissive, so must come first.  This means
  -- that the second branch is unused, but keep it anyway for
  -- completeness.
  forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a) =>
f s s
obsFWS
  forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
  --    FWS             =   ([*WSP CRLF] 1*WSP) /  obs-FWS
  forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (forall (f :: * -> * -> *) s a.
CharParsing f s a =>
(Char -> Bool) -> f s s
takeWhile forall c. IsChar c => c -> Bool
isWsp forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a) =>
f s ()
crlf) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> * -> *) s a.
CharParsing f s a =>
(Char -> Bool) -> f s s
takeWhile1 forall c. IsChar c => c -> Bool
isWsp forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> forall (f :: * -> * -> *) s a. CharParsing f s a => Char -> s
singleton Char
' '

-- | Obsolete Folding White Space:
-- https://www.rfc-editor.org/errata/eid1908
--
-- @
-- obs-FWS         =   1*([CRLF] WSP)
-- @
--
obsFWS :: (Alternative (f s), CharParsing f s a) => (f s) s
obsFWS :: forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a) =>
f s s
obsFWS = forall (f :: * -> *) a. Alternative f => f a -> f [a]
some (forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a) =>
f s ()
crlf forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> * -> *) s a. CharParsing f s a => f s a
wsp) forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> forall (f :: * -> * -> *) s a. CharParsing f s a => Char -> s
singleton Char
' '

-- | FWS collapsed to a single SPACE character, or empty string
--
optionalFWS :: (Alternative (f s), CharParsing f s a, Monoid s) => (f s) s
optionalFWS :: forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a, SM s) =>
f s s
optionalFWS = forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a) =>
f s s
fws forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty

-- | Printable ASCII excl. '(', ')', '\'
isCtext :: Char -> Bool
isCtext :: Char -> Bool
isCtext Char
c =
  Char
c forall a. Ord a => a -> a -> Bool
>= Int -> Char
chr Int
33 Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Int -> Char
chr Int
39
  Bool -> Bool -> Bool
|| Char
c forall a. Ord a => a -> a -> Bool
>= Int -> Char
chr Int
42 Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Int -> Char
chr Int
91
  Bool -> Bool -> Bool
|| Char
c forall a. Ord a => a -> a -> Bool
>= Int -> Char
chr Int
93 Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Int -> Char
chr Int
126

ccontent :: (Alternative (f s), CharParsing f s a, SM s) => (f s) s
ccontent :: forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a, SM s) =>
f s s
ccontent = (forall (f :: * -> * -> *) s a. CharParsing f s a => Char -> s
singleton forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsChar a => a -> Char
toChar forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> * -> *) s a.
CharParsing f s a =>
(Char -> Bool) -> f s a
satisfy Char -> Bool
isCtext) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a, SM s) =>
f s s
comment

comment :: (Alternative (f s), CharParsing f s a, SM s) => (f s) s
comment :: forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a, SM s) =>
f s s
comment =
  forall (f :: * -> * -> *) s a. CharParsing f s a => Char -> f s a
char Char
'(' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall m (f :: * -> *). (Monoid m, Alternative f) => f m -> f m
foldMany (forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a, SM s) =>
f s s
optionalFWS forall m (f :: * -> *).
(Semigroup m, Applicative f) =>
f m -> f m -> f m
<<>> forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a, SM s) =>
f s s
ccontent) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a, SM s) =>
f s s
optionalFWS forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (f :: * -> * -> *) s a. CharParsing f s a => Char -> f s a
char Char
')'

cfws :: (Alternative (f s), CharParsing f s a, SM s) => (f s) s
cfws :: forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a, SM s) =>
f s s
cfws =
  ((forall m (f :: * -> *). (Semigroup m, Alternative f) => f m -> f m
foldMany1 (forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a, SM s) =>
f s s
optionalFWS forall m (f :: * -> *).
(Semigroup m, Applicative f) =>
f m -> f m -> f m
<<>> forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a, SM s) =>
f s s
comment) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a, SM s) =>
f s s
optionalFWS) forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> forall (f :: * -> * -> *) s a. CharParsing f s a => Char -> s
singleton Char
' ')
  forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a) =>
f s s
fws

-- | CFWS collapsed to a single SPACE character, or empty string
--
optionalCFWS :: (Alternative (f s), CharParsing f s a, SM s) => (f s) s
optionalCFWS :: forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a, SM s) =>
f s s
optionalCFWS = forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a, SM s) =>
f s s
cfws forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty

atom :: (Alternative (f s), CharParsing f s a, SM s) => (f s) s
atom :: forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a, SM s) =>
f s s
atom = forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a, SM s) =>
f s s
optionalCFWS forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall m (f :: * -> *). (Semigroup m, Alternative f) => f m -> f m
foldMany1 (forall (f :: * -> * -> *) s a. CharParsing f s a => Char -> s
singleton forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsChar a => a -> Char
toChar forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> * -> *) s a. CharParsing f s a => f s a
atext) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a, SM s) =>
f s s
optionalCFWS

word :: (Alternative (f s), CharParsing f s a, SM s) => (f s) s
word :: forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a, SM s) =>
f s s
word = forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a, SM s) =>
f s s
atom forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a, SM s) =>
f s s
quotedString

dotAtomText :: (Alternative (f s), CharParsing f s a) => (f s) (NonEmpty s)
dotAtomText :: forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a) =>
f s (NonEmpty s)
dotAtomText = forall a. [a] -> NonEmpty a
fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (f :: * -> * -> *) s a.
CharParsing f s a =>
(Char -> Bool) -> f s s
takeWhile1 forall c. IsChar c => c -> Bool
isAtext forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`A.sepBy1` forall (f :: * -> * -> *) s a. CharParsing f s a => Char -> f s a
char Char
'.')

dotAtom :: (Alternative (f s), CharParsing f s a, SM s) => (f s) (NonEmpty s)
dotAtom :: forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a, SM s) =>
f s (NonEmpty s)
dotAtom = forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a, SM s) =>
f s s
optionalCFWS forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a) =>
f s (NonEmpty s)
dotAtomText forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a, SM s) =>
f s s
optionalCFWS

localPart :: (Alternative (f s), CharParsing f s a, SM s) => (f s) s
localPart :: forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a, SM s) =>
f s s
localPart = (forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> NonEmpty a -> NonEmpty a
intersperse (forall (f :: * -> * -> *) s a. CharParsing f s a => Char -> s
singleton Char
'.') forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a, SM s) =>
f s (NonEmpty s)
dotAtom) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a, SM s) =>
f s s
quotedString

-- | Printable US-ASCII excl "[", "]", or "\"
isDtext :: Char -> Bool
isDtext :: Char -> Bool
isDtext Char
c = (Char
c forall a. Ord a => a -> a -> Bool
>= Int -> Char
chr Int
33 Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Int -> Char
chr Int
90) Bool -> Bool -> Bool
|| (Char
c forall a. Ord a => a -> a -> Bool
>= Int -> Char
chr Int
94 Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Int -> Char
chr Int
126)

dText :: CharParsing f s a => (f s) a
dText :: forall (f :: * -> * -> *) s a. CharParsing f s a => f s a
dText = forall (f :: * -> * -> *) s a.
CharParsing f s a =>
(Char -> Bool) -> f s a
satisfy Char -> Bool
isDtext

domainLiteral :: (Alternative (f s), CharParsing f s a, SM s) => (f s) s
domainLiteral :: forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a, SM s) =>
f s s
domainLiteral =
  forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a, SM s) =>
f s s
optionalCFWS forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> * -> *) s a. CharParsing f s a => Char -> f s a
char Char
'['
  forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall m (f :: * -> *). (Monoid m, Alternative f) => f m -> f m
foldMany (forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a, SM s) =>
f s s
optionalFWS forall m (f :: * -> *).
(Semigroup m, Applicative f) =>
f m -> f m -> f m
<<>> (forall (f :: * -> * -> *) s a. CharParsing f s a => Char -> s
singleton forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsChar a => a -> Char
toChar forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> * -> *) s a. CharParsing f s a => f s a
dText) forall m (f :: * -> *).
(Semigroup m, Applicative f) =>
f m -> f m -> f m
<<>> forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a, SM s) =>
f s s
optionalFWS)
  forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (f :: * -> * -> *) s a. CharParsing f s a => Char -> f s a
char Char
']' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a, SM s) =>
f s s
optionalFWS


-- | Modify a parser to produce a case-insensitive value
--
ci :: FoldCase s => A.Parser s -> A.Parser (CI s)
ci :: forall s. FoldCase s => Parser s -> Parser (CI s)
ci = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall s. FoldCase s => s -> CI s
mk


-- | Combine two semigroup parsers into one
(<<>>) :: (Semigroup m, Applicative f) => f m -> f m -> f m
<<>> :: forall m (f :: * -> *).
(Semigroup m, Applicative f) =>
f m -> f m -> f m
(<<>>) = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall a. Semigroup a => a -> a -> a
(<>)

-- | Parse zero or more values and fold them
foldMany :: (Monoid m, Alternative f) => f m -> f m
foldMany :: forall m (f :: * -> *). (Monoid m, Alternative f) => f m -> f m
foldMany = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Alternative f => f a -> f [a]
many

-- | Parse one or more values and fold them
foldMany1 :: (Semigroup m, Alternative f) => f m -> f m
foldMany1 :: forall m (f :: * -> *). (Semigroup m, Alternative f) => f m -> f m
foldMany1 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (t :: * -> *) m. (Foldable1 t, Semigroup m) => t m -> m
fold1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> NonEmpty a
fromList) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Alternative f => f a -> f [a]
A.many1

-- | Parse one or more values and fold them with a separating element
foldMany1Sep :: (Semigroup m, Alternative f) => m -> f m -> f m
foldMany1Sep :: forall m (f :: * -> *).
(Semigroup m, Alternative f) =>
m -> f m -> f m
foldMany1Sep m
sep = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (t :: * -> *) m. (Foldable1 t, Semigroup m) => t m -> m
fold1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> NonEmpty a -> NonEmpty a
intersperse m
sep forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> NonEmpty a
fromList) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Alternative f => f a -> f [a]
A.many1

-- | Skip until the given parser succeeds
--
-- @@
-- λ> parseOnly (string "foo" *> skipTill (string ".") *> endOfInput) "foobar."
-- Right ()
-- @@
--
skipTill :: A.Parser a -> A.Parser ()
skipTill :: forall a. Parser a -> Parser ()
skipTill = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Parser a -> Parser Int
spanTill

-- | Current offset in the input
position :: AT.Parser i Int
position :: forall i. Parser i Int
position = forall i a.
(forall r.
 State i
 -> Pos
 -> More
 -> Failure i (State i) r
 -> Success i (State i) a r
 -> IResult i r)
-> Parser i a
AT.Parser forall a b. (a -> b) -> a -> b
$ \State i
t Pos
pos More
more Failure i (State i) r
_lose Success i (State i) Int r
suc -> Success i (State i) Int r
suc State i
t Pos
pos More
more (Pos -> Int
AT.fromPos Pos
pos)

-- | Number of elements between current position and first position
-- at which parser matches (fails if it never matches).  Also
-- consumes the input on which the parser succeeds.
--
-- @@
-- λ> parseOnly (string "foo" *> spanTill (string ".")) "foobar."
-- Right 3
-- λ> parseOnly (string "foo" *> spanTill (string ".")) "foobar"
-- Left "not enough input"
-- @@
--
spanTill :: A.Parser a -> A.Parser Int
spanTill :: forall a. Parser a -> Parser Int
spanTill Parser a
p = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (forall a b c. (a -> b -> c) -> b -> a -> c
flip (-)) forall i. Parser i Int
position Parser Int
q
  where
  q :: Parser Int
q = forall i. Parser i Int
position forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser a
p forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString Word8
A.anyWord8 forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Int
q

-- | Run the parser from the specified offset.
--
-- Should only be used to seek backwards, otherwise
-- you could seek beyond the buffer.  User beware.
--
-- @@
-- λ> parseOnly (seek 3 *> takeByteString) "foobar"
-- Right "bar"
-- @@
--
seek :: Int -> A.Parser ()
seek :: Int -> Parser ()
seek Int
pos = forall i a.
(forall r.
 State i
 -> Pos
 -> More
 -> Failure i (State i) r
 -> Success i (State i) a r
 -> IResult i r)
-> Parser i a
AT.Parser forall a b. (a -> b) -> a -> b
$ \State ByteString
t Pos
_pos More
more Failure ByteString (State ByteString) r
_lose Success ByteString (State ByteString) () r
win -> Success ByteString (State ByteString) () r
win State ByteString
t (Int -> Pos
AT.Pos Int
pos) More
more ()

-- | Take until the parser matches (fails if it never matches).
--
-- @@
-- λ> parseOnly (takeTill' (string "bar") <* endOfInput) "foobar"
-- Right "foo"
-- @@
--
takeTill' :: A.Parser a -> A.Parser B.ByteString
takeTill' :: forall a. Parser a -> Parser ByteString ByteString
takeTill' Parser a
p = do
  Int
pos <- forall i. Parser i Int
position
  Int
off <- forall a. Parser a -> Parser Int
spanTill Parser a
p
  Int
newPos <- forall i. Parser i Int
position
  Int -> Parser ()
seek Int
pos forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Int -> Parser ByteString ByteString
A.take Int
off forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Int -> Parser ()
seek Int
newPos

-- | Number of elements between current position and first position
-- at which the pattern matches (fails if it never matches).  Also
-- consumes the pattern.
--
-- Uses Boyer-Moore algorithm to efficiently search the input.
--
-- @@
-- λ> parseOnly (string "foo" *> spanTillString ".") "foobar."
-- Right 3
-- λ> parseOnly (string "foo" *> spanTillString ".") "foobar"
-- Left "not enough input"
-- @@
--
spanTillString :: B.ByteString -> A.Parser Int
spanTillString :: ByteString -> Parser Int
spanTillString ByteString
pat
  | ByteString -> Bool
B.null ByteString
pat = forall i. Parser i Int
position
  | Bool
otherwise = forall i. Parser i Int
position forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Parser Int
go
  where
  search :: ByteString -> [Int]
search = ByteString -> ByteString -> [Int]
indices ByteString
pat
  go :: Int -> Parser Int
go Int
start = do
    Int
pos <- forall i. Parser i Int
position
    ByteString
buf <- Parser ByteString ByteString
takeBuffer
    case ByteString -> [Int]
search ByteString
buf of
      (Int
offset:[Int]
_) ->
        -- Pattern was found.  Seek to end of pattern and return the span
        Int -> Parser ()
seek (Int
pos forall a. Num a => a -> a -> a
+ Int
offset forall a. Num a => a -> a -> a
+ ByteString -> Int
B.length ByteString
pat) forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Int
pos forall a. Num a => a -> a -> a
+ Int
offset forall a. Num a => a -> a -> a
- Int
start
      [Int]
_ ->
        -- We hit the end of the buffer without a match.  Seek to
        -- (length buf - length pat), demand more input and go again.
        Int -> Parser ()
seek (forall a. Ord a => a -> a -> a
max Int
start (ByteString -> Int
B.length ByteString
buf forall a. Num a => a -> a -> a
- ByteString -> Int
B.length ByteString
pat)) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall t. Chunk t => Parser t ()
A.demandInput forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Int -> Parser Int
go Int
start

-- | Efficient skip, using Boyer-Moore to locate the pattern.
--
-- @@
-- λ> parseOnly (string "foo" *> skipTillString "." *> endOfInput) "foobar."
-- Right ()
-- @@
--
skipTillString :: B.ByteString -> A.Parser ()
skipTillString :: ByteString -> Parser ()
skipTillString = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Parser Int
spanTillString

-- | Efficient take, using Boyer-Moore to locate the pattern.
--
-- @@
-- λ> parseOnly (takeTillString "bar" <* endOfInput) "foobar"
-- Right "foo"
-- @@
--
takeTillString :: B.ByteString -> A.Parser B.ByteString
takeTillString :: ByteString -> Parser ByteString ByteString
takeTillString ByteString
pat = do
  Int
pos <- forall i. Parser i Int
position
  Int
off <- ByteString -> Parser Int
spanTillString ByteString
pat
  Int
newPos <- forall i. Parser i Int
position
  Int -> Parser ()
seek Int
pos forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Int -> Parser ByteString ByteString
A.take Int
off forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Int -> Parser ()
seek Int
newPos

-- | /O(1)/ Take the rest of the buffer, but do not demand
-- any more input.
--
takeBuffer :: A.Parser B.ByteString
takeBuffer :: Parser ByteString ByteString
takeBuffer = do
  Int
start <- forall i. Parser i Int
position
  Int
end <- forall t. Chunk t => Parser t Int
bufSize
  Int -> Parser ByteString ByteString
A.take (Int
end forall a. Num a => a -> a -> a
- Int
start)

bufSize :: forall t. AT.Chunk t => AT.Parser t Int
bufSize :: forall t. Chunk t => Parser t Int
bufSize = forall i a.
(forall r.
 State i
 -> Pos
 -> More
 -> Failure i (State i) r
 -> Success i (State i) a r
 -> IResult i r)
-> Parser i a
AT.Parser forall a b. (a -> b) -> a -> b
$
  \State t
t Pos
pos More
more Failure t (State t) r
_lose Success t (State t) Int r
win ->
    Success t (State t) Int r
win State t
t Pos
pos More
more
      (Pos -> Int
AT.fromPos forall a b. (a -> b) -> a -> b
$ forall c. Chunk c => c -> State c -> Pos
AT.atBufferEnd (forall a. HasCallStack => a
undefined :: t) State t
t)