Improved variable definition error messages

app/Main.hs

@@ -2,7 +2,7 @@ module Main (main) where
 
 import Text.Parsec
 
-import Lib (exprparser, evaluate, replaceVars, Expr, extractVariableDefinitions)
+import Lib (exprparser, evaluate, replaceVars, Expr, extractVariableDefinitions, updateVariables)
 
 import Data.Map (Map)
 import qualified Data.Map as Map
@@ -21,20 +21,27 @@ precision = 5 :: Int
 showRatio :: Int -> Rational -> String
 showRatio p r = (if (r < 0) then "-" else "") ++ prepoint_digits ++ (if (length postpoint_digits > 0) then ("." ++ postpoint_digits) else "")
     where
-    	prepoint_digits  = init . show . round . abs $ (r * 10)
-	postpoint_digits = reverse . dropWhile (=='0') . reverse .(take p) . (drop (length prepoint_digits)) . show . round . abs $ (r * 10^p)
+        prepoint_digits  = init . show . round . abs $ (r * 10)
+        postpoint_digits = reverse . dropWhile (=='0') . reverse .(take p) . (drop (length prepoint_digits)) . show . round . abs $ (r * 10^p)
 
-useResult :: Map String Rational -> Either ParseError Expr -> String
-useResult vs (Right expr)  = either id ((showRatio precision) . evaluate) $ replaceVars expr vs
-useResult vs (Left  error) = show error
+useResult :: Map String Rational -> Expr -> String
+useResult vs expr = either id ((showRatio precision) . evaluate) $ replaceVars expr vs
 
 ioLoop :: Map String Rational -> IO ()
 ioLoop vs = do done <- isEOF
                if done
                  then putStrLn "Quit!"
                  else do inp <- getLine
-                         let expr = parse exprparser "<stdin>" inp
-			 let uvs  = either (const vs) (\e -> Map.unionWith (flip const) vs (extractVariableDefinitions e)) expr
-                         putStrLn $ useResult uvs expr
-                         ioLoop uvs
+                         let expr_res = parse exprparser "<stdin>" inp
+                         case expr_res of
+                             Left err   -> do
+                                 putStrLn . show $ err
+                                 ioLoop vs
+                             Right expr -> do
+                                 let vardefs = extractVariableDefinitions expr
+                                 let uvs_res = updateVariables vardefs vs
+                                 case uvs_res of
+                                     Left  err -> putStrLn err
+                                     Right uvs -> putStrLn $ useResult uvs expr
+                                 ioLoop (either (const vs) (id) uvs_res)
 

src/Lib.hs

@@ -1,5 +1,5 @@
 module Lib
-    ( exprparser, evaluate, replaceVars, Expr, extractVariableDefinitions
+    ( exprparser, evaluate, replaceVars, Expr, extractVariableDefinitions, updateVariables
     ) where
 import Control.Applicative((<*))
 
@@ -14,7 +14,7 @@ import Text.Parsec.Expr
 import Text.Parsec.Token
 import Text.Parsec.Language
 
-data Expr = Variable String | Constant Rational | Binary BinaryOperator Expr Expr | VariableDefinition String Rational
+data Expr = Variable String | Constant Rational | Binary BinaryOperator Expr Expr | VariableDefinition String Expr
     deriving Show
 data BinaryOperator = Plus | Minus | Multiply | Divide | Power
     deriving Show
@@ -80,7 +80,7 @@ variableDefinition :: Parser Expr
 variableDefinition = try (do
         name  <- m_identifier
         _     <- char '='
-        value <- constantInteger <|> constantRational
+        value <- exprparser
         return (VariableDefinition name value)
     )
 
@@ -90,16 +90,29 @@ term = m_parens exprparser
        <|> fmap Constant constantInteger
        <|> fmap Constant constantRational
 
-extractVariableDefinitions :: Expr -> Map.Map String Rational
-extractVariableDefinitions (VariableDefinition name value) = Map.singleton name value
-extractVariableDefinitions (Binary _ a b)                  = Map.union (extractVariableDefinitions a) (extractVariableDefinitions b)
-extractVariableDefinitions (Constant _)                    = Map.empty
-extractVariableDefinitions (Variable _)                    = Map.empty
+extractVariableDefinitions :: Expr -> [(String,Expr)]
+extractVariableDefinitions (VariableDefinition name value) = [(name, value)]
+extractVariableDefinitions (Binary _ a b)                  = extractVariableDefinitions a  ++ extractVariableDefinitions b
+extractVariableDefinitions (Constant _)                    = []
+extractVariableDefinitions (Variable _)                    = []
+
+updateVariables :: [(String, Expr)] -> Map String Rational -> Either String (Map String Rational)
+updateVariables ds vs = foldl updateVariable (Right vs) ds
+
+updateVariable :: Either String (Map String Rational) -> (String, Expr) -> Either String (Map String Rational)
+updateVariable (Left  e)  _         = Left e
+updateVariable (Right vs) (name, e) = case updateVariables nvs vs of
+        Left e    -> Left $ "In definition of variable '" ++ name ++ "':\n" ++ e
+        Right uvs -> case replaceVars e uvs of
+            Left e    -> Left $ "In definition of variable '" ++ name ++ "':\n" ++ e
+            Right exp -> Right $ Map.insert name (evaluate exp) uvs
+    where
+        nvs = extractVariableDefinitions e
 
 replaceVars :: Expr -> Map.Map String Rational -> Either String Expr
 replaceVars (Constant c)                  vs = Right $ Constant c
 replaceVars (Variable name)               vs = maybe (Left ("Usage of unknown variable: '" ++ name ++ "'\nSuggestion: define the variable\n++  " ++ name ++ "=42")) (Right . Constant . id) $ Map.lookup name vs
-replaceVars (VariableDefinition _ value ) vs = Right $ Constant value
+replaceVars (VariableDefinition name _)   vs = replaceVars (Variable name) vs
 replaceVars (Binary op l r)               vs = case leftBranch of
         Left  s -> Left  s
         Right a -> case rightBranch of
@@ -107,7 +120,7 @@ replaceVars (Binary op l r)               vs = case leftBranch of
             Right b -> Right $ Binary op a b
     where
         leftBranch  = replaceVars l vs
-	rightBranch = replaceVars r vs
+        rightBranch = replaceVars r vs
 
 {-
  - a/b ^ c/d
@@ -117,7 +130,9 @@ replaceVars (Binary op l r)               vs = case leftBranch of
 rationalPower :: Rational -> Rational -> Rational
 rationalPower a b = rationalPower' (numerator a, denominator a) (numerator b, denominator b)
     where
-        rationalPower' (a, b) (c, 1) = a ^ c % b ^ c
+        rationalPower' (a, b) (c, 1) 
+            | c >= 0    = a ^ c % b ^ c
+            | otherwise = 1 / rationalPower (a % b) (-c % 1)
         rationalPower' _ _ = error "Powers with unnatural numbers are not supported yet"
 
 evaluate :: Expr -> Rational