{-# LANGUAGE PatternGuards #-}

-- TODO, use Language.Haskell
-- Doesn't handle string literals?

module Lambdabot.Plugin.Haskell.Pl.Parser (parsePF) where

import Lambdabot.Plugin.Haskell.Pl.Common

import Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Expr
import Text.ParserCombinators.Parsec.Language
import qualified Text.ParserCombinators.Parsec.Token as T
import Control.Applicative ((<*))
import Data.List

-- is that supposed to be done that way?
tp :: T.TokenParser st
tp :: forall st. TokenParser st
tp = GenLanguageDef [Char] st Identity
-> GenTokenParser [Char] st Identity
forall s (m :: * -> *) u.
Stream s m Char =>
GenLanguageDef s u m -> GenTokenParser s u m
T.makeTokenParser (GenLanguageDef [Char] st Identity
 -> GenTokenParser [Char] st Identity)
-> GenLanguageDef [Char] st Identity
-> GenTokenParser [Char] st Identity
forall a b. (a -> b) -> a -> b
$ GenLanguageDef [Char] st Identity
forall st. LanguageDef st
haskellStyle {
  reservedNames = ["if","then","else","let","in"]
}

parens :: Parser a -> Parser a
parens :: forall a. Parser a -> Parser a
parens = GenTokenParser [Char] () Identity -> forall a. Parser a -> Parser a
forall s u (m :: * -> *).
GenTokenParser s u m
-> forall a. ParsecT s u m a -> ParsecT s u m a
T.parens GenTokenParser [Char] () Identity
forall st. TokenParser st
tp

brackets :: Parser a -> Parser a
brackets :: forall a. Parser a -> Parser a
brackets = GenTokenParser [Char] () Identity -> forall a. Parser a -> Parser a
forall s u (m :: * -> *).
GenTokenParser s u m
-> forall a. ParsecT s u m a -> ParsecT s u m a
T.brackets GenTokenParser [Char] () Identity
forall st. TokenParser st
tp

symbol :: String -> Parser String
symbol :: [Char] -> Parser [Char]
symbol = GenTokenParser [Char] () Identity -> [Char] -> Parser [Char]
forall s u (m :: * -> *).
GenTokenParser s u m -> [Char] -> ParsecT s u m [Char]
T.symbol GenTokenParser [Char] () Identity
forall st. TokenParser st
tp

modName :: CharParser st String
modName :: forall st. CharParser st [Char]
modName = do
  Char
c <- [Char] -> ParsecT [Char] st Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m Char
oneOf [Char
'A'..Char
'Z']
  [Char]
cs <- ParsecT [Char] st Identity Char -> CharParser st [Char]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (ParsecT [Char] st Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
alphaNum ParsecT [Char] st Identity Char
-> ParsecT [Char] st Identity Char
-> ParsecT [Char] st Identity Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> [Char] -> ParsecT [Char] st Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m Char
oneOf [Char]
"_'")
  [Char] -> CharParser st [Char]
forall a. a -> ParsecT [Char] st Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
cChar -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char]
cs)

qualified :: CharParser st String -> CharParser st String
qualified :: forall st. CharParser st [Char] -> CharParser st [Char]
qualified CharParser st [Char]
p = do
  [[Char]]
qs <- CharParser st [Char] -> ParsecT [Char] st Identity [[Char]]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (CharParser st [Char] -> ParsecT [Char] st Identity [[Char]])
-> CharParser st [Char] -> ParsecT [Char] st Identity [[Char]]
forall a b. (a -> b) -> a -> b
$ CharParser st [Char] -> CharParser st [Char]
forall tok st a. GenParser tok st a -> GenParser tok st a
try (CharParser st [Char] -> CharParser st [Char])
-> CharParser st [Char] -> CharParser st [Char]
forall a b. (a -> b) -> a -> b
$ CharParser st [Char]
forall st. CharParser st [Char]
modName CharParser st [Char]
-> ParsecT [Char] st Identity Char -> CharParser st [Char]
forall a b.
ParsecT [Char] st Identity a
-> ParsecT [Char] st Identity b -> ParsecT [Char] st Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> ParsecT [Char] st Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'.' CharParser st [Char]
-> ParsecT [Char] st Identity Char -> CharParser st [Char]
forall a b.
ParsecT [Char] st Identity a
-> ParsecT [Char] st Identity b -> ParsecT [Char] st Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT [Char] st Identity Char -> ParsecT [Char] st Identity Char
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m a
lookAhead (ParsecT [Char] st Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
letter ParsecT [Char] st Identity Char
-> ParsecT [Char] st Identity Char
-> ParsecT [Char] st Identity Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> [Char] -> ParsecT [Char] st Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m Char
oneOf [Char]
opchars)
  [Char]
nm <- CharParser st [Char]
p
  [Char] -> CharParser st [Char]
forall a. a -> ParsecT [Char] st Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> CharParser st [Char]) -> [Char] -> CharParser st [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"." ([[Char]]
qs [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]
nm])

atomic :: Parser String
atomic :: Parser [Char]
atomic = Parser [Char] -> Parser [Char]
forall tok st a. GenParser tok st a -> GenParser tok st a
try ([Char] -> Parser [Char]
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
"()") 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] -> Parser [Char]
forall tok st a. GenParser tok st a -> GenParser tok st a
try (Integer -> [Char]
forall a. Show a => a -> [Char]
show (Integer -> [Char])
-> ParsecT [Char] () Identity Integer -> Parser [Char]
forall a b.
(a -> b)
-> ParsecT [Char] () Identity a -> ParsecT [Char] () Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` GenTokenParser [Char] () Identity
-> ParsecT [Char] () Identity Integer
forall s u (m :: * -> *).
GenTokenParser s u m -> ParsecT s u m Integer
T.natural GenTokenParser [Char] () Identity
forall st. TokenParser st
tp) 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] -> Parser [Char]
forall st. CharParser st [Char] -> CharParser st [Char]
qualified (GenTokenParser [Char] () Identity -> Parser [Char]
forall s u (m :: * -> *).
GenTokenParser s u m -> ParsecT s u m [Char]
T.identifier GenTokenParser [Char] () Identity
forall st. TokenParser st
tp)

reserved :: String -> Parser ()
reserved :: [Char] -> Parser ()
reserved = GenTokenParser [Char] () Identity -> [Char] -> Parser ()
forall s u (m :: * -> *).
GenTokenParser s u m -> [Char] -> ParsecT s u m ()
T.reserved GenTokenParser [Char] () Identity
forall st. TokenParser st
tp

charLiteral :: Parser Char
charLiteral :: Parser Char
charLiteral = GenTokenParser [Char] () Identity -> Parser Char
forall s u (m :: * -> *).
GenTokenParser s u m -> ParsecT s u m Char
T.charLiteral GenTokenParser [Char] () Identity
forall st. TokenParser st
tp

stringLiteral :: Parser String
stringLiteral :: Parser [Char]
stringLiteral = GenTokenParser [Char] () Identity -> Parser [Char]
forall s u (m :: * -> *).
GenTokenParser s u m -> ParsecT s u m [Char]
T.stringLiteral GenTokenParser [Char] () Identity
forall st. TokenParser st
tp

table :: [[Operator Char st Expr]]
table :: forall st. [[Operator Char st Expr]]
table = Operator Char st Expr
-> [[Operator Char st Expr]] -> [[Operator Char st Expr]]
forall {a}. a -> [[a]] -> [[a]]
addToFirst Operator Char st Expr
forall st. Operator Char st Expr
def ([[Operator Char st Expr]] -> [[Operator Char st Expr]])
-> [[Operator Char st Expr]] -> [[Operator Char st Expr]]
forall a b. (a -> b) -> a -> b
$ ([([Char], (Assoc, Int))] -> [Operator Char st Expr])
-> [[([Char], (Assoc, Int))]] -> [[Operator Char st Expr]]
forall a b. (a -> b) -> [a] -> [b]
map ((([Char], (Assoc, Int)) -> Operator Char st Expr)
-> [([Char], (Assoc, Int))] -> [Operator Char st Expr]
forall a b. (a -> b) -> [a] -> [b]
map ([Char], (Assoc, Int)) -> Operator Char st Expr
forall st. ([Char], (Assoc, Int)) -> Operator Char st Expr
inf) [[([Char], (Assoc, Int))]]
operators where
  addToFirst :: a -> [[a]] -> [[a]]
addToFirst a
y ([a]
x:[[a]]
xs) = ((a
ya -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
x)[a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
:[[a]]
xs)
  addToFirst a
_ [[a]]
_ = Bool -> [[a]] -> [[a]]
forall a. (?callStack::CallStack) => Bool -> a -> a
assert Bool
False [[a]]
forall a. a
bt

  def :: Operator Char st Expr
  def :: forall st. Operator Char st Expr
def = GenParser Char st (Expr -> Expr -> Expr)
-> Assoc -> Operator Char st Expr
forall tok st a.
GenParser tok st (a -> a -> a) -> Assoc -> Operator tok st a
Infix (GenParser Char st (Expr -> Expr -> Expr)
-> GenParser Char st (Expr -> Expr -> Expr)
forall tok st a. GenParser tok st a -> GenParser tok st a
try (GenParser Char st (Expr -> Expr -> Expr)
 -> GenParser Char st (Expr -> Expr -> Expr))
-> GenParser Char st (Expr -> Expr -> Expr)
-> GenParser Char st (Expr -> Expr -> Expr)
forall a b. (a -> b) -> a -> b
$ do
      [Char]
name <- CharParser st [Char]
forall st. CharParser st [Char]
parseOp
      Bool -> ParsecT [Char] st Identity ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> ParsecT [Char] st Identity ())
-> Bool -> ParsecT [Char] st Identity ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Maybe (Assoc, Int) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (Assoc, Int) -> Bool) -> Maybe (Assoc, Int) -> Bool
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe (Assoc, Int)
lookupOp [Char]
name
      ParsecT [Char] st Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
      (Expr -> Expr -> Expr) -> GenParser Char st (Expr -> Expr -> Expr)
forall a. a -> ParsecT [Char] st Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Expr -> Expr -> Expr)
 -> GenParser Char st (Expr -> Expr -> Expr))
-> (Expr -> Expr -> Expr)
-> GenParser Char st (Expr -> Expr -> Expr)
forall a b. (a -> b) -> a -> b
$ \Expr
e1 Expr
e2 -> Expr -> Expr -> Expr
App (Fixity -> [Char] -> Expr
Var Fixity
Inf [Char]
name) Expr
e1 Expr -> Expr -> Expr
`App` Expr
e2
    ) Assoc
AssocLeft

  inf :: (String, (Assoc, Int)) -> Operator Char st Expr
  inf :: forall st. ([Char], (Assoc, Int)) -> Operator Char st Expr
inf ([Char]
name, (Assoc
assoc, Int
_)) = GenParser Char st (Expr -> Expr -> Expr)
-> Assoc -> Operator Char st Expr
forall tok st a.
GenParser tok st (a -> a -> a) -> Assoc -> Operator tok st a
Infix (GenParser Char st (Expr -> Expr -> Expr)
-> GenParser Char st (Expr -> Expr -> Expr)
forall tok st a. GenParser tok st a -> GenParser tok st a
try (GenParser Char st (Expr -> Expr -> Expr)
 -> GenParser Char st (Expr -> Expr -> Expr))
-> GenParser Char st (Expr -> Expr -> Expr)
-> GenParser Char st (Expr -> Expr -> Expr)
forall a b. (a -> b) -> a -> b
$ do
      [Char]
_ <- [Char] -> ParsecT [Char] st Identity [Char]
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
name
      ParsecT [Char] st Identity Char -> ParsecT [Char] st Identity ()
forall s (m :: * -> *) t a u.
(Stream s m t, Show a) =>
ParsecT s u m a -> ParsecT s u m ()
notFollowedBy (ParsecT [Char] st Identity Char -> ParsecT [Char] st Identity ())
-> ParsecT [Char] st Identity Char -> ParsecT [Char] st Identity ()
forall a b. (a -> b) -> a -> b
$ [Char] -> ParsecT [Char] st Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m Char
oneOf [Char]
opchars
      ParsecT [Char] st Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
      let name' :: [Char]
name' = if [Char] -> Char
forall a. (?callStack::CallStack) => [a] -> a
head [Char]
name Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'`'
                  then [Char] -> [Char]
forall a. (?callStack::CallStack) => [a] -> [a]
tail ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
forall a. [a] -> [a]
reverse ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
forall a. (?callStack::CallStack) => [a] -> [a]
tail ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
forall a. [a] -> [a]
reverse ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
name
                  else [Char]
name
      (Expr -> Expr -> Expr) -> GenParser Char st (Expr -> Expr -> Expr)
forall a. a -> ParsecT [Char] st Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Expr -> Expr -> Expr)
 -> GenParser Char st (Expr -> Expr -> Expr))
-> (Expr -> Expr -> Expr)
-> GenParser Char st (Expr -> Expr -> Expr)
forall a b. (a -> b) -> a -> b
$ \Expr
e1 Expr
e2 -> Expr -> Expr -> Expr
App (Fixity -> [Char] -> Expr
Var Fixity
Inf [Char]
name') Expr
e1 Expr -> Expr -> Expr
`App` Expr
e2
    ) Assoc
assoc


parseOp :: CharParser st String
parseOp :: forall st. CharParser st [Char]
parseOp = (ParsecT [Char] st Identity Char
-> ParsecT [Char] st Identity Char
-> ParsecT [Char] st Identity [Char]
-> ParsecT [Char] st Identity [Char]
forall s (m :: * -> *) t u open close a.
Stream s m t =>
ParsecT s u m open
-> ParsecT s u m close -> ParsecT s u m a -> ParsecT s u m a
between (Char -> ParsecT [Char] st Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'`') (Char -> ParsecT [Char] st Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'`') (ParsecT [Char] st Identity [Char]
 -> ParsecT [Char] st Identity [Char])
-> ParsecT [Char] st Identity [Char]
-> ParsecT [Char] st Identity [Char]
forall a b. (a -> b) -> a -> b
$ ParsecT [Char] st Identity [Char]
-> ParsecT [Char] st Identity [Char]
forall st. CharParser st [Char] -> CharParser st [Char]
qualified (GenTokenParser [Char] st Identity
-> ParsecT [Char] st Identity [Char]
forall s u (m :: * -> *).
GenTokenParser s u m -> ParsecT s u m [Char]
T.identifier GenTokenParser [Char] st Identity
forall st. TokenParser st
tp))
  ParsecT [Char] st Identity [Char]
-> ParsecT [Char] st Identity [Char]
-> ParsecT [Char] st Identity [Char]
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ParsecT [Char] st Identity [Char]
-> ParsecT [Char] st Identity [Char]
forall tok st a. GenParser tok st a -> GenParser tok st a
try (do
    [Char]
op <- ParsecT [Char] st Identity [Char]
-> ParsecT [Char] st Identity [Char]
forall st. CharParser st [Char] -> CharParser st [Char]
qualified (ParsecT [Char] st Identity [Char]
 -> ParsecT [Char] st Identity [Char])
-> ParsecT [Char] st Identity [Char]
-> ParsecT [Char] st Identity [Char]
forall a b. (a -> b) -> a -> b
$ ParsecT [Char] st Identity Char
-> ParsecT [Char] st Identity [Char]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (ParsecT [Char] st Identity Char
 -> ParsecT [Char] st Identity [Char])
-> ParsecT [Char] st Identity Char
-> ParsecT [Char] st Identity [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> ParsecT [Char] st Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m Char
oneOf [Char]
opchars
    Bool -> ParsecT [Char] st Identity ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> ParsecT [Char] st Identity ())
-> Bool -> ParsecT [Char] st Identity ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Char]
op [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]]
reservedOps
    [Char] -> ParsecT [Char] st Identity [Char]
forall a. a -> ParsecT [Char] st Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
op)

pattern :: Parser Pattern
pattern :: Parser Pattern
pattern = OperatorTable Char () Pattern -> Parser Pattern -> Parser Pattern
forall tok st a.
OperatorTable tok st a -> GenParser tok st a -> GenParser tok st a
buildExpressionParser OperatorTable Char () Pattern
ptable (([Char] -> Pattern
PVar ([Char] -> Pattern) -> Parser [Char] -> Parser Pattern
forall a b.
(a -> b)
-> ParsecT [Char] () Identity a -> ParsecT [Char] () Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap`
                       (    Parser [Char]
atomic
                        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]
symbol [Char]
"_" Parser [Char] -> Parser [Char] -> Parser [Char]
forall a b.
ParsecT [Char] () Identity a
-> ParsecT [Char] () Identity b -> ParsecT [Char] () Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Char] -> Parser [Char]
forall a. a -> ParsecT [Char] () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
"")))
                        Parser Pattern -> Parser Pattern -> Parser Pattern
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Parser Pattern -> Parser Pattern
forall a. Parser a -> Parser a
parens Parser Pattern
pattern)
    Parser Pattern -> [Char] -> Parser Pattern
forall s u (m :: * -> *) a.
ParsecT s u m a -> [Char] -> ParsecT s u m a
<?> [Char]
"pattern" where
  ptable :: OperatorTable Char () Pattern
ptable = [[GenParser Char () (Pattern -> Pattern -> Pattern)
-> Assoc -> Operator Char () Pattern
forall tok st a.
GenParser tok st (a -> a -> a) -> Assoc -> Operator tok st a
Infix ([Char] -> Parser [Char]
symbol [Char]
":" Parser [Char]
-> GenParser Char () (Pattern -> Pattern -> Pattern)
-> GenParser Char () (Pattern -> Pattern -> Pattern)
forall a b.
ParsecT [Char] () Identity a
-> ParsecT [Char] () Identity b -> ParsecT [Char] () Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Pattern -> Pattern -> Pattern)
-> GenParser Char () (Pattern -> Pattern -> Pattern)
forall a. a -> ParsecT [Char] () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Pattern -> Pattern -> Pattern
PCons) Assoc
AssocRight],
            [GenParser Char () (Pattern -> Pattern -> Pattern)
-> Assoc -> Operator Char () Pattern
forall tok st a.
GenParser tok st (a -> a -> a) -> Assoc -> Operator tok st a
Infix ([Char] -> Parser [Char]
symbol [Char]
"," Parser [Char]
-> GenParser Char () (Pattern -> Pattern -> Pattern)
-> GenParser Char () (Pattern -> Pattern -> Pattern)
forall a b.
ParsecT [Char] () Identity a
-> ParsecT [Char] () Identity b -> ParsecT [Char] () Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Pattern -> Pattern -> Pattern)
-> GenParser Char () (Pattern -> Pattern -> Pattern)
forall a. a -> ParsecT [Char] () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Pattern -> Pattern -> Pattern
PTuple) Assoc
AssocNone]]

lambda :: Parser Expr
lambda :: Parser Expr
lambda = do
    [Char]
_  <- [Char] -> Parser [Char]
symbol [Char]
"\\"
    [Pattern]
vs <- Parser Pattern -> ParsecT [Char] () Identity [Pattern]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 Parser Pattern
pattern
    [Char]
_  <- [Char] -> Parser [Char]
symbol [Char]
"->"
    Expr
e  <- Bool -> Parser Expr
myParser Bool
False
    Expr -> Parser Expr
forall a. a -> ParsecT [Char] () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> Parser Expr) -> Expr -> Parser Expr
forall a b. (a -> b) -> a -> b
$ (Pattern -> Expr -> Expr) -> Expr -> [Pattern] -> Expr
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Pattern -> Expr -> Expr
Lambda Expr
e [Pattern]
vs
  Parser Expr -> [Char] -> Parser Expr
forall s u (m :: * -> *) a.
ParsecT s u m a -> [Char] -> ParsecT s u m a
<?> [Char]
"lambda abstraction"

var :: Parser Expr
var :: Parser Expr
var = Parser Expr -> Parser Expr
forall tok st a. GenParser tok st a -> GenParser tok st a
try ([Char] -> Expr
makeVar ([Char] -> Expr) -> Parser [Char] -> Parser Expr
forall a b.
(a -> b)
-> ParsecT [Char] () Identity a -> ParsecT [Char] () Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Parser [Char]
atomic Parser Expr -> Parser Expr -> Parser Expr
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
           Parser Expr -> Parser Expr
forall a. Parser a -> Parser a
parens (Parser Expr -> Parser Expr
forall tok st a. GenParser tok st a -> GenParser tok st a
try Parser Expr
unaryNegation Parser Expr -> Parser Expr -> Parser Expr
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Parser Expr -> Parser Expr
forall tok st a. GenParser tok st a -> GenParser tok st a
try Parser Expr
rightSection
                   Parser Expr -> Parser Expr -> Parser Expr
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Parser Expr -> Parser Expr
forall tok st a. GenParser tok st a -> GenParser tok st a
try ([Char] -> Expr
makeVar ([Char] -> Expr) -> Parser [Char] -> Parser Expr
forall a b.
(a -> b)
-> ParsecT [Char] () Identity a -> ParsecT [Char] () Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Parser Char -> Parser [Char]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (Char -> Parser Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
','))
                   Parser Expr -> Parser Expr -> Parser Expr
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Parser Expr
tuple) Parser Expr -> Parser Expr -> Parser Expr
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Parser Expr
list Parser Expr -> Parser Expr -> Parser Expr
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (Fixity -> [Char] -> Expr
Var Fixity
Pref ([Char] -> Expr) -> (Char -> [Char]) -> Char -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> [Char]
forall a. Show a => a -> [Char]
show) (Char -> Expr) -> Parser Char -> Parser Expr
forall a b.
(a -> b)
-> ParsecT [Char] () Identity a -> ParsecT [Char] () Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Parser Char
charLiteral
                   Parser Expr -> Parser Expr -> Parser Expr
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> [Char] -> Expr
stringVar ([Char] -> Expr) -> Parser [Char] -> Parser Expr
forall a b.
(a -> b)
-> ParsecT [Char] () Identity a -> ParsecT [Char] () Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Parser [Char]
stringLiteral)
        Parser Expr -> [Char] -> Parser Expr
forall s u (m :: * -> *) a.
ParsecT s u m a -> [Char] -> ParsecT s u m a
<?> [Char]
"variable" where
  makeVar :: [Char] -> Expr
makeVar [Char]
v | Just (Assoc, Int)
_ <- [Char] -> Maybe (Assoc, Int)
lookupOp [Char]
v = Fixity -> [Char] -> Expr
Var Fixity
Inf [Char]
v -- operators always want to
                                               -- be infixed
            | Bool
otherwise            = Fixity -> [Char] -> Expr
Var Fixity
Pref [Char]
v
  stringVar :: String -> Expr
  stringVar :: [Char] -> Expr
stringVar [Char]
str = [Expr] -> Expr
makeList ([Expr] -> Expr) -> [Expr] -> Expr
forall a b. (a -> b) -> a -> b
$ (Fixity -> [Char] -> Expr
Var Fixity
Pref ([Char] -> Expr) -> (Char -> [Char]) -> Char -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> [Char]
forall a. Show a => a -> [Char]
show) (Char -> Expr) -> [Char] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
`map` [Char]
str

list :: Parser Expr
list :: Parser Expr
list = [Parser Expr] -> Parser Expr
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ((Parser Expr -> Parser Expr) -> [Parser Expr] -> [Parser Expr]
forall a b. (a -> b) -> [a] -> [b]
map (Parser Expr -> Parser Expr
forall tok st a. GenParser tok st a -> GenParser tok st a
try (Parser Expr -> Parser Expr)
-> (Parser Expr -> Parser Expr) -> Parser Expr -> Parser Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser Expr -> Parser Expr
forall a. Parser a -> Parser a
brackets) [Parser Expr]
plist) Parser Expr -> [Char] -> Parser Expr
forall s u (m :: * -> *) a.
ParsecT s u m a -> [Char] -> ParsecT s u m a
<?> [Char]
"list" where
  plist :: [Parser Expr]
plist = [
    (Expr -> Expr -> Expr) -> Expr -> [Expr] -> Expr
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Expr
e1 Expr
e2 -> Expr
cons Expr -> Expr -> Expr
`App` Expr
e1 Expr -> Expr -> Expr
`App` Expr
e2) Expr
nil ([Expr] -> Expr)
-> ParsecT [Char] () Identity [Expr] -> Parser Expr
forall a b.
(a -> b)
-> ParsecT [Char] () Identity a -> ParsecT [Char] () Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap`
      (Bool -> Parser Expr
myParser Bool
False Parser Expr -> Parser [Char] -> ParsecT [Char] () Identity [Expr]
forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
`sepBy` [Char] -> Parser [Char]
symbol [Char]
","),
    do Expr
e <- Bool -> Parser Expr
myParser Bool
False
       [Char]
_ <- [Char] -> Parser [Char]
symbol [Char]
".."
       Expr -> Parser Expr
forall a. a -> ParsecT [Char] () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> Parser Expr) -> Expr -> Parser Expr
forall a b. (a -> b) -> a -> b
$ Fixity -> [Char] -> Expr
Var Fixity
Pref [Char]
"enumFrom" Expr -> Expr -> Expr
`App` Expr
e,
    do Expr
e  <- Bool -> Parser Expr
myParser Bool
False
       [Char]
_  <- [Char] -> Parser [Char]
symbol [Char]
","
       Expr
e' <- Bool -> Parser Expr
myParser Bool
False
       [Char]
_  <- [Char] -> Parser [Char]
symbol [Char]
".."
       Expr -> Parser Expr
forall a. a -> ParsecT [Char] () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> Parser Expr) -> Expr -> Parser Expr
forall a b. (a -> b) -> a -> b
$ Fixity -> [Char] -> Expr
Var Fixity
Pref [Char]
"enumFromThen" Expr -> Expr -> Expr
`App` Expr
e Expr -> Expr -> Expr
`App` Expr
e',
    do Expr
e  <- Bool -> Parser Expr
myParser Bool
False
       [Char]
_  <- [Char] -> Parser [Char]
symbol [Char]
".."
       Expr
e' <- Bool -> Parser Expr
myParser Bool
False
       Expr -> Parser Expr
forall a. a -> ParsecT [Char] () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> Parser Expr) -> Expr -> Parser Expr
forall a b. (a -> b) -> a -> b
$ Fixity -> [Char] -> Expr
Var Fixity
Pref [Char]
"enumFromTo" Expr -> Expr -> Expr
`App` Expr
e Expr -> Expr -> Expr
`App` Expr
e',
    do Expr
e   <- Bool -> Parser Expr
myParser Bool
False
       [Char]
_   <- [Char] -> Parser [Char]
symbol [Char]
","
       Expr
e'  <- Bool -> Parser Expr
myParser Bool
False
       [Char]
_   <- [Char] -> Parser [Char]
symbol [Char]
".."
       Expr
e'' <- Bool -> Parser Expr
myParser Bool
False
       Expr -> Parser Expr
forall a. a -> ParsecT [Char] () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> Parser Expr) -> Expr -> Parser Expr
forall a b. (a -> b) -> a -> b
$ Fixity -> [Char] -> Expr
Var Fixity
Pref [Char]
"enumFromThenTo" Expr -> Expr -> Expr
`App` Expr
e Expr -> Expr -> Expr
`App` Expr
e' Expr -> Expr -> Expr
`App` Expr
e''
    ]

tuple :: Parser Expr
tuple :: Parser Expr
tuple = do
    [Expr]
elts <- Bool -> Parser Expr
myParser Bool
False Parser Expr -> Parser [Char] -> ParsecT [Char] () Identity [Expr]
forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
`sepBy` [Char] -> Parser [Char]
symbol [Char]
","
    Bool -> Parser ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Parser ()) -> Bool -> Parser ()
forall a b. (a -> b) -> a -> b
$ [Expr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Expr]
elts Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
1
    let name :: Expr
name = Fixity -> [Char] -> Expr
Var Fixity
Pref ([Char] -> Expr) -> [Char] -> Expr
forall a b. (a -> b) -> a -> b
$ Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate ([Expr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Expr]
elts Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Char
','
    Expr -> Parser Expr
forall a. a -> ParsecT [Char] () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> Parser Expr) -> Expr -> Parser Expr
forall a b. (a -> b) -> a -> b
$ (Expr -> Expr -> Expr) -> Expr -> [Expr] -> Expr
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Expr -> Expr -> Expr
App Expr
name [Expr]
elts
  Parser Expr -> [Char] -> Parser Expr
forall s u (m :: * -> *) a.
ParsecT s u m a -> [Char] -> ParsecT s u m a
<?> [Char]
"tuple"

unaryNegation :: Parser Expr
unaryNegation :: Parser Expr
unaryNegation = do
    [Char]
_ <- [Char] -> Parser [Char]
symbol [Char]
"-"
    Expr
e <- Bool -> Parser Expr
myParser Bool
False
    Expr -> Parser Expr
forall a. a -> ParsecT [Char] () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> Parser Expr) -> Expr -> Parser Expr
forall a b. (a -> b) -> a -> b
$ Fixity -> [Char] -> Expr
Var Fixity
Pref [Char]
"negate" Expr -> Expr -> Expr
`App` Expr
e
  Parser Expr -> [Char] -> Parser Expr
forall s u (m :: * -> *) a.
ParsecT s u m a -> [Char] -> ParsecT s u m a
<?> [Char]
"unary negation"

rightSection :: Parser Expr
rightSection :: Parser Expr
rightSection = do
    Expr
v <- Fixity -> [Char] -> Expr
Var Fixity
Inf ([Char] -> Expr) -> Parser [Char] -> Parser Expr
forall a b.
(a -> b)
-> ParsecT [Char] () Identity a -> ParsecT [Char] () Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Parser [Char]
forall st. CharParser st [Char]
parseOp
    Parser ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
    let rs :: Expr -> Expr
rs Expr
e = Expr
flip' Expr -> Expr -> Expr
`App` Expr
v Expr -> Expr -> Expr
`App` Expr
e
    Expr -> Parser Expr -> Parser Expr
forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option Expr
v (Expr -> Expr
rs (Expr -> Expr) -> Parser Expr -> Parser Expr
forall a b.
(a -> b)
-> ParsecT [Char] () Identity a -> ParsecT [Char] () Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Bool -> Parser Expr
myParser Bool
False)
  Parser Expr -> [Char] -> Parser Expr
forall s u (m :: * -> *) a.
ParsecT s u m a -> [Char] -> ParsecT s u m a
<?> [Char]
"right section"


myParser :: Bool -> Parser Expr
myParser :: Bool -> Parser Expr
myParser Bool
b = Parser Expr
lambda Parser Expr -> Parser Expr -> Parser Expr
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Bool -> Parser Expr
expr Bool
b

expr :: Bool -> Parser Expr
expr :: Bool -> Parser Expr
expr Bool
b = OperatorTable Char () Expr -> Parser Expr -> Parser Expr
forall tok st a.
OperatorTable tok st a -> GenParser tok st a -> GenParser tok st a
buildExpressionParser OperatorTable Char () Expr
forall st. [[Operator Char st Expr]]
table (Bool -> Parser Expr
term Bool
b) Parser Expr -> [Char] -> Parser Expr
forall s u (m :: * -> *) a.
ParsecT s u m a -> [Char] -> ParsecT s u m a
<?> [Char]
"expression"

decl :: Parser Decl
decl :: Parser Decl
decl = do
  [Char]
f <- Parser [Char]
atomic
  [Pattern]
args <- Parser Pattern
pattern Parser Pattern
-> Parser [Char] -> ParsecT [Char] () Identity [Pattern]
forall a b. Parser a -> Parser b -> Parser [a]
`endsIn` [Char] -> Parser [Char]
symbol [Char]
"="
  Expr
e <- Bool -> Parser Expr
myParser Bool
False
  Decl -> Parser Decl
forall a. a -> ParsecT [Char] () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Decl -> Parser Decl) -> Decl -> Parser Decl
forall a b. (a -> b) -> a -> b
$ [Char] -> Expr -> Decl
Define [Char]
f ((Pattern -> Expr -> Expr) -> Expr -> [Pattern] -> Expr
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Pattern -> Expr -> Expr
Lambda Expr
e [Pattern]
args)

letbind :: Parser Expr
letbind :: Parser Expr
letbind = do
  [Char] -> Parser ()
reserved [Char]
"let"
  [Decl]
ds <- Parser Decl
decl Parser Decl -> Parser [Char] -> ParsecT [Char] () Identity [Decl]
forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
`sepBy` [Char] -> Parser [Char]
symbol [Char]
";"
  [Char] -> Parser ()
reserved [Char]
"in"
  Expr
e <- Bool -> Parser Expr
myParser Bool
False
  Expr -> Parser Expr
forall a. a -> ParsecT [Char] () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> Parser Expr) -> Expr -> Parser Expr
forall a b. (a -> b) -> a -> b
$ [Decl] -> Expr -> Expr
Let [Decl]
ds Expr
e

ifexpr :: Parser Expr
ifexpr :: Parser Expr
ifexpr = do
  [Char] -> Parser ()
reserved [Char]
"if"
  Expr
p <- Bool -> Parser Expr
myParser Bool
False
  [Char] -> Parser ()
reserved [Char]
"then"
  Expr
e1 <- Bool -> Parser Expr
myParser Bool
False
  [Char] -> Parser ()
reserved [Char]
"else"
  Expr
e2 <- Bool -> Parser Expr
myParser Bool
False
  Expr -> Parser Expr
forall a. a -> ParsecT [Char] () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> Parser Expr) -> Expr -> Parser Expr
forall a b. (a -> b) -> a -> b
$ Expr
if' Expr -> Expr -> Expr
`App` Expr
p Expr -> Expr -> Expr
`App` Expr
e1 Expr -> Expr -> Expr
`App` Expr
e2

term :: Bool -> Parser Expr
term :: Bool -> Parser Expr
term Bool
b = Parser Expr
application Parser Expr -> Parser Expr -> Parser Expr
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Parser Expr
lambda Parser Expr -> Parser Expr -> Parser Expr
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Parser Expr
letbind Parser Expr -> Parser Expr -> Parser Expr
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Parser Expr
ifexpr Parser Expr -> Parser Expr -> Parser Expr
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
    (Bool -> Parser ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard Bool
b Parser () -> Parser Expr -> Parser Expr
forall a b.
ParsecT [Char] () Identity a
-> ParsecT [Char] () Identity b -> ParsecT [Char] () Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Parser Char -> Parser ()
forall s (m :: * -> *) t a u.
(Stream s m t, Show a) =>
ParsecT s u m a -> ParsecT s u m ()
notFollowedBy ([Char] -> Parser Char
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m Char
noneOf [Char]
")") Parser () -> Parser Expr -> Parser Expr
forall a b.
ParsecT [Char] () Identity a
-> ParsecT [Char] () Identity b -> ParsecT [Char] () Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Expr -> Parser Expr
forall a. a -> ParsecT [Char] () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Fixity -> [Char] -> Expr
Var Fixity
Pref [Char]
"")))
  Parser Expr -> [Char] -> Parser Expr
forall s u (m :: * -> *) a.
ParsecT s u m a -> [Char] -> ParsecT s u m a
<?> [Char]
"simple term"

application :: Parser Expr
application :: Parser Expr
application = do
    Expr
e:[Expr]
es <- Parser Expr -> ParsecT [Char] () Identity [Expr]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (Parser Expr -> ParsecT [Char] () Identity [Expr])
-> Parser Expr -> ParsecT [Char] () Identity [Expr]
forall a b. (a -> b) -> a -> b
$ Parser Expr
var Parser Expr -> Parser Expr -> Parser Expr
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Parser Expr -> Parser Expr
forall a. Parser a -> Parser a
parens (Bool -> Parser Expr
myParser Bool
True)
    Expr -> Parser Expr
forall a. a -> ParsecT [Char] () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> Parser Expr) -> Expr -> Parser Expr
forall a b. (a -> b) -> a -> b
$ (Expr -> Expr -> Expr) -> Expr -> [Expr] -> Expr
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Expr -> Expr -> Expr
App Expr
e [Expr]
es
  Parser Expr -> [Char] -> Parser Expr
forall s u (m :: * -> *) a.
ParsecT s u m a -> [Char] -> ParsecT s u m a
<?> [Char]
"application"

endsIn :: Parser a -> Parser b -> Parser [a]
endsIn :: forall a b. Parser a -> Parser b -> Parser [a]
endsIn Parser a
p Parser b
end = do
  [a]
xs <- Parser a -> Parser [a]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many Parser a
p
  b
_  <- Parser b
end
  [a] -> Parser [a]
forall a. a -> ParsecT [Char] () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ([a] -> Parser [a]) -> [a] -> Parser [a]
forall a b. (a -> b) -> a -> b
$ [a]
xs

input :: Parser TopLevel
input :: Parser TopLevel
input = do
  Parser ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
  TopLevel
tl <- Parser TopLevel -> Parser TopLevel
forall tok st a. GenParser tok st a -> GenParser tok st a
try (do
      [Char]
f    <- Parser [Char]
atomic
      [Pattern]
args <- Parser Pattern
pattern Parser Pattern
-> Parser [Char] -> ParsecT [Char] () Identity [Pattern]
forall a b. Parser a -> Parser b -> Parser [a]
`endsIn` [Char] -> Parser [Char]
symbol [Char]
"="
      Expr
e    <- Bool -> Parser Expr
myParser Bool
False
      TopLevel -> Parser TopLevel
forall a. a -> ParsecT [Char] () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (TopLevel -> Parser TopLevel) -> TopLevel -> Parser TopLevel
forall a b. (a -> b) -> a -> b
$ Bool -> Decl -> TopLevel
TLD Bool
True (Decl -> TopLevel) -> Decl -> TopLevel
forall a b. (a -> b) -> a -> b
$ [Char] -> Expr -> Decl
Define [Char]
f ((Pattern -> Expr -> Expr) -> Expr -> [Pattern] -> Expr
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Pattern -> Expr -> Expr
Lambda Expr
e [Pattern]
args)
    ) Parser TopLevel -> Parser TopLevel -> Parser TopLevel
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Expr -> TopLevel
TLE (Expr -> TopLevel) -> Parser Expr -> Parser TopLevel
forall a b.
(a -> b)
-> ParsecT [Char] () Identity a -> ParsecT [Char] () Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Bool -> Parser Expr
myParser Bool
False
  Parser ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof
  TopLevel -> Parser TopLevel
forall a. a -> ParsecT [Char] () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return TopLevel
tl

parsePF :: String -> Either String TopLevel
parsePF :: [Char] -> Either [Char] TopLevel
parsePF [Char]
inp = case Parser TopLevel
-> () -> [Char] -> [Char] -> Either ParseError TopLevel
forall tok st a.
GenParser tok st a -> st -> [Char] -> [tok] -> Either ParseError a
runParser Parser TopLevel
input () [Char]
"" [Char]
inp of
    Left ParseError
err -> [Char] -> Either [Char] TopLevel
forall a b. a -> Either a b
Left ([Char] -> Either [Char] TopLevel)
-> [Char] -> Either [Char] TopLevel
forall a b. (a -> b) -> a -> b
$ ParseError -> [Char]
forall a. Show a => a -> [Char]
show ParseError
err
    Right TopLevel
e  -> TopLevel -> Either [Char] TopLevel
forall a b. b -> Either a b
Right (TopLevel -> Either [Char] TopLevel)
-> TopLevel -> Either [Char] TopLevel
forall a b. (a -> b) -> a -> b
$ (Expr -> Expr) -> TopLevel -> TopLevel
mapTopLevel Expr -> Expr
postprocess TopLevel
e


postprocess :: Expr -> Expr
postprocess :: Expr -> Expr
postprocess (Var Fixity
f [Char]
v) = (Fixity -> [Char] -> Expr
Var Fixity
f [Char]
v)
postprocess (App Expr
e1 (Var Fixity
Pref [Char]
"")) = Expr -> Expr
postprocess Expr
e1
postprocess (App Expr
e1 Expr
e2) = Expr -> Expr -> Expr
App (Expr -> Expr
postprocess Expr
e1) (Expr -> Expr
postprocess Expr
e2)
postprocess (Lambda Pattern
v Expr
e) = Pattern -> Expr -> Expr
Lambda Pattern
v (Expr -> Expr
postprocess Expr
e)
postprocess (Let [Decl]
ds Expr
e) = [Decl] -> Expr -> Expr
Let ((Expr -> Expr) -> Decl -> Decl
mapDecl Expr -> Expr
postprocess (Decl -> Decl) -> [Decl] -> [Decl]
forall a b. (a -> b) -> [a] -> [b]
`map` [Decl]
ds) (Expr -> Expr) -> Expr -> Expr
forall a b. (a -> b) -> a -> b
$ Expr -> Expr
postprocess Expr
e where
  mapDecl :: (Expr -> Expr) -> Decl -> Decl
  mapDecl :: (Expr -> Expr) -> Decl -> Decl
mapDecl Expr -> Expr
f (Define [Char]
foo Expr
e') = [Char] -> Expr -> Decl
Define [Char]
foo (Expr -> Decl) -> Expr -> Decl
forall a b. (a -> b) -> a -> b
$ Expr -> Expr
f Expr
e'