{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE InstanceSigs               #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE TypeApplications           #-}
{-# LANGUAGE TypeFamilies               #-}
--------------------------------------------------------------------
-- |
-- Module      : XMonad.Util.Parser
-- Description : A parser combinator library for xmonad
-- Copyright   : (c) 2021  Tony Zorman
-- License     : BSD3
-- Maintainer  : Tony Zorman <soliditsallgood@mailbox.org>
-- Stability   : experimental
-- Portability : non-portable
--
-- A small wrapper around the 'ReadP' parser combinator in @base@,
-- providing a more intuitive behaviour.  While it's theoretically nice
-- that 'ReadP' is actually commutative, this makes a lot of parsing
-- operations rather awkward—more often than not, one only wants the
-- argument that's parsed "first".
--
-- Due to the left-biased nature of the chosen semigroup implementation,
-- using functions like 'many' or 'optional' from "Control.Applicative"
-- now yields more consistent behaviour with other parser combinator
-- libraries.
--
--------------------------------------------------------------------
module XMonad.Util.Parser (
  -- * Usage
  -- $usage

  -- * Running
  Parser,
  runParser,

  -- * Primitive Parsers
  eof,
  num,
  char,
  string,
  skipSpaces,
  get,
  look,

  -- * Combining Parsers
  satisfy,
  choice,
  many1,
  sepBy,
  sepBy1,
  endBy,
  endBy1,
  munch,
  munch1,
  pfail
) where

import XMonad.Prelude

import qualified Text.ParserCombinators.ReadP as ReadP

import Data.Coerce (coerce)
import Data.String (IsString (fromString))
import Text.ParserCombinators.ReadP (ReadP, (<++))

{- $usage

NOTE: This module is mostly intended for developing of other modules.
If you are a users, you probably won't find much use here—you have been
warned.

The high-level API tries to stay as close to 'ReadP' as possible.  If
you are familiar with that then no functions here should surprise you.

One notable usability difference when forcing left-biasedness is /when/
one wants to disambiguate a parse.  For normal 'ReadP' usage this
happens after the actual parsing stage by going through the list of
successful parses.  For 'Parser' it does when constructing the relevant
combinators, leading to only one successful parse.  As an example,
consider the 'ReadP'-based parser

> pLangle = ReadP.string "<"
> pLongerSequence = ReadP.char '<' *> ReadP.string "f" <* ReadP.char '>'
> pCombination = pLangle ReadP.+++ pLongerSequence

Parsing the string @"<f>"@ will return

>>> ReadP.readP_to_S pCombination "<f>"
[("<","f>"),("f","")]

One would now need to, for example, filter for the second (leftover)
string being empty and take the head of the resulting list (which may
still have more than one element).

With 'Parser', the same situation would look like the following

> pLangle' = string "<"
> pLongerSequence' = char '<' *> string "f" <* char '>'
> pCombination' = pLongerSequence' <> pLangle'

Notice how @pLangle'@ and @pLongerSequence'@ have traded places—since we
are not forcing @pLangle'@ to consume the entire string and @(<>)@ is
left-biased, @pLongerSequence'@ parses a superset of @pLangle'@!
Running @runParser pCombination'@ now yields the expected result:

>>> runParser pCombination' "<f>"
Just "f"

One might also define @pLangle'@ as @string "<" <* eof@, which would
enable a definition of @pCombination' = pLangle' <> pLongerSequence'@.

For example uses, see "XMonad.Util.EZConfig" or "XMonad.Prompt.OrgMode".
-}

-- Parser :: Type -> Type
newtype Parser a = Parser (ReadP a)
  deriving newtype ((forall a b. (a -> b) -> Parser a -> Parser b)
-> (forall a b. a -> Parser b -> Parser a) -> Functor Parser
forall a b. a -> Parser b -> Parser a
forall a b. (a -> b) -> Parser a -> Parser 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 -> Parser b -> Parser a
$c<$ :: forall a b. a -> Parser b -> Parser a
fmap :: forall a b. (a -> b) -> Parser a -> Parser b
$cfmap :: forall a b. (a -> b) -> Parser a -> Parser b
Functor, Functor Parser
Functor Parser
-> (forall a. a -> Parser a)
-> (forall a b. Parser (a -> b) -> Parser a -> Parser b)
-> (forall a b c.
    (a -> b -> c) -> Parser a -> Parser b -> Parser c)
-> (forall a b. Parser a -> Parser b -> Parser b)
-> (forall a b. Parser a -> Parser b -> Parser a)
-> Applicative Parser
forall a. a -> Parser a
forall a b. Parser a -> Parser b -> Parser a
forall a b. Parser a -> Parser b -> Parser b
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall a b c. (a -> b -> c) -> Parser a -> Parser b -> Parser c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. Parser a -> Parser b -> Parser a
$c<* :: forall a b. Parser a -> Parser b -> Parser a
*> :: forall a b. Parser a -> Parser b -> Parser b
$c*> :: forall a b. Parser a -> Parser b -> Parser b
liftA2 :: forall a b c. (a -> b -> c) -> Parser a -> Parser b -> Parser c
$cliftA2 :: forall a b c. (a -> b -> c) -> Parser a -> Parser b -> Parser c
<*> :: forall a b. Parser (a -> b) -> Parser a -> Parser b
$c<*> :: forall a b. Parser (a -> b) -> Parser a -> Parser b
pure :: forall a. a -> Parser a
$cpure :: forall a. a -> Parser a
Applicative, Applicative Parser
Applicative Parser
-> (forall a b. Parser a -> (a -> Parser b) -> Parser b)
-> (forall a b. Parser a -> Parser b -> Parser b)
-> (forall a. a -> Parser a)
-> Monad Parser
forall a. a -> Parser a
forall a b. Parser a -> Parser b -> Parser b
forall a b. Parser a -> (a -> Parser b) -> Parser b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> Parser a
$creturn :: forall a. a -> Parser a
>> :: forall a b. Parser a -> Parser b -> Parser b
$c>> :: forall a b. Parser a -> Parser b -> Parser b
>>= :: forall a b. Parser a -> (a -> Parser b) -> Parser b
$c>>= :: forall a b. Parser a -> (a -> Parser b) -> Parser b
Monad)

instance Semigroup (Parser a) where
  -- | Local, exclusive, left-biased choice: If left parser locally
  -- produces any result at all, then right parser is not used.
  (<>) :: Parser a -> Parser a -> Parser a
  <> :: Parser a -> Parser a -> Parser a
(<>) = (ReadP a -> ReadP a -> ReadP a) -> Parser a -> Parser a -> Parser a
coerce (forall a. ReadP a -> ReadP a -> ReadP a
(<++) @a)

instance Monoid (Parser a) where
  -- | A parser that always fails.
  mempty :: Parser a
  mempty :: Parser a
mempty = ReadP a -> Parser a
forall a. ReadP a -> Parser a
Parser ReadP a
forall (f :: * -> *) a. Alternative f => f a
empty

instance Alternative Parser where
  empty :: Parser a
  empty :: forall a. Parser a
empty = Parser a
forall a. Monoid a => a
mempty

  (<|>) :: Parser a -> Parser a -> Parser a
  <|> :: forall a. Parser a -> Parser a -> Parser a
(<|>) = Parser a -> Parser a -> Parser a
forall a. Semigroup a => a -> a -> a
(<>)

-- | When @-XOverloadedStrings@ is on, treat a string @s@ as the parser
-- @'string' s@, when appropriate.  This allows one to write things like
-- @"a" *> otherParser@ instead of @'string' "a" *> otherParser@.
instance a ~ String => IsString (Parser a) where
  fromString :: String -> Parser a
  fromString :: String -> Parser a
fromString = String -> Parser a
String -> Parser String
string

-- | Run a parser on a given string.
runParser :: Parser a -> String -> Maybe a
runParser :: forall a. Parser a -> String -> Maybe a
runParser (Parser ReadP a
p) = ((a, String) -> a) -> Maybe (a, String) -> Maybe a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, String) -> a
forall a b. (a, b) -> a
fst (Maybe (a, String) -> Maybe a)
-> (String -> Maybe (a, String)) -> String -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(a, String)] -> Maybe (a, String)
forall a. [a] -> Maybe a
listToMaybe ([(a, String)] -> Maybe (a, String))
-> (String -> [(a, String)]) -> String -> Maybe (a, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReadP a -> String -> [(a, String)]
forall a. ReadP a -> ReadS a
ReadP.readP_to_S ReadP a
p

-- | Always fails
pfail :: Parser a
pfail :: forall a. Parser a
pfail = Parser a
forall (f :: * -> *) a. Alternative f => f a
empty

-- | Consume and return the next character.  Fails if there is no input
-- left.
get :: Parser Char
get :: Parser Char
get = ReadP Char -> Parser Char
coerce ReadP Char
ReadP.get

-- | Look-ahead: return the part of the input that is left, without
-- consuming it.
look :: Parser String
look :: Parser String
look = ReadP String -> Parser String
coerce ReadP String
ReadP.look

-- | Succeeds if and only if we are at the end of input.
eof :: Parser ()
eof :: Parser ()
eof = ReadP () -> Parser ()
coerce ReadP ()
ReadP.eof

-- | Parse an integral number number.
num :: (Read a, Integral a) => Parser a
num :: forall a. (Read a, Integral a) => Parser a
num = String -> a
forall a. Read a => String -> a
read (String -> a) -> Parser String -> Parser a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser String
munch1 Char -> Bool
isDigit
{-# SPECIALISE num :: Parser Word    #-}
{-# SPECIALISE num :: Parser Int     #-}
{-# SPECIALISE num :: Parser Integer #-}

-- | Parse and return the specified character.
char :: Char -> Parser Char
char :: Char -> Parser Char
char = (Char -> ReadP Char) -> Char -> Parser Char
coerce Char -> ReadP Char
ReadP.char

-- | Parse and return the specified string.
string :: String -> Parser String
string :: String -> Parser String
string = (String -> ReadP String) -> String -> Parser String
coerce String -> ReadP String
ReadP.string

-- | Skip all whitespace.
skipSpaces :: Parser ()
skipSpaces :: Parser ()
skipSpaces = ReadP () -> Parser ()
coerce ReadP ()
ReadP.skipSpaces

-- | Consume and return the next character if it satisfies the specified
-- predicate.
satisfy :: (Char -> Bool) -> Parser Char
satisfy :: (Char -> Bool) -> Parser Char
satisfy = ((Char -> Bool) -> ReadP Char) -> (Char -> Bool) -> Parser Char
coerce (Char -> Bool) -> ReadP Char
ReadP.satisfy

-- | Combine all parsers in the given list in a left-biased way.
choice :: [Parser a] -> Parser a
choice :: forall a. [Parser a] -> Parser a
choice = (Parser a -> Parser a -> Parser a)
-> Parser a -> [Parser a] -> Parser a
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Parser a -> Parser a -> Parser a
forall a. Semigroup a => a -> a -> a
(<>) Parser a
forall a. Monoid a => a
mempty

-- | Parse the first zero or more characters satisfying the predicate.
-- Always succeeds; returns an empty string if the predicate returns
-- @False@ on the first character of input.
munch :: (Char -> Bool) -> Parser String
munch :: (Char -> Bool) -> Parser String
munch = ((Char -> Bool) -> ReadP String) -> (Char -> Bool) -> Parser String
coerce (Char -> Bool) -> ReadP String
ReadP.munch

-- | Parse the first one or more characters satisfying the predicate.
-- Fails if none, else succeeds exactly once having consumed all the
-- characters.
munch1 :: (Char -> Bool) -> Parser String
munch1 :: (Char -> Bool) -> Parser String
munch1 = ((Char -> Bool) -> ReadP String) -> (Char -> Bool) -> Parser String
coerce (Char -> Bool) -> ReadP String
ReadP.munch1

-- | @endBy p sep@ parses zero or more occurrences of @p@, separated and
-- ended by @sep@.
endBy :: Parser a -> Parser sep -> Parser [a]
endBy :: forall a sep. Parser a -> Parser sep -> Parser [a]
endBy Parser a
p Parser sep
sep = Parser a -> Parser [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Parser a
p Parser a -> Parser sep -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser sep
sep)

-- | @endBy p sep@ parses one or more occurrences of @p@, separated and
-- ended by @sep@.
endBy1 :: Parser a -> Parser sep -> Parser [a]
endBy1 :: forall a sep. Parser a -> Parser sep -> Parser [a]
endBy1 Parser a
p Parser sep
sep = Parser a -> Parser [a]
forall a. Parser a -> Parser [a]
many1 (Parser a
p Parser a -> Parser sep -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser sep
sep)

-- | Parse one or more occurrences of the given parser.
many1 :: Parser a -> Parser [a]
many1 :: forall a. Parser a -> Parser [a]
many1 Parser a
p = (a -> [a] -> [a]) -> Parser a -> Parser [a] -> Parser [a]
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (:) Parser a
p (Parser a -> Parser [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser a
p)

-- | @sepBy p sep@ parses zero or more occurrences of @p@, separated by
-- @sep@.  Returns a list of values returned by @p@.
sepBy :: Parser a -> Parser sep -> Parser [a]
sepBy :: forall a sep. Parser a -> Parser sep -> Parser [a]
sepBy Parser a
p Parser sep
sep = Parser a -> Parser sep -> Parser [a]
forall a sep. Parser a -> Parser sep -> Parser [a]
sepBy1 Parser a
p Parser sep
sep Parser [a] -> Parser [a] -> Parser [a]
forall a. Semigroup a => a -> a -> a
<> [a] -> Parser [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

-- | @sepBy1 p sep@ parses one or more occurrences of @p@, separated by
-- @sep@.  Returns a list of values returned by @p@.
sepBy1 :: Parser a -> Parser sep -> Parser [a]
sepBy1 :: forall a sep. Parser a -> Parser sep -> Parser [a]
sepBy1 Parser a
p Parser sep
sep = (a -> [a] -> [a]) -> Parser a -> Parser [a] -> Parser [a]
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (:) Parser a
p (Parser a -> Parser [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Parser sep
sep Parser sep -> Parser a -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser a
p))