-
Notifications
You must be signed in to change notification settings - Fork 0
/
Read.hs
42 lines (32 loc) · 1.37 KB
/
Read.hs
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
module Read ( topSExprs, readSExpr ) where
import Sexps
import Data.Maybe (fromJust)
import Control.Applicative hiding ((<|>), optional, many)
import Text.ParserCombinators.Parsec
readSExpr :: String -> SExpr
readSExpr = fromEither reportError . parse (seps *> sexpParser <* seps <* eof) ""
topSExprs :: String -> [SExpr]
topSExprs = fromEither reportLError . parse (sexpParser `sepEndBy` seps) ""
reportError = SError . show -- const (SError "read error")
reportLError = const [SError "read error"]
sexpParser :: CharParser st SExpr
sexpParser = squote <|> slist <|> satom <?> "a list or atom"
slist = SList <$> (char '(' *> (sexpParser `sepEndBy` seps) <* char ')')
satom = try snum <|> try sstring <|> ssym
snum = do
s <- many1 symchars
case reads s :: [(Integer, String)] of
[(i, "")] -> return $ sexpInt i
_ -> case reads s :: [(Float, String)] of
[(f, "")] -> return $ sexpFloat f
_ -> fail "no int"
sstring = sexpStr <$> (char '"' >> quotedChar `manyTill` (char '"'))
ssym = sexpSym <$> many1 symchars
squote = sexpQuote <$> (char '\'' >> sexpParser)
quotedChar = (char '\\' >> ((fromJust . flip lookup escapes <$> oneOf escaped) <|> anyChar)) <|> anyChar
symchars = noneOf "'(); \n\t"
seps = spaces *> optional comment
comment = char ';' >> many (noneOf "\n") <* spaces
escaped = "ntr"
escapes = zip escaped "\n\t\r"
fromEither = flip either id