{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}

-- |
-- Module      : Text.Megaparsec.Utils
-- Description : Various generic parsers and combinators.
-- Copyright   : (c) drlkf, 2024
-- License     : GPL-3
-- Maintainer  : drlkf@drlkf.net
-- Stability   : experimental
--
-- Generic utilities and common parsers.
module Text.Megaparsec.Utils (
  -- * Scalar parsers
  boolParser,
  numParser,
  posDecNumParser,
  posNumParser,
  uuidParser,

  -- * Combinators
  commaSeparated,
  occurrence,
  occurrences,

  -- * Compatibility utilities
  boundedEnumShowParser,
  parsecToReadsPrec,
  parsecToJSONParser,
) where

import Control.Applicative (many, some, (<|>))
import Control.Applicative.Combinators (choice)
import Control.Monad (replicateM)
import Control.Monad.Combinators (optional)
import Data.Aeson.Types (Parser, Value, withText)
import Data.Functor (($>))
import Data.List (intercalate, sortOn)
import Data.List.NonEmpty (NonEmpty ((:|)))
import Data.Maybe (fromJust)
import qualified Data.Text as T (unpack)
import Data.UUID (UUID)
import qualified Data.UUID as U (fromString)
import Text.Megaparsec (
  Parsec,
  ShowErrorComponent,
  anySingle,
  errorBundlePretty,
  runParser,
  try,
 )
import Text.Megaparsec.Char (
  char,
  digitChar,
  hexDigitChar,
  string',
 )
import Text.Read (readMaybe)

-- | Parse a case-insensitive human-readable boolean, including C-style numbers,
-- English yes-no and @on@ / @off@.
boolParser
  :: Ord e
  => Parsec e String Bool
boolParser :: forall e. Ord e => Parsec e String Bool
boolParser = ParsecT e String Identity Bool
true ParsecT e String Identity Bool
-> ParsecT e String Identity Bool -> ParsecT e String Identity Bool
forall a.
ParsecT e String Identity a
-> ParsecT e String Identity a -> ParsecT e String Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT e String Identity Bool
false
 where
  true :: ParsecT e String Identity Bool
true = Bool
True Bool
-> ParsecT e String Identity String
-> ParsecT e String Identity Bool
forall a b.
a -> ParsecT e String Identity b -> ParsecT e String Identity a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ [ParsecT e String Identity String]
-> ParsecT e String Identity String
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice ((String -> ParsecT e String Identity String)
-> [String] -> [ParsecT e String Identity String]
forall a b. (a -> b) -> [a] -> [b]
map String -> ParsecT e String Identity String
Tokens String -> ParsecT e String Identity (Tokens String)
forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' [String
"true", String
"y", String
"yes", String
"on", String
"1"])
  false :: ParsecT e String Identity Bool
false = Bool
False Bool
-> ParsecT e String Identity String
-> ParsecT e String Identity Bool
forall a b.
a -> ParsecT e String Identity b -> ParsecT e String Identity a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ [ParsecT e String Identity String]
-> ParsecT e String Identity String
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice ((String -> ParsecT e String Identity String)
-> [String] -> [ParsecT e String Identity String]
forall a b. (a -> b) -> [a] -> [b]
map String -> ParsecT e String Identity String
Tokens String -> ParsecT e String Identity (Tokens String)
forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' [String
"false", String
"n", String
"no", String
"off", String
"0"])

-- | Parse a 'Bounded' 'Enum' type that has a 'Show' instance, trying all
-- possibilities, case-insensitive, in the 'Enum' order.
boundedEnumShowParser
  :: forall a e
   . Ord e
  => Bounded a
  => Enum a
  => Show a
  => Parsec e String a
boundedEnumShowParser :: forall a e. (Ord e, Bounded a, Enum a, Show a) => Parsec e String a
boundedEnumShowParser =
  [ParsecT e String Identity a] -> ParsecT e String Identity a
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice ([ParsecT e String Identity a] -> ParsecT e String Identity a)
-> ([a] -> [ParsecT e String Identity a])
-> [a]
-> ParsecT e String Identity a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> ParsecT e String Identity a)
-> [a] -> [ParsecT e String Identity a]
forall a b. (a -> b) -> [a] -> [b]
map a -> ParsecT e String Identity a
forall {s} {f :: * -> *} {e} {b}.
(Tokens s ~ String, MonadParsec e s f, Show b) =>
b -> f b
parseShow ([a] -> ParsecT e String Identity a)
-> [a] -> ParsecT e String Identity a
forall a b. (a -> b) -> a -> b
$ (a -> Int) -> [a] -> [a]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Int -> Int
forall a. Num a => a -> a
negate (Int -> Int) -> (a -> Int) -> a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (String -> Int) -> (a -> String) -> a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show) [(a
forall a. Bounded a => a
minBound :: a) ..]
 where
  parseShow :: b -> f b
parseShow b
a = Tokens s -> f (Tokens s)
forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' (b -> String
forall a. Show a => a -> String
show b
a) f (Tokens s) -> b -> f b
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> b
a

-- | Parse a comma-separated list of items.
commaSeparated
  :: Ord e
  => Parsec e String a
  -> Parsec e String (NonEmpty a)
commaSeparated :: forall e a.
Ord e =>
Parsec e String a -> Parsec e String (NonEmpty a)
commaSeparated Parsec e String a
p = a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
(:|) (a -> [a] -> NonEmpty a)
-> Parsec e String a
-> ParsecT e String Identity ([a] -> NonEmpty a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parsec e String a
p ParsecT e String Identity ([a] -> NonEmpty a)
-> ParsecT e String Identity [a]
-> ParsecT e String Identity (NonEmpty a)
forall a b.
ParsecT e String Identity (a -> b)
-> ParsecT e String Identity a -> ParsecT e String Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parsec e String a -> ParsecT e String Identity [a]
forall a.
ParsecT e String Identity a -> ParsecT e String Identity [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Token String -> ParsecT e String Identity (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
',' ParsecT e String Identity Char
-> Parsec e String a -> Parsec e String a
forall a b.
ParsecT e String Identity a
-> ParsecT e String Identity b -> ParsecT e String Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parsec e String a
p)

-- | Parse any occurrence of a given parser. Consumes any input before occurrence.
occurrence
  :: Ord e
  => Parsec e String a
  -> Parsec e String a
occurrence :: forall e a. Ord e => Parsec e String a -> Parsec e String a
occurrence Parsec e String a
p = Parsec e String a
go
 where
  go :: Parsec e String a
go = Parsec e String a
p Parsec e String a -> Parsec e String a -> Parsec e String a
forall a.
ParsecT e String Identity a
-> ParsecT e String Identity a -> ParsecT e String Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (ParsecT e String Identity (Token String)
forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
anySingle ParsecT e String Identity (Token String)
-> Parsec e String a -> Parsec e String a
forall a b.
ParsecT e String Identity a
-> ParsecT e String Identity b -> ParsecT e String Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parsec e String a
go)

-- | Parse all occurrences of a given parser.
occurrences
  :: Ord e
  => Parsec e String a
  -> Parsec e String [a]
occurrences :: forall e a. Ord e => Parsec e String a -> Parsec e String [a]
occurrences = ParsecT e String Identity a -> ParsecT e String Identity [a]
forall a.
ParsecT e String Identity a -> ParsecT e String Identity [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some (ParsecT e String Identity a -> ParsecT e String Identity [a])
-> (ParsecT e String Identity a -> ParsecT e String Identity a)
-> ParsecT e String Identity a
-> ParsecT e String Identity [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsecT e String Identity a -> ParsecT e String Identity a
forall a.
ParsecT e String Identity a -> ParsecT e String Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ParsecT e String Identity a -> ParsecT e String Identity a)
-> (ParsecT e String Identity a -> ParsecT e String Identity a)
-> ParsecT e String Identity a
-> ParsecT e String Identity a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsecT e String Identity a -> ParsecT e String Identity a
forall e a. Ord e => Parsec e String a -> Parsec e String a
occurrence (ParsecT e String Identity a -> ParsecT e String Identity a)
-> (ParsecT e String Identity a -> ParsecT e String Identity a)
-> ParsecT e String Identity a
-> ParsecT e String Identity a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsecT e String Identity a -> ParsecT e String Identity a
forall a.
ParsecT e String Identity a -> ParsecT e String Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try

-- | Parse a positive number, with or without decimals prefixed by a @.@.
posDecNumParser
  :: Ord e
  => Read a
  => Parsec e String a
posDecNumParser :: forall e a. (Ord e, Read a) => Parsec e String a
posDecNumParser = do
  String
num <- ParsecT e String Identity Char -> ParsecT e String Identity String
forall a.
ParsecT e String Identity a -> ParsecT e String Identity [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some ParsecT e String Identity Char
ParsecT e String Identity (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
digitChar
  String
dec <- String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (String
"." String -> String -> String
forall a. Semigroup a => a -> a -> a
<>) (Maybe String -> String)
-> ParsecT e String Identity (Maybe String)
-> ParsecT e String Identity String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT e String Identity String
-> ParsecT e String Identity (Maybe String)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Token String -> ParsecT e String Identity (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'.' ParsecT e String Identity Char
-> ParsecT e String Identity String
-> ParsecT e String Identity String
forall a b.
ParsecT e String Identity a
-> ParsecT e String Identity b -> ParsecT e String Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT e String Identity Char -> ParsecT e String Identity String
forall a.
ParsecT e String Identity a -> ParsecT e String Identity [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some ParsecT e String Identity Char
ParsecT e String Identity (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
digitChar)

  let str :: String
str = String
num String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
dec

  Parsec e String a
-> (a -> Parsec e String a) -> Maybe a -> Parsec e String a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Parsec e String a
forall a. String -> ParsecT e String Identity a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"could not read from input: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
str)) a -> Parsec e String a
forall a. a -> ParsecT e String Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Maybe a
forall a. Read a => String -> Maybe a
readMaybe String
str)

-- | Parse a positive integer.
posNumParser
  :: Ord e
  => Read a
  => Parsec e String a
posNumParser :: forall e a. (Ord e, Read a) => Parsec e String a
posNumParser = do
  String
digits <- ParsecT e String Identity Char -> ParsecT e String Identity String
forall a.
ParsecT e String Identity a -> ParsecT e String Identity [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some ParsecT e String Identity Char
ParsecT e String Identity (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
digitChar
  Parsec e String a
-> (a -> Parsec e String a) -> Maybe a -> Parsec e String a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
    (String -> Parsec e String a
forall a. String -> ParsecT e String Identity a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"could not read from digits: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
digits))
    a -> Parsec e String a
forall a. a -> ParsecT e String Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (String -> Maybe a
forall a. Read a => String -> Maybe a
readMaybe String
digits) 

-- | Parse an integer, without any space between minus sign and digits.
numParser
  :: Ord e
  => Num a
  => Read a
  => Parsec e String a
numParser :: forall e a. (Ord e, Num a, Read a) => Parsec e String a
numParser = (Token String -> ParsecT e String Identity (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'-' ParsecT e String Identity Char
-> ParsecT e String Identity a -> ParsecT e String Identity a
forall a b.
ParsecT e String Identity a
-> ParsecT e String Identity b -> ParsecT e String Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> a
forall a. Num a => a -> a
negate (a -> a)
-> ParsecT e String Identity a -> ParsecT e String Identity a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT e String Identity a
forall e a. (Ord e, Read a) => Parsec e String a
posNumParser) ParsecT e String Identity a
-> ParsecT e String Identity a -> ParsecT e String Identity a
forall a.
ParsecT e String Identity a
-> ParsecT e String Identity a -> ParsecT e String Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT e String Identity a
forall e a. (Ord e, Read a) => Parsec e String a
posNumParser

-- | Convert a 'Parsec' parser into a 'Parser' suited for 'Data.Aeson.FromJSON'
-- instances.
parsecToJSONParser
  :: ShowErrorComponent e
  => String
  -- ^ Parser name.
  -> Parsec e String a
  -- ^ Parser.
  -> (Value -> Parser a)
parsecToJSONParser :: forall e a.
ShowErrorComponent e =>
String -> Parsec e String a -> Value -> Parser a
parsecToJSONParser String
n Parsec e String a
p =
  String -> (Text -> Parser a) -> Value -> Parser a
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
n ((ParseErrorBundle String e -> Parser a)
-> (a -> Parser a)
-> Either (ParseErrorBundle String e) a
-> Parser a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Parser a
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser a)
-> (ParseErrorBundle String e -> String)
-> ParseErrorBundle String e
-> Parser a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseErrorBundle String e -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorBundlePretty) a -> Parser a
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (ParseErrorBundle String e) a -> Parser a)
-> (Text -> Either (ParseErrorBundle String e) a)
-> Text
-> Parser a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parsec e String a
-> String -> String -> Either (ParseErrorBundle String e) a
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
runParser Parsec e String a
p String
n (String -> Either (ParseErrorBundle String e) a)
-> (Text -> String) -> Text -> Either (ParseErrorBundle String e) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack)

-- | Convert a 'Parsec' parser into a 'ReadS' parser. Useful for defining 'Read'
-- instances with 'Text.Megaparsec'.
parsecToReadsPrec
  :: Parsec e String a
  -> ReadS a
parsecToReadsPrec :: forall e a. Parsec e String a -> ReadS a
parsecToReadsPrec Parsec e String a
p = (ParseErrorBundle String e -> [(a, String)])
-> (a -> [(a, String)])
-> Either (ParseErrorBundle String e) a
-> [(a, String)]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([(a, String)] -> ParseErrorBundle String e -> [(a, String)]
forall a b. a -> b -> a
const []) (\a
x -> [(a
x, String
"")]) (Either (ParseErrorBundle String e) a -> [(a, String)])
-> (String -> Either (ParseErrorBundle String e) a)
-> String
-> [(a, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parsec e String a
-> String -> String -> Either (ParseErrorBundle String e) a
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
runParser Parsec e String a
p String
"string"

-- | Parse a RFC4122-compliant UUID.
uuidParser
  :: Ord e
  => Parsec e String UUID
uuidParser :: forall e. Ord e => Parsec e String UUID
uuidParser = do
  String
part1 <- Int
-> ParsecT e String Identity Char
-> ParsecT e String Identity String
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
8 ParsecT e String Identity Char
ParsecT e String Identity (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
hexDigitChar ParsecT e String Identity String
-> ParsecT e String Identity Char
-> ParsecT e String Identity String
forall a b.
ParsecT e String Identity a
-> ParsecT e String Identity b -> ParsecT e String Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Token String -> ParsecT e String Identity (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'-'
  String
part2 <- Int
-> ParsecT e String Identity Char
-> ParsecT e String Identity String
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
4 ParsecT e String Identity Char
ParsecT e String Identity (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
hexDigitChar ParsecT e String Identity String
-> ParsecT e String Identity Char
-> ParsecT e String Identity String
forall a b.
ParsecT e String Identity a
-> ParsecT e String Identity b -> ParsecT e String Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Token String -> ParsecT e String Identity (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'-'
  String
part3 <- Int
-> ParsecT e String Identity Char
-> ParsecT e String Identity String
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
4 ParsecT e String Identity Char
ParsecT e String Identity (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
hexDigitChar ParsecT e String Identity String
-> ParsecT e String Identity Char
-> ParsecT e String Identity String
forall a b.
ParsecT e String Identity a
-> ParsecT e String Identity b -> ParsecT e String Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Token String -> ParsecT e String Identity (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'-'
  String
part4 <- Int
-> ParsecT e String Identity Char
-> ParsecT e String Identity String
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
4 ParsecT e String Identity Char
ParsecT e String Identity (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
hexDigitChar ParsecT e String Identity String
-> ParsecT e String Identity Char
-> ParsecT e String Identity String
forall a b.
ParsecT e String Identity a
-> ParsecT e String Identity b -> ParsecT e String Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Token String -> ParsecT e String Identity (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'-'
  String
part5 <- Int
-> ParsecT e String Identity Char
-> ParsecT e String Identity String
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
12 ParsecT e String Identity Char
ParsecT e String Identity (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
hexDigitChar

  UUID -> Parsec e String UUID
forall a. a -> ParsecT e String Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (Maybe UUID -> UUID
forall a. HasCallStack => Maybe a -> a
fromJust
     (String -> Maybe UUID
U.fromString
      (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"-" [String
part1, String
part2, String
part3, String
part4, String
part5])))