{-# 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
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
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 -> 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
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
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
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 forall a. Eq a => a -> a -> Bool
/= Char
'(' Bool -> Bool -> Bool
&& Char
c 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 forall a. Eq a => a -> a -> Bool
/= Char
'"' Bool -> Bool -> Bool
&& Char -> Bool
nonDelimPred Char
c

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

spaceTP :: SexpTokParserC s => SexpTokParserM s ()
spaceTP :: forall s. SexpTokParserC s => SexpTokParserM s ()
spaceTP = 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 :: forall s a.
SexpTokParserC s =>
SexpTokParserM s a -> SexpTokParserM s a
lexTP = 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 forall s. SexpTokParserC s => SexpTokParserM s ()
spaceTP

openParenTP :: SexpTokParserC s => SexpTokParserM s ()
openParenTP :: forall s. SexpTokParserC s => SexpTokParserM s ()
openParenTP = forall s a.
SexpTokParserC s =>
SexpTokParserM s a -> SexpTokParserM s a
lexTP (forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall s (m :: * -> *) l e.
(Stream s, Monad m, Eq (Token s)) =>
Token s -> ParserT l s e m (Token s)
matchToken Char
'('))

closeParenTP :: SexpTokParserC s => SexpTokParserM s ()
closeParenTP :: forall s. SexpTokParserC s => SexpTokParserM s ()
closeParenTP = forall s a.
SexpTokParserC s =>
SexpTokParserM s a -> SexpTokParserM s a
lexTP (forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall s (m :: * -> *) l e.
(Stream s, Monad m, Eq (Token s)) =>
Token s -> ParserT l s e m (Token s)
matchToken Char
')'))

numAtomTP :: SexpTokParserC s => SexpTokParserM s Atom
numAtomTP :: forall s. SexpTokParserC s => SexpTokParserM s Atom
numAtomTP = do
  Maybe Sign
ms <- forall s (m :: * -> *) l e.
(Stream s, Token s ~ Char, Monad m) =>
ParserT l s e m (Maybe Sign)
signParser
  Either Integer Scientific
n <- 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> Atom
AtomInt (forall a. Num a => Maybe Sign -> a -> a
applySign Maybe Sign
ms Integer
i))
    Right Scientific
s -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Scientific -> Atom
AtomSci (forall a. Num a => Maybe Sign -> a -> a
applySign Maybe Sign
ms Scientific
s))

chunk1 :: SexpTokParserC s => SexpTokParserM s Text
chunk1 :: forall s. SexpTokParserC s => SexpTokParserM s Text
chunk1 = do
  Maybe (Chunk s)
mc <- 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 (forall chunk token. Chunked chunk token => chunk -> Bool
chunkEmpty Chunk s
c) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall chunk. TextualChunked chunk => chunk -> Text
packChunk Chunk s
c)
    Maybe (Chunk s)
_ -> 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 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 :: forall s. SexpTokParserC s => SexpTokParserM s Atom
identAtomTP = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Atom
AtomIdent forall s. SexpTokParserC s => SexpTokParserM s Text
identifierTP

atomTP :: SexpTokParserC s => SexpTokParserM s Atom
atomTP :: forall s. SexpTokParserC s => SexpTokParserM s Atom
atomTP = forall s a.
SexpTokParserC s =>
SexpTokParserM s a -> SexpTokParserM s a
lexTP (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 = 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 forall s. SexpTokParserC s => SexpTokParserM s Text
chunk1 (forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"failed to parse sexp 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 forall a. Maybe a
Nothing ((forall a. Eq a => a -> a -> Bool
== Char
'"') forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Char
T.head) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Atom
AtomString forall s. SexpTokParserC s => SexpTokParserM s Text
stringTP)
    , 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 forall a. Maybe a
Nothing (Char -> Text -> Bool
unaryIdentPred Char
'+') forall s. SexpTokParserC s => SexpTokParserM s Atom
identAtomTP
    , 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 forall a. Maybe a
Nothing (Char -> Text -> Bool
unaryIdentPred Char
'-') forall s. SexpTokParserC s => SexpTokParserM s Atom
identAtomTP
    , 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 forall a. Maybe a
Nothing (Char -> Bool
signedNumStartPred forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Char
T.head) forall s. SexpTokParserC s => SexpTokParserM s Atom
numAtomTP
    , 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 forall a. Maybe a
Nothing (Char -> Bool
identStartPred forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Char
T.head) forall s. SexpTokParserC s => SexpTokParserM s Atom
identAtomTP
    ]

sexpTokParser :: SexpTokParserC s => SexpTokParserM s SexpTok
sexpTokParser :: forall s. SexpTokParserC s => SexpTokParserM s SexpTok
sexpTokParser= 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 = 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 forall s (m :: * -> *) l e.
(Stream s, Monad m) =>
ParserT l s e m (Token s)
anyToken (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Atom -> SexpTok
SexpTokAtom forall s. SexpTokParserC s => SexpTokParserM s Atom
atomTP)
    [ 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 forall a. Maybe a
Nothing (forall a. Eq a => a -> a -> Bool
== Char
'(') (SexpTok
SexpTokOpenParen forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall s. SexpTokParserC s => SexpTokParserM s ()
openParenTP)
    , 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 forall a. Maybe a
Nothing (forall a. Eq a => a -> a -> Bool
== Char
')') (SexpTok
SexpTokCloseParen forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ 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 :: forall s. SexpParserC s => SexpParserM s Atom
atomP = forall s (m :: * -> *) l e.
(Stream s, Monad m) =>
ParserT l s e m (Maybe (Token s))
popToken forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case { Just (SexpTokAtom Atom
a) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Atom
a; Maybe SexpTok
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"invalid atom" }

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

listP :: SexpParserC s => SexpParserM s a -> SexpParserM s (Seq a)
listP :: forall s a.
SexpParserC s =>
SexpParserM s a -> SexpParserM s (Seq a)
listP SexpParserM s a
root = 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 forall s. SexpParserC s => SexpParserM s ()
openParenP forall s. SexpParserC s => SexpParserM s ()
closeParenP (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 :: forall s a.
SexpParserC s =>
SexpParserM s a -> SexpParserM s (SexpF a)
recSexpParser SexpParserM s a
root = 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 = 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 forall s (m :: * -> *) l e.
(Stream s, Monad m) =>
ParserT l s e m (Token s)
anyToken forall (f :: * -> *) a. Alternative f => f a
empty
    [ 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 forall a. Maybe a
Nothing SexpTok -> Bool
isOpenParenTok (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Seq a -> SexpF a
SexpList (forall s a.
SexpParserC s =>
SexpParserM s a -> SexpParserM s (Seq a)
listP SexpParserM s a
root))
    , 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 forall a. Maybe a
Nothing SexpTok -> Bool
isCloseParenTok (forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"invalid close paren")
    , 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 forall a. Maybe a
Nothing SexpTok -> Bool
isAtomTok (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Atom -> SexpF a
SexpAtom forall s. SexpParserC s => SexpParserM s Atom
atomP)
    ]

sexpParser :: SexpParserC s => SexpParserM s Sexp
sexpParser :: forall s. SexpParserC s => SexpParserM s Sexp
sexpParser = let p :: ParserT Void s Void Identity Sexp
p = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SexpF Sexp -> Sexp
Sexp (forall s a.
SexpParserC s =>
SexpParserM s a -> SexpParserM s (SexpF a)
recSexpParser ParserT Void s Void Identity Sexp
p) in ParserT Void s Void Identity 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 :: forall s (m :: * -> *).
(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 = 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 forall s. SexpTokParserC s => SexpTokParserM s SexpTok
sexpTokParser forall a. a -> a
id forall s. SexpParserC s => SexpParserM s Sexp
sexpParser