husky 0.2 → 0.3
raw patch · 21 files changed
+1638/−408 lines, 21 filesdep +old-localedep +time
Dependencies added: old-locale, time
Files
- .gitignore +2/−1
- ChangeLog +16/−0
- Makefile +12/−6
- doc/usage.html +39/−2
- doc/usage.rst +42/−2
- husky.cabal +4/−3
- src/CalculatorParser.hs +45/−40
- src/CalculatorState.hs +42/−4
- src/ExtraFunctions.hs +7/−2
- src/HelpParser.hs +95/−0
- src/InfoRoutines.hs +60/−0
- src/Messages.hs +11/−11
- src/Parser.hs +47/−0
- src/PrettyPrint.hs +4/−0
- src/TokenParser.hs +50/−22
- src/UnitConversionParser.hs +98/−0
- src/UnitConverter.hs +326/−0
- src/husky.hs +32/−19
- test/CalculatorTest.hs +353/−0
- test/ConverterTest.hs +353/−0
- test/PropertyTest.hs +0/−296
.gitignore view
@@ -1,6 +1,7 @@ *.hi *.o husky-PropertyTest+CalculatorTest+ConverterTest *.swp TAGS
ChangeLog view
@@ -1,3 +1,19 @@+2008-03-08 Markus Dittrich <haskelladdict@gmail.com>++ * 0.3 release+ + * lots of bug fixes. In particular, operations+ with unary "-" now work properly (such as 3*-3)+ Added more unit tests and use quickcheck to test+ some of the unit conversion properties.++ * added unit conversion framework. Currently,+ husky "knows about" the basic temperature and length + conversions. More to follow.++ * added basic help system++ 2008-02-22 Markus Dittrich <haskelladdict@gmail.com> * 0.2 release
Makefile view
@@ -1,18 +1,21 @@ # Copyright 2008 Markus Dittrich <markusle@gmail.com> # Distributed under the terms of the GNU General Public License v3 -VERSION=0.2+VERSION=0.3 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 -fwarn-incomplete-patterns -fwarn-incomplete-record-updates -fwarn-missing-fields -fwarn-missing-methods -fwarn-missing-signatures -fwarn-name-shadowing -fwarn-orphans -fwarn-overlapping-patterns -fwarn-simple-patterns -fwarn-tabs -fwarn-type-defaults -fwarn-monomorphism-restriction -fwarn-unused-binds -fwarn-unused-imports -fwarn-unused-matches+GHC_FLAGS_DEVEL = -O -Wall -Werror -fwarn-simple-patterns -fwarn-tabs -fwarn-incomplete-record-updates -fwarn-monomorphism-restriction -fwarn-implicit-prelude GHC_FLAGS_RELEASE = -O2 OBJECTS = src/husky.hs src/CalculatorParser.hs src/CalculatorState.hs \- src/ExtraFunctions.hs src/PrettyPrint.hs src/TokenParser.hs+ src/ExtraFunctions.hs src/HelpParser.hs src/InfoRoutines.hs \+ src/Parser.hs src/PrettyPrint.hs src/TokenParser.hs \+ src/UnitConverter.hs src/UnitConversionParser.hs+ all: husky @@ -25,9 +28,12 @@ check: $(OBJECTS)- ghc -i./src --make test/PropertyTest.hs- ./test/PropertyTest+ ghc -i./src --make test/CalculatorTest.hs+ ghc -i./src --make test/ConverterTest.hs+ ./test/CalculatorTest+ ./test/ConverterTest + install: husky install -d $(docdir) install -d $(bindir)@@ -41,4 +47,4 @@ clean: rm -f src/*.o src/*.hi src/husky test/*.o test/*.hi \- test/PropertyTest+ test/CalculatorTest
doc/usage.html view
@@ -294,7 +294,7 @@ <tr><th class="docinfo-name">Author:</th> <td>Markus Dittrich</td></tr> <tr><th class="docinfo-name">Version:</th>-<td>0.2 (02/22/2008)</td></tr>+<td>0.3 (03/08/2008)</td></tr> </tbody> </table> <div class="section" id="introduction">@@ -302,6 +302,17 @@ <p>husky is a command line calculator with a small memory footprint. It can be used in a fashion similar to the interactive shells of python, octave, or ghci.</p>+</div>+<div class="section" id="functionality">+<h1>Functionality</h1>+<p>Husky presently can be used as</p>+<ol class="arabic simple">+<li>calculator</li>+<li>unit converter</li>+</ol>+<p>The following sections describe in detail each functionality.</p>+<div class="section" id="calculator">+<h2>Calculator</h2> <p>Currently, the mathematical operations "+", "-", "*", and "/" are supported with arbitrary nesting of parenthesised expressions. All calculations are performed in double@@ -316,7 +327,8 @@ <li><em>cosh, sinh, tanh, acosh, asinh, atanh</em>: hyperbolic trigonometric functions and inverse</li> </ul> <p>Furthermore, users can define any number of variables via</p>-<p><em>variable name</em> = value</p>+<blockquote>+<em>variable name</em> = value</blockquote> <p>where variable name can be any combination of alphanumeric characters but has to begin with a letter. Hence, <em>foobar1</em> is fine, but <em>1foobar</em> is not. Defined variables can be@@ -326,12 +338,37 @@ prompt (including command history). See <a class="footnote-reference" href="#id2" id="id1">[1]</a> for more detail.</p> </div>+<div class="section" id="unit-converter">+<h2>Unit Converter</h2>+<p>The unit conversion functionality of husky can be used via the+command</p>+<blockquote>+\c[onvert] <em><unit value></em> <em><from unit></em> <em><to unit></em> [ :: <em><unit type></em>]</blockquote>+<p>Here, we convert <em><unit value></em> in units of <em><from unit></em> to the+target unit <em><to unit></em>. In addition, the user may further specify+the unit type (e.g. Length, Time, ...) to disambiguate a unit+conversion request. The space between <em><unit value></em> and <em><from unit></em>+is optional. E.g.:</p>+<pre class="literal-block">+\c 1m yd+\c 1 m yd+\c 1 m yd :: Length+</pre>+<p>will all convert 1 meter into yards. Please type:</p>+<pre class="literal-block">+\h[elp] units+</pre>+<p>for a list of all unit conversions.</p>+</div>+</div> <div class="section" id="command-shortcuts"> <h1>Command Shortcuts</h1> <p>The following commands are available at the command prompt:</p> <ul class="simple"> <li>\q : quit husky</li> <li>\v : list all currently defined variables</li>+<li>\t : current time</li>+<li>\h[elp] : available help</li> </ul> </div> <div class="section" id="copyright-and-license">
doc/usage.rst view
@@ -4,7 +4,7 @@ :Author: Markus Dittrich -:Version: 0.2 (02/22/2008)+:Version: 0.3 (03/08/2008) Introduction@@ -14,6 +14,20 @@ footprint. It can be used in a fashion similar to the interactive shells of python, octave, or ghci. +Functionality+-------------++Husky presently can be used as ++1) calculator +2) unit converter ++The following sections describe in detail each functionality.+++Calculator+==========+ Currently, the mathematical operations "+", "-", "*", and "/" are supported with arbitrary nesting of parenthesised expressions. All calculations are performed in double @@ -30,7 +44,7 @@ Furthermore, users can define any number of variables via -*variable name* = value+ *variable name* = value where variable name can be any combination of alphanumeric characters but has to begin with a letter. Hence, *foobar1*@@ -42,7 +56,31 @@ prompt (including command history). See [1]_ for more detail. +Unit Converter+============== +The unit conversion functionality of husky can be used via the +command++ \\c[onvert] *<unit value>* *<from unit>* *<to unit>* [ :: *<unit type>*]++Here, we convert *<unit value>* in units of *<from unit>* to the +target unit *<to unit>*. In addition, the user may further specify +the unit type (e.g. Length, Time, ...) to disambiguate a unit +conversion request. The space between *<unit value>* and *<from unit>*+is optional. E.g.::++ \c 1m yd+ \c 1 m yd+ \c 1 m yd :: Length++will all convert 1 meter into yards. Please type:: ++ \h[elp] units++for a list of all unit conversions.++ Command Shortcuts ----------------- @@ -50,6 +88,8 @@ - \\q : quit husky - \\v : list all currently defined variables+- \\t : current time+- \\h[elp] : available help COPYRIGHT and LICENSE
husky.cabal view
@@ -1,8 +1,8 @@ Name: husky-Version: 0.2+Version: 0.3 License: GPL license-file: COPYING-copyright: (c) 2008 Markus Dittrich+copyright: (C) 2009 Markus Dittrich category: console Synopsis: A simple command line calculator. Description: husky is a command line calculator with a small memory @@ -18,7 +18,8 @@ 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.0.0, mtl >= 1.1.0.0, + old-locale >= 1.0.0.0, time >= 1.0.0.0 ghc-options: -O2 Main-Is: husky.hs hs-source-dirs: src
src/CalculatorParser.hs view
@@ -19,7 +19,7 @@ --------------------------------------------------------------------} -- | main archy driver-module CalculatorParser ( calculator ) where+module CalculatorParser ( calculator_parser ) where -- imports@@ -29,37 +29,26 @@ -- local imports import CalculatorState import ExtraFunctions+import Prelude import TokenParser --- | main parser entry point-calculator :: CharParser CalcState (Maybe Double, CalcState)-calculator = parse_calc - >>= \val -> getState- >>= \state -> return (val, state)----- | grammar description for parser--- NOTE: We have to make sure to provide a default--- catch all parsing rule in case the user--- enters something we don't understand. Otherwise--- parsing fails and we loose our state.-parse_calc :: CharParser CalcState (Maybe Double)-parse_calc = try define_variable - <|> try (add_term >>= \x -> end_of_line >> return (Just x))- <|> return Nothing- <?> "math expression, variable definition " ++- "or variable name"+-- | 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" -- | 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 (Maybe Double)-define_variable = (spaces- >> variable- >>= \varName -> variable_def varName )- <?> "variable definition"+define_variable :: CharParser CalcState Double+define_variable = (whiteSpace+ >> variable+ >>= \varName -> variable_def varName )+ <?> "variable definition" -- | check that we are at the end of the line; otherwise@@ -73,34 +62,34 @@ -- | define a variable-variable_def :: String -> CharParser CalcState (Maybe Double)-variable_def varName = ( spaces+variable_def :: String -> CharParser CalcState Double+variable_def varName = ( whiteSpace >> reservedOp "=" - >> spaces + >> 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 (Maybe Double)+variable_def_by_value :: String -> CharParser CalcState Double variable_def_by_value varName = ( add_term >>= \value -> updateState (insert_variable value varName)- >> return (Just value) )+ >> return value ) <?> "variable from value" -- | define a variable via the value of another variable-variable_def_by_var :: String -> CharParser CalcState (Maybe Double)+variable_def_by_var :: String -> CharParser CalcState Double variable_def_by_var varName = parse_variable >>= \value -> updateState (insert_variable value varName)- >> return (Just value)+ >> return value -- | look for the value of a given variable if any parse_variable :: CharParser CalcState Double parse_variable = ( variable - >>= \val -> spaces+ >>= \val -> whiteSpace >> get_variable_value val >>= \result -> case result of Just a -> return a @@ -120,22 +109,30 @@ -- | parser for potentiation operations "^" exp_term :: CharParser CalcState Double-exp_term = (spaces >> 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 = parens add_term+factor = try signed_parenthesis <|> parse_keywords <|> parse_number <|> 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)++ -- | parse all operations we currently know about parse_keywords :: CharParser CalcState Double-parse_keywords = msum $ extract_ops keywords+parse_keywords = msum $ extract_ops builtinFunctions where extract_ops = foldr (\(x,y) acc -> @@ -150,21 +147,29 @@ multiply_action :: CharParser CalcState (Double -> Double -> Double) multiply_action = (reservedOp "*" >> return (*))- <|> (reservedOp "/" >> return (/))+ <|> (reservedOp "/" >> return (/)) + add_action :: CharParser CalcState (Double -> Double -> Double) add_action = (reservedOp "+" >> return (+))- <|> (reservedOp "-" >> return (-))+ <|> (reservedOp "-" >> return (-)) + exp_action :: CharParser CalcState (Double -> Double -> Double) exp_action = reservedOp "^" >> return real_exp + parse_number :: CharParser CalcState Double-parse_number = naturalOrFloat +parse_number = parse_sign+ >>= \sign -> naturalOrFloat >>= \num -> notFollowedBy alphaNum >> case num of - Left i -> return $ fromInteger i- Right x -> return x+ Left i -> return $ sign * (fromInteger i)+ Right x -> return (sign * x)+++parse_sign :: CharParser CalcState Double+parse_sign = option 1.0 ( whiteSpace >> char '-' >> return (-1.0) ) -- | function retrieving a variable from the database if
src/CalculatorState.hs view
@@ -22,28 +22,66 @@ -- the calculator. Eventually, these might all find a home -- in their separate modules module CalculatorState ( CalcState(..)+ , have_special_error , defaultCalcState + , insert_error , insert_variable+ , reset_state ) where -- imports import qualified Data.Map as M+import Prelude -- | this data structure provides some state information -- to the calculator (variables, etc ...)-data CalcState = CalcState { varMap :: M.Map String Double }+-- Currently, we thread the following pieces of information:+-- varMap : map with all currently defined variable/value pairs+-- (persistent across calls to reset_state below)+-- errState : bool indicating that any special error messages+-- have been queued+-- errValue : [String] holding all special error messages+data CalcState = CalcState + { + varMap :: M.Map String Double + , errValue :: [String]+ } + defaultCalcState :: CalcState-defaultCalcState = CalcState { varMap = M.fromList constantList }+defaultCalcState = CalcState + { + varMap = M.fromList constantList + , errValue = []+ } +-- | 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 adding a new variable to the database insert_variable :: Double -> String -> CalcState -> CalcState-insert_variable num name (CalcState { varMap = theMap }) =- CalcState { varMap = M.insert name num theMap } +insert_variable num name state@(CalcState { varMap = theMap }) =+ state { varMap = M.insert name num theMap } ++-- | 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 = [] } -- | provide a few useful mathematical constants that we
src/ExtraFunctions.hs view
@@ -19,20 +19,25 @@ --------------------------------------------------------------------} --- | definition of a few additional function (from libc)+-- | definition of a few additional helper function (e.g. from libc) module ExtraFunctions ( real_exp - , dbl_epsilon + , is_equal ) where -- imports import Foreign() import Foreign.C.Types+import Prelude -- | use glibc DBL_EPSILON 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 -- | helper function for defining real powers
+ src/HelpParser.hs view
@@ -0,0 +1,95 @@+{-----------------------------------------------------------------+ + (c) 2008-2009 Markus Dittrich + + This program is free software; you can redistribute it + and/or modify it under the terms of the GNU General Public + License Version 3 as published by the Free Software Foundation. + + This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License Version 3 for more details.+ + You should have received a copy of the GNU General Public + License along with this program; if not, write to the Free + Software Foundation, Inc., 59 Temple Place - Suite 330, + Boston, MA 02111-1307, USA.++--------------------------------------------------------------------}++-- | main archy driver+module HelpParser ( help ) where+++-- imports+import Control.Monad++-- local imports+import CalculatorState+import Prelude+import PrettyPrint+import TokenParser+import UnitConverter+import UnitConversionParser+++-- | 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"++++-- | parser for help keyword+-- we accept "\help" as well as the short form "\h"+help_keyword :: CharParser CalcState ()+help_keyword = reserved "\\help"+ <|> reserved "\\h"+ <?> "\\help or \\h"+++-- | parser for the particular help option requested+-- without it we print what kind of help is available+parse_help_option :: CharParser CalcState String+parse_help_option = msum . map snd $ helpOptions+++-- | 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"+++-- | return about info+about_info :: CharParser CalcState String+about_info = string "about"+ >> return about_string+ <?> "about info"+ where+ about_string = "husky (v0.3) (C) 2009 Markus Dittrich\n"+ ++ "husky is licenced under the GPL V3\n"+++-- | return all currently available help options+help_info :: String+help_info = (color_string Yellow $ "Available help options"+ ++ " (request via \\[h]elp <option>):\n") + ++ help_string+ where+ help_string = unlines . map fst $ helpOptions+++-- | data type holding all currently supported help keywords+-- together with a parser for that particular help option+helpOptions :: [(String, CharParser CalcState String)]+helpOptions = [ ("about - about husky", about_info)+ , ("units [:: <unit type>] - list available unit "+ ++ "conversions", unit_info) + ]
+ src/InfoRoutines.hs view
@@ -0,0 +1,60 @@+{-----------------------------------------------------------------+ + (c) 2008-2009 Markus Dittrich + + This program is free software; you can redistribute it + and/or modify it under the terms of the GNU General Public + License Version 3 as published by the Free Software Foundation. + + This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License Version 3 for more details.+ + You should have received a copy of the GNU General Public + License along with this program; if not, write to the Free + Software Foundation, Inc., 59 Temple Place - Suite 330, + Boston, MA 02111-1307, USA.++--------------------------------------------------------------------}++-- | 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 + , show_time+ ) where+++-- imports+import Data.Map+import Data.Time+import Prelude+import System.Locale+++-- local imports+import CalculatorState++ +-- | list all currently defined variables+list_variables :: CalcState -> IO ()+list_variables (CalcState { varMap = theMap }) = + mapM_ print_variable (assocs theMap) ++ where+ print_variable x = putStrLn (fst x ++ " == " ++ (show $ snd x)) +++-- | display the current localtime+show_time :: IO ()+show_time = getCurrentTime+ >>= \utcTime -> getTimeZone utcTime + >>= \zone -> + let + localTime = utcToLocalTime zone utcTime + timeString = formatTime defaultTimeLocale + "%a %b %m %Y <> %T %Z " localTime + in+ putStrLn timeString+
src/Messages.hs view
@@ -20,12 +20,13 @@ -- | Messages provides common messages module Messages ( husky_result- , parse_error+ , print_error_message , show_greeting ) where -- imports-import System.IO+import System.IO()+import Prelude -- local imports import PrettyPrint@@ -33,13 +34,14 @@ -- current version version :: String-version = "0.2"+version = "0.3" -- | display output somewhat colorful-husky_result :: IO ()-husky_result = do+husky_result :: [String] -> IO ()+husky_result items = do putStr $ color_string Yellow "=> "+ putStrLn $ unwords items -- | greeting @@ -50,9 +52,7 @@ putStrLn "-------------------------------------------------" --- | message indicating that something went wrong--- during parsing-parse_error :: String -> IO ()-parse_error message = do- putStr $ color_string Yellow "Error: "- putStrLn $ color_string Green "Could not parse '" ++ message ++ "'"+-- | helpful message after bad parse+print_error_message :: String -> IO ()+print_error_message er = putStrLn $ "Error: " ++ er + ++ "\nPlease type \\[h]elp for help."
+ src/Parser.hs view
@@ -0,0 +1,47 @@+{-----------------------------------------------------------------+ + (c) 2008-2009 Markus Dittrich + + This program is free software; you can redistribute it + and/or modify it under the terms of the GNU General Public + License Version 3 as published by the Free Software Foundation. + + This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License Version 3 for more details.+ + You should have received a copy of the GNU General Public + License along with this program; if not, write to the Free + Software Foundation, Inc., 59 Temple Place - Suite 330, + Boston, MA 02111-1307, USA.++--------------------------------------------------------------------}++-- | main parser driver+module Parser ( main_parser ) where+++-- local imports+import CalculatorParser+import CalculatorState+import Prelude+import TokenParser+import UnitConversionParser+++-- | main parser entry point+main_parser :: CharParser CalcState ((Double,String), CalcState)+main_parser = parser_dispatch+ >>= \val -> getState+ >>= \state -> return (val, state)+++-- | grammar description for parser+-- presently we either dispatch to unit_conversion parser+-- or calculator parser+parser_dispatch :: CharParser CalcState (Double,String)+parser_dispatch = try unit_conversion + <|> calculator_parser+ <?> "unit conversion or calculator expression"+
src/PrettyPrint.hs view
@@ -26,6 +26,10 @@ ) where +-- imports+import Prelude++ -- define colors data Color = Black | Red | Green | Yellow | Blue | Magenta | Cyan | White | Reset
src/TokenParser.hs view
@@ -20,6 +20,7 @@ -- | functionality related to parsing tokens module TokenParser ( module Text.ParserCombinators.Parsec+ , builtinFunctions , float , identifier , integer@@ -32,16 +33,23 @@ , reservedOp , reserved , stringLiteral- , variable ) where+ , unit_value+ , unit_type+ , variable + , whiteSpace+ ) where -- imports import Text.ParserCombinators.Parsec import qualified Text.ParserCombinators.Parsec.Token as PT import Text.ParserCombinators.Parsec.Language (haskellDef+ , opLetter , reservedOpNames , reservedNames )+import Prelude + -- local imports import CalculatorState @@ -56,31 +64,45 @@ >>= \rest -> return $ [first] ++ rest +-- | 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 +unit_type :: CharParser CalcState String+unit_type = variable++ -- | these are all the names and corresponding functions -- of keywords we know about type OperatorAction = (Double -> Double) -keywords :: [(String, OperatorAction)]-keywords = [ ("sqrt",sqrt)- , ("exp",exp)- , ("log",log)- , ("log2", logBase 2)- , ("log10", logBase 10)- , ("sin",sin)- , ("cos",cos)- , ("tan",tan)- , ("asin", asin)- , ("acos", acos)- , ("atan", atan)- , ("sinh", sinh)- , ("cosh", cosh)- , ("tanh", tanh)- , ("asinh", sinh)- , ("acosh", cosh)- , ("atanh", atanh)] +-- | builtin functions of the form (a -> b)+builtinFunctions :: [(String, OperatorAction)]+builtinFunctions = [ ("sqrt",sqrt)+ , ("exp",exp)+ , ("log",log)+ , ("log2", logBase 2)+ , ("log10", logBase 10)+ , ("sin",sin)+ , ("cos",cos)+ , ("tan",tan)+ , ("asin", asin)+ , ("acos", acos)+ , ("atan", atan)+ , ("sinh", sinh)+ , ("cosh", cosh)+ , ("tanh", tanh)+ , ("asinh", sinh)+ , ("acosh", cosh)+ , ("atanh", atanh)] ++-- | all other keywords that are not regular functions+keywords :: [String]+keywords = ["\\convert","\\c"]+ operators :: [String] operators = ["*","/","+","-","="] @@ -88,11 +110,14 @@ {- | prepare needed parsers from Parsec.Token -} -- | function generating a token parser based on a --- lexical parsers combined with a language record definition+-- lexical parser combined with a language record definition lexer :: PT.TokenParser st lexer = PT.makeTokenParser ( haskellDef { reservedOpNames = operators- , reservedNames = map fst keywords } )+ , opLetter = oneOf "*+/^"+ , reservedNames = keywords + ++ map fst builtinFunctions + } ) -- | token parser for parenthesis@@ -129,7 +154,10 @@ reservedOp :: String -> CharParser st () reservedOp = PT.reservedOp lexer - -- | token parser for keywords reserved :: String -> CharParser st () reserved = PT.reserved lexer++-- | token parser for whitespace+whiteSpace :: CharParser st ()+whiteSpace = PT.whiteSpace lexer
+ src/UnitConversionParser.hs view
@@ -0,0 +1,98 @@+{-----------------------------------------------------------------+ + (c) 2008-2009 Markus Dittrich + + This program is free software; you can redistribute it + and/or modify it under the terms of the GNU General Public + License Version 3 as published by the Free Software Foundation. + + This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License Version 3 for more details.+ + You should have received a copy of the GNU General Public + License along with this program; if not, write to the Free + Software Foundation, Inc., 59 Temple Place - Suite 330, + Boston, MA 02111-1307, USA.++--------------------------------------------------------------------}++-- | parser for unit conversions+module UnitConversionParser ( unit_conversion + , parse_unit_type+ ) where+++-- local imports+import CalculatorState+import Prelude+import TokenParser+import UnitConverter+++-- | parser for unit conversions +-- the user can request a conversion between two compatible+-- unit-full values (temperatures, lengths, ...).+-- The command spec is +-- conv <value in unit1> <unit1> <unit2> [ :: <unit type> ] +-- and returns <value in unit2>+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"+ ++-- | 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 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 for all acceptable conversion keywords+conversion_keyword :: CharParser CalcState ()+conversion_keyword = reserved "\\c" + <|> 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 )+ <?> "unit_type"+
+ src/UnitConverter.hs view
@@ -0,0 +1,326 @@+{-----------------------------------------------------------------+ + (c) 2008-2009 Markus Dittrich + + This program is free software; you can redistribute it + and/or modify it under the terms of the GNU General Public + License Version 3 as published by the Free Software Foundation. + + This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License Version 3 for more details.+ + You should have received a copy of the GNU General Public + License along with this program; if not, write to the Free + Software Foundation, Inc., 59 Temple Place - Suite 330, + Boston, MA 02111-1307, USA.++--------------------------------------------------------------------}++-- | this module provides the functionality needed to do unit+-- conversions+module UnitConverter ( convert_unit + , retrieve_unit_string+ ) where+ ++-- imports+import Data.Char()+import qualified Data.Map as M+import Prelude +import PrettyPrint+++-- | function in charge of the main unit conversion+-- There are possible paths:+-- 1) The user did not supply a unit type specifier. In this case+-- we look through all available unit maps for a matching+-- conversion routine. If we find more than one we'll abort+-- 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 + -> Either String (Double,String) +convert_unit unit1 unit2 unitType value = + + case unitType of+ -- no unit type specifier: look through all unit maps+ Nothing -> case unit_lookup (unit1 ++ unit2) allConv of+ [] -> Left unit_conv_error + a@(x:_) -> case length a of+ 1 -> Right ( (converter x $ value)+ , unit2 )+ _ -> Left too_many_matches++ + -- the user supplied a unit type: grab the proper map and look+ Just u -> case M.lookup u allConv of+ Nothing -> Left $ no_unit_error u+ Just a -> case M.lookup (unit1 ++ unit2) a of+ Nothing -> Left $ "In " ++ u ++ " :: "+ ++ unit_conv_error+ Just x -> Right ( (converter x $ value)+ , unit2 )+ + where+ -- unit conversion errors+ unit_conv_error = "No unit conversion known for " + ++ unit1 ++ " to " ++ unit2 ++ "!"++ no_unit_error a = "Don't know unit " ++ a ++ "!"++ too_many_matches = "More than one unit conversion matched.\n"+ ++ "Consider disambiguating with an explicit "+ ++ "unit type."+++-- | helper function looking through all unit maps for a matching+-- conversion routine+unit_lookup :: String -> M.Map String UnitMap -> [UnitConverter]+unit_lookup key = M.fold append_val [] + where+ append_val entry acc = case M.lookup key entry of+ Nothing -> acc+ Just a -> a:acc+++-- | given a possible unit type display all available conversions+-- for that type. Otherwise, display them all+retrieve_unit_string :: Maybe String -> String+retrieve_unit_string unit = case unit of+ Just u -> case M.lookup u allConv of+ Nothing -> ""+ Just m -> (color_string Yellow $ " :: " ++ u ++ "\n")+ ++ (color_string Cyan $ stringify_unit m)++ Nothing -> unlines . map stringify . M.toList $ allConv+ where+ stringify x = (color_string Yellow $ " :: " ++ fst x ++ "\n") + ++ (color_string Cyan $ stringify_unit . snd $ x)++ where + stringify_unit = unlines . map (description . snd) . M.toList+++-- | UnitConverter holds all information known about +-- a particular unit conversion +data UnitConverter = + UnitConverter + { converter :: (Double -> Double) -- actual conversion fctn+ , description :: String -- short description+ }+++-- | unitMap holds all available conversions for a particular+-- unit type+type UnitMap = M.Map String UnitConverter+++-- | allConv holds a map of all available unit conversions+-- indexed by the unit type such as Temp, Length, ....+allConv :: M.Map String UnitMap+allConv = M.fromList [ ("Temp", tempConv)+ , ("Length", lengthConv)+ ]+++-- | temperature conversions+-- Most of them come from the NIST as published at+-- http://physics.nist.gov/Pubs/SP811/appenB9.html#TEMPERATURE++-- | data structure holding temparature conversions +tempConv :: UnitMap+tempConv = M.fromList [ ("FC", fc_conv_temp) + , ("CF", cf_conv_temp)+ , ("CK", ck_conv_temp)+ , ("KC", kc_conv_temp)+ , ("FK", fk_conv_temp)+ , ("KF", kf_conv_temp)+ ]+++-- | convert Fahrenheit to Celcius+fc_conv_temp :: UnitConverter +fc_conv_temp = UnitConverter + { converter = \x -> (5/9)*(x-32)+ , description = "F -> C :: Fahrenheit to Celsius"+ }++-- | convert Celcius to Fahrenheit+cf_conv_temp :: UnitConverter +cf_conv_temp = UnitConverter + { converter = \x -> (9/5)*x + 32+ , description = "C -> F :: Celsius to Fahrenheit"+ }+++-- | convert Celius to Kelvin +ck_conv_temp :: UnitConverter +ck_conv_temp = UnitConverter + { converter = \x -> x + 273.15+ , description = "C -> K :: Celsius to Kelvin"+ }+++-- | convert Kelvin to Celcius+kc_conv_temp :: UnitConverter +kc_conv_temp = UnitConverter + { converter = \x -> x - 273.15+ , description = "K -> C :: Kelvin to Celcius"+ }+++-- | convert Fahrenheit to Kelvin+fk_conv_temp :: UnitConverter +fk_conv_temp = UnitConverter + { converter = \x -> (5/9)*(x + 459.67)+ , description = "F -> K :: Fahrenheit to Kelvin"+ }++-- | convert Kelvin to Fahrenheit+kf_conv_temp :: UnitConverter +kf_conv_temp = UnitConverter + { converter = \x -> (9/5)*x - 459.67+ , description = "K -> F :: Kelvin to Fahrenheit"+ }+++-- | length conversions+-- Most of them come from the NIST as published at+-- http://physics.nist.gov/Pubs/SP811/appenB9.html#LENGTH++-- | data structure holding length conversion +lengthConv :: UnitMap+lengthConv = M.fromList [ ("mft", mf_conv_length) + , ("ftm", fm_conv_length)+ , ("min", mi_conv_length)+ , ("inm", im_conv_length)+ , ("mmi", mmi_conv_length)+ , ("mim", mim_conv_length)+ , ("kmmi", kmmi_conv_length)+ , ("mikm", mikm_conv_length)+ , ("myd", my_conv_length)+ , ("ydm", ym_conv_length)+ , ("mnmi", mnmi_conv_length)+ , ("nmim", nmim_conv_length)+ , ("kmnmi", kmnmi_conv_length)+ , ("nmikm", nmikm_conv_length)+ ]+++-- | convert meters to feet+mf_conv_length :: UnitConverter +mf_conv_length = UnitConverter + { converter = ((1/0.3048)*)+ , description = "m -> ft :: meters to feet"+ }+++-- | convert feet to meters+fm_conv_length :: UnitConverter +fm_conv_length = UnitConverter + { converter = (0.3048*)+ , description = "ft -> m :: feet to meters"+ }++++-- | convert meters to inches+mi_conv_length :: UnitConverter +mi_conv_length = UnitConverter + { converter = ((1/0.0254)*)+ , description = "m -> in :: meters to inches"+ }+++-- | convert inches to meters+im_conv_length :: UnitConverter +im_conv_length = UnitConverter + { converter = (0.0254*)+ , description = "in -> m :: inches to meters"+ }+++-- | convert meters to miles+mmi_conv_length :: UnitConverter +mmi_conv_length = UnitConverter + { converter = ((1/1.609344e3)*)+ , description = "m -> mi :: meters to miles"+ }+++-- | convert miles to meters+mim_conv_length :: UnitConverter +mim_conv_length = UnitConverter + { converter = (1.609344e3*)+ , description = "mi -> m :: miles to meters"+ }+++-- | convert kilometers to miles+kmmi_conv_length :: UnitConverter +kmmi_conv_length = UnitConverter + { converter = ((1/1.609344)*)+ , description = "km -> mi :: kilometers to miles"+ }+++-- | convert miles to kilometers+mikm_conv_length :: UnitConverter +mikm_conv_length = UnitConverter + { converter = (1.609344*)+ , description = "mi -> km :: miles to kilometers"+ }+++-- | convert meters to yards+my_conv_length :: UnitConverter +my_conv_length = UnitConverter + { converter = ((1/0.9144)*)+ , description = "m -> yd :: meters to yards"+ }+++-- | convert yards to meters+ym_conv_length :: UnitConverter +ym_conv_length = UnitConverter + { converter = (0.9144*)+ , description = "yd -> m :: yards to meters"+ }+++-- | convert meters to nautical miles+mnmi_conv_length :: UnitConverter +mnmi_conv_length = UnitConverter + { converter = ((1/1.852e3)*)+ , description = "m -> nmi :: meters to nautical miles"+ }+++-- | convert nautical miles to meters+nmim_conv_length :: UnitConverter +nmim_conv_length = UnitConverter + { converter = (1.852e3*)+ , description = "nmi -> m :: nautical miles"+ ++ "to meters"+ }+++-- | convert kilometers to nautical miles+kmnmi_conv_length :: UnitConverter +kmnmi_conv_length = UnitConverter + { converter = ((1/1.852)*)+ , description = "km -> nmi :: kilometers "+ ++ "to nautical miles"+ }+++-- | convert nautical miles to kilometers+nmikm_conv_length :: UnitConverter +nmikm_conv_length = UnitConverter + { converter = (1.852*)+ , description = "nmi -> km :: nautical miles"+ ++ "to kilometer"+ }+
src/husky.hs view
@@ -23,13 +23,15 @@ -- imports-import Data.Map import System.Console.Readline -- local imports-import CalculatorParser+import Parser import CalculatorState+import HelpParser+import InfoRoutines import Messages+import Prelude import PrettyPrint import TokenParser @@ -49,29 +51,40 @@ 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- Just line -> do+ >> parse_it state+ Just "\\t" -> show_time -- show current time+ >> parse_it state+ Just line -> do -- otherwise calculate addHistory line - -- parse it- case runParser calculator state "" line of- Left er -> putStrLn $ "Error: " ++ (show er)- Right (result, newState) -> - case result of- Nothing -> parse_error line- Just val -> husky_result >> putStrLn (show val)+ -- 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 _ -> - >> parse_it newState+ -- parse it as a calculation or unit conversion+ case runParser main_parser state "" line of + 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] --- | list all currently defined variables-list_variables :: CalcState -> IO ()-list_variables state@(CalcState { varMap = theMap }) = - mapM_ print_variable (assocs theMap) - >> parse_it state- - where- print_variable x = putStrLn (fst x ++ " == " ++ (show $ snd x)) + >> let cleanState = reset_state newState in+ parse_it cleanState+
+ test/CalculatorTest.hs view
@@ -0,0 +1,353 @@+{-----------------------------------------------------------------+ + (c) 2008-2009 Markus Dittrich + + This program is free software; you can redistribute it + and/or modify it under the terms of the GNU General Public + License Version 3 as published by the Free Software Foundation. + + This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License Version 3 for more details.+ + You should have received a copy of the GNU General Public + License along with this program; if not, write to the Free + Software Foundation, Inc., 59 Temple Place - Suite 330, + Boston, MA 02111-1307, USA.++--------------------------------------------------------------------}++-- | handcoded test for checking out the calculator parser+module Main where+++-- import+import Control.Monad.Writer+import System.Exit+++-- local imports+import Parser+import CalculatorState+import ExtraFunctions+import PrettyPrint+import TokenParser+++-- | top level main routine +-- we use the Writer monad to capture the results for all tests +-- and then examine the results afterward+main :: IO ()+main = do+ putStrLn "\n\n\nTesting calculator Parser ..."++ putStr $ color_string Cyan "\nSimple tests:\n"+ let simple = execWriter $ good_test_driver defaultCalcState + simpleTests+ status1 <- examine_output simple++ putStr $ color_string Cyan "\nVariable tests:\n"+ let vars = execWriter $ good_test_driver defaultCalcState + variableTests+ status2 <- examine_output vars++ putStr $ color_string Cyan "\nFailure tests:\n"+ let failing = execWriter $ failing_test_driver defaultCalcState + failingTests+ status2 <- examine_output failing+++ let status = status1 && status2 + if status == True then+ exitWith ExitSuccess+ else+ exitWith $ ExitFailure 1+ ++-- | helper function for examining the output of a good test run+-- (i.e. one that should succeed), prints out the result for each +-- test, collects the number of successes/failures and returns +-- True in case all tests succeeded and False otherwise+examine_output :: [TestResult] -> IO Bool+examine_output = foldM examine_output_h True+ + where+ examine_output_h :: Bool -> TestResult -> IO Bool+ examine_output_h acc (TestResult status token target actual) = do+ if status == True then do+ putStr $ color_string Blue "["+ putStr $ color_string White "OK"+ putStr $ color_string Blue "] "+ putStr $ color_string Green " Successfully evaluated "+ putStrLn $ color_string Yellow token+ return $ acc && True+ else do+ putStr $ color_string Blue "["+ putStr $ color_string Red "TROUBLE"+ putStr $ color_string Blue "] "+ putStr $ color_string Green " Failed to evaluate "+ putStrLn $ color_string Yellow token+ putStrLn $ color_string Green "\t\texpected : " + ++ (show target)+ putStrLn $ color_string Green "\t\tgot : " + ++ (show actual)+ return False+ ++-- | main test routine for "good tests"+good_test_driver :: CalcState -> [GoodTestCase] + -> Writer [TestResult] ()+good_test_driver _ [] = return ()+good_test_driver state (x:xs) = do++ let tok = fst x+ 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+ + 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 + -> Writer [TestResult] ()+ examine_result target actual tok = + if (is_equal 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+++-- | main test routine for "failing tests"+failing_test_driver :: CalcState -> [FailingTestCase] + -> Writer [TestResult] ()+failing_test_driver _ [] = return ()+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 _ -> 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+data TestResult = TestResult { status :: Bool+ , token :: String+ , target :: String+ , actual :: String+ }+++defaultResult :: TestResult+defaultResult = TestResult False "" "" ""+++-- | a good test case consists of an expression and an+-- expected result+type GoodTestCase = (String, Double)+++-- | a failing test case currently consists only of an+-- expression to be parser and we simply tests if it+-- fails as expected. +-- FIXME:+-- In principle, we should check for the correct failure +-- message. However, since I am still playing with the parser +-- these may change so for now we just check for failure.+type FailingTestCase = String+++-- NOTE: For each "run" of test_driver we thread a common +-- calculator state to be able to test variable assignment+-- and use. Therefore, the order of which tests appear in+-- a [GoodTestCase] may matter if variable definitions are involved.+-- I.e., think twice when changing the order, or keep order+-- dependend and independent sets in different lists +simpleTests :: [GoodTestCase]+simpleTests = [ simpleTest1, simpleTest2, simpleTest3, simpleTest4+ , simpleTest5, simpleTest6, simpleTest7+ , simpleTest8, simpleTest9, simpleTest10, simpleTest11+ , simpleTest12, simpleTest13, simpleTest14+ , simpleTest15, simpleTest16, simpleTest17+ , simpleTest18, simpleTest19, simpleTest20+ , simpleTest21, simpleTest22, simpleTest23+ , simpleTest24, simpleTest25, simpleTest26]+++-- list of simple tests+simpleTest1 :: GoodTestCase+simpleTest1 = ("3+4", 7.0)++simpleTest2 :: GoodTestCase+simpleTest2 = ("3*3", 9.0)++simpleTest3 :: GoodTestCase+simpleTest3 = ("(3*3)+(3*4)", 21.0)++simpleTest4 :: GoodTestCase+simpleTest4 = ("(3.0*3.0)+(3.0*4.0)", 21.0)++simpleTest5 :: GoodTestCase+simpleTest5 = ("(3+3)*(9+8)", 102.0)++simpleTest6 :: GoodTestCase+simpleTest6 = ("(3.0+3.0)*(9.0+8.0)", 102.0)++simpleTest7 :: GoodTestCase+simpleTest7 = ("(((((((3.0+3.0)*(9.0+8.0)))))))", 102.0)++simpleTest8 :: GoodTestCase+simpleTest8 = ("(((((((3.0+3.0)))))*(((((9.0+8.0)))))))", 102.0)++simpleTest9 :: GoodTestCase+simpleTest9 = ("3+3*99.0", 300.0)++simpleTest10 :: GoodTestCase+simpleTest10 = ("3+3*8+4*3*2+1*4*3+5", 68.0)++simpleTest11 :: GoodTestCase+simpleTest11 = ("(3+3)*(8+4)*3*(2+1)*4*(3+5)", 20736.0)++simpleTest12 :: GoodTestCase+simpleTest12 = (" 3 +3* 99.0", 300.0)++simpleTest13 :: GoodTestCase+simpleTest13 = (" 3 + 3*8+4 *3 *2+1* 4*3+5 ", 68.0)++simpleTest14 :: GoodTestCase+simpleTest14 = ("(3+3) *(8+4)*3 * (2+1 )*4*( 3+5)", 20736.0)++simpleTest15 :: GoodTestCase+simpleTest15 = ("3*-4", -12.0)++simpleTest16 :: GoodTestCase+simpleTest16 = ("3* -4", -12.0)++simpleTest17 :: GoodTestCase+simpleTest17 = ("-3*4", -12.0)++simpleTest18 :: GoodTestCase+simpleTest18 = ("-3*-4", 12.0)++simpleTest19 :: GoodTestCase+simpleTest19 = ("3*(-4)", -12.0)++simpleTest20 :: GoodTestCase+simpleTest20 = ("(-3)*(-4)", 12.0)++simpleTest21 :: GoodTestCase+simpleTest21 = ("3/-4", -0.75)++simpleTest22 :: GoodTestCase+simpleTest22 = ("3^-4", 1/81)++simpleTest23 :: GoodTestCase+simpleTest23 = ("-3*-4^-4", -3/256)++simpleTest24 :: GoodTestCase+simpleTest24 = ("-3+-4", -7)++simpleTest25 :: GoodTestCase+simpleTest25 = ("-1/-1/-1/-1", 1.0)++simpleTest26 :: GoodTestCase+simpleTest26 = ("-(-(-1))", -1)+++-- a few tests involving variables+variableTests :: [GoodTestCase]+variableTests = [ variableTest1, variableTest2, variableTest3+ , variableTest4, variableTest5, variableTest6+ , variableTest7, variableTest8, variableTest9+ , variableTest10, variableTest11, variableTest12 ] ++-- list of failing tests+variableTest1 :: GoodTestCase+variableTest1 = ("b = 4", 4)++variableTest2 :: GoodTestCase+variableTest2 = ("3 * b ", 12)++variableTest3 :: GoodTestCase+variableTest3 = ("(b*b)", 16)++variableTest4 :: GoodTestCase+variableTest4 = ("a = 12", 12)++variableTest5 :: GoodTestCase+variableTest5 = ("a * b", 48)++variableTest6 :: GoodTestCase+variableTest6 = ("a - b * b", (-4))++variableTest7 :: GoodTestCase+variableTest7 = ("3 * b - a", 0)++variableTest8 :: GoodTestCase+variableTest8 = ("kjhdskfsd123hjksdf = a * b", 48)++variableTest9 :: GoodTestCase+variableTest9 = ("(a*b) - kjhdskfsd123hjksdf", 0)++variableTest10 :: GoodTestCase+variableTest10 = ("c = 2", 2) ++variableTest11 :: GoodTestCase+variableTest11 = ("a-b-c + ( a + b + c ) + (a*a)", 168)++variableTest12 :: GoodTestCase+variableTest12 = ("b^a - c", 16777214)++++-- a few tests that are failing +failingTests :: [FailingTestCase]+failingTests = [ failingTest1, failingTest2, failingTest3+ , failingTest4, failingTest5, failingTest6+ , failingTest7, failingTest8, failingTest9+ , failingTest10, failingTest11, failingTest12 ]++-- list of failing tests+failingTest1 :: FailingTestCase+failingTest1 = ("3+4b")++failingTest2 :: FailingTestCase+failingTest2 = ("3*a3")++failingTest3 :: FailingTestCase+failingTest3 = ("(3*3)B+(3*4)")++failingTest4 :: FailingTestCase+failingTest4 = ("(3.0*3.0)+3.0*4.0)")++failingTest5 :: FailingTestCase+failingTest5 = ("(3y3)*(9+8)")++failingTest6 :: FailingTestCase+failingTest6 = ("(3.0+3.0)*(9.0+8.0")++failingTest7 :: FailingTestCase+failingTest7 = ("(((((((3.0+3.0)*(9.0+8.0))))))")++failingTest8 :: FailingTestCase+failingTest8 = ("(((((((3.0+3.0))))*((((((9.0+8.0)))))))")++failingTest9 :: FailingTestCase+failingTest9 = ("a3+3*99.0")++failingTest10 :: FailingTestCase+failingTest10 = ("3+3*8+4*3++2+1*4*3+5")++failingTest11 :: FailingTestCase+failingTest11 = ("(3+3)**(8+4)*3*(2+1)*4*(3+5)")++failingTest12 :: FailingTestCase+failingTest12 = ("b")+
+ test/ConverterTest.hs view
@@ -0,0 +1,353 @@+{-----------------------------------------------------------------+ + (c) 2008-2009 Markus Dittrich + + This program is free software; you can redistribute it + and/or modify it under the terms of the GNU General Public + License Version 3 as published by the Free Software Foundation. + + This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License Version 3 for more details.+ + You should have received a copy of the GNU General Public + License along with this program; if not, write to the Free + Software Foundation, Inc., 59 Temple Place - Suite 330, + Boston, MA 02111-1307, USA.++--------------------------------------------------------------------}++-- | handcoded test for checking out the conversion function parser+module Main where+++-- import+import Control.Monad.Writer+import System.Exit+import Test.QuickCheck++import Debug.Trace++-- local imports+import Parser+import CalculatorState+import ExtraFunctions+import PrettyPrint+import TokenParser+++-- | top level main routine +-- we use the Writer monad to capture the results for all tests +-- and then examine the results afterward+main :: IO ()+main = do+ putStrLn "\n\n\nTesting conversion function parser ..."++ putStr $ color_string Cyan "\nSimple tests:\n"+ let simple1 = execWriter $ good_test_driver defaultCalcState + simpleTests+ status1 <- examine_output simple1++ putStr $ color_string Cyan "\nFailing tests:\n"+ let simple2 = execWriter $ failing_test_driver defaultCalcState + failingTests+ status2 <- examine_output simple2++ -- run a bunch of tests to test if our conversion can be+ -- be properly inverted+ check_invertibility+++ let status = status1 && status2+ if status == True then+ exitWith ExitSuccess+ else+ exitWith $ ExitFailure 1+ ++-- | helper function for examining the output of a good test run+-- (i.e. one that should succeed), prints out the result for each +-- test, collects the number of successes/failures and returns +-- True in case all tests succeeded and False otherwise+examine_output :: [TestResult] -> IO Bool+examine_output = foldM examine_output_h True+ + where+ examine_output_h :: Bool -> TestResult -> IO Bool+ examine_output_h acc (TestResult status token target actual) = do+ if status == True then do+ putStr $ color_string Blue "["+ putStr $ color_string White "OK"+ putStr $ color_string Blue "] "+ putStr $ color_string Green " Successfully evaluated "+ putStrLn $ color_string Yellow token+ return $ acc && True+ else do+ putStr $ color_string Blue "["+ putStr $ color_string Red "TROUBLE"+ putStr $ color_string Blue "] "+ putStr $ color_string Green " Failed to evaluate "+ putStrLn $ color_string Yellow token+ putStrLn $ color_string Green "\t\texpected : " + ++ (show target)+ putStrLn $ color_string Green "\t\tgot : " + ++ (show actual)+ return False+ ++-- | main test routine for "good tests"+good_test_driver :: CalcState -> [GoodTestCase] + -> Writer [TestResult] ()+good_test_driver _ [] = return ()+good_test_driver state (x:xs) = do++ let tok = fst x+ 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+ + 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,String) -> (Double,String) + -> String -> Writer [TestResult] ()+ examine_result (t_value,t_unit) (a_value,a_unit) tok = + if ((is_equal t_value a_value) && (t_unit == a_unit)) + then do+ tell [TestResult True tok target_string actual_string]+ good_test_driver newState xs+ else do+ tell [TestResult False tok target_string actual_string]+ good_test_driver newState xs++ where+ actual_string = (show a_value) ++ " " ++ a_unit+ target_string = (show t_value) ++ " " ++ t_unit+++-- | main test routine for "failing tests"+failing_test_driver :: CalcState -> [FailingTestCase] + -> Writer [TestResult] ()+failing_test_driver _ [] = return ()+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"]+ +-- | our test results consist of a bool indicating success+-- or failure, the test token as well as the expected and+-- received result+data TestResult = TestResult { status :: Bool+ , token :: String+ , target :: String+ , actual :: String+ }+++defaultResult :: TestResult+defaultResult = TestResult False "" "" ""+++-- | a good test case consists of an expression and an+-- expected result (value,unit)+type GoodTestCase = (String, (Double,String))+++-- | a failing test case currently consists only of an+-- expression to be parser and we simply tests if it+-- fails as expected. +-- FIXME:+-- In principle, we should check for the correct failure +-- message. However, since I am still playing with the parser +-- these may change so for now we just check for failure.+type FailingTestCase = String+++-- NOTE: For each "run" of test_driver we thread a common +-- calculator state to be able to test variable assignment+-- and use. Therefore, the order of which tests appear in+-- a [GoodTestCase] may matter if variable definitions are involved.+-- I.e., think twice when changing the order, or keep order+-- dependend and independent sets in different lists +simpleTests :: [GoodTestCase]+simpleTests = [ simpleTest1, simpleTest2, simpleTest3, simpleTest4+ , simpleTest5, simpleTest6, simpleTest7, simpleTest8+ , simpleTest9, simpleTest10, simpleTest11, simpleTest12+ , simpleTest13, simpleTest14, simpleTest13, simpleTest14+ , simpleTest15, simpleTest16, simpleTest17, simpleTest18+ , simpleTest19, simpleTest20]++-- list of simple tests+simpleTest1 :: GoodTestCase+simpleTest1 = ("\\c 0F C", (-17.77777777777778,"C") )++simpleTest2 :: GoodTestCase+simpleTest2 = ("\\c 0C F", (32,"F"))++simpleTest3 :: GoodTestCase+simpleTest3 = ("\\c -12C K", (261.15,"K"))++simpleTest4 :: GoodTestCase+simpleTest4 = ("\\c -12K C", (-285.15,"C"))++simpleTest5 :: GoodTestCase+simpleTest5 = ("\\c 23F K", (268.15,"K"))++simpleTest6 :: GoodTestCase+simpleTest6 = ("\\c 45K F", (-378.67,"F"))+ +simpleTest7 :: GoodTestCase+simpleTest7 = ("\\c 1ft m", (0.3048,"m"))++simpleTest8 :: GoodTestCase+simpleTest8 = ("\\c 4m ft", (13.123359580052492,"ft"))++simpleTest9 :: GoodTestCase+simpleTest9 = ("\\c 1km mi", (0.621371192237334,"mi"))++simpleTest10 :: GoodTestCase+simpleTest10 = ("\\c 5km nmi", (2.6997840172786174, "nmi"))++simpleTest11 :: GoodTestCase+simpleTest11 = ("\\c 23.1m ft", (75.78740157480314, "ft"))++simpleTest12 :: GoodTestCase+simpleTest12 = ("\\c 0.45mi km", (0.7242048, "km"))++simpleTest13 :: GoodTestCase+simpleTest13 = ("\\c 43.2mi m", (69523.66080000001, "m"))++simpleTest14 :: GoodTestCase+simpleTest14 = ("\\c 4.2m in", (165.35433070866142, "in"))++simpleTest15 :: GoodTestCase+simpleTest15 = ("\\c 34.2m mi", (2.125089477451682e-2, "mi"))++simpleTest16 :: GoodTestCase+simpleTest16 = ("\\c 123.3m nmi", (6.657667386609072e-2, "nmi"))++simpleTest17 :: GoodTestCase+simpleTest17 = ("\\c 1.23m yd", (1.3451443569553807, "yd"))++simpleTest18 :: GoodTestCase+simpleTest18 = ("\\c 0.23nmi km", (0.42596, "km"))++simpleTest19 :: GoodTestCase+simpleTest19 = ("\\c 1.2nmi m", (2222.4, "m"))++simpleTest20 :: GoodTestCase+simpleTest20 = ("\\c 1.23yd m", (1.124712, "m"))+++-- a few tests that are failing +failingTests :: [FailingTestCase]+failingTests = [ failingTest1, failingTest2, failingTest3+ , failingTest4, failingTest5, failingTest6+ , failingTest7, failingTest8, failingTest9+ , failingTest10, failingTest11, failingTest12 ]++-- list of failing tests+failingTest1 :: FailingTestCase+failingTest1 = ("\\c 1F F")++failingTest2 :: FailingTestCase+failingTest2 = ("\\c 1C D")++failingTest3 :: FailingTestCase+failingTest3 = ("\\c C F")++failingTest4 :: FailingTestCase+failingTest4 = ("\\c 1F mi")++failingTest5 :: FailingTestCase+failingTest5 = ("\\c 1mi mi")++failingTest6 :: FailingTestCase+failingTest6 = ("\\c 1mi 1K")++failingTest7 :: FailingTestCase+failingTest7 = ("\\c 1nmi yd")++failingTest8 :: FailingTestCase+failingTest8 = ("\\c 1yd yd")++failingTest9 :: FailingTestCase+failingTest9 = ("\\c 1K K")++failingTest10 :: FailingTestCase+failingTest10 = ("\\c 1F F")++failingTest11 :: FailingTestCase+failingTest11 = ("c 1C yd")++failingTest12 :: FailingTestCase+failingTest12 = ("\\c c c 1")+++-- | list of unit conversion pairs for inversion test+unitPairs :: [(String,String)]+unitPairs = [ unitPair1, unitPair2, unitPair3, unitPair4, unitPair5+ , unitPair6, unitPair7]++unitPair1 :: (String,String)+unitPair1 = ("m","yd")++unitPair2 :: (String,String)+unitPair2 = ("m","in")++unitPair3 :: (String,String)+unitPair3 = ("m","mi")++unitPair4 :: (String,String)+unitPair4 = ("ft","m")++unitPair5 :: (String,String)+unitPair5 = ("km","mi")++unitPair6 :: (String,String)+unitPair6 = ("km","nmi")++unitPair7 :: (String,String)+unitPair7 = ("m","nmi")+++-- | function using quickcheck to test if our unit conversions+-- are properly invertible, i.e. if we convert m to yd and then+-- back we should end up with our initial result+-- NOTE: It would be great if we could check the "return status"+-- of quickcheck somehow so we can propage the result to the+-- shell+check_invertibility :: IO ()+check_invertibility =+ (putStr $ color_string Cyan "\n\nCheck Invertibility ..\n") + >> mapM_ (\x -> quickCheck $ prop_invert (fst x) (snd x)) + unitPairs+++-- | properties for Quickcheck+-- in a nutshell if our conversion functions are invertible,+-- e.g. \c (\c 5yd m)m yd == 5+-- NOTE: We could use Double here instead of Integer but then+-- we had to make dbl_epsilon slightly less strict +prop_invert :: String -> String -> Integer -> Bool+prop_invert u1 u2 i =+ case runParser main_parser defaultCalcState "" $ test_to i of+ Left _ -> False+ Right ((x,_),_) -> + case runParser main_parser defaultCalcState "" $ test_from x of+ Left _ -> False+ Right ((y,_),_) -> is_equal (fromInteger i) y++ where+ test_to z = "\\c " ++ (show z) ++ u1 ++ " " ++ u2+ test_from z = "\\c " ++ (show z) ++ u2 ++ " " ++ u1
− test/PropertyTest.hs
@@ -1,296 +0,0 @@-{------------------------------------------------------------------ - (c) 2008-2009 Markus Dittrich - - This program is free software; you can redistribute it - and/or modify it under the terms of the GNU General Public - License Version 3 as published by the Free Software Foundation. - - This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License Version 3 for more details.- - You should have received a copy of the GNU General Public - License along with this program; if not, write to the Free - Software Foundation, Inc., 59 Temple Place - Suite 330, - Boston, MA 02111-1307, USA.----------------------------------------------------------------------}---- | use QuickCheck to test some properties-module Main where----- import-import Control.Monad.Writer-import System.Exit----- local imports-import CalculatorParser-import CalculatorState-import ExtraFunctions-import PrettyPrint-import TokenParser----- | top level main routine --- we use the Writer monad to capture the results for all tests --- and then examine the results afterward-main :: IO ()-main = do- putStr $ color_string Cyan "\nSimple tests:\n"- let simple = execWriter $ test_driver defaultCalcState simpleTests- status1 <- examine_output simple-- putStr $ color_string Cyan "\nFailure tests:\n"- let failing = execWriter $ test_driver defaultCalcState failingTests- status2 <- examine_output failing-- putStr $ color_string Cyan "\nVariable tests:\n"- let vars = execWriter $ test_driver defaultCalcState variableTests- status3 <- examine_output vars-- let status = status1 && status2 && status3 - if status == True then- exitWith ExitSuccess- else- exitWith $ ExitFailure 1- ---- | helper function for examining the output of a test run--- prints out the result for each test, collects the number--- of successes/failures and returns True in case all tests--- succeeded and False otherwise-examine_output :: [TestResult] -> IO Bool-examine_output = foldM examine_output_h True- - where- examine_output_h :: Bool -> TestResult -> IO Bool- examine_output_h acc (TestResult status token target actual) = do- if status == True then do- putStr $ color_string Blue "["- putStr $ color_string White "OK"- putStr $ color_string Blue "] "- putStr $ color_string Green " Successfully evaluated "- putStrLn $ color_string Yellow token- return $ acc && True- else do- putStr $ color_string Blue "["- putStr $ color_string Red "TROUBLE"- putStr $ color_string Blue "] "- putStr $ color_string Green " Failed to evaluate "- putStrLn $ color_string Yellow token- putStrLn $ color_string Green "\t\texpected : " - ++ (convert target)- putStrLn $ color_string Green "\t\tgot : " - ++ (convert actual)- return False- - where- convert :: Maybe Double -> String- convert x = case x of- Nothing -> "Nothing"- Just a -> show a----- | main test routine-test_driver :: CalcState -> [TestCase] -> Writer [TestResult] ()-test_driver _ [] = return ()-test_driver state (x:xs) = do-- let tok = fst x- let expected = snd x- case runParser calculator state "" tok of- Left er -> tell [TestResult False tok expected Nothing]- 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 :: Maybe Double -> Maybe Double -> String - -> Writer [TestResult] ()- examine_result target actual token = - if (is_equal target actual) - then do- tell [TestResult True token target actual]- test_driver newState xs- else do- tell [TestResult False token target actual]- test_driver newState xs-- where- -- we compare doubles x,y for equality by means- -- of abs(x-y) <= dbl_epsilon * abs(x)- is_equal Nothing Nothing = True- is_equal (Just a) (Just b) = - abs(a-b) <= abs(a) * dbl_epsilon- is_equal _ _ = False- - --- | our test results consist of a bool indicating success--- or failure, the test token as well as the expected and--- received result-data TestResult = TestResult { status :: Bool- , token :: String- , target :: Maybe Double- , actual :: Maybe Double- }--defaultResult :: TestResult-defaultResult = TestResult False "" Nothing Nothing----- | our test tokens are simple pairs of expressions and--- their result-type TestCase = (String, Maybe Double)----- NOTE: For each "run" of test_driver we thread a common --- calculator state to be able to test variable assignment--- and use. Therefore, the order of which tests appear in--- a [TestCase] may matter if variable definitions are involved.--- I.e., think twice when changing the order, or keep order--- dependend and independent sets in different lists -simpleTests :: [TestCase]-simpleTests = [ simpleTest1, simpleTest2, simpleTest3, simpleTest4- , simpleTest5, simpleTest6, simpleTest7- , simpleTest8, simpleTest9, simpleTest10, simpleTest11- , simpleTest12, simpleTest13, simpleTest14]---- list of simple tests-simpleTest1 :: TestCase-simpleTest1 = ("3+4", Just 7.0)--simpleTest2 :: TestCase-simpleTest2 = ("3*3", Just 9.0)--simpleTest3 :: TestCase-simpleTest3 = ("(3*3)+(3*4)", Just 21.0)--simpleTest4 :: TestCase-simpleTest4 = ("(3.0*3.0)+(3.0*4.0)", Just 21.0)--simpleTest5 :: TestCase-simpleTest5 = ("(3+3)*(9+8)", Just 102.0)--simpleTest6 :: TestCase-simpleTest6 = ("(3.0+3.0)*(9.0+8.0)", Just 102.0)--simpleTest7 :: TestCase-simpleTest7 = ("(((((((3.0+3.0)*(9.0+8.0)))))))", Just 102.0)--simpleTest8 :: TestCase-simpleTest8 = ("(((((((3.0+3.0)))))*(((((9.0+8.0)))))))", Just 102.0)--simpleTest9 :: TestCase-simpleTest9 = ("3+3*99.0", Just 300.0)--simpleTest10 :: TestCase-simpleTest10 = ("3+3*8+4*3*2+1*4*3+5", Just 68.0)--simpleTest11 :: TestCase-simpleTest11 = ("(3+3)*(8+4)*3*(2+1)*4*(3+5)", Just 20736.0)--simpleTest12 :: TestCase-simpleTest12 = (" 3 +3* 99.0", Just 300.0)--simpleTest13 :: TestCase-simpleTest13 = (" 3 + 3*8+4 *3 *2+1* 4*3+5 ", Just 68.0)--simpleTest14 :: TestCase-simpleTest14 = ("(3+3) *(8+4)*3 * (2+1 )*4*( 3+5)", Just 20736.0)------ a few tests that are failing -failingTests :: [TestCase]-failingTests = [ failingTest1, failingTest2, failingTest3- , failingTest4, failingTest5, failingTest6- , failingTest7, failingTest8, failingTest9- , failingTest10, failingTest11, failingTest12 ]---- list of failing tests-failingTest1 :: TestCase-failingTest1 = ("3+4b", Nothing)--failingTest2 :: TestCase-failingTest2 = ("3*a3", Nothing)--failingTest3 :: TestCase-failingTest3 = ("(3*3)B+(3*4)", Nothing)--failingTest4 :: TestCase-failingTest4 = ("(3.0*3.0)+3.0*4.0)", Nothing)--failingTest5 :: TestCase-failingTest5 = ("(3y3)*(9+8)", Nothing)--failingTest6 :: TestCase-failingTest6 = ("(3.0+3.0)*(9.0+8.0", Nothing)--failingTest7 :: TestCase-failingTest7 = ("(((((((3.0+3.0)*(9.0+8.0))))))", Nothing)--failingTest8 :: TestCase-failingTest8 = ("(((((((3.0+3.0))))*((((((9.0+8.0)))))))", Nothing)--failingTest9 :: TestCase-failingTest9 = ("a3+3*99.0", Nothing)--failingTest10 :: TestCase-failingTest10 = ("3+3*8+4*3++2+1*4*3+5", Nothing)--failingTest11 :: TestCase-failingTest11 = ("(3+3)**(8+4)*3*(2+1)*4*(3+5)", Nothing)--failingTest12 :: TestCase-failingTest12 = ("b", Nothing)----- a few tests involving variables-variableTests :: [TestCase]-variableTests = [ variableTest1, variableTest2, variableTest3- , variableTest4, variableTest5, variableTest6- , variableTest7, variableTest8, variableTest9- , variableTest10, variableTest11, variableTest12 ] ---- list of failing tests-variableTest1 :: TestCase-variableTest1 = ("b = 4", Just 4)--variableTest2 :: TestCase-variableTest2 = ("3 * b ", Just 12)--variableTest3 :: TestCase-variableTest3 = ("(b*b)", Just 16)--variableTest4 :: TestCase-variableTest4 = ("a = 12", Just 12)--variableTest5 :: TestCase-variableTest5 = ("a * b", Just 48)--variableTest6 :: TestCase-variableTest6 = ("a - b * b", Just (-4))--variableTest7 :: TestCase-variableTest7 = ("3 * b - a", Just 0)--variableTest8 :: TestCase-variableTest8 = ("kjhdskfsd123hjksdf = a * b", Just 48)--variableTest9 :: TestCase-variableTest9 = ("(a*b) - kjhdskfsd123hjksdf", Just 0)--variableTest10 :: TestCase-variableTest10 = ("c = 2", Just 2) --variableTest11 :: TestCase-variableTest11 = ("a-b-c + ( a + b + c ) + (a*a)", Just 168)--variableTest12 :: TestCase-variableTest12 = ("b^a - c", Just 16777214)-