{-# LANGUAGE OverloadedStrings #-}

-- | Parses S-expressions
module SimpleParser.Examples.Direct.Sexp
  ( SexpLabel (..)
  , 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,
                     Stream (..), TextLabel, TextualStream, anyToken, applySign, betweenParser, escapedStringParser,
                     lexemeParser, lookAheadMatch, matchToken, numParser, packChunk, popChunk, runParserEnd,
                     satisfyToken, sepByParser, signParser, signedNumStartPred, spaceParser, takeTokensWhile)
import SimpleParser.Examples.Common.Sexp (Atom (..), Sexp (..), SexpF (..))

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

instance ExplainLabel SexpLabel where
  explainLabel :: SexpLabel -> Builder
explainLabel SexpLabel
sl =
    case SexpLabel
sl of
      SexpLabel
SexpLabelIdentStart -> Builder
"start of identifier"
      SexpLabelEmbedText TextLabel
tl -> forall l. ExplainLabel l => l -> Builder
explainLabel TextLabel
tl
      SexpLabel
_ -> forall a. HasCallStack => a
undefined

instance EmbedTextLabel SexpLabel where
  embedTextLabel :: TextLabel -> SexpLabel
embedTextLabel = TextLabel -> SexpLabel
SexpLabelEmbedText

type SexpParserC s = TextualStream s

type SexpParserM s a = Parser SexpLabel s Void a

sexpParser :: SexpParserC s => SexpParserM s Sexp
sexpParser :: forall s. SexpParserC s => SexpParserM s Sexp
sexpParser = let p :: ParserT SexpLabel 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 SexpLabel s Void Identity Sexp
p) in ParserT SexpLabel s Void Identity Sexp
p

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 SexpLabel s Void Identity Char (SexpF a)
block where
  block :: MatchBlock SexpLabel s Void Identity Char (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 b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Atom -> SexpF a
SexpAtom forall s. SexpParserC s => SexpParserM s Atom
atomP)
    [ 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 (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))
    ]

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

stringP :: SexpParserC s => SexpParserM s Text
stringP :: forall s. SexpParserC s => SexpParserM s Text
stringP = 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
'"')

identifierP :: SexpParserC s => SexpParserM s Text
identifierP :: forall s. SexpParserC s => SexpParserM s Text
identifierP = 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 SexpLabel
SexpLabelIdentStart) 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))

spaceP :: SexpParserC s => SexpParserM s ()
spaceP :: forall s. SexpParserC s => SexpParserM s ()
spaceP = forall s (m :: * -> *) l e.
(Stream s, Token s ~ Char, Monad m) =>
ParserT l s e m ()
spaceParser

lexP :: SexpParserC s => SexpParserM s a -> SexpParserM s a
lexP :: forall s a. SexpParserC s => SexpParserM s a -> SexpParserM s a
lexP = 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. SexpParserC s => SexpParserM s ()
spaceP

openParenP :: SexpParserC s => SexpParserM s ()
openParenP :: forall s. SexpParserC s => SexpParserM s ()
openParenP = forall s a. SexpParserC s => SexpParserM s a -> SexpParserM s a
lexP (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
'('))

closeParenP :: SexpParserC s => SexpParserM s ()
closeParenP :: forall s. SexpParserC s => SexpParserM s ()
closeParenP = forall s a. SexpParserC s => SexpParserM s a -> SexpParserM s a
lexP (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
')'))

numAtomP :: SexpParserC s => SexpParserM s Atom
numAtomP :: forall s. SexpParserC s => SexpParserM s Atom
numAtomP = 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 :: SexpParserC s => SexpParserM s Text
chunk1 :: forall s. SexpParserC s => SexpParserM 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

identAtomP :: SexpParserC s => SexpParserM s Atom
identAtomP :: forall s. SexpParserC s => SexpParserM s Atom
identAtomP = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Atom
AtomIdent forall s. SexpParserC s => SexpParserM s Text
identifierP

atomP :: SexpParserC s => SexpParserM s Atom
atomP :: forall s. SexpParserC s => SexpParserM s Atom
atomP = forall s a. SexpParserC s => SexpParserM s a -> SexpParserM s a
lexP (forall (m :: * -> *) l s e a b.
Monad m =>
MatchBlock l s e m a b -> ParserT l s e m b
lookAheadMatch MatchBlock SexpLabel s Void Identity Text Atom
block) where
  block :: MatchBlock SexpLabel 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. SexpParserC s => SexpParserM 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. SexpParserC s => SexpParserM s Text
stringP)
    , 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. SexpParserC s => SexpParserM s Atom
identAtomP
    , 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. SexpParserC s => SexpParserM s Atom
identAtomP
    , 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. SexpParserC s => SexpParserM s Atom
numAtomP
    , 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. SexpParserC s => SexpParserM s Atom
identAtomP
    ]

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 s a. SexpParserC s => SexpParserM s a -> SexpParserM s a
lexP (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 () -> ParserT l s e m seq
sepByParser SexpParserM s a
root forall s. SexpParserC s => SexpParserM s ()
spaceP))

runSexpParser :: (
  Typeable s, Typeable (Token s), Typeable (Chunk s),
  Show s, Show (Token s), Show (Chunk s),
  SexpParserC s, MonadThrow m) => s -> m Sexp
runSexpParser :: forall s (m :: * -> *).
(Typeable s, Typeable (Token s), Typeable (Chunk s), Show s,
 Show (Token s), Show (Chunk s), SexpParserC s, MonadThrow m) =>
s -> m Sexp
runSexpParser = forall l s e (m :: * -> *) a.
(Typeable l, Typeable s, Typeable e, Typeable (Token s),
 Typeable (Chunk s), Show l, Show s, Show e, Show (Token s),
 Show (Chunk s), Stream s, MonadThrow m) =>
Parser l s e a -> s -> m a
runParserEnd forall s. SexpParserC s => SexpParserM s Sexp
sexpParser