-- This module has been written by Enzo Haussecker
--
-- Parsing Examples:
--
-- > functionParse "(x+1)^2"
-- Just (Exp (Add (Var "x") (Num 1.0)) (Num 2.0))
--
-- > functionParse "e^x*(cos(5*x) - 3*sin x)"
-- Just (Mul (Exp (Var "e") (Var "x")) (Sub (Cos (Mul (Num 5.0) (Var "x"))) (Mul (Num 3.0) (Sin (Var "x")))))
--
module Text.ParserCombinators.Parsec.ParserFunction
    (functionParse) where

import Data.Char (toLower)
import Data.List (isInfixOf)
import Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Expr 
import Text.ParserCombinators.Parsec.Functions

functionParse :: String -> Maybe Expr
functionParse xs = if any (==True) (symbols failingSymbols xs)
                   then Nothing
                   else either (const Nothing) (Just) (parse getFunction "" handleString)
    where
        handleString   = "(" ++ (map toLower $ filter (/=' ') xs) ++ ")"
        symbols [] y   = []
        symbols x  y   = [isInfixOf (head x) y] ++ (symbols (drop 1 x) y)
        failingSymbols = ["^^","^*","^/","^+","^-","*^","**","*/","*+","*-",
                          "/^","/*","//","/+","/-","+^","+*","+/","++","+-",
                          "-^","-*","-/","-+","--"]

getFunction :: Parser Expr
getFunction = buildExpressionParser expressionTable factor

expressionTable :: [[Operator Char st Expr]]
expressionTable =  [[pr "arcsinh" ArcSinh, pr "arcsin" ArcSin, pr "sinh" Sinh, pr "sin" Sin],
                    [pr "arccosh" ArcCosh, pr "arccos" ArcCos, pr "cosh" Cosh, pr "cos" Cos],
                    [pr "arctanh" ArcTanh, pr "arctan" ArcTan, pr "tanh" Tanh, pr "tan" Tan],
                    [pr "arcsech" ArcSech, pr "arcsec" ArcSec, pr "sech" Sech, pr "sec" Sec],
                    [pr "arccsch" ArcCsch, pr "arccsc" ArcCsc, pr "csch" Csch, pr "csc" Csc],
                    [pr "arccoth" ArcCoth, pr "arccot" ArcCot, pr "coth" Coth, pr "cot" Cot],
                    [pr "log" Log, pr "abs" Abs,pr "exp" Exp],
                    [pr "sqrt" Sqrt, pr "cbrt" Cbrt],
                    [op "^" Pow AssocLeft],
                    [op "*" Mul AssocLeft, op "/" Div AssocLeft],
                    [op "+" Add AssocLeft, op "-" Sub AssocLeft]]
    where
        op s f assoc = Infix  (do{ string s; return f}) assoc
        pr s f       = Prefix (try (string s) >> return f)

factor :: Parser Expr
factor = do
    char '('
    e <- getFunction
    char ')'
    return e
    <|> variables

variables :: Parser Expr
variables = do
    ds <- letter
    return $ Var ds
    <|> number

number :: Parser Expr
number = do
    br  <- many digit
    let d :: Double
        d = fromInteger (foldl ((. ch2num) . (+) . (*10)) 0 br)
    option (Num (d)) (try (do
        char '.'
        ar <- many1 digit
        return $ (Num (d + foldr (fd) 0 ar)) ))
        where
            fd a b = (fromInteger (ch2num a) + b) / 10
            fe = toInteger . fromEnum
            ch2num = (subtract $ fe '0') . fe