{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}

-- | Parses Sexp-formatted ASTs
module SimpleParser.Examples.Direct.Ast
  ( AstLabel (..)
  , AstParserC
  , AstParserM
  , CtorRes (..)
  , Ctor (..)
  , CtorDefns
  , astParser
  , lexAstParser
  , identAstParser
  ) where

import Control.Monad (ap, void)
import Control.Monad.Except (MonadError (..))
import Data.Char (isSpace)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Sequence (Seq)
import Data.Text (Text)
import SimpleParser (Chunk, EmbedTextLabel (..), ExplainLabel (..), MatchBlock (..), MatchCase (MatchCase), Parser,
                     TextLabel, TextualStream, anyToken, betweenParser, consumeMatch, greedyStarParser, lexemeParser,
                     lookAheadMatch, matchToken, spaceParser, takeTokensWhile1, throwParser)
import qualified Text.Builder as TB

data AstLabel =
    AstLabelEmbedText !TextLabel
  | AstLabelCtorList
  | AstLabelCtorHead
  | AstLabelCtorBody !Text
  | AstLabelCustom !Text
  deriving (AstLabel -> AstLabel -> Bool
(AstLabel -> AstLabel -> Bool)
-> (AstLabel -> AstLabel -> Bool) -> Eq AstLabel
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AstLabel -> AstLabel -> Bool
$c/= :: AstLabel -> AstLabel -> Bool
== :: AstLabel -> AstLabel -> Bool
$c== :: AstLabel -> AstLabel -> Bool
Eq, Int -> AstLabel -> ShowS
[AstLabel] -> ShowS
AstLabel -> String
(Int -> AstLabel -> ShowS)
-> (AstLabel -> String) -> ([AstLabel] -> ShowS) -> Show AstLabel
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AstLabel] -> ShowS
$cshowList :: [AstLabel] -> ShowS
show :: AstLabel -> String
$cshow :: AstLabel -> String
showsPrec :: Int -> AstLabel -> ShowS
$cshowsPrec :: Int -> AstLabel -> ShowS
Show)

instance ExplainLabel AstLabel where
  explainLabel :: AstLabel -> Builder
explainLabel AstLabel
sl =
    case AstLabel
sl of
      AstLabelEmbedText TextLabel
tl -> TextLabel -> Builder
forall l. ExplainLabel l => l -> Builder
explainLabel TextLabel
tl
      AstLabel
AstLabelCtorList -> Builder
"constructor list"
      AstLabel
AstLabelCtorHead -> Builder
"constructor head"
      AstLabelCtorBody Text
t -> Builder
"constructor body (" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
TB.text Text
t Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
")"
      AstLabelCustom Text
t -> Builder
"custom: " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
TB.text Text
t

instance EmbedTextLabel AstLabel where
  embedTextLabel :: TextLabel -> AstLabel
embedTextLabel = TextLabel -> AstLabel
AstLabelEmbedText

type AstParserC s = (TextualStream s, Chunk s ~ Text)
type AstParserM s e a = Parser AstLabel s e a

data CtorRes e a =
    CtorResFail !String
  | CtorResErr !e
  | CtorResVal !a
  deriving stock (CtorRes e a -> CtorRes e a -> Bool
(CtorRes e a -> CtorRes e a -> Bool)
-> (CtorRes e a -> CtorRes e a -> Bool) -> Eq (CtorRes e a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall e a. (Eq e, Eq a) => CtorRes e a -> CtorRes e a -> Bool
/= :: CtorRes e a -> CtorRes e a -> Bool
$c/= :: forall e a. (Eq e, Eq a) => CtorRes e a -> CtorRes e a -> Bool
== :: CtorRes e a -> CtorRes e a -> Bool
$c== :: forall e a. (Eq e, Eq a) => CtorRes e a -> CtorRes e a -> Bool
Eq, Eq (CtorRes e a)
Eq (CtorRes e a)
-> (CtorRes e a -> CtorRes e a -> Ordering)
-> (CtorRes e a -> CtorRes e a -> Bool)
-> (CtorRes e a -> CtorRes e a -> Bool)
-> (CtorRes e a -> CtorRes e a -> Bool)
-> (CtorRes e a -> CtorRes e a -> Bool)
-> (CtorRes e a -> CtorRes e a -> CtorRes e a)
-> (CtorRes e a -> CtorRes e a -> CtorRes e a)
-> Ord (CtorRes e a)
CtorRes e a -> CtorRes e a -> Bool
CtorRes e a -> CtorRes e a -> Ordering
CtorRes e a -> CtorRes e a -> CtorRes e a
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall e a. (Ord e, Ord a) => Eq (CtorRes e a)
forall e a. (Ord e, Ord a) => CtorRes e a -> CtorRes e a -> Bool
forall e a.
(Ord e, Ord a) =>
CtorRes e a -> CtorRes e a -> Ordering
forall e a.
(Ord e, Ord a) =>
CtorRes e a -> CtorRes e a -> CtorRes e a
min :: CtorRes e a -> CtorRes e a -> CtorRes e a
$cmin :: forall e a.
(Ord e, Ord a) =>
CtorRes e a -> CtorRes e a -> CtorRes e a
max :: CtorRes e a -> CtorRes e a -> CtorRes e a
$cmax :: forall e a.
(Ord e, Ord a) =>
CtorRes e a -> CtorRes e a -> CtorRes e a
>= :: CtorRes e a -> CtorRes e a -> Bool
$c>= :: forall e a. (Ord e, Ord a) => CtorRes e a -> CtorRes e a -> Bool
> :: CtorRes e a -> CtorRes e a -> Bool
$c> :: forall e a. (Ord e, Ord a) => CtorRes e a -> CtorRes e a -> Bool
<= :: CtorRes e a -> CtorRes e a -> Bool
$c<= :: forall e a. (Ord e, Ord a) => CtorRes e a -> CtorRes e a -> Bool
< :: CtorRes e a -> CtorRes e a -> Bool
$c< :: forall e a. (Ord e, Ord a) => CtorRes e a -> CtorRes e a -> Bool
compare :: CtorRes e a -> CtorRes e a -> Ordering
$ccompare :: forall e a.
(Ord e, Ord a) =>
CtorRes e a -> CtorRes e a -> Ordering
$cp1Ord :: forall e a. (Ord e, Ord a) => Eq (CtorRes e a)
Ord, Int -> CtorRes e a -> ShowS
[CtorRes e a] -> ShowS
CtorRes e a -> String
(Int -> CtorRes e a -> ShowS)
-> (CtorRes e a -> String)
-> ([CtorRes e a] -> ShowS)
-> Show (CtorRes e a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall e a. (Show e, Show a) => Int -> CtorRes e a -> ShowS
forall e a. (Show e, Show a) => [CtorRes e a] -> ShowS
forall e a. (Show e, Show a) => CtorRes e a -> String
showList :: [CtorRes e a] -> ShowS
$cshowList :: forall e a. (Show e, Show a) => [CtorRes e a] -> ShowS
show :: CtorRes e a -> String
$cshow :: forall e a. (Show e, Show a) => CtorRes e a -> String
showsPrec :: Int -> CtorRes e a -> ShowS
$cshowsPrec :: forall e a. (Show e, Show a) => Int -> CtorRes e a -> ShowS
Show, a -> CtorRes e b -> CtorRes e a
(a -> b) -> CtorRes e a -> CtorRes e b
(forall a b. (a -> b) -> CtorRes e a -> CtorRes e b)
-> (forall a b. a -> CtorRes e b -> CtorRes e a)
-> Functor (CtorRes e)
forall a b. a -> CtorRes e b -> CtorRes e a
forall a b. (a -> b) -> CtorRes e a -> CtorRes e b
forall e a b. a -> CtorRes e b -> CtorRes e a
forall e a b. (a -> b) -> CtorRes e a -> CtorRes e b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> CtorRes e b -> CtorRes e a
$c<$ :: forall e a b. a -> CtorRes e b -> CtorRes e a
fmap :: (a -> b) -> CtorRes e a -> CtorRes e b
$cfmap :: forall e a b. (a -> b) -> CtorRes e a -> CtorRes e b
Functor, CtorRes e a -> Bool
(a -> m) -> CtorRes e a -> m
(a -> b -> b) -> b -> CtorRes e a -> b
(forall m. Monoid m => CtorRes e m -> m)
-> (forall m a. Monoid m => (a -> m) -> CtorRes e a -> m)
-> (forall m a. Monoid m => (a -> m) -> CtorRes e a -> m)
-> (forall a b. (a -> b -> b) -> b -> CtorRes e a -> b)
-> (forall a b. (a -> b -> b) -> b -> CtorRes e a -> b)
-> (forall b a. (b -> a -> b) -> b -> CtorRes e a -> b)
-> (forall b a. (b -> a -> b) -> b -> CtorRes e a -> b)
-> (forall a. (a -> a -> a) -> CtorRes e a -> a)
-> (forall a. (a -> a -> a) -> CtorRes e a -> a)
-> (forall a. CtorRes e a -> [a])
-> (forall a. CtorRes e a -> Bool)
-> (forall a. CtorRes e a -> Int)
-> (forall a. Eq a => a -> CtorRes e a -> Bool)
-> (forall a. Ord a => CtorRes e a -> a)
-> (forall a. Ord a => CtorRes e a -> a)
-> (forall a. Num a => CtorRes e a -> a)
-> (forall a. Num a => CtorRes e a -> a)
-> Foldable (CtorRes e)
forall a. Eq a => a -> CtorRes e a -> Bool
forall a. Num a => CtorRes e a -> a
forall a. Ord a => CtorRes e a -> a
forall m. Monoid m => CtorRes e m -> m
forall a. CtorRes e a -> Bool
forall a. CtorRes e a -> Int
forall a. CtorRes e a -> [a]
forall a. (a -> a -> a) -> CtorRes e a -> a
forall e a. Eq a => a -> CtorRes e a -> Bool
forall e a. Num a => CtorRes e a -> a
forall e a. Ord a => CtorRes e a -> a
forall m a. Monoid m => (a -> m) -> CtorRes e a -> m
forall e m. Monoid m => CtorRes e m -> m
forall e a. CtorRes e a -> Bool
forall e a. CtorRes e a -> Int
forall e a. CtorRes e a -> [a]
forall b a. (b -> a -> b) -> b -> CtorRes e a -> b
forall a b. (a -> b -> b) -> b -> CtorRes e a -> b
forall e a. (a -> a -> a) -> CtorRes e a -> a
forall e m a. Monoid m => (a -> m) -> CtorRes e a -> m
forall e b a. (b -> a -> b) -> b -> CtorRes e a -> b
forall e a b. (a -> b -> b) -> b -> CtorRes e 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 :: CtorRes e a -> a
$cproduct :: forall e a. Num a => CtorRes e a -> a
sum :: CtorRes e a -> a
$csum :: forall e a. Num a => CtorRes e a -> a
minimum :: CtorRes e a -> a
$cminimum :: forall e a. Ord a => CtorRes e a -> a
maximum :: CtorRes e a -> a
$cmaximum :: forall e a. Ord a => CtorRes e a -> a
elem :: a -> CtorRes e a -> Bool
$celem :: forall e a. Eq a => a -> CtorRes e a -> Bool
length :: CtorRes e a -> Int
$clength :: forall e a. CtorRes e a -> Int
null :: CtorRes e a -> Bool
$cnull :: forall e a. CtorRes e a -> Bool
toList :: CtorRes e a -> [a]
$ctoList :: forall e a. CtorRes e a -> [a]
foldl1 :: (a -> a -> a) -> CtorRes e a -> a
$cfoldl1 :: forall e a. (a -> a -> a) -> CtorRes e a -> a
foldr1 :: (a -> a -> a) -> CtorRes e a -> a
$cfoldr1 :: forall e a. (a -> a -> a) -> CtorRes e a -> a
foldl' :: (b -> a -> b) -> b -> CtorRes e a -> b
$cfoldl' :: forall e b a. (b -> a -> b) -> b -> CtorRes e a -> b
foldl :: (b -> a -> b) -> b -> CtorRes e a -> b
$cfoldl :: forall e b a. (b -> a -> b) -> b -> CtorRes e a -> b
foldr' :: (a -> b -> b) -> b -> CtorRes e a -> b
$cfoldr' :: forall e a b. (a -> b -> b) -> b -> CtorRes e a -> b
foldr :: (a -> b -> b) -> b -> CtorRes e a -> b
$cfoldr :: forall e a b. (a -> b -> b) -> b -> CtorRes e a -> b
foldMap' :: (a -> m) -> CtorRes e a -> m
$cfoldMap' :: forall e m a. Monoid m => (a -> m) -> CtorRes e a -> m
foldMap :: (a -> m) -> CtorRes e a -> m
$cfoldMap :: forall e m a. Monoid m => (a -> m) -> CtorRes e a -> m
fold :: CtorRes e m -> m
$cfold :: forall e m. Monoid m => CtorRes e m -> m
Foldable, Functor (CtorRes e)
Foldable (CtorRes e)
Functor (CtorRes e)
-> Foldable (CtorRes e)
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> CtorRes e a -> f (CtorRes e b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    CtorRes e (f a) -> f (CtorRes e a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> CtorRes e a -> m (CtorRes e b))
-> (forall (m :: * -> *) a.
    Monad m =>
    CtorRes e (m a) -> m (CtorRes e a))
-> Traversable (CtorRes e)
(a -> f b) -> CtorRes e a -> f (CtorRes e b)
forall e. Functor (CtorRes e)
forall e. Foldable (CtorRes e)
forall e (m :: * -> *) a.
Monad m =>
CtorRes e (m a) -> m (CtorRes e a)
forall e (f :: * -> *) a.
Applicative f =>
CtorRes e (f a) -> f (CtorRes e a)
forall e (m :: * -> *) a b.
Monad m =>
(a -> m b) -> CtorRes e a -> m (CtorRes e b)
forall e (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> CtorRes e a -> f (CtorRes e 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 =>
CtorRes e (m a) -> m (CtorRes e a)
forall (f :: * -> *) a.
Applicative f =>
CtorRes e (f a) -> f (CtorRes e a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> CtorRes e a -> m (CtorRes e b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> CtorRes e a -> f (CtorRes e b)
sequence :: CtorRes e (m a) -> m (CtorRes e a)
$csequence :: forall e (m :: * -> *) a.
Monad m =>
CtorRes e (m a) -> m (CtorRes e a)
mapM :: (a -> m b) -> CtorRes e a -> m (CtorRes e b)
$cmapM :: forall e (m :: * -> *) a b.
Monad m =>
(a -> m b) -> CtorRes e a -> m (CtorRes e b)
sequenceA :: CtorRes e (f a) -> f (CtorRes e a)
$csequenceA :: forall e (f :: * -> *) a.
Applicative f =>
CtorRes e (f a) -> f (CtorRes e a)
traverse :: (a -> f b) -> CtorRes e a -> f (CtorRes e b)
$ctraverse :: forall e (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> CtorRes e a -> f (CtorRes e b)
$cp2Traversable :: forall e. Foldable (CtorRes e)
$cp1Traversable :: forall e. Functor (CtorRes e)
Traversable)

instance Applicative (CtorRes e) where
  pure :: a -> CtorRes e a
pure = a -> CtorRes e a
forall e a. a -> CtorRes e a
CtorResVal
  <*> :: CtorRes e (a -> b) -> CtorRes e a -> CtorRes e b
(<*>) = CtorRes e (a -> b) -> CtorRes e a -> CtorRes e b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad (CtorRes e) where
  return :: a -> CtorRes e a
return = a -> CtorRes e a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  CtorRes e a
r >>= :: CtorRes e a -> (a -> CtorRes e b) -> CtorRes e b
>>= a -> CtorRes e b
f =
    case CtorRes e a
r of
      CtorResFail String
msg -> String -> CtorRes e b
forall e a. String -> CtorRes e a
CtorResFail String
msg
      CtorResErr e
err -> e -> CtorRes e b
forall e a. e -> CtorRes e a
CtorResErr e
err
      CtorResVal a
val -> a -> CtorRes e b
f a
val

instance MonadFail (CtorRes e) where
  fail :: String -> CtorRes e a
fail = String -> CtorRes e a
forall e a. String -> CtorRes e a
CtorResFail

instance MonadError e (CtorRes e) where
  throwError :: e -> CtorRes e a
throwError = e -> CtorRes e a
forall e a. e -> CtorRes e a
CtorResErr
  catchError :: CtorRes e a -> (e -> CtorRes e a) -> CtorRes e a
catchError CtorRes e a
r e -> CtorRes e a
h =
    case CtorRes e a
r of
      CtorResFail String
msg -> String -> CtorRes e a
forall e a. String -> CtorRes e a
CtorResFail String
msg
      CtorResErr e
err -> e -> CtorRes e a
h e
err
      CtorResVal a
val -> a -> CtorRes e a
forall e a. a -> CtorRes e a
CtorResVal a
val

embedCtorRes :: CtorRes e a -> AstParserM s e a
embedCtorRes :: CtorRes e a -> AstParserM s e a
embedCtorRes = \case
  CtorResFail String
msg -> String -> AstParserM s e a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
msg
  CtorResErr e
err -> e -> AstParserM s e a
forall (m :: * -> *) e l s a. Monad m => e -> ParserT l s e m a
throwParser e
err
  CtorResVal a
val -> a -> AstParserM s e a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
val

data Ctor s e t where
  Ctor0 :: CtorRes e t -> Ctor s e t
  Ctor1 :: (a -> CtorRes e t) -> AstParserM s e a -> Ctor s e t
  Ctor2 :: (a -> b -> CtorRes e t) -> AstParserM s e a -> AstParserM s e b -> Ctor s e t
  Ctor3 :: (a -> b -> c -> CtorRes e t) -> AstParserM s e a -> AstParserM s e b -> AstParserM s e c -> Ctor s e t
  Ctor4 :: (a -> b -> c -> d -> CtorRes e t) -> AstParserM s e a -> AstParserM s e b -> AstParserM s e c -> AstParserM s e d -> Ctor s e t
  Ctor5 :: (a -> b -> c -> d -> x -> CtorRes e t) -> AstParserM s e a -> AstParserM s e b -> AstParserM s e c -> AstParserM s e d -> AstParserM s e x -> Ctor s e t
  CtorN :: (Seq a -> CtorRes e t) -> AstParserM s e a -> Ctor s e t

type CtorDefns s e t = Map Text (Ctor s e t)

data Defns s e t = Defns
  { Defns s e t -> AstParserM s e t
defAtoms :: AstParserM s e t
  , Defns s e t -> CtorDefns s e t
defCtors :: CtorDefns s e t
  }

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

lexAstParser :: AstParserC s => AstParserM s e a -> AstParserM s e a
lexAstParser :: AstParserM s e a -> AstParserM s e a
lexAstParser = ParserT AstLabel s e Identity ()
-> AstParserM s e a -> AstParserM s e 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 AstLabel s e Identity ()
forall s e. AstParserC s => AstParserM s e ()
spaceP

openParenP :: AstParserC s => AstParserM s e ()
openParenP :: AstParserM s e ()
openParenP = AstParserM s e () -> AstParserM s e ()
forall s e a. AstParserC s => AstParserM s e a -> AstParserM s e a
lexAstParser (ParserT AstLabel s e Identity Char -> AstParserM s e ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Token s -> ParserT AstLabel s e 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 :: AstParserC s => AstParserM s e ()
closeParenP :: AstParserM s e ()
closeParenP = AstParserM s e () -> AstParserM s e ()
forall s e a. AstParserC s => AstParserM s e a -> AstParserM s e a
lexAstParser (ParserT AstLabel s e Identity Char -> AstParserM s e ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Token s -> ParserT AstLabel s e 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
')'))

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)

identAstParser :: AstParserC s => Maybe AstLabel -> AstParserM s e Text
identAstParser :: Maybe AstLabel -> AstParserM s e Text
identAstParser = AstParserM s e Text -> AstParserM s e Text
forall s e a. AstParserC s => AstParserM s e a -> AstParserM s e a
lexAstParser (AstParserM s e Text -> AstParserM s e Text)
-> (Maybe AstLabel -> AstParserM s e Text)
-> Maybe AstLabel
-> AstParserM s e Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe AstLabel -> (Char -> Bool) -> AstParserM s e Text)
-> (Char -> Bool) -> Maybe AstLabel -> AstParserM s e Text
forall a b c. (a -> b -> c) -> b -> a -> c
flip Maybe AstLabel -> (Char -> Bool) -> AstParserM s e Text
forall s (m :: * -> *) l e.
(Stream s, Monad m) =>
Maybe l -> (Token s -> Bool) -> ParserT l s e m (Chunk s)
takeTokensWhile1 Char -> Bool
nonDelimPred

astParser :: AstParserC s => AstParserM s e t -> (AstParserM s e t -> CtorDefns s e t) -> AstParserM s e t
astParser :: AstParserM s e t
-> (AstParserM s e t -> CtorDefns s e t) -> AstParserM s e t
astParser AstParserM s e t
mkAtom AstParserM s e t -> CtorDefns s e t
mkCtors = let p :: AstParserM s e t
p = Defns s e t -> AstParserM s e t
forall s e t. AstParserC s => Defns s e t -> AstParserM s e t
recAstParser (AstParserM s e t -> CtorDefns s e t -> Defns s e t
forall s e t. AstParserM s e t -> CtorDefns s e t -> Defns s e t
Defns AstParserM s e t
mkAtom (AstParserM s e t -> CtorDefns s e t
mkCtors AstParserM s e t
p)) in AstParserM s e t
p

recAstParser :: AstParserC s => Defns s e t -> AstParserM s e t
recAstParser :: Defns s e t -> AstParserM s e t
recAstParser Defns s e t
defns = MatchBlock AstLabel s e Identity Char t -> AstParserM s e t
forall (m :: * -> *) l s e a b.
Monad m =>
MatchBlock l s e m a b -> ParserT l s e m b
lookAheadMatch MatchBlock AstLabel s e Identity Char t
block where
  block :: MatchBlock AstLabel s e Identity Char t
block = ParserT AstLabel s e Identity Char
-> AstParserM s e t
-> [MatchCase AstLabel s e Identity Char t]
-> MatchBlock AstLabel s e Identity Char t
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 AstLabel s e Identity Char
forall s (m :: * -> *) l e.
(Stream s, Monad m) =>
ParserT l s e m (Token s)
anyToken (AstParserM s e t -> AstParserM s e t
forall s e a. AstParserC s => AstParserM s e a -> AstParserM s e a
lexAstParser (Defns s e t -> AstParserM s e t
forall s e t. Defns s e t -> AstParserM s e t
defAtoms Defns s e t
defns))
    [ Maybe AstLabel
-> (Char -> Bool)
-> AstParserM s e t
-> MatchCase AstLabel s e Identity Char t
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 (AstLabel -> Maybe AstLabel
forall a. a -> Maybe a
Just AstLabel
AstLabelCtorList) (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'(') (CtorDefns s e t -> AstParserM s e t
forall s e t. AstParserC s => CtorDefns s e t -> AstParserM s e t
ctorDefnsAstParser (Defns s e t -> CtorDefns s e t
forall s e t. Defns s e t -> CtorDefns s e t
defCtors Defns s e t
defns))
    ]

ctorDefnsAstParser :: AstParserC s => CtorDefns s e t -> AstParserM s e t
ctorDefnsAstParser :: CtorDefns s e t -> AstParserM s e t
ctorDefnsAstParser CtorDefns s e t
ctors = ParserT AstLabel s e Identity ()
-> ParserT AstLabel s e Identity ()
-> AstParserM s e t
-> AstParserM s e t
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 AstLabel s e Identity ()
forall s e. AstParserC s => AstParserM s e ()
openParenP ParserT AstLabel s e Identity ()
forall s e. AstParserC s => AstParserM s e ()
closeParenP (MatchBlock AstLabel s e Identity Text t -> AstParserM s e t
forall (m :: * -> *) l s e a b.
Monad m =>
MatchBlock l s e m a b -> ParserT l s e m b
consumeMatch MatchBlock AstLabel s e Identity Text t
block) where
  block :: MatchBlock AstLabel s e Identity Text t
block = ParserT AstLabel s e Identity Text
-> AstParserM s e t
-> [MatchCase AstLabel s e Identity Text t]
-> MatchBlock AstLabel s e Identity Text t
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 (Maybe AstLabel -> ParserT AstLabel s e Identity Text
forall s e. AstParserC s => Maybe AstLabel -> AstParserM s e Text
identAstParser (AstLabel -> Maybe AstLabel
forall a. a -> Maybe a
Just AstLabel
AstLabelCtorHead)) (String -> AstParserM s e t
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Could not match constructor") [MatchCase AstLabel s e Identity Text t]
cases
  cases :: [MatchCase AstLabel s e Identity Text t]
cases = (((Text, Ctor s e t) -> MatchCase AstLabel s e Identity Text t)
 -> [(Text, Ctor s e t)]
 -> [MatchCase AstLabel s e Identity Text t])
-> [(Text, Ctor s e t)]
-> ((Text, Ctor s e t) -> MatchCase AstLabel s e Identity Text t)
-> [MatchCase AstLabel s e Identity Text t]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Text, Ctor s e t) -> MatchCase AstLabel s e Identity Text t)
-> [(Text, Ctor s e t)] -> [MatchCase AstLabel s e Identity Text t]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (CtorDefns s e t -> [(Text, Ctor s e t)]
forall k a. Map k a -> [(k, a)]
Map.toList CtorDefns s e t
ctors) (((Text, Ctor s e t) -> MatchCase AstLabel s e Identity Text t)
 -> [MatchCase AstLabel s e Identity Text t])
-> ((Text, Ctor s e t) -> MatchCase AstLabel s e Identity Text t)
-> [MatchCase AstLabel s e Identity Text t]
forall a b. (a -> b) -> a -> b
$ \(Text
t, Ctor s e t
c) ->
    Maybe AstLabel
-> (Text -> Bool)
-> AstParserM s e t
-> MatchCase AstLabel s e Identity Text t
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 (AstLabel -> Maybe AstLabel
forall a. a -> Maybe a
Just (Text -> AstLabel
AstLabelCtorBody Text
t)) (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
t) (Ctor s e t -> AstParserM s e t
forall s e t. AstParserC s => Ctor s e t -> AstParserM s e t
ctorAstParser Ctor s e t
c)

ctorAstParser :: AstParserC s => Ctor s e t -> AstParserM s e t
ctorAstParser :: Ctor s e t -> AstParserM s e t
ctorAstParser = \case
  Ctor0 CtorRes e t
r -> CtorRes e t -> AstParserM s e t
forall e a s. CtorRes e a -> AstParserM s e a
embedCtorRes CtorRes e t
r
  Ctor1 a -> CtorRes e t
f AstParserM s e a
pa -> do
    a
a <- AstParserM s e a -> AstParserM s e a
forall s e a. AstParserC s => AstParserM s e a -> AstParserM s e a
lexAstParser AstParserM s e a
pa
    CtorRes e t -> AstParserM s e t
forall e a s. CtorRes e a -> AstParserM s e a
embedCtorRes (a -> CtorRes e t
f a
a)
  Ctor2 a -> b -> CtorRes e t
f AstParserM s e a
pa AstParserM s e b
pb -> do
    a
a <- AstParserM s e a -> AstParserM s e a
forall s e a. AstParserC s => AstParserM s e a -> AstParserM s e a
lexAstParser AstParserM s e a
pa
    b
b <- AstParserM s e b -> AstParserM s e b
forall s e a. AstParserC s => AstParserM s e a -> AstParserM s e a
lexAstParser AstParserM s e b
pb
    CtorRes e t -> AstParserM s e t
forall e a s. CtorRes e a -> AstParserM s e a
embedCtorRes (a -> b -> CtorRes e t
f a
a b
b)
  Ctor3 a -> b -> c -> CtorRes e t
f AstParserM s e a
pa AstParserM s e b
pb AstParserM s e c
pc -> do
    a
a <- AstParserM s e a -> AstParserM s e a
forall s e a. AstParserC s => AstParserM s e a -> AstParserM s e a
lexAstParser AstParserM s e a
pa
    b
b <- AstParserM s e b -> AstParserM s e b
forall s e a. AstParserC s => AstParserM s e a -> AstParserM s e a
lexAstParser AstParserM s e b
pb
    c
c <- AstParserM s e c -> AstParserM s e c
forall s e a. AstParserC s => AstParserM s e a -> AstParserM s e a
lexAstParser AstParserM s e c
pc
    CtorRes e t -> AstParserM s e t
forall e a s. CtorRes e a -> AstParserM s e a
embedCtorRes (a -> b -> c -> CtorRes e t
f a
a b
b c
c)
  Ctor4 a -> b -> c -> d -> CtorRes e t
f AstParserM s e a
pa AstParserM s e b
pb AstParserM s e c
pc AstParserM s e d
pd -> do
    a
a <- AstParserM s e a -> AstParserM s e a
forall s e a. AstParserC s => AstParserM s e a -> AstParserM s e a
lexAstParser AstParserM s e a
pa
    b
b <- AstParserM s e b -> AstParserM s e b
forall s e a. AstParserC s => AstParserM s e a -> AstParserM s e a
lexAstParser AstParserM s e b
pb
    c
c <- AstParserM s e c -> AstParserM s e c
forall s e a. AstParserC s => AstParserM s e a -> AstParserM s e a
lexAstParser AstParserM s e c
pc
    d
d <- AstParserM s e d -> AstParserM s e d
forall s e a. AstParserC s => AstParserM s e a -> AstParserM s e a
lexAstParser AstParserM s e d
pd
    CtorRes e t -> AstParserM s e t
forall e a s. CtorRes e a -> AstParserM s e a
embedCtorRes (a -> b -> c -> d -> CtorRes e t
f a
a b
b c
c d
d)
  Ctor5 a -> b -> c -> d -> x -> CtorRes e t
f AstParserM s e a
pa AstParserM s e b
pb AstParserM s e c
pc AstParserM s e d
pd AstParserM s e x
px -> do
    a
a <- AstParserM s e a -> AstParserM s e a
forall s e a. AstParserC s => AstParserM s e a -> AstParserM s e a
lexAstParser AstParserM s e a
pa
    b
b <- AstParserM s e b -> AstParserM s e b
forall s e a. AstParserC s => AstParserM s e a -> AstParserM s e a
lexAstParser AstParserM s e b
pb
    c
c <- AstParserM s e c -> AstParserM s e c
forall s e a. AstParserC s => AstParserM s e a -> AstParserM s e a
lexAstParser AstParserM s e c
pc
    d
d <- AstParserM s e d -> AstParserM s e d
forall s e a. AstParserC s => AstParserM s e a -> AstParserM s e a
lexAstParser AstParserM s e d
pd
    x
x <- AstParserM s e x -> AstParserM s e x
forall s e a. AstParserC s => AstParserM s e a -> AstParserM s e a
lexAstParser AstParserM s e x
px
    CtorRes e t -> AstParserM s e t
forall e a s. CtorRes e a -> AstParserM s e a
embedCtorRes (a -> b -> c -> d -> x -> CtorRes e t
f a
a b
b c
c d
d x
x)
  CtorN Seq a -> CtorRes e t
f AstParserM s e a
px -> do
    Seq a
xs <- AstParserM s e a -> ParserT AstLabel s e Identity (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 (AstParserM s e a -> AstParserM s e a
forall s e a. AstParserC s => AstParserM s e a -> AstParserM s e a
lexAstParser AstParserM s e a
px)
    CtorRes e t -> AstParserM s e t
forall e a s. CtorRes e a -> AstParserM s e a
embedCtorRes (Seq a -> CtorRes e t
f Seq a
xs)