git.iko.soy/elk
on 63243ca help sign in
elk/compiler/Parse/Helpers.hs
384 lines 12 kB history raw
1{-# OPTIONS_GHC -W #-}
2module Parse.Helpers where
4import Prelude hiding (until)
5import Control.Applicative ((<$>),(<*>))
6import Control.Monad
7import Control.Monad.State
8import Data.Char (isUpper)
9import qualified Data.Set as Set
10import qualified Data.Map as Map
11import Text.Parsec hiding (newline,spaces,State)
12import Text.Parsec.Indent
13import qualified Text.Parsec.Token as T
15import SourceSyntax.Helpers as Help
16import SourceSyntax.Location as Location
17import SourceSyntax.Expression
18import SourceSyntax.PrettyPrint
19import SourceSyntax.Declaration (Assoc)
21reserveds = [ "if", "then", "else"
22 , "case", "of"
23 , "let", "in"
24 , "data", "type"
25 , "module", "where"
26 , "import", "as", "hiding", "open"
27 , "export", "foreign"
28 , "deriving", "port" ]
30jsReserveds :: Set.Set String
31jsReserveds = Set.fromList
32 [ "null", "undefined", "Nan", "Infinity", "true", "false", "eval"
33 , "arguments", "int", "byte", "char", "goto", "long", "final", "float"
34 , "short", "double", "native", "throws", "boolean", "abstract", "volatile"
35 , "transient", "synchronized", "function", "break", "case", "catch"
36 , "continue", "debugger", "default", "delete", "do", "else", "finally"
37 , "for", "function", "if", "in", "instanceof", "new", "return", "switch"
38 , "this", "throw", "try", "typeof", "var", "void", "while", "with", "class"
39 , "const", "enum", "export", "extends", "import", "super", "implements"
40 , "interface", "let", "package", "private", "protected", "public"
41 , "static", "yield"
42 -- reserved by the Elm runtime system
43 , "Elm", "ElmRuntime"
44 , "F2", "F3", "F4", "F5", "F6", "F7", "F8", "F9"
45 , "A2", "A3", "A4", "A5", "A6", "A7", "A8", "A9"
46 ]
48expecting = flip (<?>)
50type OpTable = Map.Map String (Int, Assoc)
51type SourceM = State SourcePos
52type IParser a = ParsecT String OpTable SourceM a
54iParse :: IParser a -> String -> Either ParseError a
55iParse = iParseWithTable "" Map.empty
57iParseWithTable :: SourceName -> OpTable -> IParser a -> String -> Either ParseError a
58iParseWithTable sourceName table aParser input =
59 runIndent sourceName $ runParserT aParser table sourceName input
61var :: IParser String
62var = makeVar (letter <|> char '_' <?> "variable")
64lowVar :: IParser String
65lowVar = makeVar (lower <?> "lower case variable")
66capVar :: IParser String
67capVar = makeVar (upper <?> "upper case variable")
69qualifiedVar :: IParser String
70qualifiedVar = do
71 vars <- many ((++) <$> capVar <*> string ".")
72 (++) (concat vars) <$> lowVar
74rLabel :: IParser String
75rLabel = lowVar
77innerVarChar :: IParser Char
78innerVarChar = alphaNum <|> char '_' <|> char '\'' <?> ""
80makeVar :: IParser Char -> IParser String
81makeVar p = do v <- (:) <$> p <*> many innerVarChar
82 guard (v `notElem` reserveds)
83 return v
85reserved :: String -> IParser String
86reserved word =
87 try (string word >> notFollowedBy innerVarChar) >> return word
88 <?> "reserved word '" ++ word ++ "'"
90anyOp :: IParser String
91anyOp = betwixt '`' '`' qualifiedVar <|> symOp <?> "infix operator (e.g. +, *, ||)"
93symOp :: IParser String
94symOp = do op <- many1 (satisfy Help.isSymbol)
95 guard (op `notElem` [ "=", "..", "->", "--", "|", "\8594", ":" ])
96 case op of
97 "." -> notFollowedBy lower >> return op
98 "\8728" -> return "."
99 _ -> return op
101padded :: IParser a -> IParser a
102padded p = do whitespace
103 out <- p
104 whitespace
105 return out
107equals :: IParser String
108equals = string "="
110arrow :: IParser String
111arrow = string "->" <|> string "\8594" <?> "arrow (->)"
113hasType :: IParser String
114hasType = string ":" <?> "':' (a type annotation)'"
117commitIf check p = commit <|> try p
118 where commit = do (try $ lookAhead check) >> p
120spaceySepBy1 :: IParser b -> IParser a -> IParser [a]
121spaceySepBy1 sep p = do
122 a <- p
123 (a:) <$> many (commitIf (whitespace >> sep) (padded sep >> p))
126commaSep1 :: IParser a -> IParser [a]
127commaSep1 = spaceySepBy1 (char ',' <?> "comma ','")
129commaSep :: IParser a -> IParser [a]
130commaSep = option [] . commaSep1
132semiSep1 :: IParser a -> IParser [a]
133semiSep1 = spaceySepBy1 (char ';' <?> "semicolon ';'")
135pipeSep1 :: IParser a -> IParser [a]
136pipeSep1 = spaceySepBy1 (char '|' <?> "type divider '|'")
138consSep1 :: IParser a -> IParser [a]
139consSep1 = spaceySepBy1 (string "::" <?> "cons operator '::'")
141dotSep1 :: IParser a -> IParser [a]
142dotSep1 p = (:) <$> p <*> many (try (char '.') >> p)
144spaceSep1 :: IParser a -> IParser [a]
145spaceSep1 p = (:) <$> p <*> spacePrefix p
147spacePrefix p = constrainedSpacePrefix p (\_ -> return ())
149constrainedSpacePrefix p constraint =
150 many $ choice [ try (spacing >> lookAhead (oneOf "[({")) >> p
151 , try (spacing >> p)
152 ]
153 where
154 spacing = do
155 n <- whitespace
156 constraint n
157 indented
159failure msg = do
160 inp <- getInput
161 setInput ('x':inp)
162 anyToken
163 fail msg
165followedBy a b = do x <- a ; b ; return x
167betwixt a b c = do char a ; out <- c
168 char b <?> "closing '" ++ [b] ++ "'" ; return out
170surround a z name p = do
171 char a ; v <- padded p
172 char z <?> unwords ["closing", name, show z]
173 return v
175braces :: IParser a -> IParser a
176braces = surround '[' ']' "brace"
178parens :: IParser a -> IParser a
179parens = surround '(' ')' "paren"
181brackets :: IParser a -> IParser a
182brackets = surround '{' '}' "bracket"
184addLocation :: (Pretty a) => IParser a -> IParser (Location.Located a)
185addLocation expr = do
186 (start, e, end) <- located expr
187 return (Location.at start end e)
189located :: IParser a -> IParser (SourcePos, a, SourcePos)
190located p = do
191 start <- getPosition
192 e <- p
193 end <- getPosition
194 return (start, e, end)
196accessible :: IParser LParseExpr -> IParser LParseExpr
197accessible expr = do
198 start <- getPosition
199 ce@(L _ e) <- expr
200 let rest f = do
201 let dot = char '.' >> notFollowedBy (char '.')
202 access <- optionMaybe (try dot <?> "field access (e.g. List.map)")
203 case access of
204 Nothing -> return ce
205 Just _ -> accessible $ do
206 v <- var <?> "field access (e.g. List.map)"
207 end <- getPosition
208 return (Location.at start end (f v))
209 case e of Var (c:cs) | isUpper c -> rest (\v -> Var (c:cs ++ '.':v))
210 | otherwise -> rest (Access ce)
211 _ -> rest (Access ce)
214spaces :: IParser String
215spaces = concat <$> many1 (multiComment <|> string " ") <?> "spaces"
217forcedWS :: IParser String
218forcedWS = choice [ try $ (++) <$> spaces <*> (concat <$> many nl_space)
219 , try $ concat <$> many1 nl_space ]
220 where nl_space = try ((++) <$> (concat <$> many1 newline) <*> spaces)
222-- Just eats whitespace until the next meaningful character.
223dumbWhitespace :: IParser String
224dumbWhitespace = concat <$> many (spaces <|> newline)
226whitespace :: IParser String
227whitespace = option "" forcedWS <?> "whitespace"
229freshLine :: IParser [[String]]
230freshLine = try (many1 newline >> many space_nl) <|> try (many1 space_nl) <?> ""
231 where space_nl = try $ spaces >> many1 newline
233newline :: IParser String
234newline = simpleNewline <|> lineComment <?> "newline"
236simpleNewline :: IParser String
237simpleNewline = try (string "\r\n") <|> string "\n"
239lineComment :: IParser String
240lineComment = do
241 try (string "--")
242 comment <- anyUntil $ simpleNewline <|> (eof >> return "\n")
243 return ("--" ++ comment)
245multiComment :: IParser String
246multiComment = (++) <$> try (string "{-") <*> closeComment
248closeComment :: IParser String
249closeComment =
250 anyUntil . choice $
251 [ try (string "-}") <?> "close comment"
252 , concat <$> sequence [ try (string "{-"), closeComment, closeComment ]
253 ]
255until :: IParser a -> IParser b -> IParser b
256until p end = go
257 where
258 go = end <|> (p >> go)
260anyUntil :: IParser String -> IParser String
261anyUntil end = go
262 where
263 go = end <|> (:) <$> anyChar <*> go
265ignoreUntil :: IParser a -> IParser (Maybe a)
266ignoreUntil end = go
267 where
268 ignore p = const () <$> p
269 filler = choice [ try (ignore chr) <|> ignore str
270 , ignore multiComment
271 , ignore (markdown (\_ _ -> mzero))
272 , ignore anyChar
273 ]
274 go = choice [ Just <$> end
275 , filler `until` choice [ const Nothing <$> eof, newline >> go ]
276 ]
278onFreshLines :: (a -> b -> b) -> b -> IParser a -> IParser b
279onFreshLines insert init thing = go init
280 where
281 go values = do
282 optionValue <- ignoreUntil thing
283 case optionValue of
284 Nothing -> return values
285 Just v -> go (insert v values)
287withSource :: IParser a -> IParser (String, a)
288withSource p = do
289 start <- getParserState
290 result <- p
291 endPos <- getPosition
292 setParserState start
293 raw <- anyUntilPos endPos
294 return (raw, result)
296anyUntilPos :: SourcePos -> IParser String
297anyUntilPos pos = go
298 where
299 go = do currentPos <- getPosition
300 case currentPos == pos of
301 True -> return []
302 False -> (:) <$> anyChar <*> go
304markdown :: (String -> [a] -> IParser (String, [a])) -> IParser (String, [a])
305markdown interpolation = try (string "[markdown|") >> closeMarkdown "" []
306 where
307 closeMarkdown md stuff =
308 choice [ do try (string "|]")
309 return (md, stuff)
310 , uncurry closeMarkdown =<< interpolation md stuff
311 , do c <- anyChar
312 closeMarkdown (md ++ [c]) stuff
313 ]
315--str :: IParser String
316str = expecting "String" $ do
317 s <- choice [ multiStr, singleStr ]
318 processAs T.stringLiteral . sandwich '\"' $ concat s
319 where
320 rawString quote insides =
321 quote >> manyTill insides quote
323 multiStr = rawString (try (string "\"\"\"")) multilineStringChar
324 singleStr = rawString (char '"') stringChar
326 stringChar :: IParser String
327 stringChar = choice [ newlineChar, escaped '\"', (:[]) <$> satisfy (/= '\"') ]
329 multilineStringChar :: IParser String
330 multilineStringChar =
331 do noEnd
332 choice [ newlineChar, escaped '\"', expandQuote <$> anyChar ]
333 where
334 noEnd = notFollowedBy (string "\"\"\"")
335 expandQuote c = if c == '\"' then "\\\"" else [c]
337 newlineChar :: IParser String
338 newlineChar =
339 choice [ char '\n' >> return "\\n"
340 , char '\r' >> return "\\r" ]
342sandwich :: Char -> String -> String
343sandwich delim s = delim : s ++ [delim]
345escaped :: Char -> IParser String
346escaped delim = try $ do
347 char '\\'
348 c <- char '\\' <|> char delim
349 return ['\\', c]
351chr :: IParser Char
352chr = betwixt '\'' '\'' character <?> "character"
353 where
354 nonQuote = satisfy (/='\'')
355 character = do
356 c <- choice [ escaped '\''
357 , (:) <$> char '\\' <*> many1 nonQuote
358 , (:[]) <$> nonQuote ]
359 processAs T.charLiteral $ sandwich '\'' c
361processAs :: (T.GenTokenParser String u SourceM -> IParser a) -> String -> IParser a
362processAs processor s = calloutParser s (processor lexer)
363 where
364 calloutParser :: String -> IParser a -> IParser a
365 calloutParser inp p = either (fail . show) return (iParse p inp)
367 lexer :: T.GenTokenParser String u SourceM
368 lexer = T.makeTokenParser elmDef
370 -- I don't know how many of these are necessary for charLiteral/stringLiteral
371 elmDef :: T.GenLanguageDef String u SourceM
372 elmDef = T.LanguageDef
373 { T.commentStart = "{-"
374 , T.commentEnd = "-}"
375 , T.commentLine = "--"
376 , T.nestedComments = True
377 , T.identStart = undefined
378 , T.identLetter = undefined
379 , T.opStart = undefined
380 , T.opLetter = undefined
381 , T.reservedNames = reserveds
382 , T.reservedOpNames = [":", "->", "<-", "|"]
383 , T.caseSensitive = True
384 }