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)
parseExpr :: Text -> Either ParseError (SystemFExpr Text)
parseExpr = forall s t a.
Stream s Identity t =>
Parsec s () a -> [Char] -> s -> Either ParseError a
parse (Parser ()
whitespace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Text () Identity (SystemFExpr Text)
topLevelExpr forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof) [Char]
""

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

-- Lets can only be at the top level
topLevelExpr :: Parser (SystemFExpr Text)
topLevelExpr :: ParsecT Text () Identity (SystemFExpr Text)
topLevelExpr = ParsecT Text () Identity (SystemFExpr Text)
let' forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ParsecT Text () Identity (SystemFExpr Text)
expr

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

app :: Parser (SystemFExpr Text)
app :: ParsecT Text () Identity (SystemFExpr Text)
app = 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 ParsecT Text () Identity (SystemFExpr Text)
term (forall (m :: * -> *) a. Monad m => a -> m a
return forall name.
SystemFExpr name -> SystemFExpr name -> SystemFExpr name
App)

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

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

let' :: Parser (SystemFExpr Text)
let' :: ParsecT Text () Identity (SystemFExpr Text)
let' = forall name. name -> SystemFExpr name -> SystemFExpr name
Let forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Text () Identity Text
ident forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Text () Identity (SystemFExpr Text)
expr
  where ident :: ParsecT Text () Identity Text
ident = Text -> Parser ()
symbol' Text
"let" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Text () Identity Text
exprId forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser ()
symbol Char
'='

var :: Parser (SystemFExpr Text)
var :: ParsecT Text () Identity (SystemFExpr Text)
var = forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try ParsecT Text () Identity (SystemFExpr Text)
varann forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ParsecT Text () Identity (SystemFExpr Text)
var'
  where var' :: ParsecT Text () Identity (SystemFExpr Text)
var' = forall name. name -> SystemFExpr name
Var forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Text () Identity Text
exprId
        varann :: ParsecT Text () Identity (SystemFExpr Text)
varann = forall name. name -> Ty name -> SystemFExpr name
VarAnn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ParsecT Text () Identity Text
exprId forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser ()
symbol Char
':') forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Text () Identity (Ty Text)
ty

abs :: Parser (SystemFExpr Text)
abs :: ParsecT Text () Identity (SystemFExpr Text)
abs = forall {a}. [(a, Ty a)] -> SystemFExpr a -> SystemFExpr a
curry'
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Parser ()
symbol Char
'\\' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> 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 forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser ()
symbol Char
'.')
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Text () Identity (SystemFExpr Text)
expr
  where args :: ParsecT Text () Identity (Text, Ty Text)
args = (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ParsecT Text () Identity Text
exprId forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser ()
symbol Char
':') forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Text () Identity (Ty Text)
ty
        curry' :: [(a, Ty a)] -> SystemFExpr a -> SystemFExpr a
curry' = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a b. (a -> b) -> a -> b
$ forall name.
name -> Ty name -> SystemFExpr name -> SystemFExpr name
Abs

tyabs :: Parser (SystemFExpr Text)
tyabs :: ParsecT Text () Identity (SystemFExpr Text)
tyabs = forall {a}. [a] -> SystemFExpr a -> SystemFExpr a
curry' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Text () Identity [Text]
args forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Text () Identity (SystemFExpr Text)
expr
  where args :: ParsecT Text () Identity [Text]
args = Char -> Parser ()
symbol Char
'\\' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> 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 forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser ()
symbol Char
'.'
        curry' :: [a] -> SystemFExpr a -> SystemFExpr a
curry' = forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall name. name -> SystemFExpr name -> SystemFExpr name
TyAbs)

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

forall :: Parser (Ty Text)
forall :: ParsecT Text () Identity (Ty Text)
forall = forall {a}. [a] -> Ty a -> Ty a
curry' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Text () Identity [Text]
args forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Text () Identity (Ty Text)
ty
  where args :: ParsecT Text () Identity [Text]
args = Text -> Parser ()
symbol' Text
"forall" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> 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 forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser ()
symbol Char
'.'
        curry' :: [a] -> Ty a -> Ty a
curry' = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall name. name -> Ty name -> Ty name
TyForAll

arrow :: Parser (Ty Text)
arrow :: ParsecT Text () Identity (Ty Text)
arrow = 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 ParsecT Text () Identity (Ty Text)
tyterm (Text -> Parser ()
symbol' Text
"->" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> forall name. Ty name -> Ty name -> Ty name
TyArrow)

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

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

parens :: Parser a -> Parser a
parens :: forall a. Parser a -> Parser a
parens Parser a
p = Char -> Parser ()
symbol Char
'(' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser a
p 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 = forall a. Parser a -> Parser a
lexeme forall a b. (a -> b) -> a -> b
$ Char -> Text -> Text
Text.cons forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Char
first' forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ([Char] -> Text
Text.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'_'
        rest :: Parser Char
rest = Parser Char
first' forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> 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 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 forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
lower

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

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

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

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