{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE RecordWildCards #-}

-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com
-- SPDX-License-Identifier: MIT

-- The goal of the module is to parse given phi program to Ast
module Parser
  ( parseProgram,
    parseProgramThrows,
    parseExpression,
    parseExpressionThrows,
    parseAttribute,
    parseBinding,
  )
where

import Ast
import Control.Exception (Exception, throwIO)
import Control.Monad (guard)
import Data.Char (isAsciiLower, isDigit, isLower)
import Data.Scientific (toRealFloat)
import Data.Sequence (mapWithIndex)
import Data.Text.Internal.Fusion.Size (lowerBound)
import Data.Void
import GHC.Char (chr)
import Misc (numToHex, strToHex, withVoidRho)
import Numeric (readHex)
import Text.Megaparsec
import Text.Megaparsec.Char (alphaNumChar, char, digitChar, hexDigitChar, letterChar, lowerChar, space1, string, upperChar)
import qualified Text.Megaparsec.Char.Lexer as L
import Text.Printf (printf)

type Parser = Parsec Void String

data ParserException
  = CouldNotParseProgram {ParserException -> String
message :: String}
  | CouldNotParseExpression {message :: String}
  deriving (Show ParserException
Typeable ParserException
(Typeable ParserException, Show ParserException) =>
(ParserException -> SomeException)
-> (SomeException -> Maybe ParserException)
-> (ParserException -> String)
-> Exception ParserException
SomeException -> Maybe ParserException
ParserException -> String
ParserException -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e) -> (e -> String) -> Exception e
$ctoException :: ParserException -> SomeException
toException :: ParserException -> SomeException
$cfromException :: SomeException -> Maybe ParserException
fromException :: SomeException -> Maybe ParserException
$cdisplayException :: ParserException -> String
displayException :: ParserException -> String
Exception)

instance Show ParserException where
  show :: ParserException -> String
show CouldNotParseProgram {String
message :: ParserException -> String
message :: String
..} = String -> ShowS
forall r. PrintfType r => String -> r
printf String
"Couldn't parse given phi program, cause: %s" String
message
  show CouldNotParseExpression {String
message :: ParserException -> String
message :: String
..} = String -> ShowS
forall r. PrintfType r => String -> r
printf String
"Couldn't parse given phi program, cause: %s" String
message

dataExpression :: String -> String -> Expression
dataExpression :: String -> String -> Expression
dataExpression String
obj String
bts =
  Expression -> Binding -> Expression
ExApplication
    (Expression -> Attribute -> Expression
ExDispatch (Expression -> Attribute -> Expression
ExDispatch (Expression -> Attribute -> Expression
ExDispatch Expression
ExGlobal (String -> Attribute
AtLabel String
"org")) (String -> Attribute
AtLabel String
"eolang")) (String -> Attribute
AtLabel String
obj))
    ( Attribute -> Expression -> Binding
BiTau
        (Integer -> Attribute
AtAlpha Integer
0)
        ( Expression -> Binding -> Expression
ExApplication
            (Expression -> Attribute -> Expression
ExDispatch (Expression -> Attribute -> Expression
ExDispatch (Expression -> Attribute -> Expression
ExDispatch Expression
ExGlobal (String -> Attribute
AtLabel String
"org")) (String -> Attribute
AtLabel String
"eolang")) (String -> Attribute
AtLabel String
"bytes"))
            ( Attribute -> Expression -> Binding
BiTau
                (Integer -> Attribute
AtAlpha Integer
0)
                ([Binding] -> Expression
ExFormation [String -> Binding
BiDelta String
bts, Attribute -> Binding
BiVoid Attribute
AtRho])
            )
        )
    )

-- White space consumer
whiteSpace :: Parser ()
whiteSpace :: Parser ()
whiteSpace = Parser () -> Parser () -> Parser () -> Parser ()
forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> m () -> m () -> m ()
L.space Parser ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space1 Parser ()
forall a. ParsecT Void String Identity a
forall (f :: * -> *) a. Alternative f => f a
empty Parser ()
forall a. ParsecT Void String Identity a
forall (f :: * -> *) a. Alternative f => f a
empty

-- Lexeme that ignores white spaces after
lexeme :: Parser a -> Parser a
lexeme :: forall a. Parser a -> Parser a
lexeme = Parser ()
-> ParsecT Void String Identity a -> ParsecT Void String Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m () -> m a -> m a
L.lexeme Parser ()
whiteSpace

-- Strict symbol (or sequence of symbols) with ignored white spaces after
symbol :: String -> Parser String
symbol :: String -> Parser String
symbol = Parser ()
-> Tokens String -> ParsecT Void String Identity (Tokens String)
forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> Tokens s -> m (Tokens s)
L.symbol Parser ()
whiteSpace

label' :: Parser String
label' :: Parser String
label' = Parser String -> Parser String
forall a. Parser a -> Parser a
lexeme (Parser String -> Parser String) -> Parser String -> Parser String
forall a b. (a -> b) -> a -> b
$ do
  Char
first <- [Token String] -> ParsecT Void String Identity (Token String)
forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
oneOf [Char
'a' .. Char
'z']
  String
rest <- ParsecT Void String Identity Char -> Parser String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many ((Token String -> Bool)
-> ParsecT Void String Identity (Token String)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy (Token String -> [Token String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` String
[Token String]
" \r\n\t,.|':;!?][}{)(⟧⟦") ParsecT Void String Identity Char
-> String -> ParsecT Void String Identity Char
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"allowed character")
  String -> Parser String
forall a. a -> ParsecT Void String Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
first Char -> ShowS
forall a. a -> [a] -> [a]
: String
rest)

escapedChar :: Parser Char
escapedChar :: ParsecT Void String Identity Char
escapedChar = do
  Char
_ <- Token String -> ParsecT Void String Identity (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'\\'
  Char
c <- [Token String] -> ParsecT Void String Identity (Token String)
forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
oneOf [Char
'\\', Char
'"', Char
'n', Char
'r', Char
't', Char
'b', Char
'f', Char
'u', Char
'x']
  case Char
c of
    Char
'\\' -> Char -> ParsecT Void String Identity Char
forall a. a -> ParsecT Void String Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Char
'\\'
    Char
'"' -> Char -> ParsecT Void String Identity Char
forall a. a -> ParsecT Void String Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Char
'"'
    Char
'n' -> Char -> ParsecT Void String Identity Char
forall a. a -> ParsecT Void String Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Char
'\n'
    Char
'r' -> Char -> ParsecT Void String Identity Char
forall a. a -> ParsecT Void String Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Char
'\r'
    Char
't' -> Char -> ParsecT Void String Identity Char
forall a. a -> ParsecT Void String Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Char
'\t'
    Char
'b' -> Char -> ParsecT Void String Identity Char
forall a. a -> ParsecT Void String Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Char
'\b'
    Char
'f' -> Char -> ParsecT Void String Identity Char
forall a. a -> ParsecT Void String Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Char
'\f'
    Char
'u' -> ParsecT Void String Identity Char
unicodeEscape
    Char
'x' -> ParsecT Void String Identity Char
hexEscape
    Char
_ -> String -> ParsecT Void String Identity Char
forall a. String -> ParsecT Void String Identity a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> ParsecT Void String Identity Char)
-> String -> ParsecT Void String Identity Char
forall a b. (a -> b) -> a -> b
$ String
"Unknown escape: \\" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
c]
  where
    unicodeEscape :: Parser Char
    unicodeEscape :: ParsecT Void String Identity Char
unicodeEscape = do
      String
hexDigits <- Int -> ParsecT Void String Identity Char -> Parser String
forall (m :: * -> *) a. Monad m => Int -> m a -> m [a]
count Int
4 ParsecT Void String Identity Char
ParsecT Void String Identity (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
hexDigitChar
      case ReadS Int
forall a. (Eq a, Num a) => ReadS a
readHex String
hexDigits of
        [(Int
n, String
"")] ->
          if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0xD800 Bool -> Bool -> Bool
&& Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0xDBFF
            then -- High surrogate, look for low surrogate
              do
                Tokens String
_ <- Tokens String -> ParsecT Void String Identity (Tokens String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string String
Tokens String
"\\u"
                String
lowHexDigits <- Int -> ParsecT Void String Identity Char -> Parser String
forall (m :: * -> *) a. Monad m => Int -> m a -> m [a]
count Int
4 ParsecT Void String Identity Char
ParsecT Void String Identity (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
hexDigitChar
                case ReadS Int
forall a. (Eq a, Num a) => ReadS a
readHex String
lowHexDigits of
                  [(Int
low, String
"")] ->
                    if Int
low Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0xDC00 Bool -> Bool -> Bool
&& Int
low Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0xDFFF
                      then do
                        -- Valid surrogate pair, combine them
                        let codePoint :: Int
codePoint = Int
0x10000 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ((Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
0xD800) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
0x400) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
low Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
0xDC00)
                        Char -> ParsecT Void String Identity Char
forall a. a -> ParsecT Void String Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Char
chr Int
codePoint)
                      else String -> ParsecT Void String Identity Char
forall a. String -> ParsecT Void String Identity a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Invalid low surrogate: \\u" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
lowHexDigits)
                  [(Int, String)]
_ -> String -> ParsecT Void String Identity Char
forall a. String -> ParsecT Void String Identity a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Invalid low surrogate hex: \\u" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
lowHexDigits)
            else
              if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0xDC00 Bool -> Bool -> Bool
&& Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0xDFFF
                then String -> ParsecT Void String Identity Char
forall a. String -> ParsecT Void String Identity a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Unexpected low surrogate: \\u" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
hexDigits)
                else
                  if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 Bool -> Bool -> Bool
&& Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0x10FFFF
                    then Char -> ParsecT Void String Identity Char
forall a. a -> ParsecT Void String Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Char
chr Int
n)
                    else String -> ParsecT Void String Identity Char
forall a. String -> ParsecT Void String Identity a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Invalid Unicode code point: \\u" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
hexDigits)
    hexEscape :: Parser Char
    hexEscape :: ParsecT Void String Identity Char
hexEscape = do
      String
digits <- Int -> ParsecT Void String Identity Char -> Parser String
forall (m :: * -> *) a. Monad m => Int -> m a -> m [a]
count Int
2 ParsecT Void String Identity Char
ParsecT Void String Identity (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
hexDigitChar
      case ReadS Int
forall a. (Eq a, Num a) => ReadS a
readHex String
digits of
        [(Int
n, String
"")] -> Char -> ParsecT Void String Identity Char
forall a. a -> ParsecT Void String Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Char
chr Int
n)
        [(Int, String)]
_ -> String -> ParsecT Void String Identity Char
forall a. String -> ParsecT Void String Identity a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> ParsecT Void String Identity Char)
-> String -> ParsecT Void String Identity Char
forall a b. (a -> b) -> a -> b
$ String
"Invalid hex escape: \\x" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
digits

function :: Parser String
function :: Parser String
function = Parser String -> Parser String
forall a. Parser a -> Parser a
lexeme (Parser String -> Parser String) -> Parser String -> Parser String
forall a b. (a -> b) -> a -> b
$ do
  Char
first <- [Token String] -> ParsecT Void String Identity (Token String)
forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
oneOf [Char
'A' .. Char
'Z']
  String
rest <-
    ParsecT Void String Identity Char -> Parser String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many
      ( (Token String -> Bool)
-> ParsecT Void String Identity (Token String)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy
          (\Token String
ch -> Char -> Bool
isDigit Char
Token String
ch Bool -> Bool -> Bool
|| Char -> Bool
isAsciiLower Char
Token String
ch Bool -> Bool -> Bool
|| Char
Token String
ch Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
Token String
ch Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'φ')
          ParsecT Void String Identity Char
-> String -> ParsecT Void String Identity Char
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"allowed character in function name"
      )
  String -> Parser String
forall a. a -> ParsecT Void String Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
first Char -> ShowS
forall a. a -> [a] -> [a]
: String
rest)

delta :: Parser String
delta :: Parser String
delta =
  [Parser String] -> Parser String
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ String -> Parser String
symbol String
"D>",
      String -> Parser String
symbol String
"Δ" Parser String -> Parser String -> Parser String
forall a b.
ParsecT Void String Identity a
-> ParsecT Void String Identity b -> ParsecT Void String Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser String
dashedArrow
    ]

lambda :: Parser String
lambda :: Parser String
lambda =
  [Parser String] -> Parser String
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ String -> Parser String
symbol String
"L>",
      String -> Parser String
symbol String
"λ" Parser String -> Parser String -> Parser String
forall a b.
ParsecT Void String Identity a
-> ParsecT Void String Identity b -> ParsecT Void String Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser String
dashedArrow
    ]

dashedArrow :: Parser String
dashedArrow :: Parser String
dashedArrow = String -> Parser String
symbol String
"⤍"

arrow :: Parser String
arrow :: Parser String
arrow = [Parser String] -> Parser String
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [String -> Parser String
symbol String
"->", String -> Parser String
symbol String
"↦"]

global :: Parser String
global :: Parser String
global = [Parser String] -> Parser String
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [String -> Parser String
symbol String
"Q", String -> Parser String
symbol String
"Φ"]

meta :: Char -> Parser String
meta :: Char -> Parser String
meta Char
ch = do
  Char
_ <- Token String -> ParsecT Void String Identity (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'!'
  Char
c <- Token String -> ParsecT Void String Identity (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
ch
  String
ds <- Parser String -> Parser String
forall a. Parser a -> Parser a
lexeme (ParsecT Void String Identity Char -> Parser String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many ParsecT Void String Identity Char
ParsecT Void String Identity (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
digitChar)
  String -> Parser String
forall a. a -> ParsecT Void String Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: String
ds)

meta' :: Char -> String -> Parser String
meta' :: Char -> String -> Parser String
meta' Char
ch String
uni =
  [Parser String] -> Parser String
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ Char -> Parser String
meta Char
ch,
      do
        String
_ <- String -> Parser String
symbol String
uni
        String
ds <- Parser String -> Parser String
forall a. Parser a -> Parser a
lexeme (ParsecT Void String Identity Char -> Parser String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many ParsecT Void String Identity Char
ParsecT Void String Identity (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
digitChar)
        String -> Parser String
forall a. a -> ParsecT Void String Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
ch Char -> ShowS
forall a. a -> [a] -> [a]
: String
ds)
    ]

byte :: Parser String
byte :: Parser String
byte = do
  Char
f <- ParsecT Void String Identity Char
ParsecT Void String Identity (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
hexDigitChar ParsecT Void String Identity Char
-> (Char -> ParsecT Void String Identity Char)
-> ParsecT Void String Identity Char
forall a b.
ParsecT Void String Identity a
-> (a -> ParsecT Void String Identity b)
-> ParsecT Void String Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Char -> ParsecT Void String Identity Char
forall {m :: * -> *}. MonadFail m => Char -> m Char
upperHex
  Char
s <- ParsecT Void String Identity Char
ParsecT Void String Identity (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
hexDigitChar ParsecT Void String Identity Char
-> (Char -> ParsecT Void String Identity Char)
-> ParsecT Void String Identity Char
forall a b.
ParsecT Void String Identity a
-> (a -> ParsecT Void String Identity b)
-> ParsecT Void String Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Char -> ParsecT Void String Identity Char
forall {m :: * -> *}. MonadFail m => Char -> m Char
upperHex
  String -> Parser String
forall a. a -> ParsecT Void String Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return [Char
f, Char
s]
  where
    upperHex :: Char -> m Char
upperHex Char
ch
      | Char -> Bool
isDigit Char
ch Bool -> Bool -> Bool
|| (Char
'A' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
ch Bool -> Bool -> Bool
&& Char
ch Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'F') = Char -> m Char
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Char
ch
      | Bool
otherwise = String -> m Char
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"expected 0-9 or A-F, got " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char -> String
forall a. Show a => a -> String
show Char
ch)

-- bytes
-- 1. empty: --
-- 2. one byte: 01-
-- 3. many bytes: 01-02-...-FF
bytes :: Parser String
bytes :: Parser String
bytes =
  Parser String -> Parser String
forall a. Parser a -> Parser a
lexeme
    ( [Parser String] -> Parser String
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
        [ String -> Parser String
symbol String
"--",
          Parser String -> Parser String
forall a. Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parser String -> Parser String) -> Parser String -> Parser String
forall a b. (a -> b) -> a -> b
$ do
            String
first <- Parser String
byte
            [String]
rest <- Parser String -> ParsecT Void String Identity [String]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some (Parser String -> ParsecT Void String Identity [String])
-> Parser String -> ParsecT Void String Identity [String]
forall a b. (a -> b) -> a -> b
$ do
              Char
dash <- Token String -> ParsecT Void String Identity (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'-'
              String
bte <- Parser String
byte
              String -> Parser String
forall a. a -> ParsecT Void String Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
dash Char -> ShowS
forall a. a -> [a] -> [a]
: String
bte)
            String -> Parser String
forall a. a -> ParsecT Void String Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
first String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String]
rest),
          Parser String
byte Parser String -> (String -> Parser String) -> Parser String
forall a b.
ParsecT Void String Identity a
-> (a -> ParsecT Void String Identity b)
-> ParsecT Void String Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \String
bte -> Token String -> ParsecT Void String Identity (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'-' ParsecT Void String Identity Char
-> (Char -> Parser String) -> Parser String
forall a b.
ParsecT Void String Identity a
-> (a -> ParsecT Void String Identity b)
-> ParsecT Void String Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Char
dash -> String -> Parser String
forall a. a -> ParsecT Void String Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
bte String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
dash])
        ]
        Parser String -> String -> Parser String
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"bytes"
    )

tauBinding :: Parser Attribute -> Parser Binding
tauBinding :: Parser Attribute -> Parser Binding
tauBinding Parser Attribute
attr = do
  Attribute
attr' <- Parser Attribute
attr
  [Parser Binding] -> Parser Binding
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ Parser Binding -> Parser Binding
forall a. Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parser Binding -> Parser Binding)
-> Parser Binding -> Parser Binding
forall a b. (a -> b) -> a -> b
$ do
        String
_ <- Parser String
arrow
        Attribute -> Expression -> Binding
BiTau Attribute
attr' (Expression -> Binding)
-> ParsecT Void String Identity Expression -> Parser Binding
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void String Identity Expression
expression,
      do
        String
_ <- String -> Parser String
symbol String
"("
        [Binding]
voids <- (Attribute -> Binding) -> [Attribute] -> [Binding]
forall a b. (a -> b) -> [a] -> [b]
map Attribute -> Binding
BiVoid ([Attribute] -> [Binding])
-> ParsecT Void String Identity [Attribute]
-> ParsecT Void String Identity [Binding]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Attribute
void' Parser Attribute
-> Parser String -> ParsecT Void String Identity [Attribute]
forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
`sepBy` String -> Parser String
symbol String
","
        String
_ <- String -> Parser String
symbol String
")"
        String
_ <- Parser String
arrow
        ExFormation [Binding]
bs <- ParsecT Void String Identity Expression
formation
        Binding -> Parser Binding
forall a. a -> ParsecT Void String Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Attribute -> Expression -> Binding
BiTau Attribute
attr' ([Binding] -> Expression
ExFormation ([Binding] -> [Binding]
withVoidRho ([Binding]
voids [Binding] -> [Binding] -> [Binding]
forall a. [a] -> [a] -> [a]
++ [Binding]
bs))))
    ]

metaBinding :: Parser Binding
metaBinding :: Parser Binding
metaBinding = String -> Binding
BiMeta (String -> Binding) -> Parser String -> Parser Binding
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> String -> Parser String
meta' Char
'B' String
"𝐵"

-- binding
-- 1. tau
-- 2. void
-- 3. delta
-- 4. meta delta
-- 5. meta
-- 6. lambda
-- 7. meta lambda
binding :: Parser Binding
binding :: Parser Binding
binding =
  [Parser Binding] -> Parser Binding
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ Parser Binding -> Parser Binding
forall a. Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parser Attribute -> Parser Binding
tauBinding Parser Attribute
attribute),
      Parser Binding -> Parser Binding
forall a. Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parser Binding -> Parser Binding)
-> Parser Binding -> Parser Binding
forall a b. (a -> b) -> a -> b
$ do
        Attribute
attr <- Parser Attribute
attribute
        String
_ <- Parser String
arrow
        String
_ <- [Parser String] -> Parser String
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [String -> Parser String
symbol String
"?", String -> Parser String
symbol String
"∅"]
        Binding -> Parser Binding
forall a. a -> ParsecT Void String Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Attribute -> Binding
BiVoid Attribute
attr),
      Parser Binding -> Parser Binding
forall a. Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parser Binding -> Parser Binding)
-> Parser Binding -> Parser Binding
forall a b. (a -> b) -> a -> b
$ do
        String
_ <- Parser String
delta
        String -> Binding
BiDelta (String -> Binding) -> Parser String -> Parser Binding
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser String
bytes,
      Parser Binding -> Parser Binding
forall a. Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parser Binding -> Parser Binding)
-> Parser Binding -> Parser Binding
forall a b. (a -> b) -> a -> b
$ do
        String
_ <- Parser String
delta
        String -> Binding
BiMetaDelta (String -> Binding) -> Parser String -> Parser Binding
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> Parser String
meta Char
'b',
      Parser Binding -> Parser Binding
forall a. Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try Parser Binding
metaBinding,
      Parser Binding -> Parser Binding
forall a. Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parser Binding -> Parser Binding)
-> Parser Binding -> Parser Binding
forall a b. (a -> b) -> a -> b
$ do
        String
_ <- Parser String
lambda
        String -> Binding
BiLambda (String -> Binding) -> Parser String -> Parser Binding
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser String
function,
      do
        String
_ <- Parser String
lambda
        String -> Binding
BiMetaLambda (String -> Binding) -> Parser String -> Parser Binding
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> Parser String
meta Char
'F'
    ]
    Parser Binding -> String -> Parser Binding
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"binding"

-- inlined void attribute
-- 1. label
-- 2. rho
-- 3. phi
void' :: Parser Attribute
void' :: Parser Attribute
void' =
  [Parser Attribute] -> Parser Attribute
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ String -> Attribute
AtLabel (String -> Attribute) -> Parser String -> Parser Attribute
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser String
label',
      do
        String
_ <- [Parser String] -> Parser String
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [String -> Parser String
symbol String
"^", String -> Parser String
symbol String
"ρ"]
        Attribute -> Parser Attribute
forall a. a -> ParsecT Void String Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Attribute
AtRho,
      do
        String
_ <- [Parser String] -> Parser String
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [String -> Parser String
symbol String
"@", String -> Parser String
symbol String
"φ"]
        Attribute -> Parser Attribute
forall a. a -> ParsecT Void String Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Attribute
AtPhi
    ]

-- attribute
-- 1. label
-- 2. meta
-- 3. rho
-- 4. phi
attribute :: Parser Attribute
attribute :: Parser Attribute
attribute =
  [Parser Attribute] -> Parser Attribute
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ Parser Attribute
void',
      String -> Attribute
AtMeta (String -> Attribute) -> Parser String -> Parser Attribute
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> String -> Parser String
meta' Char
'a' String
"𝜏"
    ]
    Parser Attribute -> String -> Parser Attribute
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"attribute"

-- full attribute
-- 1. label
-- 2. meta
-- 3. rho
-- 4. phi
-- 5. alpha
fullAttribute :: Parser Attribute
fullAttribute :: Parser Attribute
fullAttribute =
  [Parser Attribute] -> Parser Attribute
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ Parser Attribute
attribute,
      do
        String
_ <- [Parser String] -> Parser String
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [String -> Parser String
symbol String
"~", String -> Parser String
symbol String
"α"]
        Integer -> Attribute
AtAlpha (Integer -> Attribute)
-> ParsecT Void String Identity Integer -> Parser Attribute
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void String Identity Integer
-> ParsecT Void String Identity Integer
forall a. Parser a -> Parser a
lexeme ParsecT Void String Identity Integer
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
L.decimal
    ]
    Parser Attribute -> String -> Parser Attribute
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"full attribute"

-- formation
formation :: Parser Expression
formation :: ParsecT Void String Identity Expression
formation = do
  String
_ <- [Parser String] -> Parser String
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [String -> Parser String
symbol String
"[[", String -> Parser String
symbol String
"⟦"]
  [Binding]
bs <- Parser Binding
binding Parser Binding
-> Parser String -> ParsecT Void String Identity [Binding]
forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
`sepBy` String -> Parser String
symbol String
","
  String
_ <- [Parser String] -> Parser String
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [String -> Parser String
symbol String
"]]", String -> Parser String
symbol String
"⟧"]
  Expression -> ParsecT Void String Identity Expression
forall a. a -> ParsecT Void String Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Binding] -> Expression
ExFormation [Binding]
bs)

-- head part of expression
-- 1. formation
-- 2. this
-- 3. global
-- 4. termination
-- 5. meta expression
-- 6. full attribute -> sugar for $.attr
exHead :: Parser Expression
exHead :: ParsecT Void String Identity Expression
exHead =
  [ParsecT Void String Identity Expression]
-> ParsecT Void String Identity Expression
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ do
        ExFormation [Binding]
bs <- ParsecT Void String Identity Expression
formation
        Expression -> ParsecT Void String Identity Expression
forall a. a -> ParsecT Void String Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Binding] -> Expression
ExFormation ([Binding] -> [Binding]
withVoidRho [Binding]
bs)),
      do
        String
_ <- [Parser String] -> Parser String
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [String -> Parser String
symbol String
"$", String -> Parser String
symbol String
"ξ"]
        Expression -> ParsecT Void String Identity Expression
forall a. a -> ParsecT Void String Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Expression
ExThis,
      ParsecT Void String Identity Expression
-> ParsecT Void String Identity Expression
forall a. Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ParsecT Void String Identity Expression
 -> ParsecT Void String Identity Expression)
-> ParsecT Void String Identity Expression
-> ParsecT Void String Identity Expression
forall a b. (a -> b) -> a -> b
$ do
        String
_ <- [Parser String] -> Parser String
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [String -> Parser String
symbol String
"QQ", String -> Parser String
symbol String
"Φ̇"]
        Expression -> ParsecT Void String Identity Expression
forall a. a -> ParsecT Void String Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression -> Attribute -> Expression
ExDispatch (Expression -> Attribute -> Expression
ExDispatch Expression
ExGlobal (String -> Attribute
AtLabel String
"org")) (String -> Attribute
AtLabel String
"eolang")),
      do
        String
_ <- Parser String
global
        Expression -> ParsecT Void String Identity Expression
forall a. a -> ParsecT Void String Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Expression
ExGlobal,
      do
        String
_ <- [Parser String] -> Parser String
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [String -> Parser String
symbol String
"T", String -> Parser String
symbol String
"⊥"]
        Expression -> ParsecT Void String Identity Expression
forall a. a -> ParsecT Void String Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Expression
ExTermination,
      do
        Maybe Char
sign <- ParsecT Void String Identity Char
-> ParsecT Void String Identity (Maybe Char)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional ([ParsecT Void String Identity Char]
-> ParsecT Void String Identity Char
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [Token String -> ParsecT Void String Identity (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'-', Token String -> ParsecT Void String Identity (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'+'])
        Scientific
unsigned <- Parser Scientific -> Parser Scientific
forall a. Parser a -> Parser a
lexeme Parser Scientific
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m Scientific
L.scientific
        let num :: Double
num =
              Scientific -> Double
forall a. RealFloat a => Scientific -> a
toRealFloat
                ( case Maybe Char
sign of
                    Just Char
'-' -> Scientific -> Scientific
forall a. Num a => a -> a
negate Scientific
unsigned
                    Maybe Char
_ -> Scientific
unsigned
                )
        Expression -> ParsecT Void String Identity Expression
forall a. a -> ParsecT Void String Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> String -> Expression
dataExpression String
"number" (Double -> String
numToHex Double
num)),
      ParsecT Void String Identity Expression
-> ParsecT Void String Identity Expression
forall a. Parser a -> Parser a
lexeme (ParsecT Void String Identity Expression
 -> ParsecT Void String Identity Expression)
-> ParsecT Void String Identity Expression
-> ParsecT Void String Identity Expression
forall a b. (a -> b) -> a -> b
$ do
        Char
_ <- Token String -> ParsecT Void String Identity (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'"'
        String
str <- ParsecT Void String Identity Char
-> ParsecT Void String Identity Char -> Parser String
forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
manyTill ([ParsecT Void String Identity Char]
-> ParsecT Void String Identity Char
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [ParsecT Void String Identity Char
escapedChar, [Token String] -> ParsecT Void String Identity (Token String)
forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
noneOf [Char
'\\', Char
'"']]) (Token String -> ParsecT Void String Identity (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'"')
        Expression -> ParsecT Void String Identity Expression
forall a. a -> ParsecT Void String Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> String -> Expression
dataExpression String
"string" (ShowS
strToHex String
str)),
      ParsecT Void String Identity Expression
-> ParsecT Void String Identity Expression
forall a. Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (String -> Expression
ExMeta (String -> Expression)
-> Parser String -> ParsecT Void String Identity Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> String -> Parser String
meta' Char
'e' String
"𝑒"),
      Expression -> Attribute -> Expression
ExDispatch Expression
ExThis (Attribute -> Expression)
-> Parser Attribute -> ParsecT Void String Identity Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Attribute
fullAttribute
    ]
    ParsecT Void String Identity Expression
-> String -> ParsecT Void String Identity Expression
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"expression head"

application :: Expression -> [Binding] -> Expression
application :: Expression -> [Binding] -> Expression
application = (Expression -> Binding -> Expression)
-> Expression -> [Binding] -> Expression
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Expression -> Binding -> Expression
ExApplication

-- tail optional part of application
-- 1. any head + dispatch
-- 2. any head except $ and Q + application
-- 3. any head except meta tail + meta tail
exTail :: Expression -> Parser Expression
exTail :: Expression -> ParsecT Void String Identity Expression
exTail Expression
expr =
  [ParsecT Void String Identity Expression]
-> ParsecT Void String Identity Expression
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ do
        Expression
next <-
          [ParsecT Void String Identity Expression]
-> ParsecT Void String Identity Expression
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
            [ do
                String
_ <- String -> Parser String
symbol String
"."
                Expression -> Attribute -> Expression
ExDispatch Expression
expr (Attribute -> Expression)
-> Parser Attribute -> ParsecT Void String Identity Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Attribute
fullAttribute,
              do
                Bool -> Parser ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard
                  ( case Expression
expr of
                      Expression
ExThis -> Bool
False
                      Expression
ExGlobal -> Bool
False
                      Expression
_ -> Bool
True
                  )
                String
_ <- String -> Parser String
symbol String
"("
                [Binding]
bds <-
                  [ParsecT Void String Identity [Binding]]
-> ParsecT Void String Identity [Binding]
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
                    [ ParsecT Void String Identity [Binding]
-> ParsecT Void String Identity [Binding]
forall a. Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ParsecT Void String Identity [Binding]
 -> ParsecT Void String Identity [Binding])
-> ParsecT Void String Identity [Binding]
-> ParsecT Void String Identity [Binding]
forall a b. (a -> b) -> a -> b
$ Parser Attribute -> Parser Binding
tauBinding Parser Attribute
fullAttribute Parser Binding
-> Parser String -> ParsecT Void String Identity [Binding]
forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
`sepBy1` String -> Parser String
symbol String
",",
                      do
                        [Expression]
exprs <- ParsecT Void String Identity Expression
expression ParsecT Void String Identity Expression
-> Parser String -> ParsecT Void String Identity [Expression]
forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
`sepBy1` String -> Parser String
symbol String
","
                        [Binding] -> ParsecT Void String Identity [Binding]
forall a. a -> ParsecT Void String Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Integer -> Expression -> Binding)
-> [Integer] -> [Expression] -> [Binding]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Attribute -> Expression -> Binding
BiTau (Attribute -> Expression -> Binding)
-> (Integer -> Attribute) -> Integer -> Expression -> Binding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Attribute
AtAlpha) [Integer
0 ..] [Expression]
exprs) -- \idx expr -> BiTau (AtAlpha idx) expr
                    ]
                String
_ <- String -> Parser String
symbol String
")"
                Expression -> ParsecT Void String Identity Expression
forall a. a -> ParsecT Void String Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression -> [Binding] -> Expression
application Expression
expr [Binding]
bds),
              do
                Bool -> Parser ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard
                  ( case Expression
expr of
                      ExMetaTail Expression
_ String
_ -> Bool
False
                      Expression
_ -> Bool
True
                  )
                String
_ <- String -> Parser String
symbol String
"*"
                Expression -> String -> Expression
ExMetaTail Expression
expr (String -> Expression)
-> Parser String -> ParsecT Void String Identity Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> Parser String
meta Char
't'
            ]
            ParsecT Void String Identity Expression
-> String -> ParsecT Void String Identity Expression
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"dispatch or application"
        Expression -> ParsecT Void String Identity Expression
exTail Expression
next,
      Expression -> ParsecT Void String Identity Expression
forall a. a -> ParsecT Void String Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Expression
expr
    ]

expression :: Parser Expression
expression :: ParsecT Void String Identity Expression
expression = do
  Expression
expr <- ParsecT Void String Identity Expression
exHead
  Expression -> ParsecT Void String Identity Expression
exTail Expression
expr

program :: Parser Program
program :: Parser Program
program =
  [Parser Program] -> Parser Program
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ do
        String
_ <- String -> Parser String
symbol String
"{"
        Program
prog <- Expression -> Program
Program (Expression -> Program)
-> ParsecT Void String Identity Expression -> Parser Program
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void String Identity Expression
expression
        String
_ <- String -> Parser String
symbol String
"}"
        Program -> Parser Program
forall a. a -> ParsecT Void String Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Program
prog,
      do
        String
_ <- Parser String
global
        String
_ <- Parser String
arrow
        Expression -> Program
Program (Expression -> Program)
-> ParsecT Void String Identity Expression -> Parser Program
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void String Identity Expression
expression
    ]
    Parser Program -> String -> Parser Program
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"program"

-- Entry point
parse' :: String -> Parser a -> String -> Either String a
parse' :: forall a. String -> Parser a -> String -> Either String a
parse' String
name Parser a
parser String
input = do
  let parsed :: Either (ParseErrorBundle String Void) a
parsed =
        Parser a
-> String -> String -> Either (ParseErrorBundle String Void) a
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
runParser
          ( do
              ()
_ <- Parser ()
whiteSpace
              a
p <- Parser a
parser
              ()
_ <- Parser ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof
              a -> Parser a
forall a. a -> ParsecT Void String Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return a
p
          )
          String
name
          String
input
  case Either (ParseErrorBundle String Void) a
parsed of
    Right a
parsed' -> a -> Either String a
forall a b. b -> Either a b
Right a
parsed'
    Left ParseErrorBundle String Void
err -> String -> Either String a
forall a b. a -> Either a b
Left (ParseErrorBundle String Void -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorBundlePretty ParseErrorBundle String Void
err)

parseBinding :: String -> Either String Binding
parseBinding :: String -> Either String Binding
parseBinding = String -> Parser Binding -> String -> Either String Binding
forall a. String -> Parser a -> String -> Either String a
parse' String
"binding" Parser Binding
binding

parseAttribute :: String -> Either String Attribute
parseAttribute :: String -> Either String Attribute
parseAttribute = String -> Parser Attribute -> String -> Either String Attribute
forall a. String -> Parser a -> String -> Either String a
parse' String
"attribute" Parser Attribute
fullAttribute

parseExpression :: String -> Either String Expression
parseExpression :: String -> Either String Expression
parseExpression = String
-> ParsecT Void String Identity Expression
-> String
-> Either String Expression
forall a. String -> Parser a -> String -> Either String a
parse' String
"expression" ParsecT Void String Identity Expression
expression

parseExpressionThrows :: String -> IO Expression
parseExpressionThrows :: String -> IO Expression
parseExpressionThrows String
expression = case String -> Either String Expression
parseExpression String
expression of
  Right Expression
expr -> Expression -> IO Expression
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Expression
expr
  Left String
err -> ParserException -> IO Expression
forall e a. Exception e => e -> IO a
throwIO (String -> ParserException
CouldNotParseExpression String
err)

parseProgram :: String -> Either String Program
parseProgram :: String -> Either String Program
parseProgram = String -> Parser Program -> String -> Either String Program
forall a. String -> Parser a -> String -> Either String a
parse' String
"program" Parser Program
program

parseProgramThrows :: String -> IO Program
parseProgramThrows :: String -> IO Program
parseProgramThrows String
program = case String -> Either String Program
parseProgram String
program of
  Right Program
prog -> Program -> IO Program
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Program
prog
  Left String
err -> ParserException -> IO Program
forall e a. Exception e => e -> IO a
throwIO (String -> ParserException
CouldNotParseProgram String
err)