{-# 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 = forall s (m :: * -> *) u.
Stream s m Char =>
GenLanguageDef s u m -> GenTokenParser s u m
T.makeTokenParser forall a b. (a -> b) -> a -> b
$ forall st. LanguageDef st
haskellStyle {
  reservedNames :: [[Char]]
reservedNames = [[Char]
"if",[Char]
"then",[Char]
"else",[Char]
"let",[Char]
"in"]
}

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

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

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

modName :: CharParser st String
modName :: forall st. CharParser st [Char]
modName = do
  Char
c <- forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m Char
oneOf [Char
'A'..Char
'Z']
  [Char]
cs <- forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
alphaNum 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
oneOf [Char]
"_'")
  forall (m :: * -> *) a. Monad m => a -> m a
return (Char
cforall 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 <- forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many forall a b. (a -> b) -> a -> b
$ forall tok st a. GenParser tok st a -> GenParser tok st a
try forall a b. (a -> b) -> a -> b
$ forall st. CharParser st [Char]
modName forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'.' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m a
lookAhead (forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
letter 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
oneOf [Char]
opchars)
  [Char]
nm <- CharParser st [Char]
p
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"." ([[Char]]
qs forall a. [a] -> [a] -> [a]
++ [[Char]
nm])

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

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

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

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

table :: [[Operator Char st Expr]]
table :: forall st. [[Operator Char st Expr]]
table = forall {a}. a -> [[a]] -> [[a]]
addToFirst forall st. Operator Char st Expr
def forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> b) -> [a] -> [b]
map 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
yforall a. a -> [a] -> [a]
:[a]
x)forall a. a -> [a] -> [a]
:[[a]]
xs)
  addToFirst a
_ [[a]]
_ = forall a. (?callStack::CallStack) => Bool -> a -> a
assert Bool
False forall a. a
bt

  def :: Operator Char st Expr
  def :: forall st. Operator Char st Expr
def = forall tok st a.
GenParser tok st (a -> a -> a) -> Assoc -> Operator tok st a
Infix (forall tok st a. GenParser tok st a -> GenParser tok st a
try forall a b. (a -> b) -> a -> b
$ do
      [Char]
name <- forall st. CharParser st [Char]
parseOp
      forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall a. Maybe a -> Bool
isJust forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe (Assoc, Int)
lookupOp [Char]
name
      forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
      forall (m :: * -> *) a. Monad m => a -> m a
return 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
_)) = forall tok st a.
GenParser tok st (a -> a -> a) -> Assoc -> Operator tok st a
Infix (forall tok st a. GenParser tok st a -> GenParser tok st a
try forall a b. (a -> b) -> a -> b
$ do
      [Char]
_ <- forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
name
      forall s (m :: * -> *) t a u.
(Stream s m t, Show a) =>
ParsecT s u m a -> ParsecT s u m ()
notFollowedBy forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m Char
oneOf [Char]
opchars
      forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
      let name' :: [Char]
name' = if forall a. [a] -> a
head [Char]
name forall a. Eq a => a -> a -> Bool
== Char
'`'
                  then forall a. [a] -> [a]
tail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
tail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ [Char]
name
                  else [Char]
name
      forall (m :: * -> *) a. Monad m => a -> m a
return 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 = (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 (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'`') (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'`') forall a b. (a -> b) -> a -> b
$ forall st. CharParser st [Char] -> CharParser st [Char]
qualified (forall s u (m :: * -> *).
GenTokenParser s u m -> ParsecT s u m [Char]
T.identifier forall st. TokenParser st
tp))
  forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall tok st a. GenParser tok st a -> GenParser tok st a
try (do
    [Char]
op <- forall st. CharParser st [Char] -> CharParser st [Char]
qualified forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m Char
oneOf [Char]
opchars
    forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ [Char]
op forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]]
reservedOps
    forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
op)

pattern :: Parser Pattern
pattern :: Parser Pattern
pattern = forall tok st a.
OperatorTable tok st a -> GenParser tok st a -> GenParser tok st a
buildExpressionParser [[Operator Char () Pattern]]
ptable (([Char] -> Pattern
PVar forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap`
                       (    Parser [Char]
atomic
                        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]
"_" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
"")))
                        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 Parser Pattern
pattern)
    forall s u (m :: * -> *) a.
ParsecT s u m a -> [Char] -> ParsecT s u m a
<?> [Char]
"pattern" where
  ptable :: [[Operator Char () Pattern]]
ptable = [[forall tok st a.
GenParser tok st (a -> a -> a) -> Assoc -> Operator tok st a
Infix ([Char] -> Parser [Char]
symbol [Char]
":" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Pattern -> Pattern -> Pattern
PCons) Assoc
AssocRight],
            [forall tok st a.
GenParser tok st (a -> a -> a) -> Assoc -> Operator tok st a
Infix ([Char] -> Parser [Char]
symbol [Char]
"," forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> 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 <- 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
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> 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
  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 = forall tok st a. GenParser tok st a -> GenParser tok st a
try ([Char] -> Expr
makeVar forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Parser [Char]
atomic 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 (forall tok st a. GenParser tok st a -> GenParser tok st a
try Parser Expr
unaryNegation forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall tok st a. GenParser tok st a -> GenParser tok st a
try Parser Expr
rightSection
                   forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall tok st a. GenParser tok st a -> GenParser tok st a
try ([Char] -> Expr
makeVar forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
','))
                   forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Parser Expr
tuple) forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Parser Expr
list 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Parser Char
charLiteral
                   forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> [Char] -> Expr
stringVar forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Parser [Char]
stringLiteral)
        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 forall a b. (a -> b) -> a -> b
$ (Fixity -> [Char] -> Expr
Var Fixity
Pref forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show) forall a b. (a -> b) -> [a] -> [b]
`map` [Char]
str

list :: Parser Expr
list :: Parser Expr
list = forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum (forall a b. (a -> b) -> [a] -> [b]
map (forall tok st a. GenParser tok st a -> GenParser tok st a
try forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Parser a -> Parser a
brackets) [Parser Expr]
plist) forall s u (m :: * -> *) a.
ParsecT s u m a -> [Char] -> ParsecT s u m a
<?> [Char]
"list" where
  plist :: [Parser Expr]
plist = [
    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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap`
      (Bool -> Parser Expr
myParser Bool
False 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]
".."
       forall (m :: * -> *) a. Monad m => a -> m a
return 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]
".."
       forall (m :: * -> *) a. Monad m => a -> m a
return 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
       forall (m :: * -> *) a. Monad m => a -> m a
return 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
       forall (m :: * -> *) a. Monad m => a -> m a
return 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 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]
","
    forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length [Expr]
elts forall a. Eq a => a -> a -> Bool
/= Int
1
    let name :: Expr
name = Fixity -> [Char] -> Expr
Var Fixity
Pref forall a b. (a -> b) -> a -> b
$ forall a. Int -> a -> [a]
replicate (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Expr]
elts forall a. Num a => a -> a -> a
- Int
1) Char
','
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> 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
  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
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Fixity -> [Char] -> Expr
Var Fixity
Pref [Char]
"negate" Expr -> Expr -> Expr
`App` Expr
e
  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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall st. CharParser st [Char]
parseOp
    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
    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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Bool -> Parser Expr
myParser Bool
False)
  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 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 = forall tok st a.
OperatorTable tok st a -> GenParser tok st a -> GenParser tok st a
buildExpressionParser forall st. [[Operator Char st Expr]]
table (Bool -> Parser Expr
term Bool
b) 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 forall a b. Parser a -> Parser b -> Parser [a]
`endsIn` [Char] -> Parser [Char]
symbol [Char]
"="
  Expr
e <- Bool -> Parser Expr
myParser Bool
False
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Char] -> Expr -> Decl
Define [Char]
f (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 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
  forall (m :: * -> *) a. Monad m => a -> m a
return 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
  forall (m :: * -> *) a. Monad m => a -> m a
return 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 forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Parser Expr
lambda forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Parser Expr
letbind forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Parser Expr
ifexpr forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
    (forall (f :: * -> *). Alternative f => Bool -> f ()
guard Bool
b forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (forall s (m :: * -> *) t a u.
(Stream s m t, Show a) =>
ParsecT s u m a -> ParsecT s u m ()
notFollowedBy (forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m Char
noneOf [Char]
")") forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return (Fixity -> [Char] -> Expr
Var Fixity
Pref [Char]
"")))
  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 <- forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 forall a b. (a -> b) -> a -> b
$ Parser Expr
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 (Bool -> Parser Expr
myParser Bool
True)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> 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
  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 <- forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many Parser a
p
  b
_  <- Parser b
end
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [a]
xs

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