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

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

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

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

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

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

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

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

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

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

table :: [[Operator Char st Expr]]
table :: [[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
$ ([(String, (Assoc, Int))] -> [Operator Char st Expr])
-> [[(String, (Assoc, Int))]] -> [[Operator Char st Expr]]
forall a b. (a -> b) -> [a] -> [b]
map (((String, (Assoc, Int)) -> Operator Char st Expr)
-> [(String, (Assoc, Int))] -> [Operator Char st Expr]
forall a b. (a -> b) -> [a] -> [b]
map (String, (Assoc, Int)) -> Operator Char st Expr
forall st. (String, (Assoc, Int)) -> Operator Char st Expr
inf) [[(String, (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 :: 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
      String
name <- CharParser st String
forall st. CharParser st String
parseOp
      Bool -> ParsecT String st Identity ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> ParsecT String st Identity ())
-> Bool -> ParsecT String 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
$ String -> Maybe (Assoc, Int)
lookupOp String
name
      ParsecT String 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 (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 -> String -> Expr
Var Fixity
Inf String
name) Expr
e1 Expr -> Expr -> Expr
`App` Expr
e2
    ) Assoc
AssocLeft

  inf :: (String, (Assoc, Int)) -> Operator Char st Expr
  inf :: (String, (Assoc, Int)) -> Operator Char st Expr
inf (String
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
      String
_ <- String -> ParsecT String st Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
name
      ParsecT String st Identity Char -> ParsecT String 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 String st Identity Char -> ParsecT String st Identity ())
-> ParsecT String st Identity Char -> ParsecT String st Identity ()
forall a b. (a -> b) -> a -> b
$ String -> ParsecT String st Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
oneOf String
opchars
      ParsecT String st Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
      let name' :: String
name' = if String -> Char
forall a. [a] -> a
head String
name Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'`'
                  then String -> String
forall a. [a] -> [a]
tail (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. [a] -> [a]
reverse (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. [a] -> [a]
tail (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. [a] -> [a]
reverse (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
name
                  else String
name
      (Expr -> Expr -> Expr) -> GenParser Char st (Expr -> Expr -> Expr)
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 -> String -> Expr
Var Fixity
Inf String
name') Expr
e1 Expr -> Expr -> Expr
`App` Expr
e2
    ) Assoc
assoc


parseOp :: CharParser st String
parseOp :: CharParser st String
parseOp = (ParsecT String st Identity Char
-> ParsecT String st Identity Char
-> CharParser st String
-> CharParser st String
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 String st Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'`') (Char -> ParsecT String st Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'`') (CharParser st String -> CharParser st String)
-> CharParser st String -> CharParser st String
forall a b. (a -> b) -> a -> b
$ CharParser st String -> CharParser st String
forall st. CharParser st String -> CharParser st String
qualified (GenTokenParser String st Identity -> CharParser st String
forall s u (m :: * -> *).
GenTokenParser s u m -> ParsecT s u m String
T.identifier GenTokenParser String st Identity
forall st. TokenParser st
tp))
  CharParser st String
-> CharParser st String -> CharParser st String
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> CharParser st String -> CharParser st String
forall tok st a. GenParser tok st a -> GenParser tok st a
try (do
    String
op <- CharParser st String -> CharParser st String
forall st. CharParser st String -> CharParser st String
qualified (CharParser st String -> CharParser st String)
-> CharParser st String -> CharParser st String
forall a b. (a -> b) -> a -> b
$ ParsecT String st Identity Char -> CharParser st String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (ParsecT String st Identity Char -> CharParser st String)
-> ParsecT String st Identity Char -> CharParser st String
forall a b. (a -> b) -> a -> b
$ String -> ParsecT String st Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
oneOf String
opchars
    Bool -> ParsecT String st Identity ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> ParsecT String st Identity ())
-> Bool -> ParsecT String st Identity ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ String
op String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
reservedOps
    String -> CharParser st String
forall (m :: * -> *) a. Monad m => a -> m a
return String
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 ((String -> Pattern
PVar (String -> Pattern) -> Parser String -> Parser Pattern
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap`
                       (    Parser String
atomic
                        Parser String -> Parser String -> Parser String
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (String -> Parser String
symbol String
"_" Parser String -> Parser String -> Parser String
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Parser String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"")))
                        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.
ParsecT String () Identity a -> ParsecT String () Identity a
parens Parser Pattern
pattern)
    Parser Pattern -> String -> Parser Pattern
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"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 (String -> Parser String
symbol String
":" Parser String
-> GenParser Char () (Pattern -> Pattern -> Pattern)
-> GenParser Char () (Pattern -> Pattern -> Pattern)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Pattern -> Pattern -> Pattern)
-> GenParser Char () (Pattern -> Pattern -> Pattern)
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 (String -> Parser String
symbol String
"," Parser String
-> GenParser Char () (Pattern -> Pattern -> Pattern)
-> GenParser Char () (Pattern -> Pattern -> Pattern)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Pattern -> Pattern -> Pattern)
-> GenParser Char () (Pattern -> Pattern -> Pattern)
forall (m :: * -> *) a. Monad m => a -> m a
return Pattern -> Pattern -> Pattern
PTuple) Assoc
AssocNone]]

lambda :: Parser Expr
lambda :: Parser Expr
lambda = do
    String
_  <- String -> Parser String
symbol String
"\\"
    [Pattern]
vs <- Parser Pattern -> ParsecT String () 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
    String
_  <- String -> Parser String
symbol String
"->"
    Expr
e  <- Bool -> Parser Expr
myParser Bool
False
    Expr -> Parser Expr
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 (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Pattern -> Expr -> Expr
Lambda Expr
e [Pattern]
vs
  Parser Expr -> String -> Parser Expr
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"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 (String -> Expr
makeVar (String -> Expr) -> Parser String -> Parser Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Parser String
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.
ParsecT String () Identity a -> ParsecT String () Identity 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 (String -> Expr
makeVar (String -> Expr) -> Parser String -> Parser Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Parser Char -> Parser String
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 -> String -> Expr
Var Fixity
Pref (String -> Expr) -> (Char -> String) -> Char -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String
forall a. Show a => a -> String
show) (Char -> Expr) -> Parser Char -> Parser Expr
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
<|> String -> Expr
stringVar (String -> Expr) -> Parser String -> Parser Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Parser String
stringLiteral)
        Parser Expr -> String -> Parser Expr
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"variable" where
  makeVar :: String -> Expr
makeVar String
v | Just (Assoc, Int)
_ <- String -> Maybe (Assoc, Int)
lookupOp String
v = Fixity -> String -> Expr
Var Fixity
Inf String
v -- operators always want to
                                               -- be infixed
            | Bool
otherwise            = Fixity -> String -> Expr
Var Fixity
Pref String
v
  stringVar :: String -> Expr
  stringVar :: String -> Expr
stringVar String
str = [Expr] -> Expr
makeList ([Expr] -> Expr) -> [Expr] -> Expr
forall a b. (a -> b) -> a -> b
$ (Fixity -> String -> Expr
Var Fixity
Pref (String -> Expr) -> (Char -> String) -> Char -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String
forall a. Show a => a -> String
show) (Char -> Expr) -> String -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
`map` String
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.
ParsecT String () Identity a -> ParsecT String () Identity a
brackets) [Parser Expr]
plist) Parser Expr -> String -> Parser Expr
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"list" where
  plist :: [Parser Expr]
plist = [
    (Expr -> Expr -> Expr) -> Expr -> [Expr] -> Expr
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 String () Identity [Expr] -> Parser Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap`
      (Bool -> Parser Expr
myParser Bool
False Parser Expr -> Parser String -> ParsecT String () 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` String -> Parser String
symbol String
","),
    do Expr
e <- Bool -> Parser Expr
myParser Bool
False
       String
_ <- String -> Parser String
symbol String
".."
       Expr -> Parser Expr
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> Parser Expr) -> Expr -> Parser Expr
forall a b. (a -> b) -> a -> b
$ Fixity -> String -> Expr
Var Fixity
Pref String
"enumFrom" Expr -> Expr -> Expr
`App` Expr
e,
    do Expr
e  <- Bool -> Parser Expr
myParser Bool
False
       String
_  <- String -> Parser String
symbol String
","
       Expr
e' <- Bool -> Parser Expr
myParser Bool
False
       String
_  <- String -> Parser String
symbol String
".."
       Expr -> Parser Expr
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> Parser Expr) -> Expr -> Parser Expr
forall a b. (a -> b) -> a -> b
$ Fixity -> String -> Expr
Var Fixity
Pref String
"enumFromThen" Expr -> Expr -> Expr
`App` Expr
e Expr -> Expr -> Expr
`App` Expr
e',
    do Expr
e  <- Bool -> Parser Expr
myParser Bool
False
       String
_  <- String -> Parser String
symbol String
".."
       Expr
e' <- Bool -> Parser Expr
myParser Bool
False
       Expr -> Parser Expr
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> Parser Expr) -> Expr -> Parser Expr
forall a b. (a -> b) -> a -> b
$ Fixity -> String -> Expr
Var Fixity
Pref String
"enumFromTo" Expr -> Expr -> Expr
`App` Expr
e Expr -> Expr -> Expr
`App` Expr
e',
    do Expr
e   <- Bool -> Parser Expr
myParser Bool
False
       String
_   <- String -> Parser String
symbol String
","
       Expr
e'  <- Bool -> Parser Expr
myParser Bool
False
       String
_   <- String -> Parser String
symbol String
".."
       Expr
e'' <- Bool -> Parser Expr
myParser Bool
False
       Expr -> Parser Expr
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> Parser Expr) -> Expr -> Parser Expr
forall a b. (a -> b) -> a -> b
$ Fixity -> String -> Expr
Var Fixity
Pref String
"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 String -> ParsecT String () 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` String -> Parser String
symbol String
","
    Bool -> Parser ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Parser ()) -> Bool -> Parser ()
forall a b. (a -> b) -> a -> b
$ [Expr] -> 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 -> String -> Expr
Var Fixity
Pref (String -> Expr) -> String -> Expr
forall a b. (a -> b) -> a -> b
$ Int -> Char -> String
forall a. Int -> a -> [a]
replicate ([Expr] -> 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 (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 (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Expr -> Expr -> Expr
App Expr
name [Expr]
elts
  Parser Expr -> String -> Parser Expr
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"tuple"

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

rightSection :: Parser Expr
rightSection :: Parser Expr
rightSection = do
    Expr
v <- Fixity -> String -> Expr
Var Fixity
Inf (String -> Expr) -> Parser String -> Parser Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Parser String
forall st. CharParser st String
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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Bool -> Parser Expr
myParser Bool
False)
  Parser Expr -> String -> Parser Expr
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"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 -> String -> Parser Expr
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"expression"

decl :: Parser Decl
decl :: Parser Decl
decl = do
  String
f <- Parser String
atomic
  [Pattern]
args <- Parser Pattern
pattern Parser Pattern
-> Parser String -> ParsecT String () Identity [Pattern]
forall a b. Parser a -> Parser b -> Parser [a]
`endsIn` String -> Parser String
symbol String
"="
  Expr
e <- Bool -> Parser Expr
myParser Bool
False
  Decl -> Parser Decl
forall (m :: * -> *) a. Monad m => a -> m a
return (Decl -> Parser Decl) -> Decl -> Parser Decl
forall a b. (a -> b) -> a -> b
$ String -> Expr -> Decl
Define String
f ((Pattern -> Expr -> Expr) -> Expr -> [Pattern] -> Expr
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
  String -> Parser ()
reserved String
"let"
  [Decl]
ds <- Parser Decl
decl Parser Decl -> Parser String -> ParsecT String () 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` String -> Parser String
symbol String
";"
  String -> Parser ()
reserved String
"in"
  Expr
e <- Bool -> Parser Expr
myParser Bool
False
  Expr -> Parser Expr
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
  String -> Parser ()
reserved String
"if"
  Expr
p <- Bool -> Parser Expr
myParser Bool
False
  String -> Parser ()
reserved String
"then"
  Expr
e1 <- Bool -> Parser Expr
myParser Bool
False
  String -> Parser ()
reserved String
"else"
  Expr
e2 <- Bool -> Parser Expr
myParser Bool
False
  Expr -> Parser Expr
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 (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 (String -> Parser Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf String
")") Parser () -> Parser Expr -> Parser Expr
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Expr -> Parser Expr
forall (m :: * -> *) a. Monad m => a -> m a
return (Fixity -> String -> Expr
Var Fixity
Pref String
"")))
  Parser Expr -> String -> Parser Expr
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"simple term"

application :: Parser Expr
application :: Parser Expr
application = do
    Expr
e:[Expr]
es <- Parser Expr -> ParsecT String () 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 String () Identity [Expr])
-> Parser Expr -> ParsecT String () 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.
ParsecT String () Identity a -> ParsecT String () Identity a
parens (Bool -> Parser Expr
myParser Bool
True)
    Expr -> Parser Expr
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 (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Expr -> Expr -> Expr
App Expr
e [Expr]
es
  Parser Expr -> String -> Parser Expr
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"application"

endsIn :: Parser a -> Parser b -> Parser [a]
endsIn :: 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 (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
      String
f    <- Parser String
atomic
      [Pattern]
args <- Parser Pattern
pattern Parser Pattern
-> Parser String -> ParsecT String () Identity [Pattern]
forall a b. Parser a -> Parser b -> Parser [a]
`endsIn` String -> Parser String
symbol String
"="
      Expr
e    <- Bool -> Parser Expr
myParser Bool
False
      TopLevel -> Parser TopLevel
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
$ String -> Expr -> Decl
Define String
f ((Pattern -> Expr -> Expr) -> Expr -> [Pattern] -> Expr
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 (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 (m :: * -> *) a. Monad m => a -> m a
return TopLevel
tl

parsePF :: String -> Either String TopLevel
parsePF :: String -> Either String TopLevel
parsePF String
inp = case Parser TopLevel
-> () -> String -> String -> Either ParseError TopLevel
forall tok st a.
GenParser tok st a -> st -> String -> [tok] -> Either ParseError a
runParser Parser TopLevel
input () String
"" String
inp of
    Left ParseError
err -> String -> Either String TopLevel
forall a b. a -> Either a b
Left (String -> Either String TopLevel)
-> String -> Either String TopLevel
forall a b. (a -> b) -> a -> b
$ ParseError -> String
forall a. Show a => a -> String
show ParseError
err
    Right TopLevel
e  -> TopLevel -> Either String TopLevel
forall a b. b -> Either a b
Right (TopLevel -> Either String TopLevel)
-> TopLevel -> Either String 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 String
v) = (Fixity -> String -> Expr
Var Fixity
f String
v)
postprocess (App Expr
e1 (Var Fixity
Pref String
"")) = 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 String
foo Expr
e') = String -> Expr -> Decl
Define String
foo (Expr -> Decl) -> Expr -> Decl
forall a b. (a -> b) -> a -> b
$ Expr -> Expr
f Expr
e'