2009/07/31

Add Embed Function to Calculator

Add embed functions (sin, cos, tan, log, sqrt), and enable to call it.


import Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Expr
import qualified Text.ParserCombinators.Parsec.Token as P
import Text.ParserCombinators.Parsec.Language
import Control.Monad (when)
import System.IO

lexer :: P.TokenParser ()
lexer = P.makeTokenParser (haskellDef { reservedOpNames = ["*","/","+","-","**"] })

naturalOrFloat = P.naturalOrFloat lexer
parens = P.parens lexer
reservedOp = P.reservedOp lexer
identifier = P.identifier lexer
lexeme = P.lexeme lexer

expr :: Parser Double
expr = buildExpressionParser table factor <?> "expression"
where
table = [
[unary "-" negate, unary "+" id],
[op "**" (**) AssocRight],
[op "*" (*) AssocLeft, op "/" (/) AssocLeft],
[op "+" (+) AssocLeft, op "-" (-) AssocLeft]
]
op s f assoc = Infix (do{ reservedOp s; return f } <?> "operator") assoc
unary s f = Prefix (do{ reservedOp s; return f })

factor :: Parser Double
factor =
do {
parens expr;
} <|> do {
norf <- naturalOrFloat;
case norf of
Left i -> return $ fromInteger i
Right f -> return $ f
} <|>
funcall
<?>
"factor"

funcall :: Parser Double
funcall =
do {
fname <- identifier;
params <- lexeme formalparams;
case (applyFunc fname params) of
Right v -> return v
Left err -> fail err
}

formalparams :: Parser [Double]
formalparams = lexeme (char '(') >> params False
where
params bComma =
do {
char ')';
return [];
} <|> do {
when bComma $ lexeme (char ',') >> return ();
e <- expr;
r <- params True;
return $ e : r;
}

applyFunc :: String -> [Double] -> Either String Double
applyFunc fname params = call $ lookup fname functbl
where
functbl = [
("sin", (1, apply1 sin)),
("cos", (1, apply1 cos)),
("tan", (1, apply1 tan)),
("log", (1, apply1 log)),
("sqrt", (1, apply1 sqrt))
]

call Nothing = Left $ fname ++ ": no function"
call (Just (argnum, fn))
| length params /= argnum = Left $ fname ++ ": illegal argnum, " ++ show (length params) ++ " for " ++ show argnum
| otherwise = Right $ fn params

apply1 f [x] = f x
apply2 f [x,y] = f x y

repl :: String -> (String -> Bool) -> (String -> String) -> IO ()
repl prompt bQuit eval = loop
where
loop = do
putStr prompt
s <- getLine
if bQuit s
then return ()
else putStrLn (eval s) >> loop

calc :: IO ()
calc = repl "> " (== ":q") (tostring . parse stmt "")
where
tostring (Right v) = show v
tostring (Left err) = show err
stmt = do
e <- expr
eof
return e

main = hSetBuffering stdout NoBuffering >> putStrLn "type ':q' to quit." >> calc >> putStrLn "Bye"



  • Add factor to funcall parser.
  • Use lexeme to make strip whitespace parser.
  • Embed functions are stored in fixed table and can't add runtime.

No comments: