{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies        #-}

module Telomare.Parser where

import Control.Comonad.Cofree (Cofree (..), unwrap)
import Control.Lens.Plated (Plated (..))
import Control.Monad (void)
import Control.Monad.State (State)
import Data.Bifunctor (Bifunctor (first, second), bimap)
import Data.Functor (($>))
import Data.Functor.Foldable (Base, cata, para)
import Data.Functor.Foldable.TH (MakeBaseFunctor (makeBaseFunctor))
import Data.Maybe (fromJust)
import Data.Void (Void)
import Data.Word (Word8)
import PrettyPrint (indentSansFirstLine)
import qualified System.IO.Strict as Strict
import Telomare
import Telomare.TypeChecker (typeCheck)
import Text.Megaparsec (MonadParsec (eof, notFollowedBy, try), Parsec, Pos,
                        PosState (pstateSourcePos),
                        SourcePos (sourceColumn, sourceLine),
                        State (statePosState), between, choice,
                        errorBundlePretty, getParserState, many, manyTill,
                        optional, runParser, sepBy, some, unPos, (<?>), (<|>))
import Text.Megaparsec.Char (alphaNumChar, char, letterChar, space1, string)
import qualified Text.Megaparsec.Char.Lexer as L
import Text.Megaparsec.Debug (dbg)
import Text.Megaparsec.Pos (Pos)
import Text.Read (readMaybe)
import Text.Show.Deriving (deriveShow1)

type AnnotatedUPT = Cofree UnprocessedParsedTermF LocTag

instance Plated UnprocessedParsedTerm where
  plate :: Traversal' UnprocessedParsedTerm UnprocessedParsedTerm
plate UnprocessedParsedTerm -> f UnprocessedParsedTerm
f = \case
    ITEUP UnprocessedParsedTerm
i UnprocessedParsedTerm
t UnprocessedParsedTerm
e -> UnprocessedParsedTerm
-> UnprocessedParsedTerm
-> UnprocessedParsedTerm
-> UnprocessedParsedTerm
ITEUP forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnprocessedParsedTerm -> f UnprocessedParsedTerm
f UnprocessedParsedTerm
i forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> UnprocessedParsedTerm -> f UnprocessedParsedTerm
f UnprocessedParsedTerm
t forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> UnprocessedParsedTerm -> f UnprocessedParsedTerm
f UnprocessedParsedTerm
e
    LetUP [(String, UnprocessedParsedTerm)]
l UnprocessedParsedTerm
x   -> [(String, UnprocessedParsedTerm)]
-> UnprocessedParsedTerm -> UnprocessedParsedTerm
LetUP forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second UnprocessedParsedTerm -> f UnprocessedParsedTerm
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(String, UnprocessedParsedTerm)]
l) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> UnprocessedParsedTerm -> f UnprocessedParsedTerm
f UnprocessedParsedTerm
x
    CaseUP UnprocessedParsedTerm
x [(Pattern, UnprocessedParsedTerm)]
l  -> UnprocessedParsedTerm
-> [(Pattern, UnprocessedParsedTerm)] -> UnprocessedParsedTerm
CaseUP forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnprocessedParsedTerm -> f UnprocessedParsedTerm
f UnprocessedParsedTerm
x forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second UnprocessedParsedTerm -> f UnprocessedParsedTerm
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Pattern, UnprocessedParsedTerm)]
l)
    ListUP [UnprocessedParsedTerm]
l    -> [UnprocessedParsedTerm] -> UnprocessedParsedTerm
ListUP forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse UnprocessedParsedTerm -> f UnprocessedParsedTerm
f [UnprocessedParsedTerm]
l
    PairUP UnprocessedParsedTerm
a UnprocessedParsedTerm
b  -> UnprocessedParsedTerm
-> UnprocessedParsedTerm -> UnprocessedParsedTerm
PairUP forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnprocessedParsedTerm -> f UnprocessedParsedTerm
f UnprocessedParsedTerm
a forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> UnprocessedParsedTerm -> f UnprocessedParsedTerm
f UnprocessedParsedTerm
b
    AppUP UnprocessedParsedTerm
u UnprocessedParsedTerm
x   -> UnprocessedParsedTerm
-> UnprocessedParsedTerm -> UnprocessedParsedTerm
AppUP forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnprocessedParsedTerm -> f UnprocessedParsedTerm
f UnprocessedParsedTerm
u forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> UnprocessedParsedTerm -> f UnprocessedParsedTerm
f UnprocessedParsedTerm
x
    LamUP String
s UnprocessedParsedTerm
x   -> String -> UnprocessedParsedTerm -> UnprocessedParsedTerm
LamUP String
s forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnprocessedParsedTerm -> f UnprocessedParsedTerm
f UnprocessedParsedTerm
x
    LeftUP UnprocessedParsedTerm
x    -> UnprocessedParsedTerm -> UnprocessedParsedTerm
LeftUP forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnprocessedParsedTerm -> f UnprocessedParsedTerm
f UnprocessedParsedTerm
x
    RightUP UnprocessedParsedTerm
x   -> UnprocessedParsedTerm -> UnprocessedParsedTerm
RightUP forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnprocessedParsedTerm -> f UnprocessedParsedTerm
f UnprocessedParsedTerm
x
    TraceUP UnprocessedParsedTerm
x   -> UnprocessedParsedTerm -> UnprocessedParsedTerm
TraceUP forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnprocessedParsedTerm -> f UnprocessedParsedTerm
f UnprocessedParsedTerm
x
    HashUP UnprocessedParsedTerm
x    -> UnprocessedParsedTerm -> UnprocessedParsedTerm
HashUP forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnprocessedParsedTerm -> f UnprocessedParsedTerm
f UnprocessedParsedTerm
x
    CheckUP UnprocessedParsedTerm
c UnprocessedParsedTerm
x -> UnprocessedParsedTerm
-> UnprocessedParsedTerm -> UnprocessedParsedTerm
CheckUP forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnprocessedParsedTerm -> f UnprocessedParsedTerm
f UnprocessedParsedTerm
c forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> UnprocessedParsedTerm -> f UnprocessedParsedTerm
f UnprocessedParsedTerm
x
    UnsizedRecursionUP UnprocessedParsedTerm
x UnprocessedParsedTerm
y UnprocessedParsedTerm
z -> UnprocessedParsedTerm
-> UnprocessedParsedTerm
-> UnprocessedParsedTerm
-> UnprocessedParsedTerm
UnsizedRecursionUP forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnprocessedParsedTerm -> f UnprocessedParsedTerm
f UnprocessedParsedTerm
x forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> UnprocessedParsedTerm -> f UnprocessedParsedTerm
f UnprocessedParsedTerm
y forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> UnprocessedParsedTerm -> f UnprocessedParsedTerm
f UnprocessedParsedTerm
z
    UnprocessedParsedTerm
x           -> forall (f :: * -> *) a. Applicative f => a -> f a
pure UnprocessedParsedTerm
x

-- |TelomareParser :: * -> *
type TelomareParser = Parsec Void String

-- |Parse a variable.
parseVariable :: TelomareParser AnnotatedUPT
parseVariable :: TelomareParser (Cofree UnprocessedParsedTermF LocTag)
parseVariable = do
  State String Void
s <- forall e s (m :: * -> *). MonadParsec e s m => m (State s e)
getParserState
  let line :: Int
line = Pos -> Int
unPos forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourcePos -> Pos
sourceLine forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s. PosState s -> SourcePos
pstateSourcePos forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s e. State s e -> PosState s
statePosState forall a b. (a -> b) -> a -> b
$ State String Void
s
      column :: Int
column = Pos -> Int
unPos forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourcePos -> Pos
sourceColumn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s. PosState s -> SourcePos
pstateSourcePos forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s e. State s e -> PosState s
statePosState forall a b. (a -> b) -> a -> b
$ State String Void
s
  (\String
str -> Int -> Int -> LocTag
Loc Int
line Int
column forall (f :: * -> *) a. a -> f (Cofree f a) -> Cofree f a
:< forall r. String -> UnprocessedParsedTermF r
VarUPF String
str) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TelomareParser String
identifier

-- |Line comments start with "--".
lineComment :: TelomareParser ()
lineComment :: TelomareParser ()
lineComment = forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Tokens s -> m ()
L.skipLineComment String
"--"

-- |A block comment starts with "{-" and ends at "-}".
-- Nested block comments are also supported.
blockComment :: TelomareParser ()
blockComment :: TelomareParser ()
blockComment = forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Tokens s -> Tokens s -> m ()
L.skipBlockCommentNested String
"{-" String
"-}"

-- |Space Consumer: Whitespace and comment parser that does not consume new-lines.
sc :: TelomareParser ()
sc :: TelomareParser ()
sc = forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> m () -> m () -> m ()
L.space
  (forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
' ' forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'\t'))
  TelomareParser ()
lineComment
  TelomareParser ()
blockComment

-- |Space Consumer: Whitespace and comment parser that does consume new-lines.
scn :: TelomareParser ()
scn :: TelomareParser ()
scn = forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> m () -> m () -> m ()
L.space forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space1 TelomareParser ()
lineComment TelomareParser ()
blockComment

-- |This is a wrapper for lexemes that picks up all trailing white space
-- using sc
lexeme :: TelomareParser a -> TelomareParser a
lexeme :: forall a. TelomareParser a -> TelomareParser a
lexeme = forall e s (m :: * -> *) a. MonadParsec e s m => m () -> m a -> m a
L.lexeme TelomareParser ()
sc

-- |A parser that matches given text using string internally and then similarly
-- picks up all trailing white space.
symbol :: String -> TelomareParser String
symbol :: String -> TelomareParser String
symbol = forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> Tokens s -> m (Tokens s)
L.symbol TelomareParser ()
sc

-- |This is to parse reserved words.
reserved :: String -> TelomareParser ()
reserved :: String -> TelomareParser ()
reserved String
w = (forall a. TelomareParser a -> TelomareParser a
lexeme forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try) (forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string String
w forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
alphaNumChar)

-- |List of reserved words
rws :: [String]
rws :: [String]
rws = [String
"let", String
"in", String
"if", String
"then", String
"else", String
"case", String
"of" ]

-- |Variable identifiers can consist of alphanumeric characters, underscore,
-- and must start with an English alphabet letter
identifier :: TelomareParser String
identifier :: TelomareParser String
identifier = forall a. TelomareParser a -> TelomareParser a
lexeme forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try forall a b. (a -> b) -> a -> b
$ ParsecT Void String Identity [Token String]
p forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {m :: * -> *}. MonadFail m => String -> m String
check
  where
    p :: ParsecT Void String Identity [Token String]
p = (:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
letterChar forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
alphaNumChar forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'_' forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"variable")
    check :: String -> m String
check String
x = if String
x forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
rws
              then forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"keyword " forall a. Semigroup a => a -> a -> a
<> (forall a. Show a => a -> String
show String
x forall a. Semigroup a => a -> a -> a
<> String
" cannot be an identifier"))
              else forall (f :: * -> *) a. Applicative f => a -> f a
pure String
x

-- |Parser for parenthesis.
parens :: TelomareParser a -> TelomareParser a
parens :: forall a. TelomareParser a -> TelomareParser a
parens = forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (String -> TelomareParser String
symbol String
"(") (String -> TelomareParser String
symbol String
")")

-- |Parser for brackets.
brackets :: TelomareParser a -> TelomareParser a
brackets :: forall a. TelomareParser a -> TelomareParser a
brackets = forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (String -> TelomareParser String
symbol String
"[") (String -> TelomareParser String
symbol String
"]")

-- |Parser for curly braces
curlies :: TelomareParser a -> TelomareParser a
curlies :: forall a. TelomareParser a -> TelomareParser a
curlies = forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (String -> TelomareParser String
symbol String
"{") (String -> TelomareParser String
symbol String
"}")

-- |Comma sepparated TelomareParser that will be useful for lists
commaSep :: TelomareParser a -> TelomareParser [a]
commaSep :: forall a. TelomareParser a -> TelomareParser [a]
commaSep TelomareParser a
p = TelomareParser a
p forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
`sepBy` String -> TelomareParser String
symbol String
","

-- |Integer TelomareParser used by `parseNumber` and `parseChurch`
integer :: TelomareParser Integer
integer :: TelomareParser Integer
integer = forall a. Integral a => a -> Integer
toInteger forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. TelomareParser a -> TelomareParser a
lexeme forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
L.decimal

getLineColumn :: ParsecT Void String Identity LocTag
getLineColumn = do
  State String Void
s <- forall e s (m :: * -> *). MonadParsec e s m => m (State s e)
getParserState
  let line :: Int
line = Pos -> Int
unPos forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourcePos -> Pos
sourceLine forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s. PosState s -> SourcePos
pstateSourcePos forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s e. State s e -> PosState s
statePosState forall a b. (a -> b) -> a -> b
$ State String Void
s
      column :: Int
column = Pos -> Int
unPos forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourcePos -> Pos
sourceColumn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s. PosState s -> SourcePos
pstateSourcePos forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s e. State s e -> PosState s
statePosState forall a b. (a -> b) -> a -> b
$ State String Void
s
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Int -> Int -> LocTag
Loc Int
line Int
column

-- |Parse string literal.
parseString :: TelomareParser AnnotatedUPT
parseString :: TelomareParser (Cofree UnprocessedParsedTermF LocTag)
parseString = do
  LocTag
x <- ParsecT Void String Identity LocTag
getLineColumn
  (\String
str -> LocTag
x forall (f :: * -> *) a. a -> f (Cofree f a) -> Cofree f a
:< forall r. String -> UnprocessedParsedTermF r
StringUPF String
str) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'"' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
manyTill forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m Char
L.charLiteral (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'"' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* TelomareParser ()
sc))

-- |Parse number (Integer).
parseNumber :: TelomareParser AnnotatedUPT
parseNumber :: TelomareParser (Cofree UnprocessedParsedTermF LocTag)
parseNumber = do
  LocTag
x <- ParsecT Void String Identity LocTag
getLineColumn
  (\Integer
i -> LocTag
x forall (f :: * -> *) a. a -> f (Cofree f a) -> Cofree f a
:< (forall r. Int -> UnprocessedParsedTermF r
IntUPF forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => Integer -> a
fromInteger forall a b. (a -> b) -> a -> b
$ Integer
i)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TelomareParser Integer
integer

-- |Parse a pair.
parsePair :: TelomareParser AnnotatedUPT
parsePair :: TelomareParser (Cofree UnprocessedParsedTermF LocTag)
parsePair = forall a. TelomareParser a -> TelomareParser a
parens forall a b. (a -> b) -> a -> b
$ do
  LocTag
x <- ParsecT Void String Identity LocTag
getLineColumn
  Cofree UnprocessedParsedTermF LocTag
a <- TelomareParser ()
scn forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> TelomareParser (Cofree UnprocessedParsedTermF LocTag)
parseLongExpr forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* TelomareParser ()
scn
  String
_ <- String -> TelomareParser String
symbol String
"," forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* TelomareParser ()
scn
  Cofree UnprocessedParsedTermF LocTag
b <- TelomareParser (Cofree UnprocessedParsedTermF LocTag)
parseLongExpr forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* TelomareParser ()
scn
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ LocTag
x forall (f :: * -> *) a. a -> f (Cofree f a) -> Cofree f a
:< forall r. r -> r -> UnprocessedParsedTermF r
PairUPF Cofree UnprocessedParsedTermF LocTag
a Cofree UnprocessedParsedTermF LocTag
b

-- |Parse unsized recursion triple
parseUnsizedRecursion :: TelomareParser AnnotatedUPT
parseUnsizedRecursion :: TelomareParser (Cofree UnprocessedParsedTermF LocTag)
parseUnsizedRecursion = forall a. TelomareParser a -> TelomareParser a
curlies forall a b. (a -> b) -> a -> b
$ do
  LocTag
x <- ParsecT Void String Identity LocTag
getLineColumn
  Cofree UnprocessedParsedTermF LocTag
a <- TelomareParser ()
scn forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> TelomareParser (Cofree UnprocessedParsedTermF LocTag)
parseLongExpr forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* TelomareParser ()
scn
  String
_ <- String -> TelomareParser String
symbol String
"," forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* TelomareParser ()
scn
  Cofree UnprocessedParsedTermF LocTag
b <- TelomareParser (Cofree UnprocessedParsedTermF LocTag)
parseLongExpr forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* TelomareParser ()
scn
  String
_ <- String -> TelomareParser String
symbol String
"," forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* TelomareParser ()
scn
  Cofree UnprocessedParsedTermF LocTag
c <- TelomareParser (Cofree UnprocessedParsedTermF LocTag)
parseLongExpr forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* TelomareParser ()
scn
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ LocTag
x forall (f :: * -> *) a. a -> f (Cofree f a) -> Cofree f a
:< forall r. r -> r -> r -> UnprocessedParsedTermF r
UnsizedRecursionUPF Cofree UnprocessedParsedTermF LocTag
a Cofree UnprocessedParsedTermF LocTag
b Cofree UnprocessedParsedTermF LocTag
c

-- |Parse a list.
parseList :: TelomareParser AnnotatedUPT
parseList :: TelomareParser (Cofree UnprocessedParsedTermF LocTag)
parseList = do
  LocTag
x <- ParsecT Void String Identity LocTag
getLineColumn
  [Cofree UnprocessedParsedTermF LocTag]
exprs <- forall a. TelomareParser a -> TelomareParser a
brackets (forall a. TelomareParser a -> TelomareParser [a]
commaSep (TelomareParser ()
scn forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> TelomareParser (Cofree UnprocessedParsedTermF LocTag)
parseLongExpr forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<*TelomareParser ()
scn))
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ LocTag
x forall (f :: * -> *) a. a -> f (Cofree f a) -> Cofree f a
:< forall r. [r] -> UnprocessedParsedTermF r
ListUPF [Cofree UnprocessedParsedTermF LocTag]
exprs

-- TODO: make error more descriptive
-- |Parse ITE (which stands for "if then else").
parseITE :: TelomareParser AnnotatedUPT
parseITE :: TelomareParser (Cofree UnprocessedParsedTermF LocTag)
parseITE = do
  LocTag
x <- ParsecT Void String Identity LocTag
getLineColumn
  String -> TelomareParser ()
reserved String
"if" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* TelomareParser ()
scn
  Cofree UnprocessedParsedTermF LocTag
cond <- (TelomareParser (Cofree UnprocessedParsedTermF LocTag)
parseLongExpr forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> TelomareParser (Cofree UnprocessedParsedTermF LocTag)
parseSingleExpr) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* TelomareParser ()
scn
  String -> TelomareParser ()
reserved String
"then" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* TelomareParser ()
scn
  Cofree UnprocessedParsedTermF LocTag
thenExpr <- (TelomareParser (Cofree UnprocessedParsedTermF LocTag)
parseLongExpr forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> TelomareParser (Cofree UnprocessedParsedTermF LocTag)
parseSingleExpr) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* TelomareParser ()
scn
  String -> TelomareParser ()
reserved String
"else" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* TelomareParser ()
scn
  Cofree UnprocessedParsedTermF LocTag
elseExpr <- TelomareParser (Cofree UnprocessedParsedTermF LocTag)
parseLongExpr forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* TelomareParser ()
scn
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ LocTag
x forall (f :: * -> *) a. a -> f (Cofree f a) -> Cofree f a
:< forall r. r -> r -> r -> UnprocessedParsedTermF r
ITEUPF Cofree UnprocessedParsedTermF LocTag
cond Cofree UnprocessedParsedTermF LocTag
thenExpr Cofree UnprocessedParsedTermF LocTag
elseExpr

parseHash :: TelomareParser AnnotatedUPT
parseHash :: TelomareParser (Cofree UnprocessedParsedTermF LocTag)
parseHash = do
  LocTag
x <- ParsecT Void String Identity LocTag
getLineColumn
  String -> TelomareParser String
symbol String
"#" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* TelomareParser ()
scn
  Cofree UnprocessedParsedTermF LocTag
upt <- TelomareParser (Cofree UnprocessedParsedTermF LocTag)
parseSingleExpr
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ LocTag
x forall (f :: * -> *) a. a -> f (Cofree f a) -> Cofree f a
:< forall r. r -> UnprocessedParsedTermF r
HashUPF Cofree UnprocessedParsedTermF LocTag
upt

parseCase :: TelomareParser AnnotatedUPT
parseCase :: TelomareParser (Cofree UnprocessedParsedTermF LocTag)
parseCase = do
  LocTag
x <- ParsecT Void String Identity LocTag
getLineColumn
  String -> TelomareParser ()
reserved String
"case" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* TelomareParser ()
scn
  Cofree UnprocessedParsedTermF LocTag
iexpr <- TelomareParser (Cofree UnprocessedParsedTermF LocTag)
parseLongExpr forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* TelomareParser ()
scn
  String -> TelomareParser ()
reserved String
"of" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* TelomareParser ()
scn
  [(Pattern, Cofree UnprocessedParsedTermF LocTag)]
lpc <- forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try ParsecT
  Void
  String
  Identity
  (Pattern, Cofree UnprocessedParsedTermF LocTag)
parseSingleCase forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* TelomareParser ()
scn
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ LocTag
x forall (f :: * -> *) a. a -> f (Cofree f a) -> Cofree f a
:< forall r. r -> [(Pattern, r)] -> UnprocessedParsedTermF r
CaseUPF Cofree UnprocessedParsedTermF LocTag
iexpr [(Pattern, Cofree UnprocessedParsedTermF LocTag)]
lpc

parseSingleCase :: TelomareParser (Pattern, AnnotatedUPT)
parseSingleCase :: ParsecT
  Void
  String
  Identity
  (Pattern, Cofree UnprocessedParsedTermF LocTag)
parseSingleCase = do
  Pattern
p <- ParsecT Void String Identity Pattern
parsePattern forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* TelomareParser ()
scn
  String -> TelomareParser ()
reserved String
"->" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* TelomareParser ()
scn
  Cofree UnprocessedParsedTermF LocTag
c <- TelomareParser (Cofree UnprocessedParsedTermF LocTag)
parseLongExpr forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* TelomareParser ()
scn
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pattern
p, Cofree UnprocessedParsedTermF LocTag
c)

parsePattern :: TelomareParser Pattern
parsePattern :: ParsecT Void String Identity Pattern
parsePattern = forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ ParsecT Void String Identity Pattern
parsePatternIgnore
                                , ParsecT Void String Identity Pattern
parsePatternVar
                                , ParsecT Void String Identity Pattern
parsePatternString
                                , ParsecT Void String Identity Pattern
parsePatternInt
                                , ParsecT Void String Identity Pattern
parsePatternPair
                                ]

parsePatternPair :: TelomareParser Pattern
parsePatternPair :: ParsecT Void String Identity Pattern
parsePatternPair = forall a. TelomareParser a -> TelomareParser a
parens forall a b. (a -> b) -> a -> b
$ do
  Pattern
p <- TelomareParser ()
scn forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void String Identity Pattern
parsePattern forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* TelomareParser ()
scn
  String
_ <- String -> TelomareParser String
symbol String
"," forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* TelomareParser ()
scn
  Pattern
b <- ParsecT Void String Identity Pattern
parsePattern forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* TelomareParser ()
scn
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Pattern -> Pattern -> Pattern
PatternPair Pattern
p Pattern
b

parsePatternInt :: TelomareParser Pattern
parsePatternInt :: ParsecT Void String Identity Pattern
parsePatternInt = Int -> Pattern
PatternInt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => Integer -> a
fromInteger forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TelomareParser Integer
integer

parsePatternString :: TelomareParser Pattern
parsePatternString :: ParsecT Void String Identity Pattern
parsePatternString = String -> Pattern
PatternString forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'"' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
manyTill forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m Char
L.charLiteral (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'"'))

parsePatternVar :: TelomareParser Pattern
parsePatternVar :: ParsecT Void String Identity Pattern
parsePatternVar = String -> Pattern
PatternVar forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TelomareParser String
identifier

parsePatternIgnore :: TelomareParser Pattern
parsePatternIgnore :: ParsecT Void String Identity Pattern
parsePatternIgnore = String -> TelomareParser String
symbol String
"_" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure Pattern
PatternIgnore

-- |Parse a single expression.
parseSingleExpr :: TelomareParser AnnotatedUPT
parseSingleExpr :: TelomareParser (Cofree UnprocessedParsedTermF LocTag)
parseSingleExpr = forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ TelomareParser (Cofree UnprocessedParsedTermF LocTag)
parseHash
                                   , TelomareParser (Cofree UnprocessedParsedTermF LocTag)
parseString
                                   , TelomareParser (Cofree UnprocessedParsedTermF LocTag)
parseNumber
                                   , TelomareParser (Cofree UnprocessedParsedTermF LocTag)
parsePair
                                   , TelomareParser (Cofree UnprocessedParsedTermF LocTag)
parseUnsizedRecursion
                                   , TelomareParser (Cofree UnprocessedParsedTermF LocTag)
parseList
                                   , TelomareParser (Cofree UnprocessedParsedTermF LocTag)
parseChurch
                                   , TelomareParser (Cofree UnprocessedParsedTermF LocTag)
parseVariable
                                   , forall a. TelomareParser a -> TelomareParser a
parens (TelomareParser ()
scn forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> TelomareParser (Cofree UnprocessedParsedTermF LocTag)
parseLongExpr forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* TelomareParser ()
scn)
                                   ]

-- |Parse application of functions.
parseApplied :: TelomareParser AnnotatedUPT
parseApplied :: TelomareParser (Cofree UnprocessedParsedTermF LocTag)
parseApplied = do
  LocTag
x <- ParsecT Void String Identity LocTag
getLineColumn
  [Cofree UnprocessedParsedTermF LocTag]
fargs <- forall s e (m :: * -> *) a.
(TraversableStream s, MonadParsec e s m) =>
m () -> (m () -> m a) -> m a
L.lineFold TelomareParser ()
scn forall a b. (a -> b) -> a -> b
$ \TelomareParser ()
sc' ->
    TelomareParser (Cofree UnprocessedParsedTermF LocTag)
parseSingleExpr forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
`sepBy` forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try TelomareParser ()
sc'
  case [Cofree UnprocessedParsedTermF LocTag]
fargs of
    (Cofree UnprocessedParsedTermF LocTag
f:[Cofree UnprocessedParsedTermF LocTag]
args) ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Cofree UnprocessedParsedTermF LocTag
a Cofree UnprocessedParsedTermF LocTag
b -> LocTag
x forall (f :: * -> *) a. a -> f (Cofree f a) -> Cofree f a
:< forall r. r -> r -> UnprocessedParsedTermF r
AppUPF Cofree UnprocessedParsedTermF LocTag
a Cofree UnprocessedParsedTermF LocTag
b) Cofree UnprocessedParsedTermF LocTag
f [Cofree UnprocessedParsedTermF LocTag]
args
    [Cofree UnprocessedParsedTermF LocTag]
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"expected expression"

-- |Parse lambda expression.
parseLambda :: TelomareParser AnnotatedUPT
parseLambda :: TelomareParser (Cofree UnprocessedParsedTermF LocTag)
parseLambda = do
  LocTag
x <- ParsecT Void String Identity LocTag
getLineColumn
  String -> TelomareParser String
symbol String
"\\" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* TelomareParser ()
scn
  [String]
variables <- forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some TelomareParser String
identifier forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* TelomareParser ()
scn
  String -> TelomareParser String
symbol String
"->" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* TelomareParser ()
scn
  -- TODO make sure lambda names don't collide with bound names
  Cofree UnprocessedParsedTermF LocTag
term1expr <- TelomareParser (Cofree UnprocessedParsedTermF LocTag)
parseLongExpr forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* TelomareParser ()
scn
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\String
str Cofree UnprocessedParsedTermF LocTag
upt -> LocTag
x forall (f :: * -> *) a. a -> f (Cofree f a) -> Cofree f a
:< forall r. String -> r -> UnprocessedParsedTermF r
LamUPF String
str Cofree UnprocessedParsedTermF LocTag
upt) Cofree UnprocessedParsedTermF LocTag
term1expr [String]
variables

-- |Parser that fails if indent level is not `pos`.
parseSameLvl :: Pos -> TelomareParser a -> TelomareParser a
parseSameLvl :: forall a. Pos -> TelomareParser a -> TelomareParser a
parseSameLvl Pos
pos TelomareParser a
parser = do
  Pos
lvl <- forall s e (m :: * -> *).
(TraversableStream s, MonadParsec e s m) =>
m Pos
L.indentLevel
  if Pos
pos forall a. Eq a => a -> a -> Bool
== Pos
lvl then TelomareParser a
parser else forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Expected same indentation."

-- |Parse let expression.
parseLet :: TelomareParser AnnotatedUPT
parseLet :: TelomareParser (Cofree UnprocessedParsedTermF LocTag)
parseLet = do
  LocTag
x <- ParsecT Void String Identity LocTag
getLineColumn
  String -> TelomareParser ()
reserved String
"let" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* TelomareParser ()
scn
  Pos
lvl <- forall s e (m :: * -> *).
(TraversableStream s, MonadParsec e s m) =>
m Pos
L.indentLevel
  [(String, Cofree UnprocessedParsedTermF LocTag)]
bindingsList <- forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
manyTill (forall a. Pos -> TelomareParser a -> TelomareParser a
parseSameLvl Pos
lvl TelomareParser (String, Cofree UnprocessedParsedTermF LocTag)
parseAssignment) (String -> TelomareParser ()
reserved String
"in") forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* TelomareParser ()
scn
  Cofree UnprocessedParsedTermF LocTag
expr <- TelomareParser (Cofree UnprocessedParsedTermF LocTag)
parseLongExpr forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* TelomareParser ()
scn
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ LocTag
x forall (f :: * -> *) a. a -> f (Cofree f a) -> Cofree f a
:< forall r. [(String, r)] -> r -> UnprocessedParsedTermF r
LetUPF [(String, Cofree UnprocessedParsedTermF LocTag)]
bindingsList Cofree UnprocessedParsedTermF LocTag
expr

-- |Parse long expression.
parseLongExpr :: TelomareParser AnnotatedUPT
parseLongExpr :: TelomareParser (Cofree UnprocessedParsedTermF LocTag)
parseLongExpr = forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ TelomareParser (Cofree UnprocessedParsedTermF LocTag)
parseLet
                                 , TelomareParser (Cofree UnprocessedParsedTermF LocTag)
parseITE
                                 , TelomareParser (Cofree UnprocessedParsedTermF LocTag)
parseLambda
                                 , TelomareParser (Cofree UnprocessedParsedTermF LocTag)
parseApplied
                                 , TelomareParser (Cofree UnprocessedParsedTermF LocTag)
parseCase
                                 , TelomareParser (Cofree UnprocessedParsedTermF LocTag)
parseSingleExpr
                                 ]

-- |Parse church numerals (church numerals are a "$" appended to an integer, without any whitespace separation).
parseChurch :: TelomareParser AnnotatedUPT
parseChurch :: TelomareParser (Cofree UnprocessedParsedTermF LocTag)
parseChurch = do
  LocTag
x <- ParsecT Void String Identity LocTag
getLineColumn
  (\Int
upt -> LocTag
x forall (f :: * -> *) a. a -> f (Cofree f a) -> Cofree f a
:< forall r. Int -> UnprocessedParsedTermF r
ChurchUPF Int
upt) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => Integer -> a
fromInteger forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> TelomareParser String
symbol String
"$" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> TelomareParser Integer
integer)

-- |Parse refinement check.
parseRefinementCheck :: TelomareParser (AnnotatedUPT -> AnnotatedUPT)
parseRefinementCheck :: TelomareParser
  (Cofree UnprocessedParsedTermF LocTag
   -> Cofree UnprocessedParsedTermF LocTag)
parseRefinementCheck = do
  LocTag
x <- ParsecT Void String Identity LocTag
getLineColumn
  (\Cofree UnprocessedParsedTermF LocTag
a Cofree UnprocessedParsedTermF LocTag
b -> LocTag
x forall (f :: * -> *) a. a -> f (Cofree f a) -> Cofree f a
:< forall r. r -> r -> UnprocessedParsedTermF r
CheckUPF Cofree UnprocessedParsedTermF LocTag
a Cofree UnprocessedParsedTermF LocTag
b) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> TelomareParser String
symbol String
":" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> TelomareParser (Cofree UnprocessedParsedTermF LocTag)
parseLongExpr)

-- |Parse assignment add adding binding to ParserState.
parseAssignment :: TelomareParser (String, AnnotatedUPT)
parseAssignment :: TelomareParser (String, Cofree UnprocessedParsedTermF LocTag)
parseAssignment = do
  String
var <- TelomareParser String
identifier forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* TelomareParser ()
scn
  Maybe
  (Cofree UnprocessedParsedTermF LocTag
   -> Cofree UnprocessedParsedTermF LocTag)
annotation <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try forall a b. (a -> b) -> a -> b
$ TelomareParser
  (Cofree UnprocessedParsedTermF LocTag
   -> Cofree UnprocessedParsedTermF LocTag)
parseRefinementCheck
  TelomareParser ()
scn forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> String -> TelomareParser String
symbol String
"=" forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"assignment ="
  Cofree UnprocessedParsedTermF LocTag
expr <- TelomareParser ()
scn forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> TelomareParser (Cofree UnprocessedParsedTermF LocTag)
parseLongExpr forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* TelomareParser ()
scn
  case Maybe
  (Cofree UnprocessedParsedTermF LocTag
   -> Cofree UnprocessedParsedTermF LocTag)
annotation of
    Just Cofree UnprocessedParsedTermF LocTag
-> Cofree UnprocessedParsedTermF LocTag
annot -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
var, Cofree UnprocessedParsedTermF LocTag
-> Cofree UnprocessedParsedTermF LocTag
annot Cofree UnprocessedParsedTermF LocTag
expr)
    Maybe
  (Cofree UnprocessedParsedTermF LocTag
   -> Cofree UnprocessedParsedTermF LocTag)
_          -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
var, Cofree UnprocessedParsedTermF LocTag
expr)

-- |Parse top level expressions.
parseTopLevel :: TelomareParser AnnotatedUPT
parseTopLevel :: TelomareParser (Cofree UnprocessedParsedTermF LocTag)
parseTopLevel = [(String, Cofree UnprocessedParsedTermF LocTag)]
-> TelomareParser (Cofree UnprocessedParsedTermF LocTag)
parseTopLevelWithPrelude []

-- |Parse top level expressions.
parseTopLevelWithPrelude :: [(String, AnnotatedUPT)]    -- ^Prelude
                         -> TelomareParser AnnotatedUPT
parseTopLevelWithPrelude :: [(String, Cofree UnprocessedParsedTermF LocTag)]
-> TelomareParser (Cofree UnprocessedParsedTermF LocTag)
parseTopLevelWithPrelude [(String, Cofree UnprocessedParsedTermF LocTag)]
lst = do
  LocTag
x <- ParsecT Void String Identity LocTag
getLineColumn
  [(String, Cofree UnprocessedParsedTermF LocTag)]
bindingList <- TelomareParser ()
scn forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many TelomareParser (String, Cofree UnprocessedParsedTermF LocTag)
parseAssignment forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *). MonadParsec e s m => m ()
eof
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ LocTag
x forall (f :: * -> *) a. a -> f (Cofree f a) -> Cofree f a
:< forall r. [(String, r)] -> r -> UnprocessedParsedTermF r
LetUPF ([(String, Cofree UnprocessedParsedTermF LocTag)]
lst forall a. Semigroup a => a -> a -> a
<> [(String, Cofree UnprocessedParsedTermF LocTag)]
bindingList) (forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"main" [(String, Cofree UnprocessedParsedTermF LocTag)]
bindingList)

parseDefinitions :: TelomareParser (AnnotatedUPT -> AnnotatedUPT)
parseDefinitions :: TelomareParser
  (Cofree UnprocessedParsedTermF LocTag
   -> Cofree UnprocessedParsedTermF LocTag)
parseDefinitions = do
  LocTag
x <- ParsecT Void String Identity LocTag
getLineColumn
  [(String, Cofree UnprocessedParsedTermF LocTag)]
bindingList <- TelomareParser ()
scn forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many TelomareParser (String, Cofree UnprocessedParsedTermF LocTag)
parseAssignment forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *). MonadParsec e s m => m ()
eof
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ \Cofree UnprocessedParsedTermF LocTag
y -> LocTag
x forall (f :: * -> *) a. a -> f (Cofree f a) -> Cofree f a
:< forall r. [(String, r)] -> r -> UnprocessedParsedTermF r
LetUPF [(String, Cofree UnprocessedParsedTermF LocTag)]
bindingList Cofree UnprocessedParsedTermF LocTag
y

-- |Helper function to test parsers without a result.
runTelomareParser_ :: Show a => TelomareParser a -> String -> IO ()
runTelomareParser_ :: forall a. Show a => TelomareParser a -> String -> IO ()
runTelomareParser_ TelomareParser a
parser String
str = forall (m :: * -> *) a.
Monad m =>
TelomareParser a -> String -> m a
runTelomareParser TelomareParser a
parser String
str forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. Show a => a -> IO ()
print

-- |Helper function to debug parsers without a result.
runTelomareParserWDebug :: Show a => TelomareParser a -> String -> IO ()
runTelomareParserWDebug :: forall a. Show a => TelomareParser a -> String -> IO ()
runTelomareParserWDebug TelomareParser a
parser String
str = forall (m :: * -> *) a.
Monad m =>
TelomareParser a -> String -> m a
runTelomareParser (forall e s (m :: * -> *) a.
(VisualStream s, ShowErrorComponent e, Show a) =>
String -> ParsecT e s m a -> ParsecT e s m a
dbg String
"debug" TelomareParser a
parser) String
str forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. Show a => a -> IO ()
print

-- |Helper function to test Telomare parsers with any result.
runTelomareParser :: Monad m => TelomareParser a -> String -> m a
runTelomareParser :: forall (m :: * -> *) a.
Monad m =>
TelomareParser a -> String -> m a
runTelomareParser TelomareParser a
parser String
str =
  case forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
runParser TelomareParser a
parser String
"" String
str of
    Right a
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
    Left ParseErrorBundle String Void
e  -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorBundlePretty ParseErrorBundle String Void
e

-- |Helper function to test if parser was successful.
parseSuccessful :: Monad m => TelomareParser a -> String -> m Bool
parseSuccessful :: forall (m :: * -> *) a.
Monad m =>
TelomareParser a -> String -> m Bool
parseSuccessful TelomareParser a
parser String
str =
  case forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
runParser TelomareParser a
parser String
"" String
str of
    Right a
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
    Left ParseErrorBundle String Void
_  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

runParseLongExpr :: String -> Either String UnprocessedParsedTerm
runParseLongExpr :: String -> Either String UnprocessedParsedTerm
runParseLongExpr String
str = forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorBundlePretty Cofree UnprocessedParsedTermF LocTag -> UnprocessedParsedTerm
forget' forall a b. (a -> b) -> a -> b
$ forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
runParser TelomareParser (Cofree UnprocessedParsedTermF LocTag)
parseLongExpr String
"" String
str
  where
    forget' :: Cofree UnprocessedParsedTermF LocTag -> UnprocessedParsedTerm
    forget' :: Cofree UnprocessedParsedTermF LocTag -> UnprocessedParsedTerm
forget' = forall a anno. Corecursive a => Cofree (Base a) anno -> a
forget

parsePrelude :: String -> Either String [(String, AnnotatedUPT)]
parsePrelude :: String
-> Either String [(String, Cofree UnprocessedParsedTermF LocTag)]
parsePrelude String
str = let result :: Either
  (ParseErrorBundle String Void)
  [(String, Cofree UnprocessedParsedTermF LocTag)]
result = forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
runParser (TelomareParser ()
scn forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many TelomareParser (String, Cofree UnprocessedParsedTermF LocTag)
parseAssignment forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *). MonadParsec e s m => m ()
eof) String
"" String
str
                    in forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorBundlePretty Either
  (ParseErrorBundle String Void)
  [(String, Cofree UnprocessedParsedTermF LocTag)]
result

-- |Parse either a single expression or top level definitions defaulting to the `main` definition.
--  This function is useful and was made for telomare-evaluare
parseOneExprOrTopLevelDefs :: [(String, AnnotatedUPT)] -> TelomareParser AnnotatedUPT
parseOneExprOrTopLevelDefs :: [(String, Cofree UnprocessedParsedTermF LocTag)]
-> TelomareParser (Cofree UnprocessedParsedTermF LocTag)
parseOneExprOrTopLevelDefs [(String, Cofree UnprocessedParsedTermF LocTag)]
prelude = forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ [(String, Cofree UnprocessedParsedTermF LocTag)]
-> TelomareParser (Cofree UnprocessedParsedTermF LocTag)
parseTopLevelWithPrelude [(String, Cofree UnprocessedParsedTermF LocTag)]
prelude
                                                      , TelomareParser (Cofree UnprocessedParsedTermF LocTag)
parseLongExpr
                                                      ]

-- |Parse with specified prelude
parseWithPrelude :: [(String, AnnotatedUPT)]   -- ^Prelude
                 -> String                     -- ^Raw string to be parsed
                 -> Either String AnnotatedUPT -- ^Error on Left
parseWithPrelude :: [(String, Cofree UnprocessedParsedTermF LocTag)]
-> String -> Either String (Cofree UnprocessedParsedTermF LocTag)
parseWithPrelude [(String, Cofree UnprocessedParsedTermF LocTag)]
prelude String
str = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorBundlePretty forall a b. (a -> b) -> a -> b
$ forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
runParser ([(String, Cofree UnprocessedParsedTermF LocTag)]
-> TelomareParser (Cofree UnprocessedParsedTermF LocTag)
parseTopLevelWithPrelude [(String, Cofree UnprocessedParsedTermF LocTag)]
prelude) String
"" String
str