@@ -4,7 +4,7 @@ module ParseLib where
44import Ast
55import Control.Monad
66import Data.Char (isSymbol)
7−import Text.Parsec
7+import Text.Parsec hiding (newline,spaces)
88
99reserved = [ "if", "then", "else"
1010 , "case", "of", "data"
@@ -12,23 +12,46 @@ reserved = [ "if", "then", "else"
1212
1313expecting = flip (<?>)
1414
15+backslashed :: (Monad m) => ParsecT [Char] u m Char
16+backslashed = do { char '\\'; c <- anyChar
17+ ; return . read $ ['\'','\\',c,'\''] }
18+
1519var :: (Monad m) => ParsecT [Char] u m String
16−var = do
17− c <- letter {-lower-} <|> char '_'
20+var = makeVar $ letter <|> char '_'
21+
22+lowVar :: (Monad m) => ParsecT [Char] u m String
23+lowVar = makeVar (lower <?> "lower case variable")
24+capVar :: (Monad m) => ParsecT [Char] u m String
25+capVar = makeVar (upper <?> "upper case variable")
26+
27+makeVar p = do
28+ c <- p
1829 cs <- many $ alphaNum <|> char '_' <|> char '\''
1930 guard $ c:cs `notElem` reserved
2031 return $ c:cs
2132
33+
2234anyOp :: (Monad m) => ParsecT [Char] u m String
23−anyOp = many1 (satisfy isSymbol <|> oneOf "+-/*=.$<>:&|^?%#@~!")
35+anyOp = betwixt '`' '`' var <|>
36+ (do op <- many1 (satisfy isSymbol <|> oneOf "+-/*=.$<>:&|^?%#@~!")
37+ guard (op `notElem` [ "=", "..", "->" ])
38+ return op) <?> "infix operator"
2439
25−lexeme p = do e <- p ; whitespace ; return e
40+lexeme p = do whitespace ; p
2641
27−whitespace :: (Monad m) => ParsecT [Char] u m String
28−whitespace = try $ many (char ' ')
42+symbol :: (Monad m) => String -> ParsecT [Char] u m String
43+symbol s = whitespace >> string s
2944
30−betwixt a b = between (char a) (char b <?> "closing '" ++ [b] ++ "'")
31−betwixtSpcs a b = between (lexeme $ char a) (char b <?> "closing '" ++ [b] ++ "'")
45+arrow :: (Monad m) => ParsecT [Char] u m String
46+arrow = symbol "->" <|> symbol "\8594"
47+
48+commaSep p = p `sepBy` lexeme (char ',')
49+
50+
51+betwixt a b c = do char a ; out <- c
52+ char b <?> "closing '" ++ [b] ++ "'" ; return out
53+betwixtSpcs a b c = do char a ; whitespace ; out <- c ; whitespace
54+ char b <?> "closing '" ++ [b] ++ "'" ; return out
3255
3356listOf p = betwixtSpcs '[' ']' $ p `sepBy` lexeme (char ',')
3457
@@ -38,3 +61,37 @@ accessible expr = do
3861 case access of
3962 Just '.' -> accessible (Access e `liftM` var)
4063 Nothing -> return e
64+
65+
66+spaces :: (Monad m) => ParsecT [Char] u m String
67+spaces = many1 ((multiComment <|> string " ") >> return ' ') <?> "spaces"
68+
69+forcedWS :: (Monad m) => ParsecT [Char] u m [String]
70+forcedWS = try (do { spaces; many nl_space }) <|> try (many1 nl_space)
71+ where nl_space = try $ many1 newline >> spaces
72+
73+whitespace :: (Monad m) => ParsecT [Char] u m ()
74+whitespace = optional forcedWS <?> "whitespace"
75+
76+freshLine :: (Monad m) => ParsecT [Char] u m [[String]]
77+freshLine = try (do { many1 newline; many space_nl }) <|> try (many1 space_nl) <?> "fresh line"
78+ where space_nl = try $ spaces >> many1 newline
79+
80+newline :: (Monad m) => ParsecT [Char] u m String
81+newline = simpleNewline <|> lineComment <?> "newline"
82+
83+simpleNewline :: (Monad m) => ParsecT [Char] u m String
84+simpleNewline = try (string "\r\n") <|> string "\n"
85+
86+lineComment :: (Monad m) => ParsecT [Char] u m String
87+lineComment = do try $ string "--"
88+ manyTill anyChar $ simpleNewline <|> (eof >> return "\n")
89+
90+multiComment :: (Monad m) => ParsecT [Char] u m String
91+multiComment = do { try $ string "{-"; closeComment }
92+
93+closeComment :: (Monad m) => ParsecT [Char] u m String
94+closeComment = manyTill anyChar . choice $
95+ [ try $ string "-}"
96+ , do { try $ string "{-"; closeComment; closeComment }
97+ ]