{-# LANGUAGE OverloadedStrings #-}

-- | Parses S-expressions but lexes first
module SimpleParser.Examples.Lexed.Sexp
  ( Sexp (..)
  , SexpF (..)
  , Atom (..)
  , SexpTokLabel (..)
  , SexpTokParserC
  , SexpTokParserM
  , sexpTokParser
  , SexpParserC
  , SexpParserM
  , sexpParser
  , runSexpParser
  ) where

import Control.Applicative (empty)
import Control.Monad (void)
import Control.Monad.Catch (MonadThrow)
import Data.Char (isDigit, isSpace)
import Data.Sequence (Seq)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Typeable (Typeable)
import Data.Void (Void)
import SimpleParser (Chunked (..), EmbedTextLabel (..), ExplainLabel (..), MatchBlock (..), MatchCase (..), Parser,
                     PosStream (..), ShowTextBuildable (..), Stream (..), TextBuildable (..), TextLabel, TextualStream,
                     anyToken, applySign, betweenParser, escapedStringParser, greedyStarParser, lexemeParser,
                     lookAheadMatch, matchToken, numParser, packChunk, popChunk, popToken, runParserLexed, satisfyToken,
                     signParser, signedNumStartPred, spaceParser, takeTokensWhile)
import SimpleParser.Examples.Common.Sexp (Atom (..), Sexp (..), SexpF (..))

-- First, our tokenizer:

data SexpTokLabel =
    SexpTokLabelIdentStart
  | SexpTokLabelEmbedText !TextLabel
  deriving (SexpTokLabel -> SexpTokLabel -> Bool
(SexpTokLabel -> SexpTokLabel -> Bool)
-> (SexpTokLabel -> SexpTokLabel -> Bool) -> Eq SexpTokLabel
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SexpTokLabel -> SexpTokLabel -> Bool
$c/= :: SexpTokLabel -> SexpTokLabel -> Bool
== :: SexpTokLabel -> SexpTokLabel -> Bool
$c== :: SexpTokLabel -> SexpTokLabel -> Bool
Eq, Int -> SexpTokLabel -> ShowS
[SexpTokLabel] -> ShowS
SexpTokLabel -> String
(Int -> SexpTokLabel -> ShowS)
-> (SexpTokLabel -> String)
-> ([SexpTokLabel] -> ShowS)
-> Show SexpTokLabel
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SexpTokLabel] -> ShowS
$cshowList :: [SexpTokLabel] -> ShowS
show :: SexpTokLabel -> String
$cshow :: SexpTokLabel -> String
showsPrec :: Int -> SexpTokLabel -> ShowS
$cshowsPrec :: Int -> SexpTokLabel -> ShowS
Show)

instance ExplainLabel SexpTokLabel where
  explainLabel :: SexpTokLabel -> Builder
explainLabel SexpTokLabel
sl =
    case SexpTokLabel
sl of
      SexpTokLabel
SexpTokLabelIdentStart -> Builder
"start of identifier"
      SexpTokLabelEmbedText TextLabel
tl -> TextLabel -> Builder
forall l. ExplainLabel l => l -> Builder
explainLabel TextLabel
tl

instance EmbedTextLabel SexpTokLabel where
  embedTextLabel :: TextLabel -> SexpTokLabel
embedTextLabel = TextLabel -> SexpTokLabel
SexpTokLabelEmbedText

type SexpTokParserC s = (PosStream s, TextualStream s)

type SexpTokParserM s a = Parser SexpTokLabel s Void a

data SexpTok =
    SexpTokOpenParen
  | SexpTokCloseParen
  | SexpTokAtom !Atom
  deriving stock (SexpTok -> SexpTok -> Bool
(SexpTok -> SexpTok -> Bool)
-> (SexpTok -> SexpTok -> Bool) -> Eq SexpTok
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SexpTok -> SexpTok -> Bool
$c/= :: SexpTok -> SexpTok -> Bool
== :: SexpTok -> SexpTok -> Bool
$c== :: SexpTok -> SexpTok -> Bool
Eq, Int -> SexpTok -> ShowS
[SexpTok] -> ShowS
SexpTok -> String
(Int -> SexpTok -> ShowS)
-> (SexpTok -> String) -> ([SexpTok] -> ShowS) -> Show SexpTok
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SexpTok] -> ShowS
$cshowList :: [SexpTok] -> ShowS
show :: SexpTok -> String
$cshow :: SexpTok -> String
showsPrec :: Int -> SexpTok -> ShowS
$cshowsPrec :: Int -> SexpTok -> ShowS
Show)
  deriving (SexpTok -> Builder
(SexpTok -> Builder) -> TextBuildable SexpTok
forall a. (a -> Builder) -> TextBuildable a
buildText :: SexpTok -> Builder
$cbuildText :: SexpTok -> Builder
TextBuildable) via (ShowTextBuildable SexpTok)

nonDelimPred :: Char -> Bool
nonDelimPred :: Char -> Bool
nonDelimPred Char
c = 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
')' Bool -> Bool -> Bool
&& Bool -> Bool
not (Char -> Bool
isSpace Char
c)

identStartPred :: Char -> Bool
identStartPred :: Char -> Bool
identStartPred Char
c = Bool -> Bool
not (Char -> Bool
isDigit Char
c) Bool -> Bool -> Bool
&& Char -> Bool
identContPred Char
c

identContPred :: Char -> Bool
identContPred :: Char -> Bool
identContPred Char
c = Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'"' Bool -> Bool -> Bool
&& Char -> Bool
nonDelimPred Char
c

stringTP :: SexpTokParserC s => SexpTokParserM s Text
stringTP :: SexpTokParserM s Text
stringTP = (Chunk s -> Text)
-> ParserT SexpTokLabel s Void Identity (Chunk s)
-> SexpTokParserM s Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Chunk s -> Text
forall chunk. TextualChunked chunk => chunk -> Text
packChunk (Char -> ParserT SexpTokLabel s Void Identity (Chunk s)
forall s (m :: * -> *) l e.
(Stream s, Token s ~ Char, Monad m) =>
Char -> ParserT l s e m (Chunk s)
escapedStringParser Char
'"')

identifierTP :: SexpTokParserC s => SexpTokParserM s Text
identifierTP :: SexpTokParserM s Text
identifierTP = do
  Char
x <- Maybe SexpTokLabel
-> (Token s -> Bool)
-> ParserT SexpTokLabel s Void Identity (Token s)
forall s (m :: * -> *) l e.
(Stream s, Monad m) =>
Maybe l -> (Token s -> Bool) -> ParserT l s e m (Token s)
satisfyToken (SexpTokLabel -> Maybe SexpTokLabel
forall a. a -> Maybe a
Just SexpTokLabel
SexpTokLabelIdentStart) Char -> Bool
Token s -> Bool
identStartPred
  Chunk s
xs <- (Token s -> Bool) -> ParserT SexpTokLabel s Void Identity (Chunk s)
forall s (m :: * -> *) l e.
(Stream s, Monad m) =>
(Token s -> Bool) -> ParserT l s e m (Chunk s)
takeTokensWhile Char -> Bool
Token s -> Bool
identContPred
  Text -> SexpTokParserM s Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Chunk s -> Text
forall chunk. TextualChunked chunk => chunk -> Text
packChunk (Char -> Chunk s -> Chunk s
forall chunk token. Chunked chunk token => token -> chunk -> chunk
consChunk Char
x Chunk s
xs))

spaceTP :: SexpTokParserC s => SexpTokParserM s ()
spaceTP :: SexpTokParserM s ()
spaceTP = SexpTokParserM s ()
forall s (m :: * -> *) l e.
(Stream s, Token s ~ Char, Monad m) =>
ParserT l s e m ()
spaceParser

lexTP :: SexpTokParserC s => SexpTokParserM s a -> SexpTokParserM s a
lexTP :: SexpTokParserM s a -> SexpTokParserM s a
lexTP = ParserT SexpTokLabel s Void Identity ()
-> SexpTokParserM s a -> SexpTokParserM s a
forall (m :: * -> *) l s e a.
Monad m =>
ParserT l s e m () -> ParserT l s e m a -> ParserT l s e m a
lexemeParser ParserT SexpTokLabel s Void Identity ()
forall s. SexpTokParserC s => SexpTokParserM s ()
spaceTP

openParenTP :: SexpTokParserC s => SexpTokParserM s ()
openParenTP :: SexpTokParserM s ()
openParenTP = SexpTokParserM s () -> SexpTokParserM s ()
forall s a.
SexpTokParserC s =>
SexpTokParserM s a -> SexpTokParserM s a
lexTP (ParserT SexpTokLabel s Void Identity Char -> SexpTokParserM s ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Token s -> ParserT SexpTokLabel s Void Identity (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
'('))

closeParenTP :: SexpTokParserC s => SexpTokParserM s ()
closeParenTP :: SexpTokParserM s ()
closeParenTP = SexpTokParserM s () -> SexpTokParserM s ()
forall s a.
SexpTokParserC s =>
SexpTokParserM s a -> SexpTokParserM s a
lexTP (ParserT SexpTokLabel s Void Identity Char -> SexpTokParserM s ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Token s -> ParserT SexpTokLabel s Void Identity (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
')'))

numAtomTP :: SexpTokParserC s => SexpTokParserM s Atom
numAtomTP :: SexpTokParserM s Atom
numAtomTP = do
  Maybe Sign
ms <- ParserT SexpTokLabel s Void Identity (Maybe Sign)
forall s (m :: * -> *) l e.
(Stream s, Token s ~ Char, Monad m) =>
ParserT l s e m (Maybe Sign)
signParser
  Either Integer Scientific
n <- ParserT SexpTokLabel s Void Identity (Either Integer Scientific)
forall l s (m :: * -> *) e.
(EmbedTextLabel l, Stream s, Token s ~ Char, Monad m) =>
ParserT l s e m (Either Integer Scientific)
numParser
  case Either Integer Scientific
n of
    Left Integer
i -> Atom -> SexpTokParserM s Atom
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> Atom
AtomInt (Maybe Sign -> Integer -> Integer
forall a. Num a => Maybe Sign -> a -> a
applySign Maybe Sign
ms Integer
i))
    Right Scientific
s -> Atom -> SexpTokParserM s Atom
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Scientific -> Atom
AtomSci (Maybe Sign -> Scientific -> Scientific
forall a. Num a => Maybe Sign -> a -> a
applySign Maybe Sign
ms Scientific
s))

chunk1 :: SexpTokParserC s => SexpTokParserM s Text
chunk1 :: SexpTokParserM s Text
chunk1 = do
  Maybe (Chunk s)
mc <- Int -> ParserT SexpTokLabel s Void Identity (Maybe (Chunk s))
forall s (m :: * -> *) l e.
(Stream s, Monad m) =>
Int -> ParserT l s e m (Maybe (Chunk s))
popChunk Int
2
  case Maybe (Chunk s)
mc of
    Just Chunk s
c | Bool -> Bool
not (Chunk s -> Bool
forall chunk token. Chunked chunk token => chunk -> Bool
chunkEmpty Chunk s
c) -> Text -> SexpTokParserM s Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Chunk s -> Text
forall chunk. TextualChunked chunk => chunk -> Text
packChunk Chunk s
c)
    Maybe (Chunk s)
_ -> SexpTokParserM s Text
forall (f :: * -> *) a. Alternative f => f a
empty

unaryIdentPred :: Char -> Text -> Bool
unaryIdentPred :: Char -> Text -> Bool
unaryIdentPred Char
u Text
t0 =
  case Text -> Maybe (Char, Text)
T.uncons Text
t0 of
    Just (Char
c0, Text
t1) | Char
u Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c0 ->
      case Text -> Maybe (Char, Text)
T.uncons Text
t1 of
        Just (Char
c1, Text
_) -> Bool -> Bool
not (Char -> Bool
isDigit Char
c1)
        Maybe (Char, Text)
Nothing -> Bool
True
    Maybe (Char, Text)
_ -> Bool
False

identAtomTP :: SexpTokParserC s => SexpTokParserM s Atom
identAtomTP :: SexpTokParserM s Atom
identAtomTP = (Text -> Atom)
-> ParserT SexpTokLabel s Void Identity Text
-> SexpTokParserM s Atom
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Atom
AtomIdent ParserT SexpTokLabel s Void Identity Text
forall s. SexpTokParserC s => SexpTokParserM s Text
identifierTP

atomTP :: SexpTokParserC s => SexpTokParserM s Atom
atomTP :: SexpTokParserM s Atom
atomTP = SexpTokParserM s Atom -> SexpTokParserM s Atom
forall s a.
SexpTokParserC s =>
SexpTokParserM s a -> SexpTokParserM s a
lexTP (MatchBlock SexpTokLabel s Void Identity Text Atom
-> SexpTokParserM s Atom
forall (m :: * -> *) l s e a b.
Monad m =>
MatchBlock l s e m a b -> ParserT l s e m b
lookAheadMatch MatchBlock SexpTokLabel s Void Identity Text Atom
block) where
  block :: MatchBlock SexpTokLabel s Void Identity Text Atom
block = ParserT SexpTokLabel s Void Identity Text
-> SexpTokParserM s Atom
-> [MatchCase SexpTokLabel s Void Identity Text Atom]
-> MatchBlock SexpTokLabel s Void Identity Text Atom
forall l s e (m :: * -> *) a b.
ParserT l s e m a
-> ParserT l s e m b
-> [MatchCase l s e m a b]
-> MatchBlock l s e m a b
MatchBlock ParserT SexpTokLabel s Void Identity Text
forall s. SexpTokParserC s => SexpTokParserM s Text
chunk1 (String -> SexpTokParserM s Atom
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"failed to parse sexp atom")
    [ Maybe SexpTokLabel
-> (Text -> Bool)
-> SexpTokParserM s Atom
-> MatchCase SexpTokLabel s Void Identity Text Atom
forall l s e (m :: * -> *) a b.
Maybe l
-> (a -> Bool) -> ParserT l s e m b -> MatchCase l s e m a b
MatchCase Maybe SexpTokLabel
forall a. Maybe a
Nothing ((Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'"') (Char -> Bool) -> (Text -> Char) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Char
T.head) ((Text -> Atom)
-> ParserT SexpTokLabel s Void Identity Text
-> SexpTokParserM s Atom
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Atom
AtomString ParserT SexpTokLabel s Void Identity Text
forall s. SexpTokParserC s => SexpTokParserM s Text
stringTP)
    , Maybe SexpTokLabel
-> (Text -> Bool)
-> SexpTokParserM s Atom
-> MatchCase SexpTokLabel s Void Identity Text Atom
forall l s e (m :: * -> *) a b.
Maybe l
-> (a -> Bool) -> ParserT l s e m b -> MatchCase l s e m a b
MatchCase Maybe SexpTokLabel
forall a. Maybe a
Nothing (Char -> Text -> Bool
unaryIdentPred Char
'+') SexpTokParserM s Atom
forall s. SexpTokParserC s => SexpTokParserM s Atom
identAtomTP
    , Maybe SexpTokLabel
-> (Text -> Bool)
-> SexpTokParserM s Atom
-> MatchCase SexpTokLabel s Void Identity Text Atom
forall l s e (m :: * -> *) a b.
Maybe l
-> (a -> Bool) -> ParserT l s e m b -> MatchCase l s e m a b
MatchCase Maybe SexpTokLabel
forall a. Maybe a
Nothing (Char -> Text -> Bool
unaryIdentPred Char
'-') SexpTokParserM s Atom
forall s. SexpTokParserC s => SexpTokParserM s Atom
identAtomTP
    , Maybe SexpTokLabel
-> (Text -> Bool)
-> SexpTokParserM s Atom
-> MatchCase SexpTokLabel s Void Identity Text Atom
forall l s e (m :: * -> *) a b.
Maybe l
-> (a -> Bool) -> ParserT l s e m b -> MatchCase l s e m a b
MatchCase Maybe SexpTokLabel
forall a. Maybe a
Nothing (Char -> Bool
signedNumStartPred (Char -> Bool) -> (Text -> Char) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Char
T.head) SexpTokParserM s Atom
forall s. SexpTokParserC s => SexpTokParserM s Atom
numAtomTP
    , Maybe SexpTokLabel
-> (Text -> Bool)
-> SexpTokParserM s Atom
-> MatchCase SexpTokLabel s Void Identity Text Atom
forall l s e (m :: * -> *) a b.
Maybe l
-> (a -> Bool) -> ParserT l s e m b -> MatchCase l s e m a b
MatchCase Maybe SexpTokLabel
forall a. Maybe a
Nothing (Char -> Bool
identStartPred (Char -> Bool) -> (Text -> Char) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Char
T.head) SexpTokParserM s Atom
forall s. SexpTokParserC s => SexpTokParserM s Atom
identAtomTP
    ]

sexpTokParser :: SexpTokParserC s => SexpTokParserM s SexpTok
sexpTokParser :: SexpTokParserM s SexpTok
sexpTokParser= MatchBlock SexpTokLabel s Void Identity Char SexpTok
-> SexpTokParserM s SexpTok
forall (m :: * -> *) l s e a b.
Monad m =>
MatchBlock l s e m a b -> ParserT l s e m b
lookAheadMatch MatchBlock SexpTokLabel s Void Identity Char SexpTok
block where
  block :: MatchBlock SexpTokLabel s Void Identity Char SexpTok
block = ParserT SexpTokLabel s Void Identity Char
-> SexpTokParserM s SexpTok
-> [MatchCase SexpTokLabel s Void Identity Char SexpTok]
-> MatchBlock SexpTokLabel s Void Identity Char SexpTok
forall l s e (m :: * -> *) a b.
ParserT l s e m a
-> ParserT l s e m b
-> [MatchCase l s e m a b]
-> MatchBlock l s e m a b
MatchBlock ParserT SexpTokLabel s Void Identity Char
forall s (m :: * -> *) l e.
(Stream s, Monad m) =>
ParserT l s e m (Token s)
anyToken ((Atom -> SexpTok)
-> ParserT SexpTokLabel s Void Identity Atom
-> SexpTokParserM s SexpTok
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Atom -> SexpTok
SexpTokAtom ParserT SexpTokLabel s Void Identity Atom
forall s. SexpTokParserC s => SexpTokParserM s Atom
atomTP)
    [ Maybe SexpTokLabel
-> (Char -> Bool)
-> SexpTokParserM s SexpTok
-> MatchCase SexpTokLabel s Void Identity Char SexpTok
forall l s e (m :: * -> *) a b.
Maybe l
-> (a -> Bool) -> ParserT l s e m b -> MatchCase l s e m a b
MatchCase Maybe SexpTokLabel
forall a. Maybe a
Nothing (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'(') (SexpTok
SexpTokOpenParen SexpTok
-> ParserT SexpTokLabel s Void Identity ()
-> SexpTokParserM s SexpTok
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ParserT SexpTokLabel s Void Identity ()
forall s. SexpTokParserC s => SexpTokParserM s ()
openParenTP)
    , Maybe SexpTokLabel
-> (Char -> Bool)
-> SexpTokParserM s SexpTok
-> MatchCase SexpTokLabel s Void Identity Char SexpTok
forall l s e (m :: * -> *) a b.
Maybe l
-> (a -> Bool) -> ParserT l s e m b -> MatchCase l s e m a b
MatchCase Maybe SexpTokLabel
forall a. Maybe a
Nothing (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
')') (SexpTok
SexpTokCloseParen SexpTok
-> ParserT SexpTokLabel s Void Identity ()
-> SexpTokParserM s SexpTok
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ParserT SexpTokLabel s Void Identity ()
forall s. SexpTokParserC s => SexpTokParserM s ()
closeParenTP)
    ]

-- Now the Sexp parser itself:

type SexpParserC s = (Stream s, Token s ~ SexpTok)

type SexpParserM s a = Parser Void s Void a

isOpenParenTok, isCloseParenTok, isAtomTok :: SexpTok -> Bool
isOpenParenTok :: SexpTok -> Bool
isOpenParenTok = \case { SexpTok
SexpTokOpenParen -> Bool
True; SexpTok
_ -> Bool
False }
isCloseParenTok :: SexpTok -> Bool
isCloseParenTok = \case { SexpTok
SexpTokCloseParen -> Bool
True; SexpTok
_ -> Bool
False }
isAtomTok :: SexpTok -> Bool
isAtomTok = \case { SexpTokAtom Atom
_ -> Bool
True; SexpTok
_ -> Bool
False }

atomP :: SexpParserC s => SexpParserM s Atom
atomP :: SexpParserM s Atom
atomP = ParserT Void s Void Identity (Maybe SexpTok)
forall s (m :: * -> *) l e.
(Stream s, Monad m) =>
ParserT l s e m (Maybe (Token s))
popToken ParserT Void s Void Identity (Maybe SexpTok)
-> (Maybe SexpTok -> SexpParserM s Atom) -> SexpParserM s Atom
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case { Just (SexpTokAtom Atom
a) -> Atom -> SexpParserM s Atom
forall (f :: * -> *) a. Applicative f => a -> f a
pure Atom
a; Maybe SexpTok
_ -> String -> SexpParserM s Atom
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"invalid atom" }

openParenP, closeParenP :: SexpParserC s => SexpParserM s ()
openParenP :: SexpParserM s ()
openParenP = ParserT Void s Void Identity SexpTok -> SexpParserM s ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Token s -> ParserT Void s Void Identity (Token s)
forall s (m :: * -> *) l e.
(Stream s, Monad m, Eq (Token s)) =>
Token s -> ParserT l s e m (Token s)
matchToken Token s
SexpTok
SexpTokOpenParen)
closeParenP :: SexpParserM s ()
closeParenP = ParserT Void s Void Identity SexpTok -> SexpParserM s ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Token s -> ParserT Void s Void Identity (Token s)
forall s (m :: * -> *) l e.
(Stream s, Monad m, Eq (Token s)) =>
Token s -> ParserT l s e m (Token s)
matchToken Token s
SexpTok
SexpTokCloseParen)

listP :: SexpParserC s => SexpParserM s a -> SexpParserM s (Seq a)
listP :: SexpParserM s a -> SexpParserM s (Seq a)
listP SexpParserM s a
root = ParserT Void s Void Identity ()
-> ParserT Void s Void Identity ()
-> SexpParserM s (Seq a)
-> SexpParserM s (Seq a)
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 Void s Void Identity ()
forall s. SexpParserC s => SexpParserM s ()
openParenP ParserT Void s Void Identity ()
forall s. SexpParserC s => SexpParserM s ()
closeParenP (SexpParserM s a -> SexpParserM s (Seq a)
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 SexpParserM s a
root)

recSexpParser :: SexpParserC s => SexpParserM s a -> SexpParserM s (SexpF a)
recSexpParser :: SexpParserM s a -> SexpParserM s (SexpF a)
recSexpParser SexpParserM s a
root = MatchBlock Void s Void Identity SexpTok (SexpF a)
-> SexpParserM s (SexpF a)
forall (m :: * -> *) l s e a b.
Monad m =>
MatchBlock l s e m a b -> ParserT l s e m b
lookAheadMatch MatchBlock Void s Void Identity SexpTok (SexpF a)
block where
  block :: MatchBlock Void s Void Identity SexpTok (SexpF a)
block = ParserT Void s Void Identity SexpTok
-> SexpParserM s (SexpF a)
-> [MatchCase Void s Void Identity SexpTok (SexpF a)]
-> MatchBlock Void s Void Identity SexpTok (SexpF a)
forall l s e (m :: * -> *) a b.
ParserT l s e m a
-> ParserT l s e m b
-> [MatchCase l s e m a b]
-> MatchBlock l s e m a b
MatchBlock ParserT Void s Void Identity SexpTok
forall s (m :: * -> *) l e.
(Stream s, Monad m) =>
ParserT l s e m (Token s)
anyToken SexpParserM s (SexpF a)
forall (f :: * -> *) a. Alternative f => f a
empty
    [ Maybe Void
-> (SexpTok -> Bool)
-> SexpParserM s (SexpF a)
-> MatchCase Void s Void Identity SexpTok (SexpF a)
forall l s e (m :: * -> *) a b.
Maybe l
-> (a -> Bool) -> ParserT l s e m b -> MatchCase l s e m a b
MatchCase Maybe Void
forall a. Maybe a
Nothing SexpTok -> Bool
isOpenParenTok ((Seq a -> SexpF a)
-> ParserT Void s Void Identity (Seq a) -> SexpParserM s (SexpF a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Seq a -> SexpF a
forall a. Seq a -> SexpF a
SexpList (SexpParserM s a -> ParserT Void s Void Identity (Seq a)
forall s a.
SexpParserC s =>
SexpParserM s a -> SexpParserM s (Seq a)
listP SexpParserM s a
root))
    , Maybe Void
-> (SexpTok -> Bool)
-> SexpParserM s (SexpF a)
-> MatchCase Void s Void Identity SexpTok (SexpF a)
forall l s e (m :: * -> *) a b.
Maybe l
-> (a -> Bool) -> ParserT l s e m b -> MatchCase l s e m a b
MatchCase Maybe Void
forall a. Maybe a
Nothing SexpTok -> Bool
isCloseParenTok (String -> SexpParserM s (SexpF a)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"invalid close paren")
    , Maybe Void
-> (SexpTok -> Bool)
-> SexpParserM s (SexpF a)
-> MatchCase Void s Void Identity SexpTok (SexpF a)
forall l s e (m :: * -> *) a b.
Maybe l
-> (a -> Bool) -> ParserT l s e m b -> MatchCase l s e m a b
MatchCase Maybe Void
forall a. Maybe a
Nothing SexpTok -> Bool
isAtomTok ((Atom -> SexpF a)
-> ParserT Void s Void Identity Atom -> SexpParserM s (SexpF a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Atom -> SexpF a
forall a. Atom -> SexpF a
SexpAtom ParserT Void s Void Identity Atom
forall s. SexpParserC s => SexpParserM s Atom
atomP)
    ]

sexpParser :: SexpParserC s => SexpParserM s Sexp
sexpParser :: SexpParserM s Sexp
sexpParser = let p :: SexpParserM s Sexp
p = (SexpF Sexp -> Sexp)
-> ParserT Void s Void Identity (SexpF Sexp) -> SexpParserM s Sexp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SexpF Sexp -> Sexp
Sexp (SexpParserM s Sexp -> ParserT Void s Void Identity (SexpF Sexp)
forall s a.
SexpParserC s =>
SexpParserM s a -> SexpParserM s (SexpF a)
recSexpParser SexpParserM s Sexp
p) in SexpParserM s Sexp
p

-- And combined:

runSexpParser :: (
  Typeable s, Typeable (Token s), Typeable (Chunk s), Typeable (Pos s),
  Show s, Show (Token s), Show (Chunk s), Show (Pos s),
  SexpTokParserC s, MonadThrow m) => s -> m Sexp
runSexpParser :: s -> m Sexp
runSexpParser = Parser SexpTokLabel s Void SexpTok
-> (LexedStream (Pos s) SexpTok -> LexedStream (Pos s) SexpTok)
-> Parser Void (LexedStream (Pos s) SexpTok) Void Sexp
-> s
-> m Sexp
forall l1 e1 s l2 e2 a (m :: * -> *) b.
(Typeable l1, Typeable e1, Typeable s, Typeable (Token s),
 Typeable (Chunk s), Show l1, Show e1, Show s, Show (Token s),
 Show (Chunk s), Typeable l2, Typeable e2, Typeable (Pos s),
 Typeable a, Show l2, Show e2, Show (Pos s), Show a, PosStream s,
 MonadThrow m) =>
Parser l1 s e1 a
-> (LexedStream (Pos s) a -> LexedStream (Pos s) a)
-> Parser l2 (LexedStream (Pos s) a) e2 b
-> s
-> m b
runParserLexed Parser SexpTokLabel s Void SexpTok
forall s. SexpTokParserC s => SexpTokParserM s SexpTok
sexpTokParser LexedStream (Pos s) SexpTok -> LexedStream (Pos s) SexpTok
forall a. a -> a
id Parser Void (LexedStream (Pos s) SexpTok) Void Sexp
forall s. SexpParserC s => SexpParserM s Sexp
sexpParser