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

import           Control.Applicative           ((<$>))
import           Control.Monad                 (liftM)
import           Text.ParserCombinators.Parsec

-- TODO: use LispNumber (src/Operators.hs) here instead of IntLiteral and FloatLiteral
data Expr = List [Expr]
          | DottedList [Expr] Expr
          | StringLiteral String
          | IntLiteral Integer
          | FloatLiteral Double
          | BoolLiteral Bool
          | Id String
          deriving (Eq)

parseString :: Parser Expr
parseString = do
    char '"'
    innards <- many (noneOf "\"")
    char '"'
    return (StringLiteral innards)

parseInt :: Parser Expr
parseInt = IntLiteral . read <$> many1 digit

parseFloat :: Parser Expr
parseFloat = do
    characteristic <- many1 digit
    char '.'
    mantissa <- many1 digit
    return $ (FloatLiteral . read) $ characteristic ++ "." ++ mantissa

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 space

parseList :: Parser Expr
parseList = List <$> sepBy parseLispValue whiteSpace

parseDottedList :: Parser Expr
parseDottedList = do
    head <- endBy parseLispValue whiteSpace
    char '.'
    whiteSpace
    DottedList head <$> parseLispValue

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 =
    try parseId
    <|> parseString
    <|> try parseFloat
    <|> parseInt
    <|> parseQuote
    <|> parseQuasiquote
    <|> parseUnquote
    <|> do
        char '('
        x <- try parseList <|> parseDottedList
        char ')'
        return x
    <?> "expected 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 (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