Advertisement
ttaaa

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, (<$), (<|>))
  13. import Control.Monad (void)
  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
Advertisement
Advertisement
Advertisement
RAW Paste Data Copied
Advertisement