aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Operators.hs15
-rw-r--r--src/Parser.hs24
2 files changed, 28 insertions, 11 deletions
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
46 (I a) / (F b) = F $ fromIntegral a / b 46 (I a) / (F b) = F $ fromIntegral a / b
47 (F a) / (F b) = F $ a / b 47 (F a) / (F b) = F $ a / b
48 48
49arithmetic :: (LispNumber -> LispNumber -> LispNumber) -> [Expr] -> LispResult Expr 49type Arithmetic = LispNumber -> LispNumber -> LispNumber
50type Comparator = LispNumber -> LispNumber -> Bool
51type UnaryBool = Bool -> Bool
52type NaryBool = Bool -> Bool -> Bool
53
54arithmetic :: Arithmetic -> [Expr] -> LispResult Expr
50arithmetic op args 55arithmetic op args
51 | length args < 2 = throwError $ ArgCount 2 args 56 | null args = throwError $ ArgCount 1 args
52 | otherwise = do 57 | otherwise = do
53 as <- mapM unwrapNum args 58 as <- mapM unwrapNum args
54 return . wrapNum $ foldl1 op as 59 return . wrapNum $ foldl1 op as
55 60
56comparator :: (LispNumber -> LispNumber -> Bool) -> [Expr] -> LispResult Expr 61comparator :: Comparator -> [Expr] -> LispResult Expr
57comparator op args 62comparator op args
58 | length args < 2 = throwError $ ArgCount 2 args 63 | length args < 2 = throwError $ ArgCount 2 args
59 | otherwise = do 64 | otherwise = do
60 as <- mapM unwrapNum args 65 as <- mapM unwrapNum args
61 return . BoolLiteral . all (== True) $ zipWith op as (tail as) 66 return . BoolLiteral . all (== True) $ zipWith op as (tail as)
62 67
63unaryBool :: (Bool -> Bool) -> [Expr] -> LispResult Expr 68unaryBool :: UnaryBool -> [Expr] -> LispResult Expr
64unaryBool op args 69unaryBool op args
65 | length args /= 1 = throwError $ ArgCount 1 args 70 | length args /= 1 = throwError $ ArgCount 1 args
66 | otherwise = BoolLiteral . op <$> unwrapBool (head args) 71 | otherwise = BoolLiteral . op <$> unwrapBool (head args)
67 72
68naryBool :: (Bool -> Bool -> Bool) -> [Expr] -> LispResult Expr 73naryBool :: NaryBool -> [Expr] -> LispResult Expr
69naryBool op args 74naryBool op args
70 | length args < 2 = throwError $ ArgCount 2 args 75 | length args < 2 = throwError $ ArgCount 2 args
71 | otherwise = do 76 | 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
33 char '"' 33 char '"'
34 return (StringLiteral innards) 34 return (StringLiteral innards)
35 35
36parseSign :: Parser (Maybe Char)
37parseSign = do
38 sign <- optionMaybe (oneOf "+-")
39 return $ case sign of
40 Just '+' -> Nothing
41 s -> s
42
36parseInt :: Parser Expr 43parseInt :: Parser Expr
37parseInt = IntLiteral . read <$> many1 digit 44parseInt = do
45 sign <- parseSign
46 val <- many1 digit
47 return $ (IntLiteral . read) $ maybe val (:val) sign
38 48
39parseFloat :: Parser Expr 49parseFloat :: Parser Expr
40parseFloat = do 50parseFloat = do
51 sign <- parseSign
41 characteristic <- many1 digit 52 characteristic <- many1 digit
42 char '.' 53 char '.'
43 mantissa <- many1 digit 54 mantissa <- many1 digit
44 return $ (FloatLiteral . read) $ characteristic ++ "." ++ mantissa 55 let fval = characteristic ++ "." ++ mantissa
56 return $ (FloatLiteral . read) $ maybe fval (:fval) sign
45 57
46symbol :: Parser Char 58symbol :: Parser Char
47symbol = oneOf "!#$%&|*+:/-=<?>@^_~" 59symbol = oneOf "!#$%&|*+:/-=<?>@^_~"
@@ -73,10 +85,10 @@ parseUnquote = parseModifier ',' "unquote"
73 85
74parseLispValue :: Parser Expr 86parseLispValue :: Parser Expr
75parseLispValue = 87parseLispValue =
76 try parseId 88 parseString
77 <|> parseString
78 <|> try parseFloat 89 <|> try parseFloat
79 <|> parseInt 90 <|> try parseInt
91 <|> try parseId
80 <|> parseQuote 92 <|> parseQuote
81 <|> parseQuasiquote 93 <|> parseQuasiquote
82 <|> parseUnquote 94 <|> parseUnquote
@@ -85,7 +97,7 @@ parseLispValue =
85 char '(' >> spaces 97 char '(' >> spaces
86 x <- sepEndBy parseLispValue whiteSpace 98 x <- sepEndBy parseLispValue whiteSpace
87 spaces 99 spaces
88 t <- optionMaybe $ char '.' >> space >> parseLispValue 100 t <- optionMaybe $ space >> char '.' >> space >> parseLispValue
89 spaces >> char ')' 101 spaces >> char ')'
90 return $ maybe (List x) (DottedList x) t 102 return $ maybe (List x) (DottedList x) t
91 <?> "lisp value" 103 <?> "lisp value"