-- | Common parsers.
-- See <https://hackage.haskell.org/package/megaparsec-9.0.1/docs/Text-Megaparsec-Char-Lexer.html Text.Megaparsec.Char.Lexer>.
module SimpleParser.Common
  ( TextLabel (..)
  , EmbedTextLabel (..)
  , CompoundTextLabel (..)
  , sepByParser
  , betweenParser
  , lexemeParser
  , newlineParser
  , spaceParser
  , hspaceParser
  , spaceParser1
  , hspaceParser1
  , decimalParser
  , signedNumStartPred
  , scientificParser
  , numParser
  , Sign (..)
  , signParser
  , applySign
  , signedParser
  , escapedStringParser
  , spanParser
  , getStreamPos
  ) where

import Control.Monad (void)
import Control.Monad.State (get, gets)
import Data.Char (digitToInt, isDigit, isSpace)
import Data.Functor (($>))
import Data.List (foldl')
import Data.Scientific (Scientific)
import qualified Data.Scientific as Sci
import SimpleParser.Chunked (Chunked (..))
import SimpleParser.Input (dropTokensWhile, dropTokensWhile1, foldTokensWhile, matchToken, peekToken, popToken,
                           takeTokensWhile1)
import SimpleParser.Parser (ParserT, defaultParser, greedyStarParser, optionalParser, orParser)
import SimpleParser.Stream (PosStream (..), Span (..), Stream (..))

-- | Enumeration of common labels in textual parsing.
data TextLabel =
    TextLabelSpace
  | TextLabelHSpace
  | TextLabelDigit
  deriving (TextLabel -> TextLabel -> Bool
(TextLabel -> TextLabel -> Bool)
-> (TextLabel -> TextLabel -> Bool) -> Eq TextLabel
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TextLabel -> TextLabel -> Bool
$c/= :: TextLabel -> TextLabel -> Bool
== :: TextLabel -> TextLabel -> Bool
$c== :: TextLabel -> TextLabel -> Bool
Eq, Int -> TextLabel -> ShowS
[TextLabel] -> ShowS
TextLabel -> String
(Int -> TextLabel -> ShowS)
-> (TextLabel -> String)
-> ([TextLabel] -> ShowS)
-> Show TextLabel
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TextLabel] -> ShowS
$cshowList :: [TextLabel] -> ShowS
show :: TextLabel -> String
$cshow :: TextLabel -> String
showsPrec :: Int -> TextLabel -> ShowS
$cshowsPrec :: Int -> TextLabel -> ShowS
Show)

class EmbedTextLabel l where
  embedTextLabel :: TextLabel -> l

instance EmbedTextLabel TextLabel where
  embedTextLabel :: TextLabel -> TextLabel
embedTextLabel = TextLabel -> TextLabel
forall a. a -> a
id

-- | Union of text and custom labels
data CompoundTextLabel l =
    CompoundTextLabelText !TextLabel
  | CompoundTextLabelCustom !l
  deriving (CompoundTextLabel l -> CompoundTextLabel l -> Bool
(CompoundTextLabel l -> CompoundTextLabel l -> Bool)
-> (CompoundTextLabel l -> CompoundTextLabel l -> Bool)
-> Eq (CompoundTextLabel l)
forall l.
Eq l =>
CompoundTextLabel l -> CompoundTextLabel l -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CompoundTextLabel l -> CompoundTextLabel l -> Bool
$c/= :: forall l.
Eq l =>
CompoundTextLabel l -> CompoundTextLabel l -> Bool
== :: CompoundTextLabel l -> CompoundTextLabel l -> Bool
$c== :: forall l.
Eq l =>
CompoundTextLabel l -> CompoundTextLabel l -> Bool
Eq, Int -> CompoundTextLabel l -> ShowS
[CompoundTextLabel l] -> ShowS
CompoundTextLabel l -> String
(Int -> CompoundTextLabel l -> ShowS)
-> (CompoundTextLabel l -> String)
-> ([CompoundTextLabel l] -> ShowS)
-> Show (CompoundTextLabel l)
forall l. Show l => Int -> CompoundTextLabel l -> ShowS
forall l. Show l => [CompoundTextLabel l] -> ShowS
forall l. Show l => CompoundTextLabel l -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CompoundTextLabel l] -> ShowS
$cshowList :: forall l. Show l => [CompoundTextLabel l] -> ShowS
show :: CompoundTextLabel l -> String
$cshow :: forall l. Show l => CompoundTextLabel l -> String
showsPrec :: Int -> CompoundTextLabel l -> ShowS
$cshowsPrec :: forall l. Show l => Int -> CompoundTextLabel l -> ShowS
Show, a -> CompoundTextLabel b -> CompoundTextLabel a
(a -> b) -> CompoundTextLabel a -> CompoundTextLabel b
(forall a b.
 (a -> b) -> CompoundTextLabel a -> CompoundTextLabel b)
-> (forall a b. a -> CompoundTextLabel b -> CompoundTextLabel a)
-> Functor CompoundTextLabel
forall a b. a -> CompoundTextLabel b -> CompoundTextLabel a
forall a b. (a -> b) -> CompoundTextLabel a -> CompoundTextLabel b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> CompoundTextLabel b -> CompoundTextLabel a
$c<$ :: forall a b. a -> CompoundTextLabel b -> CompoundTextLabel a
fmap :: (a -> b) -> CompoundTextLabel a -> CompoundTextLabel b
$cfmap :: forall a b. (a -> b) -> CompoundTextLabel a -> CompoundTextLabel b
Functor, CompoundTextLabel a -> Bool
(a -> m) -> CompoundTextLabel a -> m
(a -> b -> b) -> b -> CompoundTextLabel a -> b
(forall m. Monoid m => CompoundTextLabel m -> m)
-> (forall m a. Monoid m => (a -> m) -> CompoundTextLabel a -> m)
-> (forall m a. Monoid m => (a -> m) -> CompoundTextLabel a -> m)
-> (forall a b. (a -> b -> b) -> b -> CompoundTextLabel a -> b)
-> (forall a b. (a -> b -> b) -> b -> CompoundTextLabel a -> b)
-> (forall b a. (b -> a -> b) -> b -> CompoundTextLabel a -> b)
-> (forall b a. (b -> a -> b) -> b -> CompoundTextLabel a -> b)
-> (forall a. (a -> a -> a) -> CompoundTextLabel a -> a)
-> (forall a. (a -> a -> a) -> CompoundTextLabel a -> a)
-> (forall a. CompoundTextLabel a -> [a])
-> (forall a. CompoundTextLabel a -> Bool)
-> (forall a. CompoundTextLabel a -> Int)
-> (forall a. Eq a => a -> CompoundTextLabel a -> Bool)
-> (forall a. Ord a => CompoundTextLabel a -> a)
-> (forall a. Ord a => CompoundTextLabel a -> a)
-> (forall a. Num a => CompoundTextLabel a -> a)
-> (forall a. Num a => CompoundTextLabel a -> a)
-> Foldable CompoundTextLabel
forall a. Eq a => a -> CompoundTextLabel a -> Bool
forall a. Num a => CompoundTextLabel a -> a
forall a. Ord a => CompoundTextLabel a -> a
forall m. Monoid m => CompoundTextLabel m -> m
forall a. CompoundTextLabel a -> Bool
forall a. CompoundTextLabel a -> Int
forall a. CompoundTextLabel a -> [a]
forall a. (a -> a -> a) -> CompoundTextLabel a -> a
forall m a. Monoid m => (a -> m) -> CompoundTextLabel a -> m
forall b a. (b -> a -> b) -> b -> CompoundTextLabel a -> b
forall a b. (a -> b -> b) -> b -> CompoundTextLabel a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: CompoundTextLabel a -> a
$cproduct :: forall a. Num a => CompoundTextLabel a -> a
sum :: CompoundTextLabel a -> a
$csum :: forall a. Num a => CompoundTextLabel a -> a
minimum :: CompoundTextLabel a -> a
$cminimum :: forall a. Ord a => CompoundTextLabel a -> a
maximum :: CompoundTextLabel a -> a
$cmaximum :: forall a. Ord a => CompoundTextLabel a -> a
elem :: a -> CompoundTextLabel a -> Bool
$celem :: forall a. Eq a => a -> CompoundTextLabel a -> Bool
length :: CompoundTextLabel a -> Int
$clength :: forall a. CompoundTextLabel a -> Int
null :: CompoundTextLabel a -> Bool
$cnull :: forall a. CompoundTextLabel a -> Bool
toList :: CompoundTextLabel a -> [a]
$ctoList :: forall a. CompoundTextLabel a -> [a]
foldl1 :: (a -> a -> a) -> CompoundTextLabel a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> CompoundTextLabel a -> a
foldr1 :: (a -> a -> a) -> CompoundTextLabel a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> CompoundTextLabel a -> a
foldl' :: (b -> a -> b) -> b -> CompoundTextLabel a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> CompoundTextLabel a -> b
foldl :: (b -> a -> b) -> b -> CompoundTextLabel a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> CompoundTextLabel a -> b
foldr' :: (a -> b -> b) -> b -> CompoundTextLabel a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> CompoundTextLabel a -> b
foldr :: (a -> b -> b) -> b -> CompoundTextLabel a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> CompoundTextLabel a -> b
foldMap' :: (a -> m) -> CompoundTextLabel a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> CompoundTextLabel a -> m
foldMap :: (a -> m) -> CompoundTextLabel a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> CompoundTextLabel a -> m
fold :: CompoundTextLabel m -> m
$cfold :: forall m. Monoid m => CompoundTextLabel m -> m
Foldable, Functor CompoundTextLabel
Foldable CompoundTextLabel
Functor CompoundTextLabel
-> Foldable CompoundTextLabel
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> CompoundTextLabel a -> f (CompoundTextLabel b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    CompoundTextLabel (f a) -> f (CompoundTextLabel a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> CompoundTextLabel a -> m (CompoundTextLabel b))
-> (forall (m :: * -> *) a.
    Monad m =>
    CompoundTextLabel (m a) -> m (CompoundTextLabel a))
-> Traversable CompoundTextLabel
(a -> f b) -> CompoundTextLabel a -> f (CompoundTextLabel b)
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
CompoundTextLabel (m a) -> m (CompoundTextLabel a)
forall (f :: * -> *) a.
Applicative f =>
CompoundTextLabel (f a) -> f (CompoundTextLabel a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> CompoundTextLabel a -> m (CompoundTextLabel b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> CompoundTextLabel a -> f (CompoundTextLabel b)
sequence :: CompoundTextLabel (m a) -> m (CompoundTextLabel a)
$csequence :: forall (m :: * -> *) a.
Monad m =>
CompoundTextLabel (m a) -> m (CompoundTextLabel a)
mapM :: (a -> m b) -> CompoundTextLabel a -> m (CompoundTextLabel b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> CompoundTextLabel a -> m (CompoundTextLabel b)
sequenceA :: CompoundTextLabel (f a) -> f (CompoundTextLabel a)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
CompoundTextLabel (f a) -> f (CompoundTextLabel a)
traverse :: (a -> f b) -> CompoundTextLabel a -> f (CompoundTextLabel b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> CompoundTextLabel a -> f (CompoundTextLabel b)
$cp2Traversable :: Foldable CompoundTextLabel
$cp1Traversable :: Functor CompoundTextLabel
Traversable)

instance EmbedTextLabel (CompoundTextLabel l) where
  embedTextLabel :: TextLabel -> CompoundTextLabel l
embedTextLabel = TextLabel -> CompoundTextLabel l
forall l. TextLabel -> CompoundTextLabel l
CompoundTextLabelText

-- | Yields the maximal list of separated items. May return an empty list.
sepByParser :: (Chunked seq elem, Monad m) =>
  -- | How to parse item
  ParserT l s e m elem ->
  -- | How to parse separator
  ParserT l s e m () ->
  ParserT l s e m seq
sepByParser :: ParserT l s e m elem -> ParserT l s e m () -> ParserT l s e m seq
sepByParser ParserT l s e m elem
thing ParserT l s e m ()
sep = do
  Maybe elem
ma <- ParserT l s e m elem -> ParserT l s e m (Maybe elem)
forall (m :: * -> *) l s e a.
Monad m =>
ParserT l s e m a -> ParserT l s e m (Maybe a)
optionalParser ParserT l s e m elem
thing
  case Maybe elem
ma of
    Maybe elem
Nothing -> seq -> ParserT l s e m seq
forall (f :: * -> *) a. Applicative f => a -> f a
pure seq
forall a. Monoid a => a
mempty
    Just elem
a -> do
      seq
as <- ParserT l s e m elem -> ParserT l s e m seq
forall seq elem (m :: * -> *) l s e.
(Chunked seq elem, Monad m) =>
ParserT l s e m elem -> ParserT l s e m seq
greedyStarParser (ParserT l s e m ()
sep ParserT l s e m () -> ParserT l s e m elem -> ParserT l s e m elem
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParserT l s e m elem
thing)
      seq -> ParserT l s e m seq
forall (f :: * -> *) a. Applicative f => a -> f a
pure (elem -> seq -> seq
forall chunk token. Chunked chunk token => token -> chunk -> chunk
consChunk elem
a seq
as)

-- | Parses between start and end markers.
betweenParser :: Monad m =>
  -- | How to parse start
  ParserT l s e m () ->
  -- | How to parse end
  ParserT l s e m () ->
  -- | How to parse inside
  ParserT l s e m a ->
  ParserT l s e m a
betweenParser :: ParserT l s e m ()
-> ParserT l s e m () -> ParserT l s e m a -> ParserT l s e m a
betweenParser ParserT l s e m ()
start ParserT l s e m ()
end ParserT l s e m a
thing = do
  ParserT l s e m ()
start
  a
a <- ParserT l s e m a
thing
  ParserT l s e m ()
end
  a -> ParserT l s e m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a

-- | A wrapper for lexemes (equivalent to Megaparsec's 'lexeme').
lexemeParser :: Monad m =>
  -- | How to consume white space after lexeme
  ParserT l s e m () ->
  -- | How to parse actual lexeme
  ParserT l s e m a ->
  ParserT l s e m a
lexemeParser :: ParserT l s e m () -> ParserT l s e m a -> ParserT l s e m a
lexemeParser ParserT l s e m ()
spc ParserT l s e m a
p = ParserT l s e m a
p ParserT l s e m a -> ParserT l s e m () -> ParserT l s e m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParserT l s e m ()
spc

-- | Consumes a newline character.
newlineParser :: (Stream s, Token s ~ Char, Monad m) => ParserT l s e m ()
newlineParser :: ParserT l s e m ()
newlineParser = ParserT l s e m Char -> ParserT l s e m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Token s -> ParserT l s e m (Token s)
forall s (m :: * -> *) l e.
(Stream s, Monad m, Eq (Token s)) =>
Token s -> ParserT l s e m (Token s)
matchToken Char
Token s
'\n')

-- | Consumes 0 or more space characters.
spaceParser :: (Stream s, Token s ~ Char, Monad m) => ParserT l s e m ()
spaceParser :: ParserT l s e m ()
spaceParser = ParserT l s e m Int -> ParserT l s e m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ((Token s -> Bool) -> ParserT l s e m Int
forall s (m :: * -> *) l e.
(Stream s, Monad m) =>
(Token s -> Bool) -> ParserT l s e m Int
dropTokensWhile Char -> Bool
Token s -> Bool
isSpace)

isHSpace :: Char -> Bool
isHSpace :: Char -> Bool
isHSpace Char
c = Char -> Bool
isSpace Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\r'

-- | Consumes 0 or more non-line-break space characters
hspaceParser :: (Stream s, Token s ~ Char, Monad m) => ParserT l s e m ()
hspaceParser :: ParserT l s e m ()
hspaceParser = ParserT l s e m Int -> ParserT l s e m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ((Token s -> Bool) -> ParserT l s e m Int
forall s (m :: * -> *) l e.
(Stream s, Monad m) =>
(Token s -> Bool) -> ParserT l s e m Int
dropTokensWhile Char -> Bool
Token s -> Bool
isHSpace)

-- | Consumes 1 or more space characters.
spaceParser1 :: (EmbedTextLabel l, Stream s, Token s ~ Char, Monad m) => ParserT l s e m ()
spaceParser1 :: ParserT l s e m ()
spaceParser1 = ParserT l s e m Int -> ParserT l s e m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Maybe l -> (Token s -> Bool) -> ParserT l s e m Int
forall s (m :: * -> *) l e.
(Stream s, Monad m) =>
Maybe l -> (Token s -> Bool) -> ParserT l s e m Int
dropTokensWhile1 (l -> Maybe l
forall a. a -> Maybe a
Just (TextLabel -> l
forall l. EmbedTextLabel l => TextLabel -> l
embedTextLabel TextLabel
TextLabelSpace)) Char -> Bool
Token s -> Bool
isSpace)

-- | Consumes 1 or more non-line-break space characters
hspaceParser1 :: (EmbedTextLabel l, Stream s, Token s ~ Char, Monad m) => ParserT l s e m ()
hspaceParser1 :: ParserT l s e m ()
hspaceParser1 = ParserT l s e m Int -> ParserT l s e m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Maybe l -> (Token s -> Bool) -> ParserT l s e m Int
forall s (m :: * -> *) l e.
(Stream s, Monad m) =>
Maybe l -> (Token s -> Bool) -> ParserT l s e m Int
dropTokensWhile1 (l -> Maybe l
forall a. a -> Maybe a
Just (TextLabel -> l
forall l. EmbedTextLabel l => TextLabel -> l
embedTextLabel TextLabel
TextLabelHSpace)) Char -> Bool
Token s -> Bool
isHSpace)

-- | Parses an integer in decimal representation (equivalent to Megaparsec's 'decimal').
decimalParser :: (EmbedTextLabel l, Stream s, Token s ~ Char, Monad m, Num a) => ParserT l s e m a
decimalParser :: ParserT l s e m a
decimalParser = (Chunk s -> a) -> ParserT l s e m (Chunk s) -> ParserT l s e m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Chunk s -> a
mkNum (Maybe l -> (Token s -> Bool) -> ParserT l s e m (Chunk s)
forall s (m :: * -> *) l e.
(Stream s, Monad m) =>
Maybe l -> (Token s -> Bool) -> ParserT l s e m (Chunk s)
takeTokensWhile1 (l -> Maybe l
forall a. a -> Maybe a
Just (TextLabel -> l
forall l. EmbedTextLabel l => TextLabel -> l
embedTextLabel TextLabel
TextLabelDigit)) Char -> Bool
Token s -> Bool
isDigit) where
  mkNum :: Chunk s -> a
mkNum = (a -> Char -> a) -> a -> String -> a
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' a -> Char -> a
forall a. Num a => a -> Char -> a
step a
0 (String -> a) -> (Chunk s -> String) -> Chunk s -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Chunk s -> String
forall chunk token. Chunked chunk token => chunk -> [token]
chunkToTokens
  step :: a -> Char -> a
step a
a Char
c = a
a a -> a -> a
forall a. Num a => a -> a -> a
* a
10 a -> a -> a
forall a. Num a => a -> a -> a
+ Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
digitToInt Char
c)

data SP = SP !Integer !Int

dotDecimalParser :: (EmbedTextLabel l, Stream s, Token s ~ Char, Monad m) => Integer -> ParserT l s e m SP
dotDecimalParser :: Integer -> ParserT l s e m SP
dotDecimalParser Integer
c' = do
  ParserT l s e m Char -> ParserT l s e m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Token s -> ParserT l s e m (Token s)
forall s (m :: * -> *) l e.
(Stream s, Monad m, Eq (Token s)) =>
Token s -> ParserT l s e m (Token s)
matchToken Char
Token s
'.')
  let mkNum :: Chunk s -> SP
mkNum = (SP -> Char -> SP) -> SP -> String -> SP
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' SP -> Char -> SP
step (Integer -> Int -> SP
SP Integer
c' Int
0) (String -> SP) -> (Chunk s -> String) -> Chunk s -> SP
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Chunk s -> String
forall chunk token. Chunked chunk token => chunk -> [token]
chunkToTokens
      step :: SP -> Char -> SP
step (SP Integer
a Int
e') Char
c = Integer -> Int -> SP
SP (Integer
a Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
10 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
digitToInt Char
c)) (Int
e' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
  (Chunk s -> SP) -> ParserT l s e m (Chunk s) -> ParserT l s e m SP
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Chunk s -> SP
mkNum (Maybe l -> (Token s -> Bool) -> ParserT l s e m (Chunk s)
forall s (m :: * -> *) l e.
(Stream s, Monad m) =>
Maybe l -> (Token s -> Bool) -> ParserT l s e m (Chunk s)
takeTokensWhile1 (l -> Maybe l
forall a. a -> Maybe a
Just (TextLabel -> l
forall l. EmbedTextLabel l => TextLabel -> l
embedTextLabel TextLabel
TextLabelDigit)) Char -> Bool
Token s -> Bool
isDigit)

exponentParser :: (EmbedTextLabel l, Stream s, Token s ~ Char, Monad m) => Int -> ParserT l s e m Int
exponentParser :: Int -> ParserT l s e m Int
exponentParser Int
e' = do
  ParserT l s e m Char -> ParserT l s e m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParserT l s e m Char
-> ParserT l s e m Char -> ParserT l s e m Char
forall (m :: * -> *) l s e a.
Monad m =>
ParserT l s e m a -> ParserT l s e m a -> ParserT l s e m a
orParser (Token s -> ParserT l s e m (Token s)
forall s (m :: * -> *) l e.
(Stream s, Monad m, Eq (Token s)) =>
Token s -> ParserT l s e m (Token s)
matchToken Char
Token s
'e') (Token s -> ParserT l s e m (Token s)
forall s (m :: * -> *) l e.
(Stream s, Monad m, Eq (Token s)) =>
Token s -> ParserT l s e m (Token s)
matchToken Char
Token s
'E'))
  (Int -> Int) -> ParserT l s e m Int -> ParserT l s e m Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
e') (ParserT l s e m () -> ParserT l s e m Int -> ParserT l s e m Int
forall s (m :: * -> *) a l e.
(Stream s, Token s ~ Char, Monad m, Num a) =>
ParserT l s e m () -> ParserT l s e m a -> ParserT l s e m a
signedParser (() -> ParserT l s e m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) ParserT l s e m Int
forall l s (m :: * -> *) a e.
(EmbedTextLabel l, Stream s, Token s ~ Char, Monad m, Num a) =>
ParserT l s e m a
decimalParser)

-- | Predicate for satisfying the start of signed numbers
signedNumStartPred :: Char -> Bool
signedNumStartPred :: Char -> Bool
signedNumStartPred Char
c = Char -> Bool
isDigit Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'+' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-'

-- | Parses a floating point value as a 'Scientific' number (equivalent to Megaparsec's 'scientific').
scientificParser :: (EmbedTextLabel l, Stream s, Token s ~ Char, Monad m) => ParserT l s e m Scientific
scientificParser :: ParserT l s e m Scientific
scientificParser = do
  Integer
c' <- ParserT l s e m Integer
forall l s (m :: * -> *) a e.
(EmbedTextLabel l, Stream s, Token s ~ Char, Monad m, Num a) =>
ParserT l s e m a
decimalParser
  SP Integer
c Int
e' <- SP -> ParserT l s e m SP -> ParserT l s e m SP
forall (m :: * -> *) a l s e.
Monad m =>
a -> ParserT l s e m a -> ParserT l s e m a
defaultParser (Integer -> Int -> SP
SP Integer
c' Int
0) (Integer -> ParserT l s e m SP
forall l s (m :: * -> *) e.
(EmbedTextLabel l, Stream s, Token s ~ Char, Monad m) =>
Integer -> ParserT l s e m SP
dotDecimalParser Integer
c')
  Int
e <- Int -> ParserT l s e m Int -> ParserT l s e m Int
forall (m :: * -> *) a l s e.
Monad m =>
a -> ParserT l s e m a -> ParserT l s e m a
defaultParser Int
e' (Int -> ParserT l s e m Int
forall l s (m :: * -> *) e.
(EmbedTextLabel l, Stream s, Token s ~ Char, Monad m) =>
Int -> ParserT l s e m Int
exponentParser Int
e')
  Scientific -> ParserT l s e m Scientific
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> Int -> Scientific
Sci.scientific Integer
c Int
e)

-- | Parses a number as a literal integer or a 'Scientific' number.
-- Though 'Scientific' can represent integers, this allows you to distinugish integer literals from scientific literals
-- since that information is lost after parsing.
numParser :: (EmbedTextLabel l, Stream s, Token s ~ Char, Monad m) => ParserT l s e m (Either Integer Scientific)
numParser :: ParserT l s e m (Either Integer Scientific)
numParser = do
  Integer
c' <- ParserT l s e m Integer
forall l s (m :: * -> *) a e.
(EmbedTextLabel l, Stream s, Token s ~ Char, Monad m, Num a) =>
ParserT l s e m a
decimalParser
  (SP Integer
c Int
e', Bool
b1) <- (SP, Bool)
-> ParserT l s e m (SP, Bool) -> ParserT l s e m (SP, Bool)
forall (m :: * -> *) a l s e.
Monad m =>
a -> ParserT l s e m a -> ParserT l s e m a
defaultParser (Integer -> Int -> SP
SP Integer
c' Int
0, Bool
False) ((SP -> (SP, Bool))
-> ParserT l s e m SP -> ParserT l s e m (SP, Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (,Bool
True) (Integer -> ParserT l s e m SP
forall l s (m :: * -> *) e.
(EmbedTextLabel l, Stream s, Token s ~ Char, Monad m) =>
Integer -> ParserT l s e m SP
dotDecimalParser Integer
c'))
  (Int
e, Bool
b2) <- (Int, Bool)
-> ParserT l s e m (Int, Bool) -> ParserT l s e m (Int, Bool)
forall (m :: * -> *) a l s e.
Monad m =>
a -> ParserT l s e m a -> ParserT l s e m a
defaultParser (Int
e', Bool
False) ((Int -> (Int, Bool))
-> ParserT l s e m Int -> ParserT l s e m (Int, Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (,Bool
True) (Int -> ParserT l s e m Int
forall l s (m :: * -> *) e.
(EmbedTextLabel l, Stream s, Token s ~ Char, Monad m) =>
Int -> ParserT l s e m Int
exponentParser Int
e'))
  -- If there is no decimal or exponent, return this as an integer
  -- Otherwise return as scientific, which may be float or exponentiated integer
  if Bool -> Bool
not Bool
b1 Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
b2
    then Either Integer Scientific
-> ParserT l s e m (Either Integer Scientific)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> Either Integer Scientific
forall a b. a -> Either a b
Left Integer
c')
    else Either Integer Scientific
-> ParserT l s e m (Either Integer Scientific)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Scientific -> Either Integer Scientific
forall a b. b -> Either a b
Right (Integer -> Int -> Scientific
Sci.scientific Integer
c Int
e))

data Sign = SignPos | SignNeg deriving (Sign -> Sign -> Bool
(Sign -> Sign -> Bool) -> (Sign -> Sign -> Bool) -> Eq Sign
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Sign -> Sign -> Bool
$c/= :: Sign -> Sign -> Bool
== :: Sign -> Sign -> Bool
$c== :: Sign -> Sign -> Bool
Eq, Int -> Sign -> ShowS
[Sign] -> ShowS
Sign -> String
(Int -> Sign -> ShowS)
-> (Sign -> String) -> ([Sign] -> ShowS) -> Show Sign
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Sign] -> ShowS
$cshowList :: [Sign] -> ShowS
show :: Sign -> String
$cshow :: Sign -> String
showsPrec :: Int -> Sign -> ShowS
$cshowsPrec :: Int -> Sign -> ShowS
Show)

-- | Consumes an optional + or - representing the sign of a number.
signParser :: (Stream s, Token s ~ Char, Monad m) => ParserT l s e m (Maybe Sign)
signParser :: ParserT l s e m (Maybe Sign)
signParser = do
  Maybe Char
mc <- ParserT l s e m (Maybe Char)
forall s (m :: * -> *) l e.
(Stream s, Monad m) =>
ParserT l s e m (Maybe (Token s))
peekToken
  case Maybe Char
mc of
    Just Char
'+' -> ParserT l s e m (Maybe Char)
forall s (m :: * -> *) l e.
(Stream s, Monad m) =>
ParserT l s e m (Maybe (Token s))
popToken ParserT l s e m (Maybe Char)
-> Maybe Sign -> ParserT l s e m (Maybe Sign)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Sign -> Maybe Sign
forall a. a -> Maybe a
Just Sign
SignPos
    Just Char
'-' -> ParserT l s e m (Maybe Char)
forall s (m :: * -> *) l e.
(Stream s, Monad m) =>
ParserT l s e m (Maybe (Token s))
popToken ParserT l s e m (Maybe Char)
-> Maybe Sign -> ParserT l s e m (Maybe Sign)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Sign -> Maybe Sign
forall a. a -> Maybe a
Just Sign
SignNeg
    Maybe Char
_ -> Maybe Sign -> ParserT l s e m (Maybe Sign)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Sign
forall a. Maybe a
Nothing

-- | Optionally negate the number according to the sign (treating 'Nothing' as positive sign).
applySign :: Num a => Maybe Sign -> a -> a
applySign :: Maybe Sign -> a -> a
applySign Maybe Sign
ms a
n =
  case Maybe Sign
ms of
    Just Sign
SignNeg -> a -> a
forall a. Num a => a -> a
negate a
n
    Maybe Sign
_ -> a
n

-- | Parses an optional sign character followed by a number and yields a correctly-signed
-- number (equivalend to Megaparsec's 'signed').
signedParser :: (Stream s, Token s ~ Char, Monad m, Num a) =>
  -- | How to consume white space after the sign
  ParserT l s e m () ->
  -- | How to parse the number itself
  ParserT l s e m a ->
  -- | Parser for signed numbers
  ParserT l s e m a
signedParser :: ParserT l s e m () -> ParserT l s e m a -> ParserT l s e m a
signedParser ParserT l s e m ()
spc ParserT l s e m a
p = do
  Maybe Sign
ms <- ParserT l s e m (Maybe Sign)
forall s (m :: * -> *) l e.
(Stream s, Token s ~ Char, Monad m) =>
ParserT l s e m (Maybe Sign)
signParser
  ParserT l s e m ()
spc
  (a -> a) -> ParserT l s e m a -> ParserT l s e m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe Sign -> a -> a
forall a. Num a => Maybe Sign -> a -> a
applySign Maybe Sign
ms) ParserT l s e m a
p

data Pair = Pair ![Char] !Bool

-- | Given a quote charcter (like a single or double quote), yields the contents of the
-- string bounded by those quotes. The contents may contain backslash-escaped quotes.
-- Returns nothing if outside quotes are missing or the stream ends before unquote.
escapedStringParser :: (Stream s, Token s ~ Char, Monad m) => Char -> ParserT l s e m (Chunk s)
escapedStringParser :: Char -> ParserT l s e m (Chunk s)
escapedStringParser Char
quoteChar =
  let quoteParser :: ParserT l s e m ()
quoteParser = ParserT l s e m Char -> ParserT l s e m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Token s -> ParserT l s e m (Token s)
forall s (m :: * -> *) l e.
(Stream s, Monad m, Eq (Token s)) =>
Token s -> ParserT l s e m (Token s)
matchToken Char
Token s
quoteChar)
      accParser :: ParserT l s e m Pair
accParser = (Token s -> Pair -> (Bool, Pair)) -> Pair -> ParserT l s e m Pair
forall s (m :: * -> *) x l e.
(Stream s, Monad m) =>
(Token s -> x -> (Bool, x)) -> x -> ParserT l s e m x
foldTokensWhile Char -> Pair -> (Bool, Pair)
Token s -> Pair -> (Bool, Pair)
go (String -> Bool -> Pair
Pair [] Bool
False)
      innerParser :: ParserT l s e m (Chunk s)
innerParser = (Pair -> Chunk s)
-> ParserT l s e m Pair -> ParserT l s e m (Chunk s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Pair String
acc Bool
_) -> String -> Chunk s
forall chunk token. Chunked chunk token => [token] -> chunk
revTokensToChunk String
acc) ParserT l s e m Pair
accParser
      escChar :: Char
escChar = Char
'\\'
      go :: Char -> Pair -> (Bool, Pair)
go Char
c (Pair String
acc Bool
esc)
        | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
escChar =
          if Bool
esc
            then (Bool
True, String -> Bool -> Pair
Pair (Char
escCharChar -> ShowS
forall a. a -> [a] -> [a]
:String
acc) Bool
False) -- Was escaped escape, append one
            else (Bool
True, String -> Bool -> Pair
Pair String
acc Bool
True) -- Skip appending this esc
        | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
quoteChar =
          if Bool
esc
            then (Bool
True, String -> Bool -> Pair
Pair (Char
cChar -> ShowS
forall a. a -> [a] -> [a]
:String
acc) Bool
False) -- Escaped quote
            else (Bool
False, String -> Bool -> Pair
Pair String
acc Bool
False) -- End of quote
        | Bool
otherwise =
          if Bool
esc
            then (Bool
True, String -> Bool -> Pair
Pair (Char
cChar -> ShowS
forall a. a -> [a] -> [a]
:Char
escCharChar -> ShowS
forall a. a -> [a] -> [a]
:String
acc) Bool
False) -- Was a non-quote esc, append both
            else (Bool
True, String -> Bool -> Pair
Pair (Char
cChar -> ShowS
forall a. a -> [a] -> [a]
:String
acc) Bool
False) -- Just consume char
  in ParserT l s e m ()
-> ParserT l s e m ()
-> ParserT l s e m (Chunk s)
-> ParserT l s e m (Chunk s)
forall (m :: * -> *) l s e a.
Monad m =>
ParserT l s e m ()
-> ParserT l s e m () -> ParserT l s e m a -> ParserT l s e m a
betweenParser ParserT l s e m ()
quoteParser ParserT l s e m ()
quoteParser ParserT l s e m (Chunk s)
innerParser

-- | Adds span information to parsed values.
spanParser :: (PosStream s, Monad m) => (Span (Pos s) -> a -> b) -> ParserT l s e m a -> ParserT l s e m b
spanParser :: (Span (Pos s) -> a -> b) -> ParserT l s e m a -> ParserT l s e m b
spanParser Span (Pos s) -> a -> b
f ParserT l s e m a
p = do
  s
start <- ParserT l s e m s
forall s (m :: * -> *). MonadState s m => m s
get
  a
val <- ParserT l s e m a
p
  s
end <- ParserT l s e m s
forall s (m :: * -> *). MonadState s m => m s
get
  b -> ParserT l s e m b
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Span (Pos s) -> a -> b
f (Pos s -> Pos s -> Span (Pos s)
forall p. p -> p -> Span p
Span (s -> Pos s
forall s. PosStream s => s -> Pos s
streamViewPos s
start) (s -> Pos s
forall s. PosStream s => s -> Pos s
streamViewPos s
end)) a
val)

-- | Gets the current stream position
getStreamPos :: (PosStream s, Monad m) => ParserT l s e m (Pos s)
getStreamPos :: ParserT l s e m (Pos s)
getStreamPos = (s -> Pos s) -> ParserT l s e m (Pos s)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets s -> Pos s
forall s. PosStream s => s -> Pos s
streamViewPos