diff options
Diffstat (limited to 'src/Parser.hs')
-rw-r--r-- | src/Parser.hs | 101 |
1 files changed, 101 insertions, 0 deletions
diff --git a/src/Parser.hs b/src/Parser.hs new file mode 100644 index 0000000..dcbfdb1 --- /dev/null +++ b/src/Parser.hs | |||
@@ -0,0 +1,101 @@ | |||
1 | module Parser ( parseLispValue | ||
2 | , Expr(..) | ||
3 | , parseString | ||
4 | , parseInt | ||
5 | , parseFloat | ||
6 | , parseAtom | ||
7 | , parseList | ||
8 | , parseQuote | ||
9 | , parseDottedList | ||
10 | ) where | ||
11 | |||
12 | import Control.Applicative ((<$>)) | ||
13 | import Control.Monad (liftM) | ||
14 | import Text.ParserCombinators.Parsec | ||
15 | |||
16 | |||
17 | type Ident = String | ||
18 | |||
19 | data Expr = List [Expr] | ||
20 | | DottedList [Expr] Expr | ||
21 | | StringLiteral String | ||
22 | | IntLiteral Integer | ||
23 | | FloatLiteral Double | ||
24 | | BoolLiteral Bool | ||
25 | | Id Ident | ||
26 | deriving (Eq) | ||
27 | |||
28 | parseString :: Parser Expr | ||
29 | parseString = do | ||
30 | char '"' | ||
31 | innards <- many (noneOf "\"") | ||
32 | char '"' | ||
33 | return (StringLiteral innards) | ||
34 | |||
35 | parseInt :: Parser Expr | ||
36 | parseInt = IntLiteral . read <$> many1 digit | ||
37 | |||
38 | parseFloat :: Parser Expr | ||
39 | parseFloat = do | ||
40 | characteristic <- many digit | ||
41 | char '.' | ||
42 | mantissa <- many1 digit | ||
43 | return $ (FloatLiteral . read) $ characteristic ++ "." ++ mantissa | ||
44 | |||
45 | symbol :: Parser Char | ||
46 | symbol = oneOf "!#$%&|*+:/-=<?>@^_~" | ||
47 | |||
48 | parseAtom :: Parser Expr | ||
49 | parseAtom = do | ||
50 | first <- letter <|> symbol | ||
51 | rest <- many (letter <|> symbol <|> digit) | ||
52 | let atom = first:rest | ||
53 | return $ case atom of | ||
54 | "#t" -> BoolLiteral True | ||
55 | "#f" -> BoolLiteral False | ||
56 | _ -> Id atom | ||
57 | |||
58 | whiteSpace :: Parser () | ||
59 | whiteSpace = skipMany1 space | ||
60 | |||
61 | parseList :: Parser Expr | ||
62 | parseList = List <$> sepBy parseLispValue whiteSpace | ||
63 | |||
64 | parseDottedList :: Parser Expr | ||
65 | parseDottedList = do | ||
66 | head <- endBy parseLispValue whiteSpace | ||
67 | char '.' | ||
68 | whiteSpace | ||
69 | DottedList head <$> parseLispValue | ||
70 | |||
71 | parseQuote :: Parser Expr | ||
72 | parseQuote = do | ||
73 | char '\'' | ||
74 | x <- parseLispValue | ||
75 | return $ List [Id "quote", x] | ||
76 | |||
77 | |||
78 | parseLispValue :: Parser Expr | ||
79 | parseLispValue = | ||
80 | try parseAtom | ||
81 | <|> parseString | ||
82 | <|> parseInt | ||
83 | <|> parseQuote | ||
84 | -- TODO: figure out a way to have floats and dotted lists | ||
85 | -- <|> parseFloat | ||
86 | <|> do | ||
87 | char '(' | ||
88 | x <- try parseList <|> parseDottedList | ||
89 | char ')' | ||
90 | return x | ||
91 | <?> "expected lisp value!" | ||
92 | |||
93 | instance Show Expr where | ||
94 | show (DottedList xs x) = "(" ++ unwords (map show xs) ++ " . " ++ show x ++ ")" | ||
95 | show (List xs) = "(" ++ unwords (map show xs) ++ ")" | ||
96 | show (StringLiteral s) = "\"" ++ s ++ "\"" | ||
97 | show (IntLiteral n) = show n | ||
98 | show (FloatLiteral n) = show n | ||
99 | show (BoolLiteral True) = "#t" | ||
100 | show (BoolLiteral False) = "#f" | ||
101 | show (Id i) = i | ||