{-# 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
(SexpLabel -> SexpLabel -> Bool)
-> (SexpLabel -> SexpLabel -> Bool) -> Eq SexpLabel
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
(Int -> SexpLabel -> ShowS)
-> (SexpLabel -> String)
-> ([SexpLabel] -> ShowS)
-> Show SexpLabel
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 -> TextLabel -> Builder
forall l. ExplainLabel l => l -> Builder
explainLabel TextLabel
tl
      SexpLabel
_ -> Builder
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 :: SexpParserM s Sexp
sexpParser = let p :: SexpParserM s Sexp
p = (SexpF Sexp -> Sexp)
-> ParserT SexpLabel 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 SexpLabel 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

recSexpParser :: SexpParserC s => SexpParserM s a -> SexpParserM s (SexpF a)
recSexpParser :: SexpParserM s a -> SexpParserM s (SexpF a)
recSexpParser SexpParserM s a
root = MatchBlock SexpLabel s Void Identity Char (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 SexpLabel s Void Identity Char (SexpF a)
block where
  block :: MatchBlock SexpLabel s Void Identity Char (SexpF a)
block = ParserT SexpLabel s Void Identity Char
-> SexpParserM s (SexpF a)
-> [MatchCase SexpLabel s Void Identity Char (SexpF a)]
-> MatchBlock SexpLabel s Void Identity Char (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 SexpLabel s Void Identity Char
forall s (m :: * -> *) l e.
(Stream s, Monad m) =>
ParserT l s e m (Token s)
anyToken ((Atom -> SexpF a)
-> ParserT SexpLabel 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 SexpLabel s Void Identity Atom
forall s. SexpParserC s => SexpParserM s Atom
atomP)
    [ Maybe SexpLabel
-> (Char -> Bool)
-> SexpParserM s (SexpF a)
-> MatchCase SexpLabel s Void Identity Char (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 SexpLabel
forall a. Maybe a
Nothing (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'(') ((Seq a -> SexpF a)
-> ParserT SexpLabel 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 SexpLabel s Void Identity (Seq a)
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 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

stringP :: SexpParserC s => SexpParserM s Text
stringP :: SexpParserM s Text
stringP = (Chunk s -> Text)
-> ParserT SexpLabel s Void Identity (Chunk s)
-> SexpParserM 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 SexpLabel 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
'"')

identifierP :: SexpParserC s => SexpParserM s Text
identifierP :: SexpParserM s Text
identifierP = do
  Char
x <- Maybe SexpLabel
-> (Token s -> Bool) -> ParserT SexpLabel 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 (SexpLabel -> Maybe SexpLabel
forall a. a -> Maybe a
Just SexpLabel
SexpLabelIdentStart) Char -> Bool
Token s -> Bool
identStartPred
  Chunk s
xs <- (Token s -> Bool) -> ParserT SexpLabel 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 -> SexpParserM 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))

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

openParenP :: SexpParserC s => SexpParserM s ()
openParenP :: SexpParserM s ()
openParenP = SexpParserM s () -> SexpParserM s ()
forall s a. SexpParserC s => SexpParserM s a -> SexpParserM s a
lexP (ParserT SexpLabel s Void Identity Char -> SexpParserM s ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Token s -> ParserT SexpLabel 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
'('))

closeParenP :: SexpParserC s => SexpParserM s ()
closeParenP :: SexpParserM s ()
closeParenP = SexpParserM s () -> SexpParserM s ()
forall s a. SexpParserC s => SexpParserM s a -> SexpParserM s a
lexP (ParserT SexpLabel s Void Identity Char -> SexpParserM s ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Token s -> ParserT SexpLabel 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
')'))

numAtomP :: SexpParserC s => SexpParserM s Atom
numAtomP :: SexpParserM s Atom
numAtomP = do
  Maybe Sign
ms <- ParserT SexpLabel 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 SexpLabel 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 -> SexpParserM 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 -> SexpParserM 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 :: SexpParserC s => SexpParserM s Text
chunk1 :: SexpParserM s Text
chunk1 = do
  Maybe (Chunk s)
mc <- Int -> ParserT SexpLabel 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 -> SexpParserM 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)
_ -> SexpParserM 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

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

atomP :: SexpParserC s => SexpParserM s Atom
atomP :: SexpParserM s Atom
atomP = SexpParserM s Atom -> SexpParserM s Atom
forall s a. SexpParserC s => SexpParserM s a -> SexpParserM s a
lexP (MatchBlock SexpLabel s Void Identity Text Atom
-> SexpParserM 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 SexpLabel s Void Identity Text Atom
block) where
  block :: MatchBlock SexpLabel s Void Identity Text Atom
block = ParserT SexpLabel s Void Identity Text
-> SexpParserM s Atom
-> [MatchCase SexpLabel s Void Identity Text Atom]
-> MatchBlock SexpLabel 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 SexpLabel s Void Identity Text
forall s. SexpParserC s => SexpParserM s Text
chunk1 (String -> SexpParserM s Atom
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"failed to parse sexp atom")
    [ Maybe SexpLabel
-> (Text -> Bool)
-> SexpParserM s Atom
-> MatchCase SexpLabel 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 SexpLabel
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 SexpLabel s Void Identity Text -> SexpParserM s Atom
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Atom
AtomString ParserT SexpLabel s Void Identity Text
forall s. SexpParserC s => SexpParserM s Text
stringP)
    , Maybe SexpLabel
-> (Text -> Bool)
-> SexpParserM s Atom
-> MatchCase SexpLabel 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 SexpLabel
forall a. Maybe a
Nothing (Char -> Text -> Bool
unaryIdentPred Char
'+') SexpParserM s Atom
forall s. SexpParserC s => SexpParserM s Atom
identAtomP
    , Maybe SexpLabel
-> (Text -> Bool)
-> SexpParserM s Atom
-> MatchCase SexpLabel 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 SexpLabel
forall a. Maybe a
Nothing (Char -> Text -> Bool
unaryIdentPred Char
'-') SexpParserM s Atom
forall s. SexpParserC s => SexpParserM s Atom
identAtomP
    , Maybe SexpLabel
-> (Text -> Bool)
-> SexpParserM s Atom
-> MatchCase SexpLabel 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 SexpLabel
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) SexpParserM s Atom
forall s. SexpParserC s => SexpParserM s Atom
numAtomP
    , Maybe SexpLabel
-> (Text -> Bool)
-> SexpParserM s Atom
-> MatchCase SexpLabel 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 SexpLabel
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) SexpParserM s Atom
forall s. SexpParserC s => SexpParserM s Atom
identAtomP
    ]

listP :: SexpParserC s => SexpParserM s a -> SexpParserM s (Seq a)
listP :: SexpParserM s a -> SexpParserM s (Seq a)
listP SexpParserM s a
root = SexpParserM s (Seq a) -> SexpParserM s (Seq a)
forall s a. SexpParserC s => SexpParserM s a -> SexpParserM s a
lexP (ParserT SexpLabel s Void Identity ()
-> ParserT SexpLabel 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 SexpLabel s Void Identity ()
forall s. SexpParserC s => SexpParserM s ()
openParenP ParserT SexpLabel s Void Identity ()
forall s. SexpParserC s => SexpParserM s ()
closeParenP (SexpParserM s a
-> ParserT SexpLabel s Void Identity () -> 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 () -> ParserT l s e m seq
sepByParser SexpParserM s a
root ParserT SexpLabel s Void Identity ()
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 :: s -> m Sexp
runSexpParser = Parser SexpLabel s Void Sexp -> s -> m Sexp
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 Parser SexpLabel s Void Sexp
forall s. SexpParserC s => SexpParserM s Sexp
sexpParser