diff options
Diffstat (limited to 'src')
-rw-r--r-- | src/Operators.hs | 15 | ||||
-rw-r--r-- | src/Parser.hs | 24 |
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 | ||
49 | arithmetic :: (LispNumber -> LispNumber -> LispNumber) -> [Expr] -> LispResult Expr | 49 | type Arithmetic = LispNumber -> LispNumber -> LispNumber |
50 | type Comparator = LispNumber -> LispNumber -> Bool | ||
51 | type UnaryBool = Bool -> Bool | ||
52 | type NaryBool = Bool -> Bool -> Bool | ||
53 | |||
54 | arithmetic :: Arithmetic -> [Expr] -> LispResult Expr | ||
50 | arithmetic op args | 55 | arithmetic 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 | ||
56 | comparator :: (LispNumber -> LispNumber -> Bool) -> [Expr] -> LispResult Expr | 61 | comparator :: Comparator -> [Expr] -> LispResult Expr |
57 | comparator op args | 62 | comparator 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 | ||
63 | unaryBool :: (Bool -> Bool) -> [Expr] -> LispResult Expr | 68 | unaryBool :: UnaryBool -> [Expr] -> LispResult Expr |
64 | unaryBool op args | 69 | unaryBool 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 | ||
68 | naryBool :: (Bool -> Bool -> Bool) -> [Expr] -> LispResult Expr | 73 | naryBool :: NaryBool -> [Expr] -> LispResult Expr |
69 | naryBool op args | 74 | naryBool 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 | ||
36 | parseSign :: Parser (Maybe Char) | ||
37 | parseSign = do | ||
38 | sign <- optionMaybe (oneOf "+-") | ||
39 | return $ case sign of | ||
40 | Just '+' -> Nothing | ||
41 | s -> s | ||
42 | |||
36 | parseInt :: Parser Expr | 43 | parseInt :: Parser Expr |
37 | parseInt = IntLiteral . read <$> many1 digit | 44 | parseInt = do |
45 | sign <- parseSign | ||
46 | val <- many1 digit | ||
47 | return $ (IntLiteral . read) $ maybe val (:val) sign | ||
38 | 48 | ||
39 | parseFloat :: Parser Expr | 49 | parseFloat :: Parser Expr |
40 | parseFloat = do | 50 | parseFloat = 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 | ||
46 | symbol :: Parser Char | 58 | symbol :: Parser Char |
47 | symbol = oneOf "!#$%&|*+:/-=<?>@^_~" | 59 | symbol = oneOf "!#$%&|*+:/-=<?>@^_~" |
@@ -73,10 +85,10 @@ parseUnquote = parseModifier ',' "unquote" | |||
73 | 85 | ||
74 | parseLispValue :: Parser Expr | 86 | parseLispValue :: Parser Expr |
75 | parseLispValue = | 87 | parseLispValue = |
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" |