ParserFunction.hs

-- 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 Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Expr

data Expr = Num Double    | Var String    | Sub Expr Expr
          | Div Expr Expr | Exp Expr Expr | Log Expr
          | Abs Expr      | Sqrt Expr     | Cbrt Expr
          | ArcSinh Expr  | ArcCosh Expr  | ArcTanh Expr
          | ArcSin Expr   | ArcCos Expr   | ArcTan Expr
          | Sinh Expr     | Cosh Expr     | Tanh Expr
          | Sin Expr      | Cos Expr      | Tan Expr
          | ArcSech Expr  | ArcCsch Expr  | ArcCoth Expr
          | ArcSec Expr   | ArcCsc Expr   | ArcCot Expr
          | Sech Expr     | Csch Expr     | Coth Expr
          | Sec Expr      | Csc Expr      | Cot Expr
          | Mul Expr Expr | Add Expr Expr deriving (Show, Eq, Ord)

functionParse :: String -> Maybe Expr
functionParse xs = either (const Nothing) (Just) (parse getFunction "" handleString)
    where
        handleString = "(" ++ (map toLower $ filter (/=' ') xs) ++ ")"

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 "sqrt" Sqrt, pr "cbrt" Cbrt],
                    [op "^" Exp 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  <- many1 letter
    return $
        case ds of
             ds | (length ds) == 1 -> Var ds
             ds -> error $ "parser error on `" ++ 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