blob: 54728938299a0be61d15f6b1a8cdfe78d8926367 (
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
|
{-# LANGUAGE LambdaCase #-}
module Parser(parseProgram, parseExpression) where
import qualified Control.Exception as E
import Control.Monad
import Control.Monad.Trans
import Data.Char
import Data.Maybe
import System.FilePath
import System.IO.Error (isDoesNotExistError)
import Text.Parsec
import Text.Parsec.Pos
import AST
newtype ParserState = ParserState (Maybe FilePath)
type Parser = ParsecT String ParserState IO
parseProgram :: Maybe FilePath -> String -> IO (Either ParseError Program)
parseProgram mpath = runParserT pProgram (ParserState mpath) (fromMaybe "" mpath)
pProgram :: Parser Program
pProgram = between pWhiteComment eof (liftM Program (many pValue))
parseExpression :: String -> IO (Either ParseError Value)
parseExpression = runParserT pExpression (ParserState Nothing) ""
pExpression :: Parser Value
pExpression = between pWhiteComment eof pValue
pValue :: Parser Value
pValue = pPPC <|> pVEllipsis <|> pVList <|> pVNum <|> pVString <|> pVName <|> pVQuoted <?> "value"
pVList :: Parser Value
pVList = flip label "list" $ do
symbol "("
exs <- many pValue
symbol ")"
return $ VList exs
pVNum :: Parser Value
pVNum = liftM (VNum . read) (try ((:) <$> char '-' <*> many1 digit) <|> many1 digit) <* pWhiteComment <?> "number"
pVString :: Parser Value
pVString = fmap VString pString
pVName :: Parser Value
pVName = flip label "name" $ do
first <- satisfy isFirstNameChar
rest <- many (satisfy isNameChar)
pWhiteComment
return $ VName $ first : rest
where
isNameChar c = ((c >= '*' && c <= 'z') || c `elem` "!$%&|~") && c /= ';'
isFirstNameChar c = isNameChar c && not (isDigit c)
pVQuoted :: Parser Value
pVQuoted = char '\'' >> liftM VQuoted pValue <?> "quoted value"
pVEllipsis :: Parser Value
pVEllipsis = symbol "..." >> return VEllipsis <?> "ellipsis"
pPPC :: Parser Value
pPPC = flip label "preprocessor command" $ do
symbol "#include"
incfname <- pString
ParserState basefname <- getState
(fname, src) <- liftIO (readPPCinclude basefname incfname)
stateBackup <- getParserState
void $ setParserState (State ("(do " ++ src ++ ")") (initialPos fname) (ParserState (Just fname)))
result <- pValue <* eof
void $ setParserState stateBackup
return result
symbol :: String -> Parser ()
symbol s = try (string s) >> pWhiteComment
pString :: Parser String
pString = flip label "string" $ do
void $ char '"'
s <- manyTill pStringChar (symbol "\"")
return s
pStringChar :: Parser Char
pStringChar =
(char '\\' >>
choice [ char 'n' >> return '\n'
, char 'r' >> return '\r'
, char 't' >> return '\t'
, char '0' >> return '\0'
, char 'x' >> pHexDigit >>= \a -> pHexDigit >>= \b -> return (chr (16 * a + b))
, char '"' >> return '"'
, char '\\' >> return '\\' ]) <|>
anyChar
where
pHexDigit :: Parser Int
pHexDigit = (subtract 48 . fromEnum <$> digit)
<|> ((+ (10 - 97)) . ord <$> oneOf "abcdef")
<|> ((+ (10 - 65)) . ord <$> oneOf "ABCDEF")
pWhiteComment :: Parser ()
pWhiteComment = do
pWhitespace
void $ many $ pComment >> pWhitespace
where
pWhitespace :: Parser ()
pWhitespace = void (many space) <?> "whitespace"
pComment :: Parser ()
pComment = flip label "comment" $ do
void $ char ';'
void (manyTill anyChar (void endOfLine <|> eof))
readPPCinclude :: Maybe FilePath -> String -> IO (FilePath, String)
readPPCinclude mbase fname =
let searchDirs = [maybe "." takeDirectory mbase]
cands = map (</> fname) searchDirs
tryCand cand = E.tryJust (guard . isDoesNotExistError) (readFile cand) >>= \case
Left _ -> return Nothing
Right src -> return (Just (cand, src))
in (catMaybes <$> sequence (map tryCand cands)) >>= \case
[] -> error $ "Cannot find #include'd file '" ++ fname ++ "'"
pair : _ -> return pair
|
