module Language.Lambda.SystemF.Parser (
  parseExpr,
  parseType
  ) where

import Control.Monad
import Data.Functor
import RIO hiding ((<|>), abs, many, try)
import qualified RIO.Text as Text

import Text.Parsec
import Text.Parsec.Text

import Language.Lambda.SystemF.Expression

parseExpr :: Text -> Either ParseError (SystemFExpr Text Text)
parseExpr :: Text -> Either ParseError (SystemFExpr Text Text)
parseExpr = Parsec Text () (SystemFExpr Text Text)
-> SourceName -> Text -> Either ParseError (SystemFExpr Text Text)
forall s t a.
Stream s Identity t =>
Parsec s () a -> SourceName -> s -> Either ParseError a
parse (Parser ()
whitespace Parser ()
-> Parsec Text () (SystemFExpr Text Text)
-> Parsec Text () (SystemFExpr Text Text)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parsec Text () (SystemFExpr Text Text)
expr Parsec Text () (SystemFExpr Text Text)
-> Parser () -> Parsec Text () (SystemFExpr Text Text)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof) SourceName
""

parseType :: Text -> Either ParseError (Ty Text)
parseType :: Text -> Either ParseError (Ty Text)
parseType = Parsec Text () (Ty Text)
-> SourceName -> Text -> Either ParseError (Ty Text)
forall s t a.
Stream s Identity t =>
Parsec s () a -> SourceName -> s -> Either ParseError a
parse (Parser ()
whitespace Parser () -> Parsec Text () (Ty Text) -> Parsec Text () (Ty Text)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parsec Text () (Ty Text)
ty Parsec Text () (Ty Text) -> Parser () -> Parsec Text () (Ty Text)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof) SourceName
""

-- Parse expressions
expr :: Parser (SystemFExpr Text Text)
expr :: Parsec Text () (SystemFExpr Text Text)
expr = Parsec Text () (SystemFExpr Text Text)
-> Parsec Text () (SystemFExpr Text Text)
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try Parsec Text () (SystemFExpr Text Text)
tyapp Parsec Text () (SystemFExpr Text Text)
-> Parsec Text () (SystemFExpr Text Text)
-> Parsec Text () (SystemFExpr Text Text)
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Parsec Text () (SystemFExpr Text Text)
-> Parsec Text () (SystemFExpr Text Text)
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try Parsec Text () (SystemFExpr Text Text)
app Parsec Text () (SystemFExpr Text Text)
-> Parsec Text () (SystemFExpr Text Text)
-> Parsec Text () (SystemFExpr Text Text)
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Parsec Text () (SystemFExpr Text Text)
term

app :: Parser (SystemFExpr Text Text)
app :: Parsec Text () (SystemFExpr Text Text)
app = Parsec Text () (SystemFExpr Text Text)
-> ParsecT
     Text
     ()
     Identity
     (SystemFExpr Text Text
      -> SystemFExpr Text Text -> SystemFExpr Text Text)
-> Parsec Text () (SystemFExpr Text Text)
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m (a -> a -> a) -> ParsecT s u m a
chainl1 Parsec Text () (SystemFExpr Text Text)
term ((SystemFExpr Text Text
 -> SystemFExpr Text Text -> SystemFExpr Text Text)
-> ParsecT
     Text
     ()
     Identity
     (SystemFExpr Text Text
      -> SystemFExpr Text Text -> SystemFExpr Text Text)
forall (m :: * -> *) a. Monad m => a -> m a
return SystemFExpr Text Text
-> SystemFExpr Text Text -> SystemFExpr Text Text
forall name ty.
SystemFExpr name ty -> SystemFExpr name ty -> SystemFExpr name ty
App)

tyapp :: Parser (SystemFExpr Text Text)
tyapp :: Parsec Text () (SystemFExpr Text Text)
tyapp = SystemFExpr Text Text -> Ty Text -> SystemFExpr Text Text
forall name ty. SystemFExpr name ty -> Ty ty -> SystemFExpr name ty
TyApp
      (SystemFExpr Text Text -> Ty Text -> SystemFExpr Text Text)
-> Parsec Text () (SystemFExpr Text Text)
-> ParsecT Text () Identity (Ty Text -> SystemFExpr Text Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parsec Text () (SystemFExpr Text Text)
term
      ParsecT Text () Identity (Ty Text -> SystemFExpr Text Text)
-> Parsec Text () (Ty Text)
-> Parsec Text () (SystemFExpr Text Text)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parsec Text () (Ty Text)
ty'
  where ty' :: Parsec Text () (Ty Text)
ty' = Char -> Parser ()
symbol Char
'[' Parser () -> Parsec Text () (Ty Text) -> Parsec Text () (Ty Text)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parsec Text () (Ty Text)
ty Parsec Text () (Ty Text) -> Parser () -> Parsec Text () (Ty Text)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser ()
symbol Char
']'

term :: Parser (SystemFExpr Text Text)
term :: Parsec Text () (SystemFExpr Text Text)
term = Parsec Text () (SystemFExpr Text Text)
-> Parsec Text () (SystemFExpr Text Text)
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try Parsec Text () (SystemFExpr Text Text)
abs Parsec Text () (SystemFExpr Text Text)
-> Parsec Text () (SystemFExpr Text Text)
-> Parsec Text () (SystemFExpr Text Text)
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Parsec Text () (SystemFExpr Text Text)
tyabs Parsec Text () (SystemFExpr Text Text)
-> Parsec Text () (SystemFExpr Text Text)
-> Parsec Text () (SystemFExpr Text Text)
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Parsec Text () (SystemFExpr Text Text)
var Parsec Text () (SystemFExpr Text Text)
-> Parsec Text () (SystemFExpr Text Text)
-> Parsec Text () (SystemFExpr Text Text)
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Parsec Text () (SystemFExpr Text Text)
-> Parsec Text () (SystemFExpr Text Text)
forall a. Parser a -> Parser a
parens Parsec Text () (SystemFExpr Text Text)
expr

var :: Parser (SystemFExpr Text Text)
var :: Parsec Text () (SystemFExpr Text Text)
var = Text -> SystemFExpr Text Text
forall name ty. name -> SystemFExpr name ty
Var (Text -> SystemFExpr Text Text)
-> ParsecT Text () Identity Text
-> Parsec Text () (SystemFExpr Text Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Text () Identity Text
exprId

abs :: Parser (SystemFExpr Text Text)
abs :: Parsec Text () (SystemFExpr Text Text)
abs = [(Text, Ty Text)] -> SystemFExpr Text Text -> SystemFExpr Text Text
forall a ty. [(a, Ty ty)] -> SystemFExpr a ty -> SystemFExpr a ty
curry'
    ([(Text, Ty Text)]
 -> SystemFExpr Text Text -> SystemFExpr Text Text)
-> ParsecT Text () Identity [(Text, Ty Text)]
-> ParsecT
     Text () Identity (SystemFExpr Text Text -> SystemFExpr Text Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Parser ()
symbol Char
'\\' Parser ()
-> ParsecT Text () Identity [(Text, Ty Text)]
-> ParsecT Text () Identity [(Text, Ty Text)]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Text () Identity (Text, Ty Text)
-> ParsecT Text () Identity [(Text, Ty Text)]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT Text () Identity (Text, Ty Text)
args ParsecT Text () Identity [(Text, Ty Text)]
-> Parser () -> ParsecT Text () Identity [(Text, Ty Text)]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser ()
symbol Char
'.') 
    ParsecT
  Text () Identity (SystemFExpr Text Text -> SystemFExpr Text Text)
-> Parsec Text () (SystemFExpr Text Text)
-> Parsec Text () (SystemFExpr Text Text)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parsec Text () (SystemFExpr Text Text)
expr
  where args :: ParsecT Text () Identity (Text, Ty Text)
args = (,) (Text -> Ty Text -> (Text, Ty Text))
-> ParsecT Text () Identity Text
-> ParsecT Text () Identity (Ty Text -> (Text, Ty Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ParsecT Text () Identity Text
exprId ParsecT Text () Identity Text
-> Parser () -> ParsecT Text () Identity Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser ()
symbol Char
':') ParsecT Text () Identity (Ty Text -> (Text, Ty Text))
-> Parsec Text () (Ty Text)
-> ParsecT Text () Identity (Text, Ty Text)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parsec Text () (Ty Text)
ty
        curry' :: [(a, Ty ty)] -> SystemFExpr a ty -> SystemFExpr a ty
curry' = (SystemFExpr a ty -> [(a, Ty ty)] -> SystemFExpr a ty)
-> [(a, Ty ty)] -> SystemFExpr a ty -> SystemFExpr a ty
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((SystemFExpr a ty -> [(a, Ty ty)] -> SystemFExpr a ty)
 -> [(a, Ty ty)] -> SystemFExpr a ty -> SystemFExpr a ty)
-> ((a -> Ty ty -> SystemFExpr a ty -> SystemFExpr a ty)
    -> SystemFExpr a ty -> [(a, Ty ty)] -> SystemFExpr a ty)
-> (a -> Ty ty -> SystemFExpr a ty -> SystemFExpr a ty)
-> [(a, Ty ty)]
-> SystemFExpr a ty
-> SystemFExpr a ty
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, Ty ty) -> SystemFExpr a ty -> SystemFExpr a ty)
-> SystemFExpr a ty -> [(a, Ty ty)] -> SystemFExpr a ty
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (((a, Ty ty) -> SystemFExpr a ty -> SystemFExpr a ty)
 -> SystemFExpr a ty -> [(a, Ty ty)] -> SystemFExpr a ty)
-> ((a -> Ty ty -> SystemFExpr a ty -> SystemFExpr a ty)
    -> (a, Ty ty) -> SystemFExpr a ty -> SystemFExpr a ty)
-> (a -> Ty ty -> SystemFExpr a ty -> SystemFExpr a ty)
-> SystemFExpr a ty
-> [(a, Ty ty)]
-> SystemFExpr a ty
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Ty ty -> SystemFExpr a ty -> SystemFExpr a ty)
-> (a, Ty ty) -> SystemFExpr a ty -> SystemFExpr a ty
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((a -> Ty ty -> SystemFExpr a ty -> SystemFExpr a ty)
 -> [(a, Ty ty)] -> SystemFExpr a ty -> SystemFExpr a ty)
-> (a -> Ty ty -> SystemFExpr a ty -> SystemFExpr a ty)
-> [(a, Ty ty)]
-> SystemFExpr a ty
-> SystemFExpr a ty
forall a b. (a -> b) -> a -> b
$ a -> Ty ty -> SystemFExpr a ty -> SystemFExpr a ty
forall name ty.
name -> Ty ty -> SystemFExpr name ty -> SystemFExpr name ty
Abs

tyabs :: Parser (SystemFExpr Text Text)
tyabs :: Parsec Text () (SystemFExpr Text Text)
tyabs = [Text] -> SystemFExpr Text Text -> SystemFExpr Text Text
forall ty name. [ty] -> SystemFExpr name ty -> SystemFExpr name ty
curry' ([Text] -> SystemFExpr Text Text -> SystemFExpr Text Text)
-> ParsecT Text () Identity [Text]
-> ParsecT
     Text () Identity (SystemFExpr Text Text -> SystemFExpr Text Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Text () Identity [Text]
args ParsecT
  Text () Identity (SystemFExpr Text Text -> SystemFExpr Text Text)
-> Parsec Text () (SystemFExpr Text Text)
-> Parsec Text () (SystemFExpr Text Text)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parsec Text () (SystemFExpr Text Text)
expr
  where args :: ParsecT Text () Identity [Text]
args = Char -> Parser ()
symbol Char
'\\' Parser ()
-> ParsecT Text () Identity [Text]
-> ParsecT Text () Identity [Text]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Text () Identity Text -> ParsecT Text () Identity [Text]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT Text () Identity Text
typeId ParsecT Text () Identity [Text]
-> Parser () -> ParsecT Text () Identity [Text]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser ()
symbol Char
'.'
        curry' :: [ty] -> SystemFExpr name ty -> SystemFExpr name ty
curry' = (SystemFExpr name ty -> [ty] -> SystemFExpr name ty)
-> [ty] -> SystemFExpr name ty -> SystemFExpr name ty
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((ty -> SystemFExpr name ty -> SystemFExpr name ty)
-> SystemFExpr name ty -> [ty] -> SystemFExpr name ty
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ty -> SystemFExpr name ty -> SystemFExpr name ty
forall name ty. ty -> SystemFExpr name ty -> SystemFExpr name ty
TyAbs)

-- Parse type expressions
ty :: Parser (Ty Text)
ty :: Parsec Text () (Ty Text)
ty = Parsec Text () (Ty Text) -> Parsec Text () (Ty Text)
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try Parsec Text () (Ty Text)
arrow

arrow :: Parser (Ty Text)
arrow :: Parsec Text () (Ty Text)
arrow = Parsec Text () (Ty Text)
-> ParsecT Text () Identity (Ty Text -> Ty Text -> Ty Text)
-> Parsec Text () (Ty Text)
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m (a -> a -> a) -> ParsecT s u m a
chainr1 Parsec Text () (Ty Text)
tyterm (Text -> Parser ()
symbol' Text
"->" Parser ()
-> (Ty Text -> Ty Text -> Ty Text)
-> ParsecT Text () Identity (Ty Text -> Ty Text -> Ty Text)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Ty Text -> Ty Text -> Ty Text
forall name. Ty name -> Ty name -> Ty name
TyArrow)

tyterm :: Parser (Ty Text)
tyterm :: Parsec Text () (Ty Text)
tyterm = Parsec Text () (Ty Text)
tyvar Parsec Text () (Ty Text)
-> Parsec Text () (Ty Text) -> Parsec Text () (Ty Text)
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Parsec Text () (Ty Text) -> Parsec Text () (Ty Text)
forall a. Parser a -> Parser a
parens Parsec Text () (Ty Text)
ty

tyvar :: Parser (Ty Text)
tyvar :: Parsec Text () (Ty Text)
tyvar = Text -> Ty Text
forall name. name -> Ty name
TyVar (Text -> Ty Text)
-> ParsecT Text () Identity Text -> Parsec Text () (Ty Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Text () Identity Text
typeId

parens :: Parser a -> Parser a
parens :: Parser a -> Parser a
parens Parser a
p = Char -> Parser ()
symbol Char
'(' Parser () -> Parser a -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser a
p Parser a -> Parser () -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser ()
symbol Char
')'

identifier :: Parser Char -> Parser Text
identifier :: Parser Char -> ParsecT Text () Identity Text
identifier Parser Char
firstChar = ParsecT Text () Identity Text -> ParsecT Text () Identity Text
forall a. Parser a -> Parser a
lexeme (ParsecT Text () Identity Text -> ParsecT Text () Identity Text)
-> ParsecT Text () Identity Text -> ParsecT Text () Identity Text
forall a b. (a -> b) -> a -> b
$ Char -> Text -> Text
Text.cons (Char -> Text -> Text)
-> Parser Char -> ParsecT Text () Identity (Text -> Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Char
first' ParsecT Text () Identity (Text -> Text)
-> ParsecT Text () Identity Text -> ParsecT Text () Identity Text
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (SourceName -> Text
Text.pack (SourceName -> Text)
-> ParsecT Text () Identity SourceName
-> ParsecT Text () Identity Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Char -> ParsecT Text () Identity SourceName
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many Parser Char
rest)
  where first' :: Parser Char
first' = Parser Char
firstChar Parser Char -> Parser Char -> Parser Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Char -> Parser Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'_'
        rest :: Parser Char
rest = Parser Char
first' Parser Char -> Parser Char -> Parser Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Parser Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit

typeId, exprId :: Parser Text
typeId :: ParsecT Text () Identity Text
typeId = Parser Char -> ParsecT Text () Identity Text
identifier Parser Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
upper
exprId :: ParsecT Text () Identity Text
exprId = Parser Char -> ParsecT Text () Identity Text
identifier Parser Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
lower

whitespace :: Parser ()
whitespace :: Parser ()
whitespace = ParsecT Text () Identity SourceName -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Text () Identity SourceName -> Parser ())
-> (SourceName -> ParsecT Text () Identity SourceName)
-> SourceName
-> Parser ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser Char -> ParsecT Text () Identity SourceName
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (Parser Char -> ParsecT Text () Identity SourceName)
-> (SourceName -> Parser Char)
-> SourceName
-> ParsecT Text () Identity SourceName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceName -> Parser Char
forall s (m :: * -> *) u.
Stream s m Char =>
SourceName -> ParsecT s u m Char
oneOf (SourceName -> Parser ()) -> SourceName -> Parser ()
forall a b. (a -> b) -> a -> b
$ SourceName
" \t"

symbol :: Char -> Parser ()
symbol :: Char -> Parser ()
symbol = Parser Char -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser Char -> Parser ())
-> (Char -> Parser Char) -> Char -> Parser ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser Char -> Parser Char
forall a. Parser a -> Parser a
lexeme (Parser Char -> Parser Char)
-> (Char -> Parser Char) -> Char -> Parser Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Parser Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char

symbol' :: Text -> Parser ()
symbol' :: Text -> Parser ()
symbol' = ParsecT Text () Identity SourceName -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Text () Identity SourceName -> Parser ())
-> (Text -> ParsecT Text () Identity SourceName)
-> Text
-> Parser ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsecT Text () Identity SourceName
-> ParsecT Text () Identity SourceName
forall a. Parser a -> Parser a
lexeme (ParsecT Text () Identity SourceName
 -> ParsecT Text () Identity SourceName)
-> (Text -> ParsecT Text () Identity SourceName)
-> Text
-> ParsecT Text () Identity SourceName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceName -> ParsecT Text () Identity SourceName
forall s (m :: * -> *) u.
Stream s m Char =>
SourceName -> ParsecT s u m SourceName
string (SourceName -> ParsecT Text () Identity SourceName)
-> (Text -> SourceName)
-> Text
-> ParsecT Text () Identity SourceName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> SourceName
Text.unpack

lexeme :: Parser a -> Parser a
lexeme :: Parser a -> Parser a
lexeme Parser a
p = Parser a
p Parser a -> Parser () -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
whitespace