From da70b8021ff08d2f994597a9f01289cf4cc04adb Mon Sep 17 00:00:00 2001
From: Akshay <nerdy@peppe.rs>
Date: Thu, 15 Oct 2020 16:02:17 +0530
Subject: improve arity error messages

 - now includes function name with expected arity
 - closes #4 on github.com/dscrv/lisk
---
 src/Error/Base.hs |  7 +++++--
 src/Operators.hs  | 53 +++++++++++++++++++++++++++--------------------------
 2 files changed, 32 insertions(+), 28 deletions(-)

(limited to 'src')

diff --git a/src/Error/Base.hs b/src/Error/Base.hs
index 509377b..d7b685c 100644
--- a/src/Error/Base.hs
+++ b/src/Error/Base.hs
@@ -12,7 +12,7 @@ import           Text.ParserCombinators.Parsec
 
 data LispError = Parse ParseError
                | BadForm String Expr
-               | ArgCount Int [Expr]
+               | ArgCount String Int [Expr]
                | UnknownFunction String
                | TypeMismatch String Expr
 
@@ -22,7 +22,10 @@ unwordsList = unwords . map show
 instance Show LispError where
     show (Parse e)              = "Parser Error: " ++ show e
     show (BadForm s expr)       = "Bad Form: " ++ s ++ ": " ++ show expr
-    show (ArgCount n es)        = "Invalid arity, expected " ++ show n ++ ", got value(s): " ++ unwordsList es
+    -- TODO: clean this up
+    show (ArgCount fn n es)
+      | null es = "Invalid arity, `" ++ fn ++ "` expects " ++ show n ++ " or more expression(s)!"
+      | otherwise = "Invalid arity, `" ++ fn ++ "` expects " ++ show n ++ " or more expression(s), got value(s): " ++ unwordsList es
     show (UnknownFunction fn)   = "Cannot apply function: " ++ fn
     show (TypeMismatch msg got) = "Type mismatch, expected " ++ msg ++ ", got: " ++ show got
 
diff --git a/src/Operators.hs b/src/Operators.hs
index 27488f3..051655a 100644
--- a/src/Operators.hs
+++ b/src/Operators.hs
@@ -7,21 +7,21 @@ import           Error.Base           (LispError (..), LispResult (..))
 import           Parser
 
 primitives :: [(String, [Expr] -> LispResult Expr)]
-primitives =
+primitives = map (\(n, f) -> (n, f n))
     [
-    ("+", arithmetic (+))
-    , ("-", arithmetic (-))
-    , ("*", arithmetic (*))
-    , ("/", arithmetic (/))
-    , (">", comparator (>))
-    , ("<", comparator (<))
-    , (">=", comparator (>=))
-    , ("<=", comparator (<=))
-    , ("=", comparator (==))
-    , ("!=", comparator (/=))
-    , ("not", unaryBool not)
-    , ("or", naryBool (||))
-    , ("and", naryBool (&&))
+           ("+" , arithmetic (+))
+         , ("-" , arithmetic (-))
+         , ("*" , arithmetic (*))
+         , ("/" , arithmetic (/))
+         , (">" , comparator (>))
+         , ("<" , comparator (<))
+         , (">=" , comparator (>=))
+         , ("<=" , comparator (<=))
+         , ("=" , comparator (==))
+         , ("!=" , comparator (/=))
+         , ("not" , unaryBool not)
+         , ("or" , naryBool  (||))
+         , ("and" , naryBool  (&&))
     ]
 
 data LispNumber = I Integer
@@ -46,33 +46,34 @@ instance Fractional LispNumber where
     (I a) / (F b) = F $ fromIntegral a / b
     (F a) / (F b) = F $ a / b
 
+type FName = String
 type Arithmetic = LispNumber -> LispNumber -> LispNumber
 type Comparator = LispNumber -> LispNumber -> Bool
 type UnaryBool = Bool -> Bool
 type NaryBool = Bool -> Bool -> Bool
 
-arithmetic :: Arithmetic -> [Expr] -> LispResult Expr
-arithmetic op args
-    | null args = throwError $ ArgCount 1 args
+arithmetic ::  Arithmetic -> FName -> [Expr] -> LispResult Expr
+arithmetic op name args
+    | null args = throwError $ ArgCount name 1 args
     | otherwise = do
         as <- mapM unwrapNum args
         return . wrapNum $ foldl1 op as
 
-comparator :: Comparator -> [Expr] -> LispResult Expr
-comparator op args
-    | length args < 2 = throwError $ ArgCount 2 args
+comparator :: Comparator -> FName -> [Expr] -> LispResult Expr
+comparator op name args
+    | length args < 2 = throwError $ ArgCount name 2 args
     | otherwise = do
         as <- mapM unwrapNum args
         return . BoolLiteral . all (== True) $ zipWith op as (tail as)
 
-unaryBool :: UnaryBool -> [Expr] -> LispResult Expr
-unaryBool op args
-  | length args /= 1 = throwError $ ArgCount 1 args
+unaryBool :: UnaryBool -> FName -> [Expr] -> LispResult Expr
+unaryBool op name args
+  | length args /= 1 = throwError $ ArgCount name 1 args
   | otherwise = BoolLiteral . op <$> unwrapBool (head args)
 
-naryBool :: NaryBool -> [Expr] -> LispResult Expr
-naryBool op args
-  | length args < 2 = throwError $ ArgCount 2 args
+naryBool :: NaryBool -> FName -> [Expr] -> LispResult Expr
+naryBool op name args
+  | length args < 2 = throwError $ ArgCount name 2 args
   | otherwise = do
       as <- mapM unwrapBool args
       return . BoolLiteral $ foldl1 op as
-- 
cgit v1.2.3