VoidEx

data PMaybe a = PJust a | PError String
data Parsed a = Parsed (String -> (String, PMaybe a))

result :: Parsed a -> PMaybe a
result (Parsed f) = snd (f "")

fails :: Parsed a -> Bool
fails (Parsed f) = isError (snd (f "")) where
    isError (PError _) = True
    isError (PJust _) = False

instance Monad Parsed where
    return x = Parsed (\s -> (s, PJust x))
    (Parsed v) >>= f = Parsed f_ where
        f_ s = do_f (v s) where
            do_f (str, PJust x) = app (f x) s where
                app (Parsed f') = f'
            do_f (str, PError x) = (str, PError x)

setError :: String -> Parsed ()
setError str = Parsed (\_ -> (str, PJust ()))

addError :: String -> Parsed ()
addError str = Parsed (\s -> (s ++ " " ++ str, PJust()))

getError :: Parsed String
getError = Parsed (\s -> (s, PJust s))

throwError :: Parsed a
throwError = Parsed (\s -> (s, PError s))

class Expression a where
    parse :: String -> Parsed (a, String)
    eval :: a -> Float

trim :: String -> String
trim (' ' : xs) = xs
trim x = x

parseStr :: String -> String -> Parsed String
parseStr p str = parseStr_ (f p str) where
    parseStr_ Nothing = do throwError
    parseStr_ (Just l) = do return (trim l)
    f [] [] = Just []
    f _ [] = Nothing
    f [] s = Just s
    f (x : xs) (y : ys) | x == y = (f xs ys)
        | otherwise = Nothing

parseOr :: Parsed a -> Parsed a -> Parsed a
parseOr (Parsed l) (Parsed r) = Parsed f where
    f s = do_l (l s) where
        do_l (_, PJust xl) = l s
        do_l (_, PError errl) = do_r (r s) where
            do_r (_, PJust xr) = r s
            do_r (_, PError errr) = ("", PError (errl ++ " and " ++ errr))

parseOrList :: [Parsed a] -> Parsed a
parseOrList [] = do throwError
parseOrList (x : y : []) = parseOr x y
parseOrList (x : xs) = parseOr x (parseOrList xs)

parseOneOf :: [(String, a)] -> String -> Parsed (a, String)
parseOneOf [] _ = do throwError
parseOneOf _ [] = do throwError
parseOneOf ((s, v) : xs) str = parseOr x x_ where
    x = do
        l <- parseStr s str
        return (v, l)
    x_ = do
        (r, l) <- parseOneOf xs str
        return (r, l)

parseVal :: String -> Parsed (Float, String)
parseVal [] = do
    addError " can't parse value from empty string"
    throwError
parseVal str = getVal (readsPrec 0 str) where
    getVal [] = do
        addError (" can't parse value from " ++ str)
        throwError
    getVal ((x, r) : _) = do return (x, trim r)

genericParse :: String -> [(String, Float -> Float -> Float)] -> (String -> Parsed (Float, String)) -> Parsed (Float, String)
genericParse str bin_ops cont = do
    (v, l) <- cont str
    repeatParse v l where
        repeatParse v_ l_ =
            if (fails (parseNext v_ l_)) then
                return (v_, l_)
            else
                do
                    (nv, nl) <- parseNext v_ l_
                    repeatParse nv nl where
                        parseNext _v_ _l_ = do
                            (f, l2) <- parseOneOf bin_ops _l_
                            (v2, l3) <- cont l2
                            return (f _v_ v2, l3)

exprOps :: [(String, Float -> Float -> Float)]
exprOps = [("+", (+)), ("-", (-))]
parseExpr :: String -> Parsed (Float, String)
parseExpr str = genericParse str exprOps parseFactor

factorOps :: [(String, Float -> Float -> Float)]
factorOps = [("*", (*)), ("/", (/))]
parseFactor :: String -> Parsed (Float, String)
parseFactor str = genericParse str factorOps parseTerm

parseTerm :: String -> Parsed (Float, String)
parseTerm str = parseOrList [pval, pfun, pbrack, pmin] where
    pval = do
        (v, l) <- parseVal str
        return (v, l)
    pfun = do
        (v, l) <- parseFunc str
        return (v, l)
    pbrack = do
        l <- parseStr "(" str
        (v, l2) <- parseExpr l
        l3 <- parseStr ")" l2
        return (v, l3)
    pmin = do
        l <- parseStr "-" str
        (v, l2) <- parseTerm l
        return (-v, l2)

unaryFuncs :: [(String, Float -> Float)]
unaryFuncs = [("ln", log), ("sin", sin), ("cos", cos), ("sqrt", sqrt)]
parseUnaryFunc :: String -> Parsed (Float, String)
parseUnaryFunc str = do
    (f, l1) <- parseOneOf unaryFuncs str
    l2 <- parseStr "(" l1
    (v, l3) <- parseExpr l2
    l4 <- parseStr ")" l3
    return (f v, l4)

binaryFuncs :: [(String, Float -> Float -> Float)]
binaryFuncs = [("add", (+)), ("sub", (-)), ("mul" , (*)), ("div", (/)), ("pow", (**))]
parseBinaryFunc :: String -> Parsed (Float, String)
parseBinaryFunc str = do
    (f, l1) <- parseOneOf binaryFuncs str
    l2 <- parseStr "(" l1
    (v1, l3) <- parseExpr l2
    l4 <- parseStr "," l3
    (v2, l5) <- parseExpr l4
    l6 <- parseStr ")" l5
    return (f v1 v2, l6)

parseFunc :: String -> Parsed (Float, String)
parseFunc str = parseOr un bin where
    un = parseUnaryFunc str
    bin = parseBinaryFunc str

calc :: String -> IO ()
calc str = showResult (result (parseExpr str)) where
    showResult (PJust (x, r)) = do putStrLn (str ++ " = " ++ (show x))
    showResult (PError e) = do putStrLn e