1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
|
module Parser ( parseLispValue
, Expr(..)
, parseString
, parseInt
, parseFloat
, parseId
, parseQuote
) where
import Control.Applicative ((<$>))
import Text.ParserCombinators.Parsec
-- TODO: use LispNumber (src/Operators.hs) here instead of IntLiteral and FloatLiteral
-- TODO: add character literals: \#a \#b \#c \#space \#newline
-- TODO: add support for complex numbers, oct and hex numbers
data Expr = List [Expr]
| Vector [Expr]
| DottedList [Expr] Expr
| StringLiteral String
| IntLiteral Integer
| FloatLiteral Double
| BoolLiteral Bool
| Id String
| NoReturn
deriving (Eq)
-- backslash double quote escapes a quote inside strings
quotedChar = noneOf ['\"'] <|> try (string "\\\"" >> return '"')
parseString :: Parser Expr
parseString = do
char '"'
innards <- many quotedChar
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 = 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
let fval = characteristic ++ "." ++ mantissa
return $ (FloatLiteral . read) $ maybe fval (:fval) sign
parseVector :: Parser Expr
parseVector = do
string "#(" >> optionalWhiteSpace
x <- sepEndBy parseLispValue whiteSpace
optionalWhiteSpace >> char ')'
return $ Vector x
symbol :: Parser Char
symbol = oneOf "!#$%&|*+:/-=<?>@^_~"
parseId :: Parser Expr
parseId = do
first <- letter <|> symbol
rest <- many (letter <|> symbol <|> digit)
let atom = first:rest
return $ case atom of
"#t" -> BoolLiteral True
"#f" -> BoolLiteral False
_ -> Id atom
whiteSpace :: Parser ()
whiteSpace = skipMany1 $ oneOf [' ', '\n']
optionalWhiteSpace :: Parser ()
optionalWhiteSpace = skipMany $ oneOf [' ', '\n']
type Alias = String
parseModifier :: Char -> Alias -> Parser Expr
parseModifier c alias = do
char c
x <- parseLispValue
return $ List [Id alias, x]
parseQuote = parseModifier '\'' "quote"
parseQuasiquote = parseModifier '`' "quasiquote"
parseUnquote = parseModifier ',' "unquote"
-- TODO: add modifier for unquote splicing: ,@
parseLispValue :: Parser Expr
parseLispValue =
parseString
<|> try parseFloat
<|> try parseInt
<|> try parseVector
<|> try parseId
<|> parseQuote
<|> parseQuasiquote
<|> parseUnquote
-- handles lists and dotted lists
<|> do
char '(' >> optionalWhiteSpace
x <- sepEndBy parseLispValue whiteSpace
spaces
t <- optionMaybe $ char '.' >> space >> parseLispValue
optionalWhiteSpace >> char ')'
return $ maybe (List x) (DottedList x) t
<?> "lisp value"
showLispList :: [Expr] -> String
showLispList = unwords . map show
instance Show Expr where
show (DottedList xs x) = "(" ++ showLispList xs ++ " . " ++ show x ++ ")"
show (List xs) = "(" ++ showLispList xs ++ ")"
show (Vector xs) = "#(" ++ showLispList xs ++ ")"
show (StringLiteral s) = "\"" ++ s ++ "\""
show (IntLiteral n) = show n
show (FloatLiteral n) = show n
show (BoolLiteral True) = "#t"
show (BoolLiteral False) = "#f"
show (Id i) = i
show NoReturn = ";;; environment extension"
|
