{- |
   Module      :  Text.Parsec.Rfc2234
   Copyright   :  (c) 2007-2019 Peter Simons
   License     :  BSD3

   Maintainer  :  simons@cryp.to
   Stability   :  provisional
   Portability :  portable

   This module provides parsers for the grammar defined in
   RFC2234, \"Augmented BNF for Syntax Specifications:
   ABNF\", <http://www.faqs.org/rfcs/rfc2234.html>. The
   terminal called @char@ in the RFC is called 'character'
   here to avoid conflicts with Parsec's 'char' function.
 -}

{-# LANGUAGE FlexibleContexts #-}

module Text.Parsec.Rfc2234
  ( caseChar, caseString
  , manyN, manyNtoM
  , alpha, bit, character, cr, lf, crlf, ctl, dquote, hexdig
  , htab, lwsp, octet, sp, vchar, wsp
  , quoted_pair, quoted_string
  ) where

import Control.Monad ( liftM2, replicateM )
import Data.Char ( toUpper, chr, ord )
import Text.Parsec hiding ( crlf )

-- Customize hlint ...
{-# ANN module "HLint: ignore Use camelCase" #-}

----------------------------------------------------------------------
-- * Parser Combinators
----------------------------------------------------------------------

-- | Case-insensitive variant of Parsec's 'char' function.

caseChar :: Stream s m Char => Char -> ParsecT s u m Char
caseChar :: forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
caseChar Char
c = (Char -> Bool) -> ParsecT s u m Char
forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy (\Char
x -> Char -> Char
toUpper Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char -> Char
toUpper Char
c)

-- | Case-insensitive variant of Parsec's 'string' function.

caseString :: Stream s m Char => String -> ParsecT s u m ()
caseString :: forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m ()
caseString String
cs = (Char -> ParsecT s u m Char) -> String -> ParsecT s u m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Char -> ParsecT s u m Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
caseChar String
cs ParsecT s u m () -> String -> ParsecT s u m ()
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
cs

-- | Match a parser at least @n@ times.

manyN :: Int -> ParsecT s u m a -> ParsecT s u m [a]
manyN :: forall s u (m :: * -> *) a.
Int -> ParsecT s u m a -> ParsecT s u m [a]
manyN Int
n ParsecT s u m a
p | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0    = [a] -> ParsecT s u m [a]
forall a. a -> ParsecT s u m a
forall (m :: * -> *) a. Monad m => a -> m a
return []
          | Bool
otherwise = ([a] -> [a] -> [a])
-> ParsecT s u m [a] -> ParsecT s u m [a] -> ParsecT s u m [a]
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++) (Int -> ParsecT s u m a -> ParsecT s u m [a]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n ParsecT s u m a
p) (ParsecT s u m a -> ParsecT s u m [a]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many ParsecT s u m a
p)

-- | Match a parser at least @n@ times, but no more than @m@ times.

manyNtoM :: Int -> Int -> ParsecT s u m a -> ParsecT s u m [a]
manyNtoM :: forall s u (m :: * -> *) a.
Int -> Int -> ParsecT s u m a -> ParsecT s u m [a]
manyNtoM Int
n Int
m ParsecT s u m a
p
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0     = [a] -> ParsecT s u m [a]
forall a. a -> ParsecT s u m a
forall (m :: * -> *) a. Monad m => a -> m a
return []
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
m     = [a] -> ParsecT s u m [a]
forall a. a -> ParsecT s u m a
forall (m :: * -> *) a. Monad m => a -> m a
return []
  | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
m    = Int -> ParsecT s u m a -> ParsecT s u m [a]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n ParsecT s u m a
p
  | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0    = (Int -> ParsecT s u m [a] -> ParsecT s u m [a])
-> ParsecT s u m [a] -> [Int] -> ParsecT s u m [a]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (ParsecT s u m [a] -> ParsecT s u m [a] -> ParsecT s u m [a]
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
(<|>) (ParsecT s u m [a] -> ParsecT s u m [a] -> ParsecT s u m [a])
-> (Int -> ParsecT s u m [a])
-> Int
-> ParsecT s u m [a]
-> ParsecT s u m [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\Int
x -> ParsecT s u m [a] -> ParsecT s u m [a]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (Int -> ParsecT s u m a -> ParsecT s u m [a]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
x ParsecT s u m a
p))) ([a] -> ParsecT s u m [a]
forall a. a -> ParsecT s u m a
forall (m :: * -> *) a. Monad m => a -> m a
return []) ([Int] -> [Int]
forall a. [a] -> [a]
reverse [Int
1 .. Int
m])
  | Bool
otherwise = ([a] -> [a] -> [a])
-> ParsecT s u m [a] -> ParsecT s u m [a] -> ParsecT s u m [a]
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++) (Int -> ParsecT s u m a -> ParsecT s u m [a]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n ParsecT s u m a
p) (Int -> Int -> ParsecT s u m a -> ParsecT s u m [a]
forall s u (m :: * -> *) a.
Int -> Int -> ParsecT s u m a -> ParsecT s u m [a]
manyNtoM Int
0 (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n) ParsecT s u m a
p)

----------------------------------------------------------------------
-- * Primitive Parsers
----------------------------------------------------------------------

-- | Match any character of the alphabet.

alpha :: Stream s m Char => ParsecT s u m Char
alpha :: forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
alpha = (Char -> Bool) -> ParsecT s u m Char
forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy (\Char
c -> Char
c Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ([Char
'A' .. Char
'Z'] String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
'a' .. Char
'z'])) ParsecT s u m Char -> String -> ParsecT s u m Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"alphabetic character"

-- | Match either \"1\" or \"0\".

bit :: Stream s m Char => ParsecT s u m Char
bit :: forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
bit = String -> ParsecT s u m Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
oneOf String
"01" ParsecT s u m Char -> String -> ParsecT s u m Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"bit ('0' or '1')"

-- | Match any 7-bit US-ASCII character except for NUL (ASCII value 0, that
-- is).

character :: Stream s m Char => ParsecT s u m Char
character :: forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
character = (Char -> Bool) -> ParsecT s u m Char
forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy (\Char
c -> (Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Int -> Char
chr Int
1) Bool -> Bool -> Bool
&& (Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Int -> Char
chr Int
127)) ParsecT s u m Char -> String -> ParsecT s u m Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"7-bit character excluding NUL"

-- | Match the carriage return character @\\r@.

cr :: Stream s m Char => ParsecT s u m Char
cr :: forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
cr = Char -> ParsecT s u m Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'\r' ParsecT s u m Char -> String -> ParsecT s u m Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"carriage return"

-- | Match returns the linefeed character @\\n@.

lf :: Stream s m Char => ParsecT s u m Char
lf :: forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
lf = Char -> ParsecT s u m Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'\n' ParsecT s u m Char -> String -> ParsecT s u m Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"linefeed"

-- | Match the Internet newline @\\r\\n@.

crlf :: Stream s m Char => ParsecT s u m String
crlf :: forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m String
crlf = do Char
c <- ParsecT s u m Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
cr
          Char
l <- ParsecT s u m Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
lf
          String -> ParsecT s u m String
forall a. a -> ParsecT s u m a
forall (m :: * -> *) a. Monad m => a -> m a
return [Char
c, Char
l]
       ParsecT s u m String -> String -> ParsecT s u m String
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"carriage return followed by linefeed"

-- | Match any US-ASCII control character. That is any character with a decimal
-- value in the range of [0..31,127].

ctl :: Stream s m Char => ParsecT s u m Char
ctl :: forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
ctl = (Char -> Bool) -> ParsecT s u m Char
forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy (\Char
c -> Char -> Int
ord Char
c Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ([Int
0 .. Int
31] [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int
127])) ParsecT s u m Char -> String -> ParsecT s u m Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"control character"

-- | Match the double quote character \"@\"@\".

dquote :: Stream s m Char => ParsecT s u m Char
dquote :: forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
dquote = Char -> ParsecT s u m Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char (Int -> Char
chr Int
34) ParsecT s u m Char -> String -> ParsecT s u m Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"double quote"

-- | Match any character that is valid in a hexadecimal number; [\'0\'..\'9\']
-- and [\'A\'..\'F\',\'a\'..\'f\'] that is.

hexdig :: Stream s m Char => ParsecT s u m Char
hexdig :: forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
hexdig = ParsecT s u m Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
hexDigit ParsecT s u m Char -> String -> ParsecT s u m Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"hexadecimal digit"

-- | Match the tab (\"@\\t@\") character.

htab :: Stream s m Char => ParsecT s u m Char
htab :: forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
htab = Char -> ParsecT s u m Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'\t' ParsecT s u m Char -> String -> ParsecT s u m Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"horizontal tab"

-- | Match \"linear white-space\". That is any number of consecutive 'wsp',
-- optionally followed by a 'crlf' and (at least) one more 'wsp'.

lwsp :: Stream s m Char => ParsecT s u m String
lwsp :: forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m String
lwsp = do String
r  <- [ParsecT s u m String] -> ParsecT s u m String
forall s (m :: * -> *) t u a.
Stream s m t =>
[ParsecT s u m a] -> ParsecT s u m a
choice [ParsecT s u m Char -> ParsecT s u m String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT s u m Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
wsp, ParsecT s u m String -> ParsecT s u m String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try ((String -> String -> String)
-> ParsecT s u m String
-> ParsecT s u m String
-> ParsecT s u m String
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 String -> String -> String
forall a. [a] -> [a] -> [a]
(++) ParsecT s u m String
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m String
crlf (ParsecT s u m Char -> ParsecT s u m String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT s u m Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
wsp))]
          String
rs <- String -> ParsecT s u m String -> ParsecT s u m String
forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option [] ParsecT s u m String
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m String
lwsp
          String -> ParsecT s u m String
forall a. a -> ParsecT s u m a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
rs)
       ParsecT s u m String -> String -> ParsecT s u m String
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"linear white-space"

-- | Match /any/ character.
octet :: Stream s m Char => ParsecT s u m Char
octet :: forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
octet = ParsecT s u m Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar ParsecT s u m Char -> String -> ParsecT s u m Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"any 8-bit character"

-- | Match the space.

sp :: Stream s m Char => ParsecT s u m Char
sp :: forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
sp = Char -> ParsecT s u m Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
' ' ParsecT s u m Char -> String -> ParsecT s u m Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"space"

-- | Match any printable ASCII character. (The \"v\" stands for \"visible\".)
-- That is any character in the decimal range of [33..126].

vchar :: Stream s m Char => ParsecT s u m Char
vchar :: forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
vchar = (Char -> Bool) -> ParsecT s u m Char
forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy (\Char
c -> (Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Int -> Char
chr Int
33) Bool -> Bool -> Bool
&& (Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Int -> Char
chr Int
126)) ParsecT s u m Char -> String -> ParsecT s u m Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"printable character"

-- | Match either 'sp' or 'htab'.

wsp :: Stream s m Char => ParsecT s u m Char
wsp :: forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
wsp = ParsecT s u m Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
sp ParsecT s u m Char -> ParsecT s u m Char -> ParsecT s u m Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ParsecT s u m Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
htab ParsecT s u m Char -> String -> ParsecT s u m Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"white-space"


-- ** Useful additions

-- | Match a \"quoted pair\". Any characters (excluding CR and LF) may be
-- quoted.

quoted_pair :: Stream s m Char => ParsecT s u m String
quoted_pair :: forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m String
quoted_pair = do Char
_ <- Char -> ParsecT s u m Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'\\'
                 Char
r <- String -> ParsecT s u m Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf String
"\r\n"
                 String -> ParsecT s u m String
forall a. a -> ParsecT s u m a
forall (m :: * -> *) a. Monad m => a -> m a
return [Char
'\\', Char
r]
              ParsecT s u m String -> String -> ParsecT s u m String
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"quoted pair"

-- | Match a quoted string. The specials \"@\\@\" and \"@\"@\" must be escaped
-- inside a quoted string; CR and LF are not allowed at all.

quoted_string :: Stream s m Char => ParsecT s u m String
quoted_string :: forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m String
quoted_string = do Char
_ <- ParsecT s u m Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
dquote
                   [String]
r <- ParsecT s u m String -> ParsecT s u m [String]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many ParsecT s u m String
forall {u}. ParsecT s u m String
qcont
                   Char
_ <- ParsecT s u m Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
dquote
                   String -> ParsecT s u m String
forall a. a -> ParsecT s u m a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
"\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String]
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"")
                ParsecT s u m String -> String -> ParsecT s u m String
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"quoted string"
 where
  qtext :: ParsecT s u m Char
qtext = String -> ParsecT s u m Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf String
"\\\"\r\n"
  qcont :: ParsecT s u m String
qcont = ParsecT s u m Char -> ParsecT s u m String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT s u m Char
forall {u}. ParsecT s u m Char
qtext ParsecT s u m String
-> ParsecT s u m String -> ParsecT s u m String
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ParsecT s u m String
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m String
quoted_pair