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

import           Base                          (Expr (..), LispNumber(..))
import           Control.Applicative           ((<$>))
import           Control.Monad                 (void)
import           Text.Parsec.Char
import           Text.ParserCombinators.Parsec

-- 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 $ (Number . I . read) $ maybe val (:val) sign

parseFloat :: Parser Expr
parseFloat = do
    sign <- parseSign
    characteristic <- many1 digit
    char '.'
    mantissa <- many1 digit
    let fval = characteristic ++ "." ++ mantissa
    return $ (Number . F . 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

-- atmosphere
parseComment :: Parser ()
parseComment = do
    char ';'
    -- get internals of comment by getting it from here
    void $ manyTill anyChar $ try $ eol <|> eof
        where eol = void endOfLine

whiteSpace::Parser()
whiteSpace = skipMany $ parseComment <|> nl <|> spc
    where nl = void endOfLine
          spc = void space

optionalWhiteSpace :: Parser ()
optionalWhiteSpace = void $ optionMaybe whiteSpace

type Alias = String
parseModifier :: String -> Alias -> Parser Expr
parseModifier s alias = do
    string s
    x <- parseLispValue
    return $ List [Id alias, x]

parseQuote           = parseModifier "'" "quote"
parseQuasiquote      = parseModifier "`" "quasiquote"
parseUnquote         = parseModifier "," "unquote"
parseUnquoteSplicing = parseModifier ",@" "unquote-splicing"

parseLispValue :: Parser Expr
parseLispValue =
        parseString
    <|> try parseFloat
    <|> try parseInt
    <|> try parseVector
    <|> try parseId
    <|> parseQuote
    <|> parseQuasiquote
    <|> try parseUnquoteSplicing
    <|> parseUnquote
    <|> do
        char '(' >> optionalWhiteSpace
        x <- sepEndBy parseLispValue whiteSpace
        spaces
        t <- optionMaybe $ char '.' >> space >> parseLispValue
        optionalWhiteSpace >> char ')'
        return $ maybe (List x) (DottedList x) t
    <?> "lisp value";