# CalculatorParser

Jan 24th, 2022
1,096
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
1. module CalculatorParser
2.     (
3.         calculateExpression,
4.         parseExpression
5.     ) where
6.
7. import Text.Parsec.String (Parser)
8. import Text.Parsec (parse)
9. import Text.Parsec.Language (emptyDef)
10. import Text.Parsec.Char (char, string)
11.
12. import Control.Applicative ((<\$>), (<*), many, (<\$), (<|>))
14.
15. import qualified Text.Parsec.Expr as E
16. import qualified Text.Parsec.Token as P
17.
18. data Expr = Num Double
19.           | Parens Expr
20.           | PrefixOp String (Double -> Double) Expr
21.           | BinaryOp String Expr (Double -> Double -> Double) Expr
22.
23. instance Show Expr where
24.     show (Num d) = show d
25.     show (Parens e) = "( " ++ (show e) ++ " )"
26.     show (PrefixOp op _ e) = "( " ++ op ++ " " ++ (show e) ++ " )"
27.     show (BinaryOp op e1 _ e2) = "( " ++ (show e1) ++ " " ++ op ++ " " ++ (show e2) ++ " )"
28.
29. calculateExpression :: Expr -> Double
30. calculateExpression ex = case ex of
31.     Num d -> d
32.     Parens e -> calculateExpression e
33.     PrefixOp n f e -> f (calculateExpression e)
34.     BinaryOp n e1 f e2 -> calculateExpression(e1) `f` calculateExpression(e2)
35.
36. parseExpression :: String -> Either String Expr
37. parseExpression input = case (parse expr "" input) of
38.     Left err -> Left ("Failed to parse expression: " ++ input ++ "\n" ++ show err)
39.     Right expr -> Right expr
40.
41. expr :: Parser Expr
42. expr = E.buildExpressionParser table term
43.
44. table = [[prefix "-" negate, prefix "+" id]
45.         ,[prefix "sin" sin, prefix "cos" cos]
46.         ,[binary "^" (**) E.AssocLeft]
47.         ,[binary "*" (*) E.AssocLeft, binary "/" (/) E.AssocLeft]
48.         ,[binary "+" (+) E.AssocLeft, binary "-" (-) E.AssocLeft]
49.         ]
50.   where
51.     binary name fun assoc = E.Infix (mkBinOp fun name <\$ symbol name) assoc
52.     prefix name fun = E.Prefix (PrefixOp name fun <\$ symbol name)
53.     mkBinOp fun name a b = BinaryOp name a fun b
54.
55. symbol :: String -> Parser String
56. symbol s = lexeme \$ string s
57.
58. lexeme :: Parser a -> Parser a
59. lexeme p = p <* whitespace
60.
61. whitespace :: Parser ()
62. whitespace = void \$ many \$ char ' '
63.
64. term :: Parser Expr
65. term = num <|> parens
66.
67. num :: Parser Expr
68. num = Num <\$> double
69.
70. double :: Parser Double
71. double = do res <- P.naturalOrFloat lexer
72.             case res of
73.                 Left n -> return \$ fromInteger n
74.                 Right f -> return f
75.
76. parens :: Parser Expr
77. parens = Parens <\$> (P.parens lexer expr)
78.
79. lexer = P.makeTokenParser emptyDef