From c5d07ee83d1522b5ee9753d379dc1daf09600c08 Mon Sep 17 00:00:00 2001
From: Akshay <nerdy@peppe.rs>
Date: Mon, 12 Oct 2020 11:26:57 +0530
Subject: parse signed ints and floats correctly

---
 bin/Main.hs      |  3 +--
 src/Operators.hs | 15 ++++++++++-----
 src/Parser.hs    | 24 ++++++++++++++++++------
 3 files changed, 29 insertions(+), 13 deletions(-)

diff --git a/bin/Main.hs b/bin/Main.hs
index 7bb6d84..a088fdb 100644
--- a/bin/Main.hs
+++ b/bin/Main.hs
@@ -26,8 +26,7 @@ repl = do
       Just ",q" -> return ()
       Just line -> do
           addHistory line
-          -- TODO: don't directly print Either values
-          print $ eval =<< readExpr line
+          putStrLn $ either show show $ eval =<< readExpr line
           repl
 
 main :: IO ()
diff --git a/src/Operators.hs b/src/Operators.hs
index 45be7f3..84d2894 100644
--- a/src/Operators.hs
+++ b/src/Operators.hs
@@ -46,26 +46,31 @@ instance Fractional LispNumber where
     (I a) / (F b) = F $ fromIntegral a / b
     (F a) / (F b) = F $ a / b
 
-arithmetic :: (LispNumber -> LispNumber -> LispNumber) -> [Expr] -> LispResult Expr
+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
-    | length args < 2 = throwError $ ArgCount 2 args
+    | null args = throwError $ ArgCount 1 args
     | otherwise = do
         as <- mapM unwrapNum args
         return . wrapNum $ foldl1 op as
 
-comparator :: (LispNumber -> LispNumber -> Bool) -> [Expr] -> LispResult Expr
+comparator :: Comparator -> [Expr] -> LispResult Expr
 comparator op args
     | length args < 2 = throwError $ ArgCount 2 args
     | otherwise = do
         as <- mapM unwrapNum args
         return . BoolLiteral . all (== True) $ zipWith op as (tail as)
 
-unaryBool :: (Bool -> Bool) -> [Expr] -> LispResult Expr
+unaryBool :: UnaryBool -> [Expr] -> LispResult Expr
 unaryBool op args
   | length args /= 1 = throwError $ ArgCount 1 args
   | otherwise = BoolLiteral . op <$> unwrapBool (head args)
 
-naryBool :: (Bool -> Bool -> Bool) -> [Expr] -> LispResult Expr
+naryBool :: NaryBool -> [Expr] -> LispResult Expr
 naryBool op args
   | length args < 2 = throwError $ ArgCount 2 args
   | otherwise = do
diff --git a/src/Parser.hs b/src/Parser.hs
index 37b0b9d..0ac8b54 100644
--- a/src/Parser.hs
+++ b/src/Parser.hs
@@ -33,15 +33,27 @@ parseString = do
     char '"'
     return (StringLiteral innards)
 
+parseSign :: Parser (Maybe Char)
+parseSign = do
+    sign <- optionMaybe (oneOf "+-")
+    return $ case sign of
+               Just '+' -> Nothing
+               s        -> s
+
 parseInt :: Parser Expr
-parseInt = IntLiteral . read <$> many1 digit
+parseInt = do
+    sign <- parseSign
+    val <- many1 digit
+    return $ (IntLiteral . read) $ maybe val (:val) sign
 
 parseFloat :: Parser Expr
 parseFloat = do
+    sign <- parseSign
     characteristic <- many1 digit
     char '.'
     mantissa <- many1 digit
-    return $ (FloatLiteral . read) $ characteristic ++ "." ++ mantissa
+    let fval = characteristic ++ "." ++ mantissa
+    return $ (FloatLiteral . read) $ maybe fval (:fval) sign
 
 symbol :: Parser Char
 symbol = oneOf "!#$%&|*+:/-=<?>@^_~"
@@ -73,10 +85,10 @@ parseUnquote = parseModifier ',' "unquote"
 
 parseLispValue :: Parser Expr
 parseLispValue =
-    try parseId
-    <|> parseString
+    parseString
     <|> try parseFloat
-    <|> parseInt
+    <|> try parseInt
+    <|> try parseId
     <|> parseQuote
     <|> parseQuasiquote
     <|> parseUnquote
@@ -85,7 +97,7 @@ parseLispValue =
         char '(' >> spaces
         x <- sepEndBy parseLispValue whiteSpace
         spaces
-        t <- optionMaybe $ char '.' >> space >> parseLispValue
+        t <- optionMaybe $ space >> char '.' >> space >> parseLispValue
         spaces >> char ')'
         return $ maybe (List x) (DottedList x) t
     <?> "lisp value"
-- 
cgit v1.2.3