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

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

module Parser
  ( parseExpression
  , parseExpression'
  , parseExpressionThrows
  , parseExpressionThrows'
  , Form (..)
  , parseAttribute
  , parseAttributeThrows
  , ParserException (..)
  , parseAlpha
  , parseIndex
  , parseNumber
  , parseNumberThrows
  , parseBinding
  , parseBytes
  , PhiParser (..)
  , phiParser
  )
where

import AST
import Bytes (nonFiniteBts, nonFiniteOf, numToBts, strToBts)
import Control.Exception (Exception)
import Control.Monad (guard, when)
import Control.Monad.Trans.State.Strict (StateT, evalStateT, get, put)
import Data.Char (isAsciiLower, isAsciiUpper, isDigit)
import Data.Scientific (scientific, toRealFloat)
import qualified Data.Set as Set
import qualified Data.Text as T
import Data.Void
import GHC.Char
import Misc
import Numeric
import Text.Megaparsec
import Text.Megaparsec.Char
import qualified Text.Megaparsec.Char.Lexer as L
import Text.Printf (printf)

data Form = MONOFORM | POLYFORM
  deriving (Form -> Form -> Bool
(Form -> Form -> Bool) -> (Form -> Form -> Bool) -> Eq Form
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Form -> Form -> Bool
== :: Form -> Form -> Bool
$c/= :: Form -> Form -> Bool
/= :: Form -> Form -> Bool
Eq, Int -> Form -> String -> String
[Form] -> String -> String
Form -> String
(Int -> Form -> String -> String)
-> (Form -> String) -> ([Form] -> String -> String) -> Show Form
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Form -> String -> String
showsPrec :: Int -> Form -> String -> String
$cshow :: Form -> String
show :: Form -> String
$cshowList :: [Form] -> String -> String
showList :: [Form] -> String -> String
Show)

data Script = Ascii | Unicode
  deriving (Script -> Script -> Bool
(Script -> Script -> Bool)
-> (Script -> Script -> Bool) -> Eq Script
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Script -> Script -> Bool
== :: Script -> Script -> Bool
$c/= :: Script -> Script -> Bool
/= :: Script -> Script -> Bool
Eq)

data Style = Free | Open | Fixed Script String SourcePos

type Parser = StateT Style (Parsec Void String)

data ParserException
  = CouldNotParseExpression {ParserException -> String
message :: String}
  | CouldNotParseAttribute {message :: String}
  | CouldNotParseNumber {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)

data PhiParser = PhiParser
  { PhiParser -> Parsec Void String Attribute
_attribute :: Parsec Void String Attribute
  , PhiParser -> Parsec Void String Alpha
_alpha :: Parsec Void String Alpha
  , PhiParser -> Parsec Void String (Either Slot Text)
_index :: Parsec Void String (Either Slot T.Text)
  , PhiParser -> Parsec Void String Binding
_binding :: Parsec Void String Binding
  , PhiParser -> Parsec Void String Expression
_expression :: Parsec Void String Expression
  , PhiParser -> Parsec Void String String
_string :: Parsec Void String String
  }

phiParser :: PhiParser
phiParser :: PhiParser
phiParser = Parsec Void String Attribute
-> Parsec Void String Alpha
-> Parsec Void String (Either Slot Text)
-> Parsec Void String Binding
-> Parsec Void String Expression
-> Parsec Void String String
-> PhiParser
PhiParser (Parser Attribute -> Parsec Void String Attribute
forall a. Parser a -> Parsec Void String a
free Parser Attribute
attribute) (Parser Alpha -> Parsec Void String Alpha
forall a. Parser a -> Parsec Void String a
free Parser Alpha
alpha) (Parser (Either Slot Text) -> Parsec Void String (Either Slot Text)
forall a. Parser a -> Parsec Void String a
free Parser (Either Slot Text)
indexVar) (Parser Binding -> Parsec Void String Binding
forall a. Parser a -> Parsec Void String a
free Parser Binding
binding) (Parser Expression -> Parsec Void String Expression
forall a. Parser a -> Parsec Void String a
free Parser Expression
expression) (Parser String -> Parsec Void String String
forall a. Parser a -> Parsec Void String a
free Parser String
quotedStr)
  where
    free :: Parser a -> Parsec Void String a
    free :: forall a. Parser a -> Parsec Void String a
free Parser a
parser = Parser a -> Style -> ParsecT Void String Identity a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT Parser a
parser Style
Free

instance Show ParserException where
  show :: ParserException -> String
show CouldNotParseExpression{String
message :: ParserException -> String
message :: String
..} = String -> String -> String
forall r. PrintfType r => String -> r
printf String
"Couldn't parse given phi expression, cause: %s" String
message
  show CouldNotParseAttribute{String
message :: ParserException -> String
message :: String
..} = String -> String -> String
forall r. PrintfType r => String -> r
printf String
"Couldn't parse given attribute, cause: %s" String
message
  show CouldNotParseNumber{String
message :: ParserException -> String
message :: String
..} = String -> String -> String
forall r. PrintfType r => String -> r
printf String
"Couldn't parse given number to 'Φ.number', cause: %s" String
message

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. StateT Style (Parsec Void String) a
forall (f :: * -> *) a. Alternative f => f a
empty Parser ()
forall a. StateT Style (Parsec Void String) a
forall (f :: * -> *) a. Alternative f => f a
empty

lexeme :: Parser a -> Parser a
lexeme :: forall a. Parser a -> Parser a
lexeme = Parser ()
-> StateT Style (Parsec Void String) a
-> StateT Style (Parsec Void String) a
forall e s (m :: * -> *) a. MonadParsec e s m => m () -> m a -> m a
L.lexeme Parser ()
whiteSpace

symbol :: String -> Parser String
symbol :: String -> Parser String
symbol = Parser ()
-> Tokens String
-> StateT Style (Parsec Void String) (Tokens String)
forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> Tokens s -> m (Tokens s)
L.symbol Parser ()
whiteSpace

twofold :: Parser String -> Parser String -> Parser String
twofold :: Parser String -> Parser String -> Parser String
twofold Parser String
ascii' Parser String
unicode' = StateT Style (Parsec Void String) Style
forall (m :: * -> *) s. Monad m => StateT s m s
get StateT Style (Parsec Void String) Style
-> (Style -> Parser String) -> Parser String
forall a b.
StateT Style (Parsec Void String) a
-> (a -> StateT Style (Parsec Void String) b)
-> StateT Style (Parsec Void String) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Style -> Parser String
spelled
  where
    spelled :: Style -> Parser String
    spelled :: Style -> Parser String
spelled Style
Free = Parser String
ascii' Parser String -> Parser String -> Parser String
forall a.
StateT Style (Parsec Void String) a
-> StateT Style (Parsec Void String) a
-> StateT Style (Parsec Void String) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser String
unicode'
    spelled Style
Open = do
      SourcePos
pos <- StateT Style (Parsec Void String) SourcePos
forall s e (m :: * -> *).
(TraversableStream s, MonadParsec e s m) =>
m SourcePos
getSourcePos
      (Script
script, String
word) <- Parser (Script, String)
written
      Style -> Parser ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (Script -> String -> SourcePos -> Style
Fixed Script
script String
word SourcePos
pos)
      String -> Parser String
forall a. a -> StateT Style (Parsec Void String) a
forall (m :: * -> *) a. Monad m => a -> m a
return String
word
    spelled (Fixed Script
first String
spelling SourcePos
at) = do
      Int
offset <- StateT Style (Parsec Void String) Int
forall e s (m :: * -> *). MonadParsec e s m => m Int
getOffset
      SourcePos
pos <- StateT Style (Parsec Void String) SourcePos
forall s e (m :: * -> *).
(TraversableStream s, MonadParsec e s m) =>
m SourcePos
getSourcePos
      (Script
script, String
word) <- Parser (Script, String)
written
      Bool -> Parser () -> Parser ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
        (Script
script Script -> Script -> Bool
forall a. Eq a => a -> a -> Bool
/= Script
first)
        ( ParseError String Void -> Parser ()
forall e s (m :: * -> *).
MonadParsec e s m =>
ParseError s e -> m ()
registerParseError (Int -> Set (ErrorFancy Void) -> ParseError String Void
forall s e. Int -> Set (ErrorFancy e) -> ParseError s e
FancyError Int
offset (ErrorFancy Void -> Set (ErrorFancy Void)
forall a. a -> Set a
Set.singleton (String -> ErrorFancy Void
forall e. String -> ErrorFancy e
ErrorFail (String
-> String
-> String
-> String
-> String
-> String
-> String
-> String
forall r. PrintfType r => String -> r
printf String
"The %s symbol \"%s\" at %s mixes with the %s \"%s\" at %s, while --monoform is set" (Script -> String
named Script
script) String
word (SourcePos -> String
place SourcePos
pos) (Script -> String
named Script
first) String
spelling (SourcePos -> String
place SourcePos
at)))))
            Parser () -> Parser () -> Parser ()
forall a b.
StateT Style (Parsec Void String) a
-> StateT Style (Parsec Void String) b
-> StateT Style (Parsec Void String) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Style -> Parser ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put Style
Free
        )
      String -> Parser String
forall a. a -> StateT Style (Parsec Void String) a
forall (m :: * -> *) a. Monad m => a -> m a
return String
word
    written :: Parser (Script, String)
    written :: Parser (Script, String)
written = ((,) Script
Ascii (String -> (Script, String))
-> Parser String -> Parser (Script, String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser String
ascii') Parser (Script, String)
-> Parser (Script, String) -> Parser (Script, String)
forall a.
StateT Style (Parsec Void String) a
-> StateT Style (Parsec Void String) a
-> StateT Style (Parsec Void String) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ((,) Script
Unicode (String -> (Script, String))
-> Parser String -> Parser (Script, String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser String
unicode')
    named :: Script -> String
    named :: Script -> String
named Script
Ascii = String
"ASCII"
    named Script
Unicode = String
"Unicode"
    place :: SourcePos -> String
    place :: SourcePos -> String
place SourcePos
pos = String -> Int -> Int -> String
forall r. PrintfType r => String -> r
printf String
"%d:%d" (Pos -> Int
unPos (SourcePos -> Pos
sourceLine SourcePos
pos)) (Pos -> Int
unPos (SourcePos -> Pos
sourceColumn SourcePos
pos))

label' :: Parser T.Text
label' :: Parser Text
label' = Parser Text -> Parser Text
forall a. Parser a -> Parser a
lexeme (Parser Text -> Parser Text) -> Parser Text -> Parser Text
forall a b. (a -> b) -> a -> b
$ do
  Char
first <- [Token String] -> StateT Style (Parsec Void String) (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 <- StateT Style (Parsec Void String) Char -> Parser String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many ([StateT Style (Parsec Void String) Char]
-> StateT Style (Parsec Void String) Char
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [StateT Style (Parsec Void String) Char
-> StateT Style (Parsec Void String) Char
forall a. Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Token String -> StateT Style (Parsec Void String) (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'-' StateT Style (Parsec Void String) Char
-> Parser () -> StateT Style (Parsec Void String) Char
forall a b.
StateT Style (Parsec Void String) a
-> StateT Style (Parsec Void String) b
-> StateT Style (Parsec Void String) a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* StateT Style (Parsec Void String) Char -> Parser ()
forall a. StateT Style (Parsec Void String) a -> Parser ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy (Token String -> StateT Style (Parsec Void String) (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'>')), (Token String -> Bool)
-> StateT Style (Parsec Void String) (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,.|':;!?][}{)(⟧⟦-↦⤍>\"ξΦ⊥")] StateT Style (Parsec Void String) Char
-> String -> StateT Style (Parsec Void String) Char
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"allowed character")
  Text -> Parser Text
forall a. a -> StateT Style (Parsec Void String) a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Text
T.pack (Char
first Char -> String -> String
forall a. a -> [a] -> [a]
: String
rest))

function :: Parser String
function :: Parser String
function =
  Parser String -> Parser String
forall a. Parser a -> Parser a
lexeme
    ( do
        Char
first <- [Token String] -> StateT Style (Parsec Void String) (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 <-
          StateT Style (Parsec Void String) Char -> Parser String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many
            ( (Token String -> Bool)
-> StateT Style (Parsec Void String) (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
'φ')
                StateT Style (Parsec Void String) Char
-> String -> StateT Style (Parsec Void String) 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 -> StateT Style (Parsec Void String) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
first Char -> String -> String
forall a. a -> [a] -> [a]
: String
rest)
    )
    Parser String -> String -> Parser String
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"function name"

delta :: Parser String
delta :: Parser String
delta = Parser String -> Parser String -> Parser String
twofold (String -> Parser String
symbol String
"D>") (String
"Δ ⤍" String -> Parser String -> Parser String
forall a b.
a
-> StateT Style (Parsec Void String) b
-> StateT Style (Parsec Void String) a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (String -> Parser String
symbol String
"Δ" Parser String -> Parser String -> Parser String
forall a b.
StateT Style (Parsec Void String) a
-> StateT Style (Parsec Void String) b
-> StateT Style (Parsec Void String) 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 -> Parser String
twofold (String -> Parser String
symbol String
"L>") (String
"λ ⤍" String -> Parser String -> Parser String
forall a b.
a
-> StateT Style (Parsec Void String) b
-> StateT Style (Parsec Void String) a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (String -> Parser String
symbol String
"λ" Parser String -> Parser String -> Parser String
forall a b.
StateT Style (Parsec Void String) a
-> StateT Style (Parsec Void String) b
-> StateT Style (Parsec Void String) 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 -> Parser String
twofold (String -> Parser String
symbol String
"->") (String -> Parser String
symbol String
"↦")

global :: Parser String
global :: Parser String
global = Parser String -> Parser String -> Parser String
twofold (Char -> Parser String
ascii Char
'Q') (String -> Parser String
symbol String
"Φ")

ascii :: Char -> Parser String
ascii :: Char -> Parser String
ascii Char
letter = Parser String -> Parser String
forall a. Parser a -> Parser a
lexeme (Parser String -> Parser String
forall a. Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Char -> String
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Char -> String)
-> StateT Style (Parsec Void String) Char -> Parser String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Token String -> StateT Style (Parsec Void String) (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
letter Parser String -> Parser () -> Parser String
forall a b.
StateT Style (Parsec Void String) a
-> StateT Style (Parsec Void String) b
-> StateT Style (Parsec Void String) a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* StateT Style (Parsec Void String) Char -> Parser ()
forall a. StateT Style (Parsec Void String) a -> Parser ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy ((Token String -> Bool)
-> StateT Style (Parsec Void String) (Token String)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
Token String -> Bool
named StateT Style (Parsec Void String) Char
-> StateT Style (Parsec Void String) Char
-> StateT Style (Parsec Void String) Char
forall a.
StateT Style (Parsec Void String) a
-> StateT Style (Parsec Void String) a
-> StateT Style (Parsec Void String) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char
'_' Char
-> StateT Style (Parsec Void String) Char
-> StateT Style (Parsec Void String) Char
forall a b.
a
-> StateT Style (Parsec Void String) b
-> StateT Style (Parsec Void String) a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ StateT Style (Parsec Void String) Char
lambdaOf)))
  where
    named :: Char -> Bool
    named :: Char -> Bool
named Char
ch = Char -> Bool
isDigit Char
ch Bool -> Bool -> Bool
|| Char -> Bool
isAsciiLower Char
ch Bool -> Bool -> Bool
|| Char
ch Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
ch Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'φ'
    lambdaOf :: Parser Char
    lambdaOf :: StateT Style (Parsec Void String) Char
lambdaOf = Parser ()
whiteSpace Parser ()
-> StateT Style (Parsec Void String) Char
-> StateT Style (Parsec Void String) Char
forall a b.
StateT Style (Parsec Void String) a
-> StateT Style (Parsec Void String) b
-> StateT Style (Parsec Void String) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Token String -> StateT Style (Parsec Void String) (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
':' StateT Style (Parsec Void String) Char -> Parser () -> Parser ()
forall a b.
StateT Style (Parsec Void String) a
-> StateT Style (Parsec Void String) b
-> StateT Style (Parsec Void String) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser ()
whiteSpace Parser ()
-> StateT Style (Parsec Void String) Char
-> StateT Style (Parsec Void String) Char
forall a b.
StateT Style (Parsec Void String) a
-> StateT Style (Parsec Void String) b
-> StateT Style (Parsec Void String) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Token String] -> StateT Style (Parsec Void String) (Token String)
forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
oneOf [Char
'L', Char
'λ']

metaSuffix :: Parser String
metaSuffix :: Parser String
metaSuffix = Parser String -> Parser String
forall a. Parser a -> Parser a
lexeme (StateT Style (Parsec Void String) Char -> Parser String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many ([StateT Style (Parsec Void String) Char]
-> StateT Style (Parsec Void String) Char
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [StateT Style (Parsec Void String) Char
-> StateT Style (Parsec Void String) Char
forall a. Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Token String -> StateT Style (Parsec Void String) (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'-' StateT Style (Parsec Void String) Char
-> Parser () -> StateT Style (Parsec Void String) Char
forall a b.
StateT Style (Parsec Void String) a
-> StateT Style (Parsec Void String) b
-> StateT Style (Parsec Void String) a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* StateT Style (Parsec Void String) Char -> Parser ()
forall a. StateT Style (Parsec Void String) a -> Parser ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy (Token String -> StateT Style (Parsec Void String) (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'>')), [Token String] -> StateT Style (Parsec Void String) (Token String)
forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
oneOf (Char
'_' Char -> String -> String
forall a. a -> [a] -> [a]
: [Char
'0' .. Char
'9'] String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
'a' .. Char
'z'] String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
'A' .. Char
'Z'])] StateT Style (Parsec Void String) Char
-> String -> StateT Style (Parsec Void String) Char
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"meta suffix"))

metaVar :: Char -> String -> Parser (Either Slot T.Text)
metaVar :: Char -> String -> Parser (Either Slot Text)
metaVar Char
ch String
uni = do
  Int
offset <- StateT Style (Parsec Void String) Int
forall e s (m :: * -> *). MonadParsec e s m => m Int
getOffset
  String
suf <- Parser String -> Parser String -> Parser String
twofold ([Char
'!', Char
ch] String -> StateT Style (Parsec Void String) Char -> Parser String
forall a b.
a
-> StateT Style (Parsec Void String) b
-> StateT Style (Parsec Void String) a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (Token String -> StateT Style (Parsec Void String) (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'!' StateT Style (Parsec Void String) Char
-> StateT Style (Parsec Void String) Char
-> StateT Style (Parsec Void String) Char
forall a b.
StateT Style (Parsec Void String) a
-> StateT Style (Parsec Void String) b
-> StateT Style (Parsec Void String) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Token String -> StateT Style (Parsec Void String) (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
ch)) (Tokens String -> StateT Style (Parsec Void String) (Tokens String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string String
Tokens String
uni) Parser String -> Parser String -> Parser String
forall a b.
StateT Style (Parsec Void String) a
-> StateT Style (Parsec Void String) b
-> StateT Style (Parsec Void String) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser String
metaSuffix
  Bool -> Parser () -> Parser ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
    (String
suf String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"0")
    (String -> Parser ()
forall a. String -> StateT Style (Parsec Void String) a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Char -> String
forall r. PrintfType r => String -> r
printf String
"the meta variable '!%c0' is indexed with zero, while indexes start with one" Char
ch))
  Either Slot Text -> Parser (Either Slot Text)
forall a. a -> StateT Style (Parsec Void String) a
forall (m :: * -> *) a. Monad m => a -> m a
return
    ( if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
suf
        then Slot -> Either Slot Text
forall a b. a -> Either a b
Left (Text -> Int -> Slot
Slot (Char -> Text
T.singleton Char
ch) Int
offset)
        else Text -> Either Slot Text
forall a b. b -> Either a b
Right (String -> Text
T.pack (Char
ch Char -> String -> String
forall a. a -> [a] -> [a]
: String
suf))
    )

sigma :: Parser Function
sigma :: Parser Function
sigma = Char -> String -> Parser (Either Slot Text)
metaVar Char
'S' String
"𝜎" Parser (Either Slot Text)
-> (Either Slot Text -> Parser Function) -> Parser Function
forall a b.
StateT Style (Parsec Void String) a
-> (a -> StateT Style (Parsec Void String) b)
-> StateT Style (Parsec Void String) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Slot -> Parser Function)
-> (Text -> Parser Function) -> Either Slot Text -> Parser Function
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Function -> Parser Function
forall a. a -> StateT Style (Parsec Void String) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Function -> Parser Function)
-> (Slot -> Function) -> Slot -> Parser Function
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Slot -> Function
FnFresh) Text -> Parser Function
numbered
  where
    numbered :: T.Text -> Parser Function
    numbered :: Text -> Parser Function
numbered Text
named = case Text -> String
T.unpack (Int -> Text -> Text
T.drop Int
1 Text
named) of
      digits :: String
digits@(Char
first : String
_)
        | (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isDigit String
digits Bool -> Bool -> Bool
&& Char
first Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'0' Bool -> Bool -> Bool
&& (String -> Integer
forall a. Read a => String -> a
read String
digits :: Integer) Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int
forall a. Bounded a => a
maxBound :: Int) -> Function -> Parser Function
forall a. a -> StateT Style (Parsec Void String) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Function
FnSymbol (String -> Int
forall a. Read a => String -> a
read String
digits))
      String
_ -> String -> Parser Function
forall a. String -> StateT Style (Parsec Void String) a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> String -> String
forall r. PrintfType r => String -> r
printf String
"the symbol '%s' is not numbered by a positive integer without leading zeros that fits into Int" (Text -> String
T.unpack Text
named))

byte :: Parser String
byte :: Parser String
byte = do
  Char
f <- StateT Style (Parsec Void String) Char
StateT Style (Parsec Void String) (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
hexDigitChar StateT Style (Parsec Void String) Char
-> (Char -> StateT Style (Parsec Void String) Char)
-> StateT Style (Parsec Void String) Char
forall a b.
StateT Style (Parsec Void String) a
-> (a -> StateT Style (Parsec Void String) b)
-> StateT Style (Parsec Void String) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Char -> StateT Style (Parsec Void String) Char
upperHex
  Char
s <- StateT Style (Parsec Void String) Char
StateT Style (Parsec Void String) (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
hexDigitChar StateT Style (Parsec Void String) Char
-> (Char -> StateT Style (Parsec Void String) Char)
-> StateT Style (Parsec Void String) Char
forall a b.
StateT Style (Parsec Void String) a
-> (a -> StateT Style (Parsec Void String) b)
-> StateT Style (Parsec Void String) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Char -> StateT Style (Parsec Void String) Char
upperHex
  String -> Parser String
forall a. a -> StateT Style (Parsec Void String) a
forall (m :: * -> *) a. Monad m => a -> m a
return [Char
f, Char
s]
  where
    upperHex :: Char -> Parser Char
    upperHex :: Char -> StateT Style (Parsec Void String) 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 -> StateT Style (Parsec Void String) Char
forall a. a -> StateT Style (Parsec Void String) a
forall (m :: * -> *) a. Monad m => a -> m a
return Char
ch
      | Bool
otherwise = String -> StateT Style (Parsec Void String) Char
forall a. String -> StateT Style (Parsec Void String) a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"expected 0-9 or A-F, got " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char -> String
forall a. Show a => a -> String
show Char
ch)

bytes :: Parser Bytes
bytes :: Parser Bytes
bytes =
  Parser Bytes -> Parser Bytes
forall a. Parser a -> Parser a
lexeme
    ( [Parser Bytes] -> Parser Bytes
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
        [ (Slot -> Bytes) -> (Text -> Bytes) -> Either Slot Text -> Bytes
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Slot -> Bytes
BtAny Text -> Bytes
BtMeta (Either Slot Text -> Bytes)
-> Parser (Either Slot Text) -> Parser Bytes
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> String -> Parser (Either Slot Text)
metaVar Char
'd' String
"𝛿"
        , String -> Parser String
symbol String
"--" Parser String -> Parser Bytes -> Parser Bytes
forall a b.
StateT Style (Parsec Void String) a
-> StateT Style (Parsec Void String) b
-> StateT Style (Parsec Void String) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bytes -> Parser Bytes
forall a. a -> StateT Style (Parsec Void String) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bytes
BtEmpty
        , Parser Bytes -> Parser Bytes
forall a. Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parser Bytes -> Parser Bytes) -> Parser Bytes -> Parser Bytes
forall a b. (a -> b) -> a -> b
$ do
            String
first <- Parser String
byte
            [String]
rest <- Parser String -> StateT Style (Parsec Void String) [String]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some (Parser String -> StateT Style (Parsec Void String) [String])
-> Parser String -> StateT Style (Parsec Void String) [String]
forall a b. (a -> b) -> a -> b
$ do
              Char
_ <- Token String -> StateT Style (Parsec Void String) (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'-'
              Parser String
byte
            Bytes -> Parser Bytes
forall a. a -> StateT Style (Parsec Void String) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> Bytes
BtMany (String
first String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
rest))
        , do
            String
bte <- Parser String
byte
            Char
_ <- Token String -> StateT Style (Parsec Void String) (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'-'
            Bytes -> Parser Bytes
forall a. a -> StateT Style (Parsec Void String) a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Bytes
BtOne String
bte)
        ]
        Parser Bytes -> String -> Parser Bytes
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"bytes"
    )

number :: Parser Expression
number :: Parser Expression
number = do
  Maybe Char
sign <- StateT Style (Parsec Void String) Char
-> StateT Style (Parsec Void String) (Maybe Char)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional ([StateT Style (Parsec Void String) Char]
-> StateT Style (Parsec Void String) Char
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [Token String -> StateT Style (Parsec Void String) (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'-', Token String -> StateT Style (Parsec Void String) (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'+'])
  Double
unsigned <- Parser Double -> Parser Double
forall a. Parser a -> Parser a
lexeme Parser Double
magnitude
  Expression -> Parser Expression
forall a. a -> StateT Style (Parsec Void String) a
forall (m :: * -> *) a. Monad m => a -> m a
return
    ( Bytes -> Expression
DataNumber
        ( Double -> Bytes
numToBts
            ( case Maybe Char
sign of
                Just Char
'-' -> Double -> Double
forall a. Num a => a -> a
negate Double
unsigned
                Maybe Char
_ -> Double
unsigned
            )
        )
    )
  where
    magnitude :: Parser Double
    magnitude :: Parser Double
magnitude = do
      String
whole <- StateT Style (Parsec Void String) Char -> Parser String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some StateT Style (Parsec Void String) Char
StateT Style (Parsec Void String) (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
digitChar
      String
fraction <- String -> Parser String -> Parser String
forall (m :: * -> *) a. Alternative m => a -> m a -> m a
option 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 (Token String -> StateT Style (Parsec Void String) (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'.' StateT Style (Parsec Void String) Char
-> Parser String -> Parser String
forall a b.
StateT Style (Parsec Void String) a
-> StateT Style (Parsec Void String) b
-> StateT Style (Parsec Void String) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> StateT Style (Parsec Void String) Char -> Parser String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some StateT Style (Parsec Void String) Char
StateT Style (Parsec Void String) (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
digitChar))
      Integer
power <- Integer
-> StateT Style (Parsec Void String) Integer
-> StateT Style (Parsec Void String) Integer
forall (m :: * -> *) a. Alternative m => a -> m a -> m a
option Integer
0 (StateT Style (Parsec Void String) Integer
-> StateT Style (Parsec Void String) Integer
forall a. Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try ([Token String] -> StateT Style (Parsec Void String) (Token String)
forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
oneOf [Char
'e', Char
'E'] StateT Style (Parsec Void String) (Token String)
-> StateT Style (Parsec Void String) Integer
-> StateT Style (Parsec Void String) Integer
forall a b.
StateT Style (Parsec Void String) a
-> StateT Style (Parsec Void String) b
-> StateT Style (Parsec Void String) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser ()
-> StateT Style (Parsec Void String) Integer
-> StateT Style (Parsec Void String) Integer
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m () -> m a -> m a
L.signed (() -> Parser ()
forall a. a -> StateT Style (Parsec Void String) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) StateT Style (Parsec Void String) Integer
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
L.decimal))
      Double -> Parser Double
forall a. a -> StateT Style (Parsec Void String) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> Integer -> Integer -> Double
scaled (String -> Integer
forall a. Read a => String -> a
read (String
whole String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fraction)) (Integer
power Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Int -> Integer
forall a. Integral a => a -> Integer
toInteger (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
fraction)) (Int -> Integer
forall a. Integral a => a -> Integer
toInteger (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (String
whole String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fraction))))
    scaled :: Integer -> Integer -> Integer -> Double
    scaled :: Integer -> Integer -> Integer -> Double
scaled Integer
coefficient Integer
power Integer
digits
      | Integer
coefficient Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 = Double
0
      | Integer
power Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
400 = Double
1 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
0
      | Integer
power Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer -> Integer
forall a. Num a => a -> a
negate (Integer
400 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
digits) = Double
0
      | Bool
otherwise = Scientific -> Double
forall a. RealFloat a => Scientific -> a
toRealFloat (Integer -> Int -> Scientific
scientific Integer
coefficient (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
power))

root :: Parser Expression
root :: Parser Expression
root = do
  String
_ <- Parser String
global
  Expression -> Parser Expression -> Parser Expression
forall (m :: * -> *) a. Alternative m => a -> m a -> m a
option Expression
ExRoot (Parser Expression -> Parser Expression
forall a. Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try Parser Expression
labelled)
  where
    labelled :: Parser Expression
    labelled :: Parser Expression
labelled = do
      String
_ <- String -> Parser String
symbol String
"."
      Text -> Expression
named (Text -> Expression) -> Parser Text -> Parser Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
label'
    named :: T.Text -> Expression
    named :: Text -> Expression
named Text
name = Expression
-> (NonFinite -> Expression) -> Maybe NonFinite -> Expression
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Expression -> Attribute -> Expression
ExDispatch Expression
ExRoot (Text -> Attribute
AtLabel Text
name)) (Bytes -> Expression
DataNumber (Bytes -> Expression)
-> (NonFinite -> Bytes) -> NonFinite -> Expression
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonFinite -> Bytes
nonFiniteBts) (Text -> Maybe NonFinite
nonFiniteOf Text
name)

quotedStr :: Parser String
quotedStr :: Parser String
quotedStr = Token String -> StateT Style (Parsec Void String) (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'"' StateT Style (Parsec Void String) Char
-> Parser String -> Parser String
forall a b.
StateT Style (Parsec Void String) a
-> StateT Style (Parsec Void String) b
-> StateT Style (Parsec Void String) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> StateT Style (Parsec Void String) Char
-> StateT Style (Parsec Void String) Char -> Parser String
forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
manyTill ([StateT Style (Parsec Void String) Char]
-> StateT Style (Parsec Void String) Char
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [StateT Style (Parsec Void String) Char
escapedChar, [Token String] -> StateT Style (Parsec Void String) (Token String)
forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
noneOf [Char
'\\', Char
'"']]) (Token String -> StateT Style (Parsec Void String) (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'"')
  where
    escapedChar :: Parser Char
    escapedChar :: StateT Style (Parsec Void String) Char
escapedChar = do
      Char
_ <- Token String -> StateT Style (Parsec Void String) (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] -> StateT Style (Parsec Void String) (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 -> StateT Style (Parsec Void String) Char
forall a. a -> StateT Style (Parsec Void String) a
forall (m :: * -> *) a. Monad m => a -> m a
return Char
'\\'
        Char
'"' -> Char -> StateT Style (Parsec Void String) Char
forall a. a -> StateT Style (Parsec Void String) a
forall (m :: * -> *) a. Monad m => a -> m a
return Char
'"'
        Char
'n' -> Char -> StateT Style (Parsec Void String) Char
forall a. a -> StateT Style (Parsec Void String) a
forall (m :: * -> *) a. Monad m => a -> m a
return Char
'\n'
        Char
'r' -> Char -> StateT Style (Parsec Void String) Char
forall a. a -> StateT Style (Parsec Void String) a
forall (m :: * -> *) a. Monad m => a -> m a
return Char
'\r'
        Char
't' -> Char -> StateT Style (Parsec Void String) Char
forall a. a -> StateT Style (Parsec Void String) a
forall (m :: * -> *) a. Monad m => a -> m a
return Char
'\t'
        Char
'b' -> Char -> StateT Style (Parsec Void String) Char
forall a. a -> StateT Style (Parsec Void String) a
forall (m :: * -> *) a. Monad m => a -> m a
return Char
'\b'
        Char
'f' -> Char -> StateT Style (Parsec Void String) Char
forall a. a -> StateT Style (Parsec Void String) a
forall (m :: * -> *) a. Monad m => a -> m a
return Char
'\f'
        Char
'u' -> StateT Style (Parsec Void String) Char
unicodeEscape
        Char
'x' -> StateT Style (Parsec Void String) Char
hexEscape
        Char
_ -> String -> StateT Style (Parsec Void String) Char
forall a. String -> StateT Style (Parsec Void String) a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Unknown escape: \\" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
c])
    unicodeEscape :: Parser Char
    unicodeEscape :: StateT Style (Parsec Void String) Char
unicodeEscape = do
      String
hexDigits <- Int -> StateT Style (Parsec Void String) Char -> Parser String
forall (m :: * -> *) a. Monad m => Int -> m a -> m [a]
count Int
4 StateT Style (Parsec Void String) Char
StateT Style (Parsec Void String) (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 do
              Tokens String
_ <- Tokens String -> StateT Style (Parsec Void String) (Tokens String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string String
Tokens String
"\\u"
              String
lowHexDigits <- Int -> StateT Style (Parsec Void String) Char -> Parser String
forall (m :: * -> *) a. Monad m => Int -> m a -> m [a]
count Int
4 StateT Style (Parsec Void String) Char
StateT Style (Parsec Void String) (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
                      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 -> StateT Style (Parsec Void String) Char
forall a. a -> StateT Style (Parsec Void String) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Char
chr Int
codePoint)
                    else String -> StateT Style (Parsec Void String) Char
forall a. String -> StateT Style (Parsec Void String) a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Invalid low surrogate: \\u" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
lowHexDigits)
                [(Int, String)]
_ -> String -> StateT Style (Parsec Void String) Char
forall a. String -> StateT Style (Parsec Void String) a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Invalid low surrogate hex: \\u" String -> String -> String
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 -> StateT Style (Parsec Void String) Char
forall a. String -> StateT Style (Parsec Void String) a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Unexpected low surrogate: \\u" String -> String -> String
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 -> StateT Style (Parsec Void String) Char
forall a. a -> StateT Style (Parsec Void String) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Char
chr Int
n)
                    else String -> StateT Style (Parsec Void String) Char
forall a. String -> StateT Style (Parsec Void String) a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Invalid Unicode code point: \\u" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
hexDigits)
        [(Int, String)]
_ -> String -> StateT Style (Parsec Void String) Char
forall a. String -> StateT Style (Parsec Void String) a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Invalid Unicode escape: \\u" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
hexDigits)
    hexEscape :: Parser Char
    hexEscape :: StateT Style (Parsec Void String) Char
hexEscape = do
      String
digits <- Int -> StateT Style (Parsec Void String) Char -> Parser String
forall (m :: * -> *) a. Monad m => Int -> m a -> m [a]
count Int
2 StateT Style (Parsec Void String) Char
StateT Style (Parsec Void String) (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 -> StateT Style (Parsec Void String) Char
forall a. a -> StateT Style (Parsec Void String) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Char
chr Int
n)
        [(Int, String)]
_ -> String -> StateT Style (Parsec Void String) Char
forall a. String -> StateT Style (Parsec Void String) a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Invalid hex escape: \\x" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
digits)

tauValue :: Parser Expression
tauValue :: Parser Expression
tauValue =
  [Parser Expression] -> Parser Expression
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ do
        String
_ <- Parser String
arrow
        Parser Expression
expression
    , do
        String
_ <- String -> Parser String
symbol String
"("
        [(Int, Binding)]
voids <-
          [StateT Style (Parsec Void String) [(Int, Binding)]]
-> StateT Style (Parsec Void String) [(Int, Binding)]
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
            [ Parser String
rb Parser String
-> StateT Style (Parsec Void String) [(Int, Binding)]
-> StateT Style (Parsec Void String) [(Int, Binding)]
forall a b.
StateT Style (Parsec Void String) a
-> StateT Style (Parsec Void String) b
-> StateT Style (Parsec Void String) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [(Int, Binding)]
-> StateT Style (Parsec Void String) [(Int, Binding)]
forall a. a -> StateT Style (Parsec Void String) a
forall (m :: * -> *) a. Monad m => a -> m a
return []
            , do
                [(Int, Binding)]
voids' <- ((,) (Int -> Binding -> (Int, Binding))
-> StateT Style (Parsec Void String) Int
-> StateT Style (Parsec Void String) (Binding -> (Int, Binding))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT Style (Parsec Void String) Int
forall e s (m :: * -> *). MonadParsec e s m => m Int
getOffset StateT Style (Parsec Void String) (Binding -> (Int, Binding))
-> Parser Binding
-> StateT Style (Parsec Void String) (Int, Binding)
forall a b.
StateT Style (Parsec Void String) (a -> b)
-> StateT Style (Parsec Void String) a
-> StateT Style (Parsec Void String) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Attribute -> Binding
BiVoid (Attribute -> Binding) -> Parser Attribute -> Parser Binding
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Attribute
void')) StateT Style (Parsec Void String) (Int, Binding)
-> Parser String
-> StateT Style (Parsec Void String) [(Int, Binding)]
forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
`sepBy1` String -> Parser String
symbol String
","
                Parser String
rb Parser String
-> StateT Style (Parsec Void String) [(Int, Binding)]
-> StateT Style (Parsec Void String) [(Int, Binding)]
forall a b.
StateT Style (Parsec Void String) a
-> StateT Style (Parsec Void String) b
-> StateT Style (Parsec Void String) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [(Int, Binding)]
-> StateT Style (Parsec Void String) [(Int, Binding)]
forall a. a -> StateT Style (Parsec Void String) a
forall (m :: * -> *) a. Monad m => a -> m a
return [(Int, Binding)]
voids'
            ]
        String
_ <- Parser String
arrow
        [Parser Expression] -> Parser Expression
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
          [ do
              [(Int, Binding)]
bds <- StateT Style (Parsec Void String) [(Int, Binding)]
formationBindingsOffsets
              Bool
tailed <- Bool
-> StateT Style (Parsec Void String) Bool
-> StateT Style (Parsec Void String) Bool
forall (m :: * -> *) a. Alternative m => a -> m a -> m a
option Bool
False (Bool
True Bool
-> StateT Style (Parsec Void String) (Token String)
-> StateT Style (Parsec Void String) Bool
forall a b.
a
-> StateT Style (Parsec Void String) b
-> StateT Style (Parsec Void String) a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ StateT Style (Parsec Void String) (Token String)
-> StateT Style (Parsec Void String) (Token String)
forall a. Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
lookAhead ([Token String] -> StateT Style (Parsec Void String) (Token String)
forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
oneOf String
[Token String]
".(:"))
              if Bool
tailed
                then [(Int, Binding)] -> Parser [Binding]
reportDuplicates [(Int, Binding)]
bds Parser [Binding]
-> ([Binding] -> Parser Expression) -> Parser Expression
forall a b.
StateT Style (Parsec Void String) a
-> (a -> StateT Style (Parsec Void String) b)
-> StateT Style (Parsec Void String) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Expression -> Parser Expression
exTail (Expression -> Parser Expression)
-> ([Binding] -> Expression) -> [Binding] -> Parser Expression
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Binding] -> Expression
ExFormation Parser Expression
-> (Expression -> Parser Expression) -> Parser Expression
forall a b.
StateT Style (Parsec Void String) a
-> (a -> StateT Style (Parsec Void String) b)
-> StateT Style (Parsec Void String) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [(Int, Binding)] -> Expression -> Parser Expression
opening [(Int, Binding)]
voids
                else [Binding] -> Expression
ExFormation ([Binding] -> Expression) -> Parser [Binding] -> Parser Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Int, Binding)] -> Parser [Binding]
reportDuplicates ([(Int, Binding)]
voids [(Int, Binding)] -> [(Int, Binding)] -> [(Int, Binding)]
forall a. [a] -> [a] -> [a]
++ [(Int, Binding)]
bds)
          , Parser Expression
expression Parser Expression
-> (Expression -> Parser Expression) -> Parser Expression
forall a b.
StateT Style (Parsec Void String) a
-> (a -> StateT Style (Parsec Void String) b)
-> StateT Style (Parsec Void String) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [(Int, Binding)] -> Expression -> Parser Expression
opening [(Int, Binding)]
voids
          ]
    ]
  where
    rb :: Parser String
    rb :: Parser String
rb = String -> Parser String
symbol String
")"
    opening :: [(Int, Binding)] -> Expression -> Parser Expression
    opening :: [(Int, Binding)] -> Expression -> Parser Expression
opening [(Int, Binding)]
voids (ExFormation [Binding]
bds) = [Binding] -> Expression
ExFormation ([Binding] -> Expression) -> Parser [Binding] -> Parser Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Binding] -> Parser [Binding]
validatedBindings (((Int, Binding) -> Binding) -> [(Int, Binding)] -> [Binding]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Binding) -> Binding
forall a b. (a, b) -> b
snd [(Int, Binding)]
voids [Binding] -> [Binding] -> [Binding]
forall a. [a] -> [a] -> [a]
++ [Binding]
bds)
    opening [(Int, Binding)]
_ Expression
_ = String -> Parser Expression
forall a. String -> StateT Style (Parsec Void String) a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Inline voids open a formation, so nothing but a formation may follow their arrow"

lambdaName :: Parser Function
lambdaName :: Parser Function
lambdaName = [Parser Function] -> Parser Function
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [Text -> Function
Function (Text -> Function) -> (String -> Text) -> String -> Function
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Function) -> Parser String -> Parser Function
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser String
function, Parser Function -> Parser Function
forall a. Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try ((Slot -> Function)
-> (Text -> Function) -> Either Slot Text -> Function
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Slot -> Function
FnAny Text -> Function
FnMeta (Either Slot Text -> Function)
-> Parser (Either Slot Text) -> Parser Function
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> String -> Parser (Either Slot Text)
metaVar Char
'F' String
"𝑓"), Parser Function
sigma]

colon :: Parser String
colon :: Parser String
colon = String -> Parser String
symbol String
":"

alone :: Parser Binding -> Parser Expression
alone :: Parser Binding -> Parser Expression
alone Parser Binding
bd = [Binding] -> Expression
ExFormation ([Binding] -> Expression)
-> (Binding -> [Binding]) -> Binding -> Expression
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Binding -> [Binding]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Binding -> Expression) -> Parser Binding -> Parser Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Binding
bd

deltaHead :: Parser Expression
deltaHead :: Parser Expression
deltaHead =
  StateT Style (Parsec Void String) (Token String)
-> StateT Style (Parsec Void String) (Token String)
forall a. Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
lookAhead ((Token String -> Bool)
-> StateT Style (Parsec Void String) (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
'A' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
Token String
ch Bool -> Bool -> Bool
&& Char
Token String
ch Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'F') Bool -> Bool -> Bool
|| Char
Token String
ch Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (String
"-!𝛿" :: String)))
    StateT Style (Parsec Void String) (Token String)
-> Parser Expression -> Parser Expression
forall a b.
StateT Style (Parsec Void String) a
-> StateT Style (Parsec Void String) b
-> StateT Style (Parsec Void String) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Binding -> Parser Expression
alone (Parser Binding -> Parser Binding
forall a. Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Bytes -> Binding
BiDelta (Bytes -> Binding) -> Parser Bytes -> Parser Binding
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Bytes
bytes Parser Binding -> Parser String -> Parser Binding
forall a b.
StateT Style (Parsec Void String) a
-> StateT Style (Parsec Void String) b
-> StateT Style (Parsec Void String) a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser String
colon Parser Binding -> Parser String -> Parser Binding
forall a b.
StateT Style (Parsec Void String) a
-> StateT Style (Parsec Void String) b
-> StateT Style (Parsec Void String) a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser String -> Parser String -> Parser String
twofold (String -> Parser String
symbol String
"D") (String -> Parser String
symbol String
"Δ")))

lambdaHead :: Parser Expression
lambdaHead :: Parser Expression
lambdaHead =
  StateT Style (Parsec Void String) (Token String)
-> StateT Style (Parsec Void String) (Token String)
forall a. Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
lookAhead ((Token String -> Bool)
-> StateT Style (Parsec Void String) (Token String)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy (\Token String
ch -> Char -> Bool
isAsciiUpper Char
Token String
ch Bool -> Bool -> Bool
|| Char
Token String
ch Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (String
"!𝑓𝜎" :: String)))
    StateT Style (Parsec Void String) (Token String)
-> Parser Expression -> Parser Expression
forall a b.
StateT Style (Parsec Void String) a
-> StateT Style (Parsec Void String) b
-> StateT Style (Parsec Void String) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Binding -> Parser Expression
alone (Parser Binding -> Parser Binding
forall a. Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Function -> Binding
BiLambda (Function -> Binding) -> Parser Function -> Parser Binding
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Function
lambdaName Parser Binding -> Parser String -> Parser Binding
forall a b.
StateT Style (Parsec Void String) a
-> StateT Style (Parsec Void String) b
-> StateT Style (Parsec Void String) a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser String
colon Parser Binding -> Parser String -> Parser Binding
forall a b.
StateT Style (Parsec Void String) a
-> StateT Style (Parsec Void String) b
-> StateT Style (Parsec Void String) a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser String -> Parser String -> Parser String
twofold (String -> Parser String
symbol String
"L") (String -> Parser String
symbol String
"λ")))

voidHead :: Parser Expression
voidHead :: Parser Expression
voidHead = Parser Binding -> Parser Expression
alone (Parser String
vacant Parser String -> Parser String -> Parser String
forall a b.
StateT Style (Parsec Void String) a
-> StateT Style (Parsec Void String) b
-> StateT Style (Parsec Void String) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser String
colon Parser String -> Parser Binding -> Parser Binding
forall a b.
StateT Style (Parsec Void String) a
-> StateT Style (Parsec Void String) b
-> StateT Style (Parsec Void String) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Attribute -> Binding
BiVoid (Attribute -> Binding) -> Parser Attribute -> Parser Binding
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Attribute
attribute)

vacant :: Parser String
vacant :: Parser String
vacant = Parser String -> Parser String -> Parser String
twofold (String -> Parser String
symbol String
"?") (String -> Parser String
symbol String
"∅")

metaBinding :: Parser Binding
metaBinding :: Parser Binding
metaBinding = (Slot -> Binding)
-> (Text -> Binding) -> Either Slot Text -> Binding
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Slot -> Binding
BiAny Text -> Binding
BiMeta (Either Slot Text -> Binding)
-> Parser (Either Slot Text) -> Parser Binding
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> String -> Parser (Either Slot Text)
metaVar Char
'B' String
"𝐵"

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
    [ do
        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
delta
        Bytes -> Binding
BiDelta (Bytes -> Binding) -> Parser Bytes -> Parser Binding
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Bytes
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
metaBinding
    , do
        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
lambda
        Function -> Binding
BiLambda (Function -> Binding) -> Parser Function -> Parser Binding
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Function
lambdaName
    , do
        Attribute
attr <- Parser Attribute
attribute
        [Parser Binding] -> Parser Binding
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
          [ 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
blank Parser String -> Parser Binding -> Parser Binding
forall a b.
StateT Style (Parsec Void String) a
-> StateT Style (Parsec Void String) b
-> StateT Style (Parsec Void String) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Binding -> Parser Binding
forall a. a -> StateT Style (Parsec Void String) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Attribute -> Binding
BiVoid Attribute
attr)
          , Attribute -> Expression -> Binding
BiTau Attribute
attr (Expression -> Binding) -> Parser Expression -> Parser Binding
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Expression
tauValue
          ]
    ]
    Parser Binding -> String -> Parser Binding
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"binding"
  where
    blank :: Parser String
    blank :: Parser String
blank = Parser String
arrow Parser String -> Parser String -> Parser String
forall a b.
StateT Style (Parsec Void String) a
-> StateT Style (Parsec Void String) b
-> StateT Style (Parsec Void String) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser String
vacant Parser String -> Parser () -> Parser String
forall a b.
StateT Style (Parsec Void String) a
-> StateT Style (Parsec Void String) b
-> StateT Style (Parsec Void String) a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser String -> Parser ()
forall a. StateT Style (Parsec Void String) a -> Parser ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy Parser String
colon

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
    [ Text -> Attribute
AtLabel (Text -> Attribute) -> Parser Text -> Parser Attribute
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
label'
    , do
        String
_ <- Parser String -> Parser String -> Parser String
twofold (String -> Parser String
symbol String
"^") (String -> Parser String
symbol String
"ρ")
        Attribute -> Parser Attribute
forall a. a -> StateT Style (Parsec Void String) a
forall (m :: * -> *) a. Monad m => a -> m a
return Attribute
AtRho
    , do
        String
_ <- Parser String -> Parser String -> Parser String
twofold (String -> Parser String
symbol String
"@") (String -> Parser String
symbol String
"φ")
        Attribute -> Parser Attribute
forall a. a -> StateT Style (Parsec Void String) a
forall (m :: * -> *) a. Monad m => a -> m a
return Attribute
AtPhi
    ]

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'
    , (Slot -> Attribute)
-> (Text -> Attribute) -> Either Slot Text -> Attribute
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Slot -> Attribute
AtAny Text -> Attribute
AtMeta (Either Slot Text -> Attribute)
-> Parser (Either Slot Text) -> Parser Attribute
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> String -> Parser (Either Slot Text)
metaVar Char
't' String
"𝜏"
    ]
    Parser Attribute -> String -> Parser Attribute
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"attribute"

indexVar :: Parser (Either Slot T.Text)
indexVar :: Parser (Either Slot Text)
indexVar = Char -> String -> Parser (Either Slot Text)
metaVar Char
'i' String
"𝑖"

alpha :: Parser Alpha
alpha :: Parser Alpha
alpha = do
  String
_ <- Parser String -> Parser String -> Parser String
twofold (String -> Parser String
symbol String
"~") (String -> Parser String
symbol String
"α")
  [Parser Alpha] -> Parser Alpha
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ StateT Style (Parsec Void String) Integer
-> StateT Style (Parsec Void String) Integer
forall a. Parser a -> Parser a
lexeme StateT Style (Parsec Void String) Integer
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
L.decimal StateT Style (Parsec Void String) Integer
-> (Integer -> Parser Alpha) -> Parser Alpha
forall a b.
StateT Style (Parsec Void String) a
-> (a -> StateT Style (Parsec Void String) b)
-> StateT Style (Parsec Void String) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Integer -> Parser Alpha
ranged
    , (Slot -> Alpha) -> (Text -> Alpha) -> Either Slot Text -> Alpha
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Slot -> Alpha
AlAny Text -> Alpha
AlMeta (Either Slot Text -> Alpha)
-> Parser (Either Slot Text) -> Parser Alpha
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (Either Slot Text)
indexVar
    ]
    Parser Alpha -> String -> Parser Alpha
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"alpha"
  where
    ranged :: Integer -> Parser Alpha
    ranged :: Integer -> Parser Alpha
ranged Integer
idx
      | Integer
idx Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int
forall a. Bounded a => a
maxBound :: Int) = String -> Parser Alpha
forall a. String -> StateT Style (Parsec Void String) a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Integer -> Int -> String
forall r. PrintfType r => String -> r
printf String
"the index of 'α%d' is too big, while it must fit into %d" Integer
idx (Int
forall a. Bounded a => a
maxBound :: Int))
      | Bool
otherwise = Alpha -> Parser Alpha
forall a. a -> StateT Style (Parsec Void String) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Alpha
Alpha (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
idx))

argument :: Parser Argument
argument :: Parser Argument
argument =
  [Parser Argument] -> Parser Argument
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ Alpha -> Expression -> Argument
ArAlpha (Alpha -> Expression -> Argument)
-> Parser Alpha
-> StateT Style (Parsec Void String) (Expression -> Argument)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Alpha -> Parser Alpha
forall a. Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try Parser Alpha
alpha StateT Style (Parsec Void String) (Expression -> Argument)
-> Parser String
-> StateT Style (Parsec Void String) (Expression -> Argument)
forall a b.
StateT Style (Parsec Void String) a
-> StateT Style (Parsec Void String) b
-> StateT Style (Parsec Void String) a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser String
arrow StateT Style (Parsec Void String) (Expression -> Argument)
-> Parser Expression -> Parser Argument
forall a b.
StateT Style (Parsec Void String) (a -> b)
-> StateT Style (Parsec Void String) a
-> StateT Style (Parsec Void String) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Expression
expression
    , Attribute -> Expression -> Argument
ArTau (Attribute -> Expression -> Argument)
-> Parser Attribute
-> StateT Style (Parsec Void String) (Expression -> Argument)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Attribute
attribute StateT Style (Parsec Void String) (Expression -> Argument)
-> Parser String
-> StateT Style (Parsec Void String) (Expression -> Argument)
forall a b.
StateT Style (Parsec Void String) a
-> StateT Style (Parsec Void String) b
-> StateT Style (Parsec Void String) a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser String
arrow StateT Style (Parsec Void String) (Expression -> Argument)
-> Parser Expression -> Parser Argument
forall a b.
StateT Style (Parsec Void String) (a -> b)
-> StateT Style (Parsec Void String) a
-> StateT Style (Parsec Void String) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Expression
expression
    ]
    Parser Argument -> String -> Parser Argument
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"argument"

validatedBindings :: [Binding] -> Parser [Binding]
validatedBindings :: [Binding] -> Parser [Binding]
validatedBindings [Binding]
bds = case [Binding] -> Either String [Binding]
uniqueBindings [Binding]
bds of
  Left String
msg -> String -> Parser [Binding]
forall a. String -> StateT Style (Parsec Void String) a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
msg
  Right [Binding]
bds' -> [Binding] -> Parser [Binding]
forall a. a -> StateT Style (Parsec Void String) a
forall (m :: * -> *) a. Monad m => a -> m a
return [Binding]
bds'

reportDuplicates :: [(Int, Binding)] -> Parser [Binding]
reportDuplicates :: [(Int, Binding)] -> Parser [Binding]
reportDuplicates [(Int, Binding)]
bs = do
  (String -> Parser ())
-> ([Binding] -> Parser ()) -> Either String [Binding] -> Parser ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (ParseError String Void -> Parser ()
forall a.
ParseError String Void -> StateT Style (Parsec Void String) a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
ParseError s e -> m a
parseError (ParseError String Void -> Parser ())
-> (String -> ParseError String Void) -> String -> Parser ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Set (ErrorFancy Void) -> ParseError String Void
forall s e. Int -> Set (ErrorFancy e) -> ParseError s e
FancyError ([Attribute] -> [(Int, Binding)] -> Int
repeating [] [(Int, Binding)]
bs) (Set (ErrorFancy Void) -> ParseError String Void)
-> (String -> Set (ErrorFancy Void))
-> String
-> ParseError String Void
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorFancy Void -> Set (ErrorFancy Void)
forall a. a -> Set a
Set.singleton (ErrorFancy Void -> Set (ErrorFancy Void))
-> (String -> ErrorFancy Void) -> String -> Set (ErrorFancy Void)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ErrorFancy Void
forall e. String -> ErrorFancy e
ErrorFail) (Parser () -> [Binding] -> Parser ()
forall a b. a -> b -> a
const (() -> Parser ()
forall a. a -> StateT Style (Parsec Void String) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())) ([Binding] -> Either String [Binding]
uniqueBindings (((Int, Binding) -> Binding) -> [(Int, Binding)] -> [Binding]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Binding) -> Binding
forall a b. (a, b) -> b
snd [(Int, Binding)]
bs))
  [Binding] -> Parser [Binding]
forall a. a -> StateT Style (Parsec Void String) a
forall (m :: * -> *) a. Monad m => a -> m a
return (((Int, Binding) -> Binding) -> [(Int, Binding)] -> [Binding]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Binding) -> Binding
forall a b. (a, b) -> b
snd [(Int, Binding)]
bs)
  where
    repeating :: [Attribute] -> [(Int, Binding)] -> Int
    repeating :: [Attribute] -> [(Int, Binding)] -> Int
repeating [Attribute]
_ [] = Int
0
    repeating [Attribute]
seen ((Int
offset, Binding
bd) : [(Int, Binding)]
rest)
      | (Attribute -> Bool) -> [Attribute] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Attribute -> [Attribute] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Attribute]
seen) ([Binding] -> [Attribute]
attributesFromBindings [Binding
bd]) = Int
offset
      | Bool
otherwise = [Attribute] -> [(Int, Binding)] -> Int
repeating ([Attribute]
seen [Attribute] -> [Attribute] -> [Attribute]
forall a. [a] -> [a] -> [a]
++ [Binding] -> [Attribute]
attributesFromBindings [Binding
bd]) [(Int, Binding)]
rest

formationBindingsOffsets :: Parser [(Int, Binding)]
formationBindingsOffsets :: StateT Style (Parsec Void String) [(Int, Binding)]
formationBindingsOffsets = do
  String
_ <- Parser String -> Parser String -> Parser String
twofold (String -> Parser String
symbol String
"[[") (String -> Parser String
symbol String
"⟦")
  [StateT Style (Parsec Void String) [(Int, Binding)]]
-> StateT Style (Parsec Void String) [(Int, Binding)]
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ Parser String
rsb Parser String
-> StateT Style (Parsec Void String) [(Int, Binding)]
-> StateT Style (Parsec Void String) [(Int, Binding)]
forall a b.
StateT Style (Parsec Void String) a
-> StateT Style (Parsec Void String) b
-> StateT Style (Parsec Void String) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [(Int, Binding)]
-> StateT Style (Parsec Void String) [(Int, Binding)]
forall a. a -> StateT Style (Parsec Void String) a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    , do
        [(Int, Binding)]
bs <- ((,) (Int -> Binding -> (Int, Binding))
-> StateT Style (Parsec Void String) Int
-> StateT Style (Parsec Void String) (Binding -> (Int, Binding))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT Style (Parsec Void String) Int
forall e s (m :: * -> *). MonadParsec e s m => m Int
getOffset StateT Style (Parsec Void String) (Binding -> (Int, Binding))
-> Parser Binding
-> StateT Style (Parsec Void String) (Int, Binding)
forall a b.
StateT Style (Parsec Void String) (a -> b)
-> StateT Style (Parsec Void String) a
-> StateT Style (Parsec Void String) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Binding
binding) StateT Style (Parsec Void String) (Int, Binding)
-> Parser String
-> StateT Style (Parsec Void String) [(Int, Binding)]
forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
`sepBy1` String -> Parser String
symbol String
","
        Parser String
rsb Parser String
-> StateT Style (Parsec Void String) [(Int, Binding)]
-> StateT Style (Parsec Void String) [(Int, Binding)]
forall a b.
StateT Style (Parsec Void String) a
-> StateT Style (Parsec Void String) b
-> StateT Style (Parsec Void String) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [(Int, Binding)]
-> StateT Style (Parsec Void String) [(Int, Binding)]
forall a. a -> StateT Style (Parsec Void String) a
forall (m :: * -> *) a. Monad m => a -> m a
return [(Int, Binding)]
bs
    ]
  where
    rsb :: Parser String
    rsb :: Parser String
rsb = Parser String -> Parser String -> Parser String
twofold (String -> Parser String
symbol String
"]]") (String -> Parser String
symbol String
"⟧")

formationBindings :: Parser [Binding]
formationBindings :: Parser [Binding]
formationBindings = StateT Style (Parsec Void String) [(Int, Binding)]
formationBindingsOffsets StateT Style (Parsec Void String) [(Int, Binding)]
-> ([(Int, Binding)] -> Parser [Binding]) -> Parser [Binding]
forall a b.
StateT Style (Parsec Void String) a
-> (a -> StateT Style (Parsec Void String) b)
-> StateT Style (Parsec Void String) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [(Int, Binding)] -> Parser [Binding]
reportDuplicates

exHead :: Parser Expression
exHead :: Parser Expression
exHead =
  [Parser Expression] -> Parser Expression
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ [Binding] -> Expression
ExFormation ([Binding] -> Expression) -> Parser [Binding] -> Parser Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser [Binding]
formationBindings
    , do
        String
_ <- Parser String -> Parser String -> Parser String
twofold (String -> Parser String
symbol String
"$") (String -> Parser String
symbol String
"ξ")
        Expression -> Parser Expression
forall a. a -> StateT Style (Parsec Void String) a
forall (m :: * -> *) a. Monad m => a -> m a
return Expression
ExXi
    , Parser Expression
root
    , do
        String
_ <- Parser String -> Parser String -> Parser String
twofold (Char -> Parser String
ascii Char
'T') (String -> Parser String
symbol String
"⊥")
        Expression -> Parser Expression
forall a. a -> StateT Style (Parsec Void String) a
forall (m :: * -> *) a. Monad m => a -> m a
return Expression
ExTermination
    , Parser Expression -> Parser Expression
forall a. Parser a -> Parser a
lexeme (Bytes -> Expression
DataString (Bytes -> Expression) -> (String -> Bytes) -> String -> Expression
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bytes
strToBts (String -> Expression) -> Parser String -> Parser Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser String
quotedStr)
    , Parser Expression
deltaHead
    , Parser Expression
number
    , Parser Expression -> Parser Expression
forall a. Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try ((Slot -> Expression)
-> (Text -> Expression) -> Either Slot Text -> Expression
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Slot -> Expression
ExAny Text -> Expression
ExMeta (Either Slot Text -> Expression)
-> Parser (Either Slot Text) -> Parser Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> String -> Parser (Either Slot Text)
metaVar Char
'e' String
"𝑒")
    , Parser Expression -> Parser Expression
forall a. Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try ((Slot -> Expression)
-> (Text -> Expression) -> Either Slot Text -> Expression
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Slot -> Expression
ExAny Text -> Expression
ExMeta (Either Slot Text -> Expression)
-> Parser (Either Slot Text) -> Parser Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> String -> Parser (Either Slot Text)
metaVar Char
'n' String
"𝑛")
    , Parser Expression -> Parser Expression
forall a. Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try ((Slot -> Expression)
-> (Text -> Expression) -> Either Slot Text -> Expression
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Slot -> Expression
ExAny Text -> Expression
ExMeta (Either Slot Text -> Expression)
-> Parser (Either Slot Text) -> Parser Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> String -> Parser (Either Slot Text)
metaVar Char
'k' String
"𝑘")
    , Parser Expression
lambdaHead
    , Expression -> Attribute -> Expression
ExDispatch Expression
ExXi (Attribute -> Expression) -> Parser Attribute -> Parser Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Attribute
attribute
    , Parser Expression
voidHead
    ]
    Parser Expression -> String -> Parser Expression
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"expression head"

application :: Expression -> [Argument] -> Expression
application :: Expression -> [Argument] -> Expression
application = (Expression -> Argument -> Expression)
-> Expression -> [Argument] -> 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 -> Argument -> Expression
ExApplication

exTail :: Expression -> Parser Expression
exTail :: Expression -> Parser Expression
exTail Expression
expr =
  [Parser Expression] -> Parser Expression
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ do
        Expression
next <-
          [Parser Expression] -> Parser 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 -> Parser Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Attribute
attribute
            , do
                Bool -> Parser ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard
                  ( case Expression
expr of
                      Expression
ExXi -> Bool
False
                      Expression
ExRoot -> Bool
False
                      Expression
_ -> Bool
True
                  )
                String
_ <- String -> Parser String
symbol String
"("
                [Argument]
bds <-
                  [StateT Style (Parsec Void String) [Argument]]
-> StateT Style (Parsec Void String) [Argument]
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
                    [ StateT Style (Parsec Void String) [Argument]
-> StateT Style (Parsec Void String) [Argument]
forall a. Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (StateT Style (Parsec Void String) [Argument]
 -> StateT Style (Parsec Void String) [Argument])
-> StateT Style (Parsec Void String) [Argument]
-> StateT Style (Parsec Void String) [Argument]
forall a b. (a -> b) -> a -> b
$ Parser Argument
argument Parser Argument
-> Parser String -> StateT Style (Parsec Void String) [Argument]
forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
`sepBy1` String -> Parser String
symbol String
","
                    , do
                        [Expression]
exprs <- Parser Expression
expression Parser Expression
-> Parser String -> StateT Style (Parsec Void String) [Expression]
forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
`sepBy1` String -> Parser String
symbol String
","
                        [Argument] -> StateT Style (Parsec Void String) [Argument]
forall a. a -> StateT Style (Parsec Void String) a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Int -> Expression -> Argument)
-> [Int] -> [Expression] -> [Argument]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Alpha -> Expression -> Argument
ArAlpha (Alpha -> Expression -> Argument)
-> (Int -> Alpha) -> Int -> Expression -> Argument
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Alpha
Alpha) [Int
0 ..] [Expression]
exprs)
                    ]
                String
_ <- String -> Parser String
symbol String
")"
                Expression -> Parser Expression
forall a. a -> StateT Style (Parsec Void String) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression -> [Argument] -> Expression
application Expression
expr [Argument]
bds)
            , do
                String
_ <- Parser String
colon
                [Binding] -> Expression
ExFormation ([Binding] -> Expression)
-> (Attribute -> [Binding]) -> Attribute -> Expression
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Binding -> [Binding]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Binding -> [Binding])
-> (Attribute -> Binding) -> Attribute -> [Binding]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Attribute -> Expression -> Binding
`BiTau` Expression
expr) (Attribute -> Expression) -> Parser Attribute -> Parser Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Attribute
attribute
            ]
            Parser Expression -> String -> Parser Expression
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"dispatch or application"
        Expression -> Parser Expression
exTail Expression
next
    , Expression -> Parser Expression
forall a. a -> StateT Style (Parsec Void String) a
forall (m :: * -> *) a. Monad m => a -> m a
return Expression
expr
    ]

expression :: Parser Expression
expression :: Parser Expression
expression = do
  Expression
expr <- Parser Expression
exHead
  Expression -> Parser Expression
exTail Expression
expr

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 =
        Parsec Void String a
-> String -> String -> Either (ParseErrorBundle String Void) a
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
runParser
          ( Parser a -> Style -> Parsec Void String a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT
              ( 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 -> StateT Style (Parsec Void String) a
forall (m :: * -> *) a. Monad m => a -> m a
return a
p
              )
              Style
Free
          )
          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)

parseBytes :: String -> Either String Bytes
parseBytes :: String -> Either String Bytes
parseBytes = String -> Parser Bytes -> String -> Either String Bytes
forall a. String -> Parser a -> String -> Either String a
parse' String
"bytes" Parser Bytes
bytes

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

parseNumber :: String -> Either String Expression
parseNumber :: String -> Either String Expression
parseNumber = String -> Parser Expression -> String -> Either String Expression
forall a. String -> Parser a -> String -> Either String a
parse' String
"number" Parser Expression
number

parseNumberThrows :: String -> IO Expression
parseNumberThrows :: String -> IO Expression
parseNumberThrows String
num = (String -> ParserException)
-> Either String Expression -> IO Expression
forall e a. Exception e => (String -> e) -> Either String a -> IO a
orThrow String -> ParserException
CouldNotParseNumber (String -> Either String Expression
parseNumber String
num)

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
attribute

parseAlpha :: String -> Either String Alpha
parseAlpha :: String -> Either String Alpha
parseAlpha = String -> Parser Alpha -> String -> Either String Alpha
forall a. String -> Parser a -> String -> Either String a
parse' String
"alpha" Parser Alpha
alpha

parseIndex :: String -> Either String (Either Slot T.Text)
parseIndex :: String -> Either String (Either Slot Text)
parseIndex = String
-> Parser (Either Slot Text)
-> String
-> Either String (Either Slot Text)
forall a. String -> Parser a -> String -> Either String a
parse' String
"index meta" Parser (Either Slot Text)
indexVar

parseAttributeThrows :: String -> IO Attribute
parseAttributeThrows :: String -> IO Attribute
parseAttributeThrows String
attr = (String -> ParserException)
-> Either String Attribute -> IO Attribute
forall e a. Exception e => (String -> e) -> Either String a -> IO a
orThrow String -> ParserException
CouldNotParseAttribute (String -> Either String Attribute
parseAttribute String
attr)

parseExpression :: String -> Either String Expression
parseExpression :: String -> Either String Expression
parseExpression = Form -> String -> Either String Expression
parseExpression' Form
POLYFORM

parseExpression' :: Form -> String -> Either String Expression
parseExpression' :: Form -> String -> Either String Expression
parseExpression' Form
MONOFORM = String -> Parser Expression -> String -> Either String Expression
forall a. String -> Parser a -> String -> Either String a
parse' String
"expression" (Style -> Parser ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put Style
Open Parser () -> Parser Expression -> Parser Expression
forall a b.
StateT Style (Parsec Void String) a
-> StateT Style (Parsec Void String) b
-> StateT Style (Parsec Void String) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Expression
expression)
parseExpression' Form
POLYFORM = String -> Parser Expression -> String -> Either String Expression
forall a. String -> Parser a -> String -> Either String a
parse' String
"expression" Parser Expression
expression

parseExpressionThrows :: String -> IO Expression
parseExpressionThrows :: String -> IO Expression
parseExpressionThrows = Form -> String -> IO Expression
parseExpressionThrows' Form
POLYFORM

parseExpressionThrows' :: Form -> String -> IO Expression
parseExpressionThrows' :: Form -> String -> IO Expression
parseExpressionThrows' Form
form String
ex = (String -> ParserException)
-> Either String Expression -> IO Expression
forall e a. Exception e => (String -> e) -> Either String a -> IO a
orThrow String -> ParserException
CouldNotParseExpression (Form -> String -> Either String Expression
parseExpression' Form
form String
ex)