Write a calculator

It's pretty nice. It works for what I want. I don't think I have any
complaints about its functionality. I'll add new functions as I need
them. Haskell is actually really easy to program in. I wonder actually
if this would have been easier in Python. I think no.

1 files changed, 66 insertions, 0 deletions

diff --git a/Expr.hs b/Expr.hs
new file mode 100644
index 0000000..5514e4a
--- /dev/null
+++ b/Expr.hs
@@ -0,0 +1,66 @@
+module Expr (parseE, Expr(..)) where
+
+import Text.Parsec
+import Text.Parsec.Language
+import Text.Parsec.Token
+import Text.Parsec.Expr
+import qualified Data.Functor.Identity
+
+data Expr = Plus Expr Expr
+          | Negate Expr
+          | Minus Expr Expr
+          | Times Expr Expr
+          | Div Expr Expr
+          | EInt Integer
+          | EFloat Double
+          | E
+          | Pi
+          | Log Expr
+          | Sin Expr
+          | Cos Expr
+          | Sqrt Expr
+
+tokenParser :: TokenParser st
+tokenParser = haskell
+
+parseNumber :: Parsec String u Expr
+parseNumber = do n <- naturalOrFloat tokenParser
+                 case n of
+                   Left i -> return (EInt i)
+                   Right d -> return (EFloat d)
+
+tokenS :: String -> Parsec String u ()
+tokenS s = () <$ try (symbol tokenParser s)
+
+inner :: Parsec String u Expr
+inner = parseNumber <|> E <$ tokenS "e" <|> Pi <$ tokenS "pi" <|> parens tokenParser parseExpr
+
+binary :: String -> (a -> a -> a) -> Assoc
+       -> Operator String u Data.Functor.Identity.Identity a
+binary name fun assoc =
+  Infix (fun <$ tokenS name) assoc
+
+prefix :: String -> (a -> a)
+       -> Operator String u Data.Functor.Identity.Identity a
+prefix name fun = Prefix (fun <$ tokenS name)
+
+table :: [[Operator String u Data.Functor.Identity.Identity Expr]]
+table = [ [ prefix "log" Log, prefix "sin" Sin, prefix "cos" Cos, prefix "sqrt" Sqrt ]
+        , [ prefix "-" Negate ]
+        , [ binary "*" Times AssocLeft
+          , binary "/" Div AssocLeft
+          ]
+        , [ binary "+" Plus AssocLeft
+          , binary "-" Minus AssocLeft
+          ]
+        ]
+
+parseExpr :: Parsec String u Expr
+parseExpr = buildExpressionParser table inner
+
+parser :: Parsec String u Expr
+parser = do whiteSpace tokenParser
+            parseExpr
+
+parseE :: String -> Either ParseError Expr
+parseE s = parse parser "" s