aboutsummaryrefslogtreecommitdiff
path: root/src/Parser.hs
blob: a7f5571604894cca96197c4b7c58684b5419c473 (plain)
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
131
module Parser ( parseLispValue
              , Expr(..)
              , parseString
              , parseInt
              , parseFloat
              , parseId
              , parseQuote
              ) where

import           Control.Applicative           ((<$>))
import           Control.Monad                 (liftM)
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"