diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,5 +1,19 @@ -2008-03-08 Markus Dittrich +2009-04-04 Markus Dittrich + * 0.4 release + + * lots of internal improvements and bugfixes; + parser is now almost completely applicative instead of + monadic + + * added ability to define and use custom functions + + * improved help system + + + +2009-03-08 Markus Dittrich + * 0.3 release * lots of bug fixes. In particular, operations @@ -14,7 +28,7 @@ * added basic help system -2008-02-22 Markus Dittrich +2009-02-22 Markus Dittrich * 0.2 release @@ -31,6 +45,6 @@ -2008-02-18 Markus Dittrich +2009-02-18 Markus Dittrich * 0.1 release diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -1,14 +1,14 @@ # Copyright 2008 Markus Dittrich # Distributed under the terms of the GNU General Public License v3 -VERSION=0.3 +VERSION=0.4 DESTDIR= mandir=$(DESTDIR)/usr/share/man/man1 docdir=$(DESTDIR)/usr/share/doc/husky-$(VERSION) htmldir=$(docdir)/html bindir=$(DESTDIR)/usr/bin -GHC_FLAGS_DEVEL = -O -Wall -Werror -fwarn-simple-patterns -fwarn-tabs -fwarn-incomplete-record-updates -fwarn-monomorphism-restriction -fwarn-implicit-prelude +GHC_FLAGS_DEVEL = -O -Wall -fwarn-simple-patterns -fwarn-tabs -fwarn-incomplete-record-updates -fwarn-monomorphism-restriction -fwarn-implicit-prelude -Werror -fno-warn-orphans GHC_FLAGS_RELEASE = -O2 OBJECTS = src/husky.hs src/CalculatorParser.hs src/CalculatorState.hs \ diff --git a/doc/usage.html b/doc/usage.html --- a/doc/usage.html +++ b/doc/usage.html @@ -294,7 +294,7 @@ Author: Markus Dittrich Version: -0.3 (03/08/2008) +0.4 (04/04/2009)
@@ -313,6 +313,8 @@

The following sections describe in detail each functionality.

Calculator

+
+

Basic Functionality

Currently, the mathematical operations "+", "-", "*", and "/" are supported with arbitrary nesting of parenthesised expressions. All calculations are performed in double @@ -325,19 +327,67 @@

  • ln, log2, log10 : natural, base2, and base10 logarithm
  • cos, sin, tan, acos, asin, atan: trigonometric functions and inverse
  • cosh, sinh, tanh, acosh, asinh, atanh: hyperbolic trigonometric functions and inverse
    • +
  • fact n: factorial function. NOTE: n has to be an integer or be convertible to an integer type, i.e., fact 2 and fact 2.0 are fine but fact 2.1 is not.
    • -

    Furthermore, users can define any number of variables via

    +
    +
    +

    Variables

    +

    Users can define any number of variables via

    variable name = value

    where variable name can be any combination of alphanumeric characters but has to begin with a letter. Hence, foobar1 is fine, but 1foobar is not. Defined variables can be -used in expressions and definition of other variables.

    +used in expressions and definition of other variables. Users +can list all currently defined variables via \v (see +Command Shortcuts)

    Since husky uses the GNU readline library all readline related functionality is available at husky's interactive prompt (including command history). See [1] for more detail.

    +
    +

    Functions

    +

    Users can define their own custom functions via the syntax

    +
    +function <function name> <list of variables> = <expression>
    +

    Here, the list of variables can either be a comma separated list +of variable names enclosed in parentheses or a simple list of +variables separated by whitespace without parentheses like in +Haskell. The following expressions are valid and equivalent +function definitions

    +
    +f(x,y) = x * y
+f x y  = x * x
+
    +

    Several restrictions currently apply to function definitions:

    +
      +
    • <expression> can only span a single line and will be parsed +until the end of the line.
      • +
    • <expression> has to be a single expression, i.e., it can not +contain a list of semicolon separated expressions.
      • +
    +

    Functions which have been defined can then be called according to +the same conventions used for function definitions. Hence, function +f as defined above can be called via

    +
    +f(3,2) or f 3 2
    +

    Here, the calling method does not depend on the way the function +was defined, i.e., a function could be defined the Haskell way and +then be called via f(x,y). The function arguments can either be +literals or constants that have been defined previously. Hence, +the following husky session is valid

    +
    +a = 3
+b = 4
+function f x y = x * y
+f(a,b)
+
    +

    will yield the value "12.0".

    +

    Users can list all presently defined function via \f (see +Command Shortcuts).

    +
    +

    Unit Converter

    The unit conversion functionality of husky can be used via the @@ -367,6 +417,7 @@

    • \q : quit husky
    • \v : list all currently defined variables
      • +
    • \f : list all currently defined functions
    • \t : current time
    • \h[elp] : available help
    diff --git a/doc/usage.rst b/doc/usage.rst --- a/doc/usage.rst +++ b/doc/usage.rst @@ -4,7 +4,7 @@ :Author: Markus Dittrich -:Version: 0.3 (03/08/2008) +:Version: 0.4 (04/04/2009) Introduction @@ -28,6 +28,9 @@ Calculator ========== +Basic Functionality +################### + Currently, the mathematical operations "+", "-", "*", and "/" are supported with arbitrary nesting of parenthesised expressions. All calculations are performed in double @@ -40,22 +43,80 @@ - *ln, log2, log10* : natural, base2, and base10 logarithm - *cos, sin, tan, acos, asin, atan*: trigonometric functions and inverse - *cosh, sinh, tanh, acosh, asinh, atanh*: hyperbolic trigonometric functions and inverse +- *fact n*: factorial function. NOTE: *n* has to be an integer or be convertible to an integer type, i.e., *fact 2* and *fact 2.0* are fine but *fact 2.1* is not. -Furthermore, users can define any number of variables via +Variables +######### +Users can define any number of variables via + *variable name* = value where variable name can be any combination of alphanumeric characters but has to begin with a letter. Hence, *foobar1* is fine, but *1foobar* is not. Defined variables can be -used in expressions and definition of other variables. +used in expressions and definition of other variables. Users +can list all currently defined variables via \\v (see +`Command Shortcuts`_) Since husky uses the GNU readline library all readline related functionality is available at husky's interactive prompt (including command history). See [1]_ for more detail. + +Functions +######### + +Users can define their own custom functions via the syntax + + *function = * + +Here, the list of variables can either be a comma separated list +of variable names enclosed in parentheses or a simple list of +variables separated by whitespace without parentheses like in +Haskell. The following expressions are valid and equivalent +function definitions + +:: + + f(x,y) = x * y + f x y = x * x + +Several restrictions currently apply to function definitions: + +- ** can only span a single line and will be parsed + until the end of the line. +- ** has to be a single expression, i.e., it can **not** + contain a list of semicolon separated sub-expressions. + +Functions which have been defined can then be called according to +the same conventions used for function definitions. Hence, function +f as defined above can be called via + + f(3,2) or f 3 2 + +Here, the calling method does not depend on the way the function +was defined, i.e., a function could be defined the Haskell way and +then be called via f(x,y). The function arguments can either be +literals or constants that have been defined previously. Hence, +the following husky session is valid + +:: + + a = 3 + b = 4 + function f x y = x * y + f(a,b) + +will yield the value "12.0". + +Users can list all currently defined function via \\f (see +`Command Shortcuts`_). + + + Unit Converter ============== @@ -88,6 +149,7 @@ - \\q : quit husky - \\v : list all currently defined variables +- \\f : list all currently defined functions - \\t : current time - \\h[elp] : available help diff --git a/husky.cabal b/husky.cabal --- a/husky.cabal +++ b/husky.cabal @@ -1,5 +1,5 @@ Name: husky -Version: 0.3 +Version: 0.4 License: GPL license-file: COPYING copyright: (C) 2009 Markus Dittrich @@ -10,15 +10,15 @@ interactive shells of python, octave, or ruby. Author: Markus Dittrich Maintainer: Markus Dittrich -stability: alpha +stability: beta build-type: Simple Homepage: http://github.com/markusle/husky/tree/master -cabal-version: >= 1.2.1 +cabal-version: >= 1.6 extra-source-files: README Executable husky Build-Depends: base, readline >= 1.0.1.0, containers >= 0.1.0.0, - parsec >= 2.1.0.0, mtl >= 1.1.0.0, + parsec == 2.1.*, mtl >= 1.1.0.0, old-locale >= 1.0.0.0, time >= 1.0.0.0 ghc-options: -O2 Main-Is: husky.hs diff --git a/src/CalculatorParser.hs b/src/CalculatorParser.hs --- a/src/CalculatorParser.hs +++ b/src/CalculatorParser.hs @@ -32,70 +32,59 @@ import Prelude import TokenParser +--import Debug.Trace -- | grammar description for calculator parser -calculator_parser :: CharParser CalcState (Double, String) -calculator_parser = try ( define_variable >>= \x -> return (x,"") ) - <|> (add_term >>= \x -> end_of_line >> return (x,"") ) - "math expression, variable definition, " ++ - "variable name" +calculator_parser :: CharParser CalcState ParseResult +calculator_parser = parse_statements <* eof + "math expression, variable definition, " + ++ "variable name" +-- | parse individual statements separated by semicolon +-- NOTE: 'sepBy1' as opposed to 'sepBy' is crucial here to +-- guarantee the list is not empty; otherwise head will die +-- on us. +parse_statements :: CharParser CalcState ParseResult +parse_statements = (head . reverse) <$> individual_statement + `sepBy1` semi + "statement" + + +-- | parse an individual statement, i.e. either a computation +-- , a function definition, or a variable definition +individual_statement :: CharParser CalcState ParseResult +individual_statement = try define_function + <|> try (DblResult <$> define_variable) + <|> (DblResult <$> add_term) + "expression or variable definition" + + + -- | if the line starts off with a string we either -- have a variable definition or want to show the value -- stored in a variable define_variable :: CharParser CalcState Double -define_variable = (whiteSpace - >> variable - >>= \varName -> variable_def varName ) +define_variable = variable_def_by_value "variable definition" --- | check that we are at the end of the line; otherwise --- parsing failed since we always expect to parse the --- full expression -end_of_line :: CharParser CalcState () -end_of_line = getInput >>= \input -> - case length input of - 0 -> return () - _ -> pzero - - --- | define a variable -variable_def :: String -> CharParser CalcState Double -variable_def varName = ( whiteSpace - >> reservedOp "=" - >> whiteSpace - >> ( variable_def_by_value varName - <|> variable_def_by_var varName) ) - "variable" - - -- | define a variable via a literal double -variable_def_by_value :: String -> CharParser CalcState Double -variable_def_by_value varName = ( add_term - >>= \value -> updateState (insert_variable value varName) - >> return value ) - "variable from value" +variable_def_by_value :: CharParser CalcState Double +variable_def_by_value = update_var (whiteSpace *> variable) + (whiteSpace *> reservedOp "=" *> whiteSpace *> add_term) + "variable from value" --- | define a variable via the value of another variable -variable_def_by_var :: String -> CharParser CalcState Double -variable_def_by_var varName = parse_variable - >>= \value -> updateState (insert_variable value varName) - >> return value - +-- | update the state of a variable +update_var :: CharParser CalcState String + -> CharParser CalcState Double + -> CharParser CalcState Double +update_var name_p val_p = name_p + >>= \name -> val_p + >>= \val -> updateState (insert_variable name val) + >> return val --- | look for the value of a given variable if any -parse_variable :: CharParser CalcState Double -parse_variable = ( variable - >>= \val -> whiteSpace - >> get_variable_value val - >>= \result -> case result of - Just a -> return a - Nothing -> pzero ) - "variable" - -- | parser for expressions chained via "+" or "-" add_term :: CharParser CalcState Double @@ -109,71 +98,241 @@ -- | parser for potentiation operations "^" exp_term :: CharParser CalcState Double -exp_term = (whiteSpace >> factor) `chainl1` exp_action +exp_term = (whiteSpace *> factor) `chainl1` exp_action -- | parser for individual factors, i.e, numbers, -- variables or operations factor :: CharParser CalcState Double factor = try signed_parenthesis - <|> parse_keywords - <|> parse_number - <|> parse_variable + <|> try parse_user_functions + <|> parse_functions + <|> parse_functions_int + <|> try parse_single_number -- need try because of possible + -- unitary '-' + <|> try parse_stack -- always parse stack first since + -- local variables hide global ones + <|> parse_variable "token or variable" -- | parse a potentially signed expression enclosed in parenthesis. -- In the case of parenzised expressions we parse -() as (-1.0)*() signed_parenthesis :: CharParser CalcState Double -signed_parenthesis = parse_sign - >>= \sign -> parens add_term - >>= \result -> return (sign * result) +signed_parenthesis = (*) <$> parse_sign <*> parens add_term --- | parse all operations we currently know about -parse_keywords :: CharParser CalcState Double -parse_keywords = msum $ extract_ops builtinFunctions +-- | parse all operations of type (Double -> Double) +-- we currently know about +parse_functions :: CharParser CalcState Double +parse_functions = msum $ extract_ops builtinFunctions - where - extract_ops = foldr (\(x,y) acc -> - ((reserved x >> execute y):acc)) [] + where + extract_ops = foldr (\(x,y) acc -> + ((reserved x *> execute y):acc)) [] + execute op = op <$> ( parens add_term + <|> parse_single_number + <|> parse_variable ) + "function parsing" --- | execute the requested operator on the term enclosed --- in parentheses -execute :: OperatorAction -> CharParser CalcState Double -execute op = parens add_term >>= return . op +-- | parse all operations of type (Int -> Int) we currently know about +-- NOTE: They way we do things right now to deal with Integers +-- in the framework of our Double parser is somewhat of a +-- hack. In a nutshell, we check if a Double can be interpreted +-- as an Integer and then use (of fail the parse) +parse_functions_int :: CharParser CalcState Double +parse_functions_int = msum $ extract_ops_int builtinFunctionsInt - + where + extract_ops_int :: [(String, Integer -> Integer)] + -> [CharParser CalcState Double] + extract_ops_int = foldr (\(x,y) acc -> + ((reserved x *> execute_int y):acc)) [] + + execute_int op = fromInteger . op <$> ( parens add_term + <|> parse_single_number + <|> parse_variable + >>= evaluate_int ) + + evaluate_int = \val -> case is_non_negative_int val of + Just a -> return a + Nothing -> pzero + "non-negative integer value" + + +-- | chain multiplicative of divisive statements multiply_action :: CharParser CalcState (Double -> Double -> Double) -multiply_action = (reservedOp "*" >> return (*)) - <|> (reservedOp "/" >> return (/)) +multiply_action = (reservedOp "*" *> pure (*)) + <|> (reservedOp "/" *> pure (/)) +-- | chain additive or subtractive statements add_action :: CharParser CalcState (Double -> Double -> Double) -add_action = (reservedOp "+" >> return (+)) - <|> (reservedOp "-" >> return (-)) +add_action = (reservedOp "+" *> pure (+)) + <|> (reservedOp "-" *> pure (-)) +-- | parse an exponentiation term exp_action :: CharParser CalcState (Double -> Double -> Double) -exp_action = reservedOp "^" >> return real_exp +exp_action = reservedOp "^" *> pure real_exp +-- | parse a single number; integers are automatically promoted +-- to double +-- NOTE: Due to the notFollowedBy this parser can not be used +-- with 'many' and other parser combinators. +parse_single_number :: CharParser CalcState Double +parse_single_number = parse_number <* notFollowedBy alphaNum + "signed single integer or double" + + +-- | parse a number, can be used with 'many' and other parser +-- combinators; integers are automatically promoted to double parse_number :: CharParser CalcState Double -parse_number = parse_sign - >>= \sign -> naturalOrFloat - >>= \num -> notFollowedBy alphaNum - >> case num of - Left i -> return $ sign * (fromInteger i) - Right x -> return (sign * x) +parse_number = converter <$> (parse_sign <* whiteSpace) <*> + naturalOrFloat + "signed integer or double" + where + converter sign val = case val of + Left i -> sign * (fromInteger i) + Right x -> sign * x +-- | parse the sign of a numerical expression parse_sign :: CharParser CalcState Double -parse_sign = option 1.0 ( whiteSpace >> char '-' >> return (-1.0) ) +parse_sign = option 1.0 ( whiteSpace *> char '-' *> pure (-1.0) ) +-- | look for the value of a given variable if any +parse_variable :: CharParser CalcState Double +parse_variable = (*) <$> (parse_sign <* whiteSpace) <*> + (get_variable_value variable <* whiteSpace) + "variable" + + -- | function retrieving a variable from the database if -- present -get_variable_value :: String -> CharParser CalcState (Maybe Double) -get_variable_value name = getState - >>= \(CalcState { varMap = myMap }) -> return $ M.lookup name myMap +get_variable_value :: CharParser CalcState String + -> CharParser CalcState Double +get_variable_value name_parser = getState + >>= \(CalcState { varMap = myMap }) -> name_parser + >>= \name -> case M.lookup name myMap of + Nothing -> pzero + Just a -> return a + + +-- | this is how valid variable names have to look like +variable :: CharParser CalcState String +variable = (:) <$> letter <*> many alphaNum + + +-- | look for the value of a given stack variable +parse_stack :: CharParser CalcState Double +parse_stack = (*) <$> (parse_sign <* whiteSpace) <*> + (get_stack_variable variable <* whiteSpace) + "variable" + + +-- | function retrieving a variable from the database if +-- present +get_stack_variable :: CharParser CalcState String + -> CharParser CalcState Double +get_stack_variable name_parser = getState + >>= \(CalcState { funcStack = stack }) -> name_parser + >>= \name -> case M.lookup name stack of + Nothing -> pzero + Just a -> return a + + +-- | this is how valid function Strings have to look like +functionString :: CharParser CalcState String +functionString = many anyChar + + +-- | parser for a function definition +-- TODO: It might be a good idea to check the user defined +-- function somewhat, e.g., do the parameters match etc +define_function :: CharParser CalcState ParseResult +define_function = add_function parse_function_name parse_vars + parse_function_def + *> pure (StrResult "") + + where + add_function name_parser var_parser expr_parser = + join $ updateState <$> + (insert_function <$> name_parser <*> var_parser <*> expr_parser) + + + parse_function_name = (whiteSpace *> reserved "function" + *> whiteSpace *> variable <* whiteSpace) + + + -- | we allow both f(x,y) and haskell style f x y function + -- definitions + parse_vars = (parens ((variable <* whiteSpace) `sepBy` comma)) + <|> many (variable <* whiteSpace) + + + parse_function_def = (whiteSpace *> reservedOp "=" *> whiteSpace + *> functionString) + + +-- | parse available user function; the way we deal with user +-- functions for now goes like this: +-- 1) Check if a user function of the given name exists +-- 2) If yes, check if the user supplied the proper number of +-- arguments (for now we only allow literals, not variables) +-- 3) If yes, replace the variables by the literals in the function +-- string. +-- 4) Insert the so manipulated and parenthesized function +-- expression into the current parser and parse it +parse_user_functions :: CharParser CalcState Double +parse_user_functions = + substitute_function parse_function_name parse_arguments + + where + -- | arguments can either be applied via f(x,y) or the haskell + -- way f x y + parse_arguments = parens ((parse_arg <* whiteSpace) `sepBy` comma) + <|> many ( parse_arg <* whiteSpace ) + + where + parse_arg = (parse_number <|> parse_variable) + + + parse_function_name = (whiteSpace *> variable <* whiteSpace) + + + -- | substitute a function expression into the current parse + -- string + substitute_function name_parser var_parser = name_parser + >>= get_function_expression + >>= \(Function { f_vars = target_vars + , f_expression = expr } ) -> var_parser + >>= \vars -> push_vars_to_stack vars target_vars + >> getInput + >>= \inp -> setInput ("(" ++ expr ++ ")" ++ inp) + >> parens add_term + >>= \result -> updateState clear_stack + >> return result + + + -- | retrieve the function expression corresponding to a + -- particular function name + get_function_expression name = getState + >>= \(CalcState { funcMap = myMap }) -> + case M.lookup name myMap of + Nothing -> pzero + Just a -> return a + + + -- | check if the number of expected and provided arguments + -- match and push the variables on the local stack so the + -- parser can replace the parameters while parsing + push_vars_to_stack vars target_vars = + if length vars /= length target_vars + then pzero + else mapM_ (updateState . push_to_stack) + (zip target_vars vars) + diff --git a/src/CalculatorState.hs b/src/CalculatorState.hs --- a/src/CalculatorState.hs +++ b/src/CalculatorState.hs @@ -22,11 +22,12 @@ -- the calculator. Eventually, these might all find a home -- in their separate modules module CalculatorState ( CalcState(..) - , have_special_error + , clear_stack , defaultCalcState - , insert_error + , Function(..) + , insert_function , insert_variable - , reset_state + , push_to_stack ) where @@ -35,6 +36,16 @@ import Prelude +-- | this data structure holds information for user defined +-- functions +data Function = Function + { + f_vars :: [String] + , f_expression :: String + } + deriving(Show) + + -- | this data structure provides some state information -- to the calculator (variables, etc ...) -- Currently, we thread the following pieces of information: @@ -45,43 +56,49 @@ -- errValue : [String] holding all special error messages data CalcState = CalcState { - varMap :: M.Map String Double - , errValue :: [String] + varMap :: M.Map String Double + , funcMap :: M.Map String Function + , funcStack :: M.Map String Double -- local stack for passing + -- function parameters } defaultCalcState :: CalcState defaultCalcState = CalcState { - varMap = M.fromList constantList - , errValue = [] + varMap = M.fromList constantList + , funcMap = M.empty + , funcStack = M.empty } --- | function returning special error message if present -have_special_error :: CalcState -> Maybe String -have_special_error (CalcState { errValue = msg }) = - if (null msg) - then Nothing - else Just . unlines $ msg +-- | function pushing a variable on the stack +push_to_stack :: (String,Double) -> CalcState -> CalcState +push_to_stack (name,val) state@(CalcState {funcStack = stack}) = + state { funcStack = M.insert name val stack } --- | function adding a new variable to the database -insert_variable :: Double -> String -> CalcState -> CalcState -insert_variable num name state@(CalcState { varMap = theMap }) = - state { varMap = M.insert name num theMap } +-- | function for clearing the stack +clear_stack :: CalcState -> CalcState +clear_stack state = state { funcStack = M.empty } --- | function inserting a new special error message into --- the error queue -insert_error :: String -> CalcState -> CalcState -insert_error err state@(CalcState { errValue = val }) = - state { errValue = err:val } - --- | function resetting the special error queue -reset_state :: CalcState -> CalcState -reset_state state = state { errValue = [] } +-- | function adding a new variable into the calculator state +-- database +insert_variable :: String -> Double -> CalcState -> CalcState +insert_variable name num state@(CalcState {varMap = theMap}) = + state { varMap = M.insert name num theMap } + + +-- | insert a user definied function into the calculator state +-- database +insert_function :: String -> [String] -> String -> CalcState + -> CalcState +insert_function name vars expr state@(CalcState {funcMap = theMap}) = + state { funcMap = M.insert name theFunc theMap } + where + theFunc = Function { f_vars = vars, f_expression = expr } -- | provide a few useful mathematical constants that we diff --git a/src/ExtraFunctions.hs b/src/ExtraFunctions.hs --- a/src/ExtraFunctions.hs +++ b/src/ExtraFunctions.hs @@ -19,9 +19,11 @@ --------------------------------------------------------------------} --- | definition of a few additional helper function (e.g. from libc) -module ExtraFunctions ( real_exp +-- | definition of additional math and helper functions +module ExtraFunctions ( fact , is_equal + , is_non_negative_int + , real_exp ) where @@ -35,11 +37,27 @@ dbl_epsilon :: Double dbl_epsilon = 2.2204460492503131e-16 + -- | comparison function for doubles via dbl_epsion is_equal :: Double -> Double -> Bool is_equal x y = abs(x-y) <= abs(x) * dbl_epsilon +-- | function checking if a Double can be interpreted as a non +-- negative Integer. We need this since all parsing of numbers +-- is done with Doubles but some functions only work for +-- non-negative integers such as factorial. +-- To check if we are dealing with Double, we convert to an +-- Integer via floor and the compare if the numbers are identical. +-- If yes, the number seems to be an Integer and we return it, +-- otherwise Nothing +is_non_negative_int :: Double -> Maybe Integer +is_non_negative_int x = + case is_equal (fromInteger . floor $ x) x of + True -> Just $ floor x + False -> Nothing + + -- | helper function for defining real powers -- NOTE: We use glibc's pow function since it is more -- precise than implementing it ourselves via, e.g., @@ -47,5 +65,11 @@ foreign import ccall "math.h pow" c_pow :: CDouble -> CDouble -> CDouble -real_exp :: Double -> Double -> Double +real_exp :: Double -> Double -> Double real_exp a x = realToFrac $ c_pow (realToFrac a) (realToFrac x) + + +-- | factorial function +fact :: Integer -> Integer +fact 0 = 1 +fact n = n * fact (n-1) diff --git a/src/HelpParser.hs b/src/HelpParser.hs --- a/src/HelpParser.hs +++ b/src/HelpParser.hs @@ -27,6 +27,7 @@ -- local imports import CalculatorState +import Messages import Prelude import PrettyPrint import TokenParser @@ -36,13 +37,13 @@ -- | main help parser entry point help :: CharParser CalcState String -help = ( help_keyword - >> optionMaybe parse_help_option - >>= \opt -> case opt of - Nothing -> return help_info - Just r -> return r ) +help = eval_request <$> (help_keyword + *> optionMaybe parse_help_option) "help" - + where + eval_request x = case x of + Nothing -> help_info + Just r -> r -- | parser for help keyword @@ -61,22 +62,33 @@ -- | retrieve unit conversion information unit_info :: CharParser CalcState String -unit_info = ( string "units" - >> optionMaybe parse_unit_type - >>= \unitType -> return $ retrieve_unit_string unitType) +unit_info = retrieve_unit_string <$> (string "units" + *> optionMaybe parse_unit_type) "unit info" -- | return about info about_info :: CharParser CalcState String about_info = string "about" - >> return about_string + >> return infoString "about info" - where - about_string = "husky (v0.3) (C) 2009 Markus Dittrich\n" - ++ "husky is licenced under the GPL V3\n" +-- | return info about available commands +command_info :: CharParser CalcState String +command_info = string "commands" *> pure commandString + "command info" + + +-- | currently available commands +commandString :: String +commandString = (color_string Yellow $ "Available commands:\n") + ++ "\\q - quit\n" + ++ "\\t - show current date and time\n" + ++ "\\v - list currently defined variables\n" + ++ "\\f - list currently defined functions\n" + + -- | return all currently available help options help_info :: String help_info = (color_string Yellow $ "Available help options" @@ -90,6 +102,7 @@ -- together with a parser for that particular help option helpOptions :: [(String, CharParser CalcState String)] helpOptions = [ ("about - about husky", about_info) - , ("units [:: ] - list available unit " + , ("commands - list commands", command_info) + , ("conversion [:: ] - list available unit " ++ "conversions", unit_info) ] diff --git a/src/InfoRoutines.hs b/src/InfoRoutines.hs --- a/src/InfoRoutines.hs +++ b/src/InfoRoutines.hs @@ -21,15 +21,19 @@ -- | routines called from the toplevel readline instance without -- before any parsing is done, aka info routines of any sort and -- shape -module InfoRoutines ( list_variables +module InfoRoutines ( confirm_and_exit + , list_functions + , list_variables , show_time ) where -- imports +import Data.List import Data.Map import Data.Time import Prelude +import System.IO import System.Locale @@ -39,13 +43,27 @@ -- | list all currently defined variables list_variables :: CalcState -> IO () -list_variables (CalcState { varMap = theMap }) = +list_variables (CalcState {varMap = theMap}) = mapM_ print_variable (assocs theMap) where - print_variable x = putStrLn (fst x ++ " == " ++ (show $ snd x)) + print_variable (x,y) = putStrLn (x ++ " == " ++ (show y)) +-- | list all currently defined functions +list_functions :: CalcState -> IO () +list_functions (CalcState {funcMap = theMap} ) = + mapM_ print_function (assocs theMap) + + where + print_function ( x + , (Function { f_vars = vars + , f_expression = expr } + ) + ) = + putStrLn (x ++ "(" ++ intercalate [','] vars ++ ") = " ++ expr) + + -- | display the current localtime show_time :: IO () show_time = getCurrentTime @@ -54,7 +72,17 @@ let localTime = utcToLocalTime zone utcTime timeString = formatTime defaultTimeLocale - "%a %b %m %Y <> %T %Z " localTime + "%a %b %d %Y <> %T %Z " localTime in putStrLn timeString + +-- | ask user for confirmation before exiting +confirm_and_exit :: IO Bool +confirm_and_exit = putStr "Really quit (y/n)? " + >> hFlush stdout + >> getLine + >>= \answer -> case answer of + "y" -> return True + "n" -> return False + _ -> confirm_and_exit diff --git a/src/Messages.hs b/src/Messages.hs --- a/src/Messages.hs +++ b/src/Messages.hs @@ -20,6 +20,7 @@ -- | Messages provides common messages module Messages ( husky_result + , infoString , print_error_message , show_greeting ) where @@ -32,11 +33,17 @@ import PrettyPrint --- current version +-- | current version version :: String -version = "0.3" +version = "0.4" +-- | info string +infoString :: String +infoString = "Welcome to husky (v" ++ version ++ ")\n" + ++ "(C) 2009 Markus Dittrich, licensed under the GPL-3\n" + ++ "husky comes WITHOUT ANY WARRANTY\n" + -- | display output somewhat colorful husky_result :: [String] -> IO () husky_result items = do @@ -46,11 +53,9 @@ -- | greeting show_greeting :: IO () -show_greeting = do - putStrLn $ "Welcome to husky (v" ++ version - ++ ") (C) 2009 Markus Dittrich" - putStrLn "-------------------------------------------------" - +show_greeting = putStrLn $ banner ++ "\n" ++ infoString ++ banner + where + banner = replicate 60 '*' -- | helpful message after bad parse print_error_message :: String -> IO () diff --git a/src/Parser.hs b/src/Parser.hs --- a/src/Parser.hs +++ b/src/Parser.hs @@ -31,17 +31,17 @@ -- | main parser entry point -main_parser :: CharParser CalcState ((Double,String), CalcState) -main_parser = parser_dispatch - >>= \val -> getState - >>= \state -> return (val, state) +main_parser :: CharParser CalcState (ParseResult, CalcState) +main_parser = (,) <$> parser_dispatch <*> getState + "main parser" -- | grammar description for parser -- presently we either dispatch to unit_conversion parser -- or calculator parser -parser_dispatch :: CharParser CalcState (Double,String) +parser_dispatch :: CharParser CalcState ParseResult parser_dispatch = try unit_conversion <|> calculator_parser "unit conversion or calculator expression" + diff --git a/src/TokenParser.hs b/src/TokenParser.hs --- a/src/TokenParser.hs +++ b/src/TokenParser.hs @@ -19,69 +19,82 @@ --------------------------------------------------------------------} -- | functionality related to parsing tokens -module TokenParser ( module Text.ParserCombinators.Parsec +module TokenParser ( module Control.Applicative + , module Text.ParserCombinators.Parsec , builtinFunctions + , builtinFunctionsInt + , comma + , charLiteral , float - , identifier , integer , parens + , keywords , lexer , naturalOrFloat - , keywords , OperatorAction + , ParseResult(..) , operators , reservedOp , reserved + , semi , stringLiteral - , unit_value - , unit_type - , variable , whiteSpace ) where -- imports -import Text.ParserCombinators.Parsec +import Control.Applicative +import Control.Monad (ap, MonadPlus (..)) +import Prelude +import Text.ParserCombinators.Parsec hiding (many,optional, (<|>)) import qualified Text.ParserCombinators.Parsec.Token as PT import Text.ParserCombinators.Parsec.Language (haskellDef , opLetter , reservedOpNames , reservedNames ) -import Prelude -- local imports -import CalculatorState +import ExtraFunctions -{- | some basic definitions for the calculator -} +{- Definitions for Applicative Parsec instance -} --- | this is how valid variable names have to look like -variable :: CharParser CalcState String -variable = letter - >>= \first -> many alphaNum - >>= \rest -> return $ [first] ++ rest +-- | Applicative instance for Monad +instance Applicative (GenParser s a) where + pure = return + (<*>) = ap --- | an identifier for a unit_value and unit_type is just a variable --- (at least for now). -unit_value :: CharParser CalcState String -unit_value = variable +-- |Alternative instance for MonadPlus +instance Alternative (GenParser s a) where + empty = mzero + (<|>) = mplus -unit_type :: CharParser CalcState String -unit_type = variable +{- define possible Parse Results -} +data ParseResult = + DblResult Double -- double result + | UnitResult (Double,String) -- unit conversion result + | StrResult String -- no result (e.g. function def) + | ErrResult String -- error occured, has error message + deriving(Eq,Show,Ord) + + +{- set up the Token Parser -} + -- | these are all the names and corresponding functions -- of keywords we know about -type OperatorAction = (Double -> Double) +type OperatorAction = (Double -> Double) +type OperatorActionInt = (Integer -> Integer) --- | builtin functions of the form (a -> b) +-- | builtin functions of the form (Double -> Double) builtinFunctions :: [(String, OperatorAction)] builtinFunctions = [ ("sqrt",sqrt) - , ("exp",exp) + , ("exp",exp) , ("log",log) , ("log2", logBase 2) , ("log10", logBase 10) @@ -96,27 +109,34 @@ , ("tanh", tanh) , ("asinh", sinh) , ("acosh", cosh) - , ("atanh", atanh)] + , ("atanh", atanh)] +-- | builtin function of the type (Integer -> Double) that need +-- type conversion from Int to Double. This is a separate category +-- since in the parser we need to explicitly check the the +-- user entered an Int and fail otherwise +builtinFunctionsInt :: [(String, OperatorActionInt)] +builtinFunctionsInt = [("fact", fact)] + + -- | all other keywords that are not regular functions keywords :: [String] -keywords = ["\\convert","\\c"] +keywords = ["convert","conv","function","end"] operators :: [String] operators = ["*","/","+","-","="] -{- | prepare needed parsers from Parsec.Token -} - -- | function generating a token parser based on a -- lexical parser combined with a language record definition lexer :: PT.TokenParser st lexer = PT.makeTokenParser ( haskellDef { reservedOpNames = operators - , opLetter = oneOf "*+/^" - , reservedNames = keywords - ++ map fst builtinFunctions + , opLetter = oneOf "*+/^" + , reservedNames = keywords + ++ map fst builtinFunctions + ++ map fst builtinFunctionsInt } ) @@ -136,8 +156,8 @@ -- | token parser for Char -identifier :: CharParser st String -identifier = PT.stringLiteral lexer +charLiteral :: CharParser st Char +charLiteral = PT.charLiteral lexer -- | token parser for Double @@ -161,3 +181,13 @@ -- | token parser for whitespace whiteSpace :: CharParser st () whiteSpace = PT.whiteSpace lexer + +-- | token parser for semicolon +semi :: CharParser st String +semi = PT.semi lexer + + +-- | token parser for comma +comma :: CharParser st String +comma = PT.comma lexer + diff --git a/src/UnitConversionParser.hs b/src/UnitConversionParser.hs --- a/src/UnitConversionParser.hs +++ b/src/UnitConversionParser.hs @@ -31,68 +31,65 @@ import UnitConverter +-- | an identifier for a unit_value and unit_type +unit_value :: CharParser CalcState String +unit_value = unit_variable + +unit_type :: CharParser CalcState String +unit_type = unit_variable + +unit_variable :: CharParser CalcState String +unit_variable = letter + >>= \first -> many alphaNum + >>= \rest -> return $ [first] ++ rest + + -- | parser for unit conversions -- the user can request a conversion between two compatible -- unit-full values (temperatures, lengths, ...). -- The command spec is -- conv [ :: ] -- and returns -unit_conversion :: CharParser CalcState (Double,String) -unit_conversion = (whiteSpace - >> conversion_keyword - >> whiteSpace - >> parse_unit_value - >>= \value -> whiteSpace - >> unit_value - >>= \unit1 -> whiteSpace - >> unit_value - >>= \unit2 -> whiteSpace - >> optionMaybe parse_unit_type - >>= \unitType -> - case convert_unit unit1 unit2 unitType value of - Left err -> add_error_message err - >> return (0,"") - Right (conv, unit) -> return (conv,unit) ) - "unit conversion" - +unit_conversion :: CharParser CalcState ParseResult +unit_conversion = whiteSpace *> conversion_keyword *> + ( converter + <$> (whiteSpace *> parse_unit_value) + <*> (whiteSpace *> unit_value) + <*> (whiteSpace *> unit_value) + <*> (whiteSpace *> optionMaybe parse_unit_type) ) + where + converter val u1 u2 utype = case convert_unit val u1 u2 utype of + Left err -> ErrResult err + Right (conv,unit) -> UnitResult (conv,unit) + + -- | parse a unit value -- We can't use parse_number since we'd like to explictly allow -- things like 1m or 2yd which parse_number rejects parse_unit_value :: CharParser CalcState Double -parse_unit_value = parse_sign - >>= \sign -> naturalOrFloat - >>= \num -> case num of - Left i -> return $ sign * (fromInteger i) - Right d -> return (sign * d) +parse_unit_value = converter <$> parse_sign <*> naturalOrFloat + where + converter sign val = case val of + Left i -> sign * (fromInteger i) + Right x -> sign * x -- | parse the optional sign in front of a unit value parse_sign :: CharParser CalcState Double -parse_sign = option 1.0 ( whiteSpace >> char '-' >> return (-1.0) ) +parse_sign = option 1.0 ( whiteSpace *> char '-' *> pure (-1.0) ) -- | parse for all acceptable conversion keywords conversion_keyword :: CharParser CalcState () -conversion_keyword = reserved "\\c" - <|> reserved "\\convert" +conversion_keyword = reserved "conv" + <|> reserved "convert" "(c)onv keyword" --- | this function adds an error message to the queue of --- special (outside of parsing errors) to the error --- queue -add_error_message :: String -> CharParser CalcState () -add_error_message = updateState . insert_error - - -- | this parser parses an (optional) unit type signature following -- a unit conversion statement. It should be of the form -- (a la Haskell ;) ) " :: unit_type " parse_unit_type :: CharParser CalcState String -parse_unit_type = (whiteSpace - >> string "::" - >> whiteSpace - >> unit_type ) +parse_unit_type = whiteSpace *> string "::" *> whiteSpace *> unit_type "unit_type" - diff --git a/src/UnitConverter.hs b/src/UnitConverter.hs --- a/src/UnitConverter.hs +++ b/src/UnitConverter.hs @@ -40,9 +40,9 @@ -- with a hopefully useful error message. -- 2) If a user supplies a unit type specifier we directly look -- through the corresponding map for a conversion -convert_unit :: String -> String -> Maybe String -> Double +convert_unit :: Double -> String -> String -> Maybe String -> Either String (Double,String) -convert_unit unit1 unit2 unitType value = +convert_unit value unit1 unit2 unitType = case unitType of -- no unit type specifier: look through all unit maps diff --git a/src/husky.hs b/src/husky.hs --- a/src/husky.hs +++ b/src/husky.hs @@ -51,23 +51,34 @@ input <- readline $ color_string Red "husky> " case input of Nothing -> parse_it state - Just "" -> parse_it state -- continue without parsing - Just "\\q" -> return () -- quit - Just "\\v" -> list_variables state -- list all defined variables - >> parse_it state - Just "\\t" -> show_time -- show current time + + Just "" -> parse_it state -- continue w/o parsing + + Just "\\q" -> confirm_and_exit + >>= \ans -> case ans of -- quit after confirmation + True -> return () -- otherwise continue + False -> parse_it state + + Just "\\v" -> list_variables state -- list all defined + >> parse_it state -- variables + + Just "\\f" -> list_functions state -- list all defined + >> parse_it state -- functions + + Just "\\t" -> show_time -- show current time >> parse_it state - Just line -> do -- otherwise calculate + Just line -> do -- otherwise calculate + addHistory line - -- parse it as a potential help request - -- if it succeeds we parse the next command line, otherwise - -- we channel it into the calculator parser + {- parse it as a potential help request if it succeeds we + parse the next command line, otherwise we channel it + into the calculator parser -} case runParser help state "" line of Right helpMsg -> putStr helpMsg >> parse_it state - Left _ -> + Left _ -> -- parse it as a calculation or unit conversion case runParser main_parser state "" line of @@ -75,16 +86,17 @@ Left er -> print_error_message (show er) >> parse_it state - -- if the parser succeeds we still check for special - -- error conditions in our parse state that may have - -- been triggered by errors outside the parser (e.g., - -- unit conversion may have failed for lack of proper - -- conversion function etc.) - Right ((result,unit), newState) -> - case have_special_error newState of - Just err -> (putStr $ "Error: " ++ err) - Nothing -> husky_result $ (show result):[unit] + {- if the parser succeeds we do one of the following: + 1) If the return value is a DblResult or UnitResult we + just print it + 2) If the return value is a ErrResult we print the + the associated error string -} + Right (result, newState) -> + case result of + DblResult d -> husky_result $ (show d):[""] + UnitResult (v,u) -> husky_result $ (show v):[u] + ErrResult err -> (putStrLn $ "Error: " ++ err) + StrResult str -> husky_result $ str:[""] - >> let cleanState = reset_state newState in - parse_it cleanState + >> parse_it newState diff --git a/test/CalculatorTest.hs b/test/CalculatorTest.hs --- a/test/CalculatorTest.hs +++ b/test/CalculatorTest.hs @@ -47,18 +47,27 @@ simpleTests status1 <- examine_output simple + putStr $ color_string Cyan "\nFunction parsing tests:\n" + let vars = execWriter $ good_test_driver defaultCalcState + functionTests + status2 <- examine_output vars + putStr $ color_string Cyan "\nVariable tests:\n" let vars = execWriter $ good_test_driver defaultCalcState variableTests - status2 <- examine_output vars + status3 <- examine_output vars putStr $ color_string Cyan "\nFailure tests:\n" let failing = execWriter $ failing_test_driver defaultCalcState failingTests - status2 <- examine_output failing + status4 <- examine_output failing + putStr $ color_string Cyan "\nUser defined function tests:\n" + let userFuncs = execWriter $ good_test_driver defaultCalcState + userFunctionTests + status5 <- examine_output userFuncs - let status = status1 && status2 + let status = status1 && status2 && status3 && status4 && status5 if status == True then exitWith ExitSuccess else @@ -105,24 +114,40 @@ let expected = snd x case runParser main_parser state "" tok of Left er -> tell [TestResult False tok (show expected) (show er)] - Right ((result,_), newState) -> examine_result expected result tok + Right (result, newState) -> examine_result expected result tok where - -- NOTE: when we compare target and actual result we - -- probably need to be more careful and can't use == - -- if we are dealing with Doubles!!! - examine_result :: Double -> Double -> String + -- for comparing doubles we use is_equal otherwise we + -- go with good old == + examine_result :: ParseResult -> ParseResult -> String -> Writer [TestResult] () - examine_result target actual tok = + examine_result (DblResult target) (DblResult actual) tok = if (is_equal target actual) - then do + then success target actual + else failure target actual + + examine_result target actual tok = + if target == actual + then success target actual + else failure target actual + + + {- then do tell [TestResult True tok (show target) (show actual)] good_test_driver newState xs else do tell [TestResult False tok (show target) (show actual)] - good_test_driver newState xs + good_test_driver newState xs -} + success target actual = do + tell [TestResult True tok (show target) (show actual)] + good_test_driver newState xs + failure target actual = do + tell [TestResult False tok (show target) (show actual)] + good_test_driver newState xs + + -- | main test routine for "failing tests" failing_test_driver :: CalcState -> [FailingTestCase] -> Writer [TestResult] () @@ -151,7 +176,7 @@ -- | a good test case consists of an expression and an -- expected result -type GoodTestCase = (String, Double) +type GoodTestCase = (String, ParseResult) -- | a failing test case currently consists only of an @@ -178,141 +203,240 @@ , simpleTest15, simpleTest16, simpleTest17 , simpleTest18, simpleTest19, simpleTest20 , simpleTest21, simpleTest22, simpleTest23 - , simpleTest24, simpleTest25, simpleTest26] - + , simpleTest24, simpleTest25, simpleTest26 + , simpleTest27, simpleTest28, simpleTest29 + , simpleTest30, simpleTest31, simpleTest32 + , simpleTest33, simpleTest34] -- list of simple tests simpleTest1 :: GoodTestCase -simpleTest1 = ("3+4", 7.0) +simpleTest1 = ("3+4", DblResult 7.0) simpleTest2 :: GoodTestCase -simpleTest2 = ("3*3", 9.0) +simpleTest2 = ("3*3", DblResult 9.0) simpleTest3 :: GoodTestCase -simpleTest3 = ("(3*3)+(3*4)", 21.0) +simpleTest3 = ("(3*3)+(3*4)", DblResult 21.0) simpleTest4 :: GoodTestCase -simpleTest4 = ("(3.0*3.0)+(3.0*4.0)", 21.0) +simpleTest4 = ("(3.0*3.0)+(3.0*4.0)", DblResult 21.0) simpleTest5 :: GoodTestCase -simpleTest5 = ("(3+3)*(9+8)", 102.0) +simpleTest5 = ("(3+3)*(9+8)", DblResult 102.0) simpleTest6 :: GoodTestCase -simpleTest6 = ("(3.0+3.0)*(9.0+8.0)", 102.0) +simpleTest6 = ("(3.0+3.0)*(9.0+8.0)", DblResult 102.0) simpleTest7 :: GoodTestCase -simpleTest7 = ("(((((((3.0+3.0)*(9.0+8.0)))))))", 102.0) +simpleTest7 = ("(((((((3.0+3.0)*(9.0+8.0)))))))", DblResult 102.0) simpleTest8 :: GoodTestCase -simpleTest8 = ("(((((((3.0+3.0)))))*(((((9.0+8.0)))))))", 102.0) +simpleTest8 = ("(((((((3.0+3.0)))))*(((((9.0+8.0)))))))" + , DblResult 102.0) simpleTest9 :: GoodTestCase -simpleTest9 = ("3+3*99.0", 300.0) +simpleTest9 = ("3+3*99.0", DblResult 300.0) simpleTest10 :: GoodTestCase -simpleTest10 = ("3+3*8+4*3*2+1*4*3+5", 68.0) +simpleTest10 = ("3+3*8+4*3*2+1*4*3+5", DblResult 68.0) simpleTest11 :: GoodTestCase -simpleTest11 = ("(3+3)*(8+4)*3*(2+1)*4*(3+5)", 20736.0) +simpleTest11 = ("(3+3)*(8+4)*3*(2+1)*4*(3+5)", DblResult 20736.0) simpleTest12 :: GoodTestCase -simpleTest12 = (" 3 +3* 99.0", 300.0) +simpleTest12 = (" 3 +3* 99.0", DblResult 300.0) simpleTest13 :: GoodTestCase -simpleTest13 = (" 3 + 3*8+4 *3 *2+1* 4*3+5 ", 68.0) +simpleTest13 = (" 3 + 3*8+4 *3 *2+1* 4*3+5 ", DblResult 68.0) simpleTest14 :: GoodTestCase -simpleTest14 = ("(3+3) *(8+4)*3 * (2+1 )*4*( 3+5)", 20736.0) +simpleTest14 = ("(3+3) *(8+4)*3 * (2+1 )*4*( 3+5)" + , DblResult 20736.0) simpleTest15 :: GoodTestCase -simpleTest15 = ("3*-4", -12.0) +simpleTest15 = ("3*-4", DblResult (-12.0)) simpleTest16 :: GoodTestCase -simpleTest16 = ("3* -4", -12.0) +simpleTest16 = ("3* -4", DblResult (-12.0)) simpleTest17 :: GoodTestCase -simpleTest17 = ("-3*4", -12.0) +simpleTest17 = ("-3*4", DblResult (-12.0)) simpleTest18 :: GoodTestCase -simpleTest18 = ("-3*-4", 12.0) +simpleTest18 = ("-3*-4", DblResult 12.0) simpleTest19 :: GoodTestCase -simpleTest19 = ("3*(-4)", -12.0) +simpleTest19 = ("3*(-4)", DblResult (-12.0)) simpleTest20 :: GoodTestCase -simpleTest20 = ("(-3)*(-4)", 12.0) +simpleTest20 = ("(-3)*(-4)", DblResult 12.0) simpleTest21 :: GoodTestCase -simpleTest21 = ("3/-4", -0.75) +simpleTest21 = ("3/-4", DblResult (-0.75)) simpleTest22 :: GoodTestCase -simpleTest22 = ("3^-4", 1/81) +simpleTest22 = ("3^-4", DblResult (1/81)) simpleTest23 :: GoodTestCase -simpleTest23 = ("-3*-4^-4", -3/256) +simpleTest23 = ("-3*-4^-4", DblResult (-3/256)) simpleTest24 :: GoodTestCase -simpleTest24 = ("-3+-4", -7) +simpleTest24 = ("-3+-4", DblResult (-7)) simpleTest25 :: GoodTestCase -simpleTest25 = ("-1/-1/-1/-1", 1.0) +simpleTest25 = ("-1/-1/-1/-1", DblResult 1.0) simpleTest26 :: GoodTestCase -simpleTest26 = ("-(-(-1))", -1) +simpleTest26 = ("-(-(-1))", DblResult (-1)) +simpleTest27 :: GoodTestCase +simpleTest27 = ("3/-4; -1/-1/-1/-1; -3*-4^-4", DblResult (-3/256)) +simpleTest28 :: GoodTestCase +simpleTest28 = ("3*3; 4+5; 34 * 34 ; 3^-4", DblResult (1/81)) + +simpleTest29 :: GoodTestCase +simpleTest29 = ("3*3;4*4;-3*-4^-4", DblResult (-3/256)) + +simpleTest30 :: GoodTestCase +simpleTest30 = (" 3; 3+4; 4*2 ; -3+-4", DblResult (-7)) + +simpleTest31 :: GoodTestCase +simpleTest31 = ("3*1;3;3;3;3 ;-1/-1/-1/-1", DblResult 1.0) + +simpleTest32 :: GoodTestCase +simpleTest32 = ("4^4;-(-(-1))", DblResult (-1)) + +simpleTest33 :: GoodTestCase +simpleTest33 = ("-3", DblResult (-3)) + +simpleTest34 :: GoodTestCase +simpleTest34 = (" - 9 ", DblResult (-9)) + + -- a few tests involving variables variableTests :: [GoodTestCase] variableTests = [ variableTest1, variableTest2, variableTest3 , variableTest4, variableTest5, variableTest6 , variableTest7, variableTest8, variableTest9 - , variableTest10, variableTest11, variableTest12 ] + , variableTest10, variableTest11, variableTest12 + , variableTest13, variableTest14, variableTest15 + , variableTest16, variableTest17, variableTest18 + , variableTest19, variableTest20 ] --- list of failing tests +-- list of variable tests variableTest1 :: GoodTestCase -variableTest1 = ("b = 4", 4) +variableTest1 = ("b = 4", DblResult 4) variableTest2 :: GoodTestCase -variableTest2 = ("3 * b ", 12) +variableTest2 = ("3 * b ", DblResult 12) variableTest3 :: GoodTestCase -variableTest3 = ("(b*b)", 16) +variableTest3 = ("(b*b)", DblResult 16) variableTest4 :: GoodTestCase -variableTest4 = ("a = 12", 12) +variableTest4 = ("a = 12", DblResult 12) variableTest5 :: GoodTestCase -variableTest5 = ("a * b", 48) +variableTest5 = ("a * b", DblResult 48) variableTest6 :: GoodTestCase -variableTest6 = ("a - b * b", (-4)) +variableTest6 = ("a - b * b", DblResult (-4)) variableTest7 :: GoodTestCase -variableTest7 = ("3 * b - a", 0) +variableTest7 = ("3 * b - a", DblResult 0) variableTest8 :: GoodTestCase -variableTest8 = ("kjhdskfsd123hjksdf = a * b", 48) +variableTest8 = ("kjhdskfsd123hjksdf = a * b", DblResult 48) variableTest9 :: GoodTestCase -variableTest9 = ("(a*b) - kjhdskfsd123hjksdf", 0) +variableTest9 = ("(a*b) - kjhdskfsd123hjksdf", DblResult 0) variableTest10 :: GoodTestCase -variableTest10 = ("c = 2", 2) +variableTest10 = ("c = 2", DblResult 2) variableTest11 :: GoodTestCase -variableTest11 = ("a-b-c + ( a + b + c ) + (a*a)", 168) +variableTest11 = ("a-b-c + ( a + b + c ) + (a*a)", DblResult 168) variableTest12 :: GoodTestCase -variableTest12 = ("b^a - c", 16777214) +variableTest12 = ("b^a - c", DblResult 16777214) +variableTest13 :: GoodTestCase +variableTest13 = ("a=3; b=4; c=a/b; c*b", DblResult 3) +variableTest14 :: GoodTestCase +variableTest14 = ("x= 10; y = log(x); exp(y)", DblResult 10) +variableTest15 :: GoodTestCase +variableTest15 = ("x=5; x=6; x=7; 3*x; y = x*3", DblResult 21) + +variableTest16 :: GoodTestCase +variableTest16 = ("x = 2; y = 10^x; log10(y)", DblResult 2) + +variableTest17 :: GoodTestCase +variableTest17 = ("c = 2; d = c; d", DblResult 2) + +variableTest18 :: GoodTestCase +variableTest18 = (" x = pi; y = cos(x); acos(y)", DblResult pi) + +variableTest19 :: GoodTestCase +variableTest19 = ("a = 5; -a", DblResult (-5.0)) + +variableTest20 :: GoodTestCase +variableTest20 = ("b= 15; 3*( - b)", DblResult (-45)) + + + +-- a few tests involving builtin functions, mostly to check +-- for proper parsing rather than proper math +functionTests :: [GoodTestCase] +functionTests = [ functionTest1, functionTest2, functionTest3 + , functionTest4, functionTest5, functionTest6 + , functionTest7, functionTest8, functionTest9 + , functionTest10, functionTest11] + +-- list of variable tests +functionTest1 :: GoodTestCase +functionTest1 = ("sqrt 2", DblResult 1.4142135623730951) + +functionTest2 :: GoodTestCase +functionTest2 = ("sqrt 2 * 2", DblResult 2.8284271247461903) + +functionTest3 :: GoodTestCase +functionTest3 = ("sqrt 2*2", DblResult 2.8284271247461903) + +functionTest4 :: GoodTestCase +functionTest4 = ("sqrt(2*2)", DblResult 2) + +functionTest5 :: GoodTestCase +functionTest5 = ("cos 0.5", DblResult 0.8775825618903728) + +functionTest6 :: GoodTestCase +functionTest6 = ("cos 0.5 +0.5", DblResult 1.3775825618903728) + +functionTest7 :: GoodTestCase +functionTest7 = ("cos 0.5 - 0.5", DblResult 0.37758256189037276) + +functionTest8 :: GoodTestCase +functionTest8 = ("cos(0.5 -0.5)", DblResult 1.0) + +functionTest9 :: GoodTestCase +functionTest9 = ("cos -0.5", DblResult 0.8775825618903728) + +functionTest10 :: GoodTestCase +functionTest10 = ("cos(-0.5)", DblResult 0.8775825618903728) + +functionTest11 :: GoodTestCase +functionTest11 = ("cos 0.5 - cos -0.5", DblResult 0) + + -- a few tests that are failing failingTests :: [FailingTestCase] failingTests = [ failingTest1, failingTest2, failingTest3 , failingTest4, failingTest5, failingTest6 , failingTest7, failingTest8, failingTest9 - , failingTest10, failingTest11, failingTest12 ] + , failingTest10, failingTest11, failingTest12 + , failingTest13, failingTest14, failingTest15 ] -- list of failing tests failingTest1 :: FailingTestCase @@ -351,3 +475,121 @@ failingTest12 :: FailingTestCase failingTest12 = ("b") +failingTest13 :: FailingTestCase +failingTest13 = ("3+3;;3+4") + +failingTest14 :: FailingTestCase +failingTest14 = ("(3+3;4+4)") + +failingTest15 :: FailingTestCase +failingTest15 = ("3+3, 3+3") + + +-- a few tests for testing proper parsing of user defined +-- functions +userFunctionTests :: [GoodTestCase] +userFunctionTests = [ userFunctionTest1, userFunctionTest2 + , userFunctionTest3, userFunctionTest4 + , userFunctionTest5, userFunctionTest6 + , userFunctionTest7, userFunctionTest8 + , userFunctionTest9, userFunctionTest10 + , userFunctionTest11, userFunctionTest12 + , userFunctionTest13, userFunctionTest14 + , userFunctionTest15, userFunctionTest16 + , userFunctionTest17, userFunctionTest18 + , userFunctionTest19, userFunctionTest20 + , userFunctionTest21, userFunctionTest22 + , userFunctionTest23, userFunctionTest24 + , userFunctionTest25, userFunctionTest26 + , userFunctionTest27, userFunctionTest28] + + +-- list of user defined function tests +userFunctionTest1 :: GoodTestCase +userFunctionTest1 = ("function f(x , y )= x * y", StrResult "") + +userFunctionTest2 :: GoodTestCase +userFunctionTest2 = ("f ( 5, 6)", DblResult 30) + +userFunctionTest3 :: GoodTestCase +userFunctionTest3 = ("x=2.0; y = 3.0", DblResult 3.0) + +userFunctionTest4 :: GoodTestCase +userFunctionTest4 = ("x * f( 5, 6)+ f(5,6) + y", DblResult 93) + +userFunctionTest5 :: GoodTestCase +userFunctionTest5 = ("f(5,6) ^ 2", DblResult 900) + +userFunctionTest6 :: GoodTestCase +userFunctionTest6 = ("function g(a, b, c) = a * b + c" + , StrResult "") + +userFunctionTest7 :: GoodTestCase +userFunctionTest7 = ("a = 100; b = 77; c = 300; g( 1, 2, 3)" + , DblResult 5) + +userFunctionTest8 :: GoodTestCase +userFunctionTest8 = ("a * b + c", DblResult 8000) + +userFunctionTest9 :: GoodTestCase +userFunctionTest9 = ("f( 5, 6) * g( 1, 2, 3)", DblResult 150) + +userFunctionTest10 :: GoodTestCase +userFunctionTest10 = ("sqrt( f( 5, 6) )", DblResult 5.477225575051661) + +userFunctionTest11 :: GoodTestCase +userFunctionTest11 = ("f( 5, 6) + g( 1, 2, 3) + f( 1, 2) - 37", DblResult 0) + +userFunctionTest12 :: GoodTestCase +userFunctionTest12 = ("function d x y = x * y", StrResult "") + +userFunctionTest13 :: GoodTestCase +userFunctionTest13 = ("d 5 6", DblResult 30) + +userFunctionTest14 :: GoodTestCase +userFunctionTest14 = ("x=2.0; y = 3.0", DblResult 3.0) + +userFunctionTest15 :: GoodTestCase +userFunctionTest15 = ("x * d 5 6 + f(5,6) + y", DblResult 93) + +userFunctionTest16 :: GoodTestCase +userFunctionTest16 = ("d 5 6 ^ 2", DblResult 900) + +userFunctionTest17 :: GoodTestCase +userFunctionTest17 = ("function foo a b c = a * b + c" + , StrResult "") + +userFunctionTest18 :: GoodTestCase +userFunctionTest18 = ("a = 100; b = 77; c = 300; foo 1 2 3" + , DblResult 5) + +userFunctionTest19 :: GoodTestCase +userFunctionTest19 = ("a * b + c", DblResult 8000) + +userFunctionTest20 :: GoodTestCase +userFunctionTest20 = ("d 5 6 * g( 1, 2, 3)", DblResult 150) + +userFunctionTest21 :: GoodTestCase +userFunctionTest21 = ("sqrt( d 5 6 )", DblResult 5.477225575051661) + +userFunctionTest22 :: GoodTestCase +userFunctionTest22 = ("f( 5, 6) + foo 1 2 3 + (d 1 2) - 37", DblResult 0) + +userFunctionTest23 :: GoodTestCase +userFunctionTest23 = ("a = 10; b = 5", DblResult 5) + +userFunctionTest24 :: GoodTestCase +userFunctionTest24 = ("function bar a b c = a * b + c" + , StrResult "") + +userFunctionTest25 :: GoodTestCase +userFunctionTest25 = ("bar a a b", DblResult 105) + +userFunctionTest26 :: GoodTestCase +userFunctionTest26 = ("bar(a,b,b)", DblResult 55) + +userFunctionTest27 :: GoodTestCase +userFunctionTest27 = ("bar(a,1,2) * bar(b,4,a)", DblResult 360) + +userFunctionTest28 :: GoodTestCase +userFunctionTest28 = ("sqrt( bar 1 1 1 )", DblResult 1.4142135623730951) diff --git a/test/ConverterTest.hs b/test/ConverterTest.hs --- a/test/ConverterTest.hs +++ b/test/ConverterTest.hs @@ -106,7 +106,7 @@ let expected = snd x case runParser main_parser state "" tok of Left er -> tell [TestResult False tok (show expected) (show er)] - Right (result, newState) -> examine_result expected result tok + Right (UnitResult result, newState) -> examine_result expected result tok where -- NOTE: when we compare target and actual result we @@ -135,15 +135,18 @@ failing_test_driver state (x:xs) = do case runParser main_parser state "" x of - Left er -> tell [TestResult True x "Failure" "Failure"] - >> failing_test_driver state xs - Right (_,status) -> case have_special_error status of - Just err -> tell [TestResult True x - "Failure" "Failure"] - >> failing_test_driver state xs - Nothing -> tell [TestResult False x - "Failure" "Success"] + Left er -> + tell [TestResult True x "Failure" "Failure"] + >> failing_test_driver state xs + + Right (ErrResult _,_) -> + tell [TestResult True x "Failure" "Failure"] + >> failing_test_driver state xs + + _ -> + tell [TestResult False x "Failure" "Success"] + -- | our test results consist of a bool indicating success -- or failure, the test token as well as the expected and -- received result @@ -189,64 +192,64 @@ -- list of simple tests simpleTest1 :: GoodTestCase -simpleTest1 = ("\\c 0F C", (-17.77777777777778,"C") ) +simpleTest1 = ("conv 0F C", (-17.77777777777778,"C") ) simpleTest2 :: GoodTestCase -simpleTest2 = ("\\c 0C F", (32,"F")) +simpleTest2 = ("conv 0C F", (32,"F")) simpleTest3 :: GoodTestCase -simpleTest3 = ("\\c -12C K", (261.15,"K")) +simpleTest3 = ("conv -12C K", (261.15,"K")) simpleTest4 :: GoodTestCase -simpleTest4 = ("\\c -12K C", (-285.15,"C")) +simpleTest4 = ("conv -12K C", (-285.15,"C")) simpleTest5 :: GoodTestCase -simpleTest5 = ("\\c 23F K", (268.15,"K")) +simpleTest5 = ("conv 23F K", (268.15,"K")) simpleTest6 :: GoodTestCase -simpleTest6 = ("\\c 45K F", (-378.67,"F")) +simpleTest6 = ("conv 45K F", (-378.67,"F")) simpleTest7 :: GoodTestCase -simpleTest7 = ("\\c 1ft m", (0.3048,"m")) +simpleTest7 = ("conv 1ft m", (0.3048,"m")) simpleTest8 :: GoodTestCase -simpleTest8 = ("\\c 4m ft", (13.123359580052492,"ft")) +simpleTest8 = ("conv 4m ft", (13.123359580052492,"ft")) simpleTest9 :: GoodTestCase -simpleTest9 = ("\\c 1km mi", (0.621371192237334,"mi")) +simpleTest9 = ("conv 1km mi", (0.621371192237334,"mi")) simpleTest10 :: GoodTestCase -simpleTest10 = ("\\c 5km nmi", (2.6997840172786174, "nmi")) +simpleTest10 = ("conv 5km nmi", (2.6997840172786174, "nmi")) simpleTest11 :: GoodTestCase -simpleTest11 = ("\\c 23.1m ft", (75.78740157480314, "ft")) +simpleTest11 = ("conv 23.1m ft", (75.78740157480314, "ft")) simpleTest12 :: GoodTestCase -simpleTest12 = ("\\c 0.45mi km", (0.7242048, "km")) +simpleTest12 = ("conv 0.45mi km", (0.7242048, "km")) simpleTest13 :: GoodTestCase -simpleTest13 = ("\\c 43.2mi m", (69523.66080000001, "m")) +simpleTest13 = ("conv 43.2mi m", (69523.66080000001, "m")) simpleTest14 :: GoodTestCase -simpleTest14 = ("\\c 4.2m in", (165.35433070866142, "in")) +simpleTest14 = ("conv 4.2m in", (165.35433070866142, "in")) simpleTest15 :: GoodTestCase -simpleTest15 = ("\\c 34.2m mi", (2.125089477451682e-2, "mi")) +simpleTest15 = ("conv 34.2m mi", (2.125089477451682e-2, "mi")) simpleTest16 :: GoodTestCase -simpleTest16 = ("\\c 123.3m nmi", (6.657667386609072e-2, "nmi")) +simpleTest16 = ("conv 123.3m nmi", (6.657667386609072e-2, "nmi")) simpleTest17 :: GoodTestCase -simpleTest17 = ("\\c 1.23m yd", (1.3451443569553807, "yd")) +simpleTest17 = ("conv 1.23m yd", (1.3451443569553807, "yd")) simpleTest18 :: GoodTestCase -simpleTest18 = ("\\c 0.23nmi km", (0.42596, "km")) +simpleTest18 = ("conv 0.23nmi km", (0.42596, "km")) simpleTest19 :: GoodTestCase -simpleTest19 = ("\\c 1.2nmi m", (2222.4, "m")) +simpleTest19 = ("conv 1.2nmi m", (2222.4, "m")) simpleTest20 :: GoodTestCase -simpleTest20 = ("\\c 1.23yd m", (1.124712, "m")) +simpleTest20 = ("conv 1.23yd m", (1.124712, "m")) -- a few tests that are failing @@ -258,40 +261,40 @@ -- list of failing tests failingTest1 :: FailingTestCase -failingTest1 = ("\\c 1F F") +failingTest1 = ("conv 1F F") failingTest2 :: FailingTestCase -failingTest2 = ("\\c 1C D") +failingTest2 = ("conv 1C D") failingTest3 :: FailingTestCase -failingTest3 = ("\\c C F") +failingTest3 = ("conv C F") failingTest4 :: FailingTestCase -failingTest4 = ("\\c 1F mi") +failingTest4 = ("conv 1F mi") failingTest5 :: FailingTestCase -failingTest5 = ("\\c 1mi mi") +failingTest5 = ("conv 1mi mi") failingTest6 :: FailingTestCase -failingTest6 = ("\\c 1mi 1K") +failingTest6 = ("conv 1mi 1K") failingTest7 :: FailingTestCase -failingTest7 = ("\\c 1nmi yd") +failingTest7 = ("conv 1nmi yd") failingTest8 :: FailingTestCase -failingTest8 = ("\\c 1yd yd") +failingTest8 = ("conv 1yd yd") failingTest9 :: FailingTestCase -failingTest9 = ("\\c 1K K") +failingTest9 = ("conv 1K K") failingTest10 :: FailingTestCase -failingTest10 = ("\\c 1F F") +failingTest10 = ("conv 1F F") failingTest11 :: FailingTestCase failingTest11 = ("c 1C yd") failingTest12 :: FailingTestCase -failingTest12 = ("\\c c c 1") +failingTest12 = ("conv c c 1") -- | list of unit conversion pairs for inversion test @@ -343,11 +346,11 @@ prop_invert u1 u2 i = case runParser main_parser defaultCalcState "" $ test_to i of Left _ -> False - Right ((x,_),_) -> + Right (UnitResult (x,_),_) -> case runParser main_parser defaultCalcState "" $ test_from x of Left _ -> False - Right ((y,_),_) -> is_equal (fromInteger i) y + Right (UnitResult (y,_),_) -> is_equal (fromInteger i) y where - test_to z = "\\c " ++ (show z) ++ u1 ++ " " ++ u2 - test_from z = "\\c " ++ (show z) ++ u2 ++ " " ++ u1 + test_to z = "conv " ++ (show z) ++ u1 ++ " " ++ u2 + test_from z = "conv " ++ (show z) ++ u2 ++ " " ++ u1