never executed always true always false
1 {-# LANGUAGE FlexibleContexts #-}
2 {-# LANGUAGE DataKinds #-}
3 module Parse.Helpers where
4
5 import Prelude hiding (until)
6 import Control.Monad (guard)
7 import qualified Data.Indexed as I
8 import Data.Map.Strict hiding (foldl)
9 import Text.Parsec hiding (newline, spaces, State)
10 import Text.Parsec.Indent (indented, runIndent)
11
12 import AST.V0_16
13 import qualified AST.Helpers as Help
14 import AST.Structure (FixAST)
15 import ElmVersion
16 import qualified Parse.State as State
17 import Parse.Comments
18 import Parse.IParser
19 import Parse.Whitespace
20 import qualified Reporting.Annotation as A
21 import qualified Reporting.Error.Syntax as Syntax
22 import qualified Reporting.Region as R
23
24
25 reserveds :: [String]
26 reserveds =
27 [ "if", "then", "else"
28 , "case", "of"
29 , "let", "in"
30 , "type"
31 , "module", "where"
32 , "import", "exposing"
33 , "as"
34 , "port"
35 ]
36
37 -- ERROR HELP
38
39 expecting :: String -> IParser a -> IParser a
40 expecting = flip (<?>)
41
42
43 -- SETUP
44
45 iParse :: IParser a -> String -> Either ParseError a
46 iParse =
47 iParseWithState "" State.init
48
49
50 iParseWithState :: SourceName -> State.State -> IParser a -> String -> Either ParseError a
51 iParseWithState sourceName state aParser input =
52 runIndent sourceName $ runParserT aParser state sourceName input
53
54
55 -- VARIABLES
56
57 var :: ElmVersion -> IParser (Ref [UppercaseIdentifier])
58 var elmVersion =
59 try (qualifiedVar elmVersion) <|> qualifiedTag elmVersion <?> "a name"
60
61
62 lowVar :: ElmVersion -> IParser LowercaseIdentifier
63 lowVar elmVersion =
64 LowercaseIdentifier <$> makeVar elmVersion lower <?> "a lower case name"
65
66
67 capVar :: ElmVersion -> IParser UppercaseIdentifier
68 capVar elmVersion =
69 UppercaseIdentifier <$> makeVar elmVersion upper <?> "an upper case name"
70
71
72 qualifiedVar :: ElmVersion -> IParser (Ref [UppercaseIdentifier])
73 qualifiedVar elmVersion =
74 VarRef
75 <$> many (const <$> capVar elmVersion <*> string ".")
76 <*> lowVar elmVersion
77
78
79 qualifiedTag :: ElmVersion -> IParser (Ref [UppercaseIdentifier])
80 qualifiedTag elmVersion =
81 TagRef
82 <$> many (try $ const <$> capVar elmVersion <*> string ".")
83 <*> capVar elmVersion
84
85
86 rLabel :: ElmVersion -> IParser LowercaseIdentifier
87 rLabel = lowVar
88
89
90 innerVarChar :: ElmVersion -> IParser Char
91 innerVarChar elmVersion =
92 if syntax_0_19_disallowApostropheInVars elmVersion
93 then alphaNum <|> char '_' <?> "more letters in this name"
94 else alphaNum <|> char '_' <|> char '\'' <?> "more letters in this name"
95
96
97 makeVar :: ElmVersion -> IParser Char -> IParser String
98 makeVar elmVersion firstChar =
99 do variable <- (:) <$> firstChar <*> many (innerVarChar elmVersion)
100 if variable `elem` reserveds
101 then fail (Syntax.keyword variable)
102 else return variable
103
104
105 reserved :: ElmVersion -> String -> IParser ()
106 reserved elmVersion word =
107 expecting ("reserved word `" ++ word ++ "`") $
108 do _ <- string word
109 notFollowedBy (innerVarChar elmVersion)
110 return ()
111
112
113 -- INFIX OPERATORS
114
115 anyOp :: ElmVersion -> IParser (Ref [UppercaseIdentifier])
116 anyOp elmVersion =
117 (betwixt '`' '`' (qualifiedVar elmVersion) <?> "an infix operator like `andThen`")
118 <|> (OpRef <$> symOp)
119
120
121 symOp :: IParser SymbolIdentifier
122 symOp =
123 do op <- many1 (satisfy Help.isSymbol) <?> "an infix operator like +"
124 guard (op `notElem` [ "=", "..", "->", "--", "|", "\8594", ":" ])
125 case op of
126 "." -> notFollowedBy lower >> return (SymbolIdentifier op)
127 _ -> return $ SymbolIdentifier op
128
129
130 symOpInParens :: IParser SymbolIdentifier
131 symOpInParens =
132 parens' symOp
133
134
135 -- COMMON SYMBOLS
136
137 equals :: IParser ()
138 equals =
139 const () <$> char '=' <?> "="
140
141
142 lenientEquals :: IParser ()
143 lenientEquals =
144 const () <$> (char '=' <|> char ':') <?> "="
145
146
147 rightArrow :: IParser ()
148 rightArrow =
149 const () <$> (string "->" <|> string "\8594") <?> "->"
150
151
152 cons :: IParser ()
153 cons =
154 const () <$> string "::" <?> "a cons operator '::'"
155
156
157 hasType :: IParser ()
158 hasType =
159 const () <$> char ':' <?> "the \"has type\" symbol ':'"
160
161
162 lenientHasType :: IParser ()
163 lenientHasType =
164 const () <$> (char ':' <|> char '=') <?> "the \"has type\" symbol ':'"
165
166
167 comma :: IParser ()
168 comma =
169 const () <$> char ',' <?> "a comma ','"
170
171
172 semicolon :: IParser ()
173 semicolon =
174 const () <$> char ';' <?> "a semicolon ';'"
175
176
177 verticalBar :: IParser ()
178 verticalBar =
179 const () <$> char '|' <?> "a vertical bar '|'"
180
181
182 commitIf :: IParser any -> IParser a -> IParser a
183 commitIf check p =
184 commit <|> try p
185 where
186 commit =
187 try (lookAhead check) >> p
188
189
190 -- SEPARATORS
191
192
193 spaceySepBy1 :: IParser sep -> IParser a -> IParser (ExposedCommentedList a)
194 spaceySepBy1 sep parser =
195 let
196 -- step :: PostCommented (WithEol a) -> [Commented (WithEol a)] -> Comments -> IParser (ExposedCommentedList a)
197 step first rest post =
198 do
199 (C eol next) <- withEol parser
200 choice
201 [ try (padded sep)
202 >>= (\(C (preSep, postSep) _) -> step first (C (post, preSep, eol) next : rest) postSep)
203 , return $ Multiple first (reverse rest) (C (post, eol) next)
204 ]
205
206 in
207 do
208 (C eol value) <- withEol parser
209 choice
210 [ try (padded sep)
211 >>= (\(C (preSep, postSep) _) -> step (C (preSep, eol) value) [] postSep)
212 , return $ Single (C eol value)
213 ]
214
215
216 -- DEPRECATED: use spaceySepBy1 instead
217 spaceySepBy1'' :: IParser sep -> IParser (Comments -> Comments -> a) -> IParser (Comments -> Comments -> [a])
218 spaceySepBy1'' sep parser =
219 let
220 combine eol post =
221 eolToComment eol ++ post
222 in
223 do
224 result <- spaceySepBy1 sep parser
225 case result of
226 Single (C eol item) ->
227 return $ \pre post -> [item pre (combine eol post)]
228
229 Multiple (C (postFirst, firstEol) first ) rest (C (preLast, eol) last) ->
230 return $ \preFirst postLast ->
231 concat
232 [ [first preFirst $ combine firstEol postFirst]
233 , fmap (\(C (pre, post, eol) item) -> item pre $ combine eol post) rest
234 , [last preLast $ combine eol postLast ]
235 ]
236
237
238 -- DEPRECATED: use spaceySepBy1 instead
239 spaceySepBy1' :: IParser sep -> IParser a -> IParser (Comments -> Comments -> [C2 before after a])
240 spaceySepBy1' sep parser =
241 spaceySepBy1'' sep ((\x pre post -> C (pre, post) x) <$> parser)
242
243
244 commaSep1 :: IParser (Comments -> Comments -> a) -> IParser (Comments -> Comments -> [a])
245 commaSep1 =
246 spaceySepBy1'' comma
247
248
249 commaSep1' :: IParser a -> IParser (Comments -> Comments -> [C2 before after a])
250 commaSep1' =
251 spaceySepBy1' comma
252
253
254 toSet :: Ord k => (v -> v -> v) -> [C2 before after (k, v)] -> Map k (C2 before after v)
255 toSet merge values =
256 let
257 merge' (C (pre1, post1) a) (C (pre2, post2) b) =
258 C (pre1 ++ pre2, post1 ++ post2) (merge a b)
259 in
260 foldl (\m (C (pre, post) (k, v)) -> insertWith merge' k (C (pre, post) v) m) empty values
261
262
263 commaSep1Set' :: Ord k => IParser (k, v) -> (v -> v -> v) -> IParser (Comments -> Comments -> Map k (C2 before after v))
264 commaSep1Set' parser merge =
265 do
266 values <- commaSep1' parser
267 return $ \pre post -> toSet merge $ values pre post
268
269
270 commaSep :: IParser (Comments -> Comments -> a) -> IParser (Maybe (Comments -> Comments -> [a]))
271 commaSep term =
272 option Nothing (Just <$> commaSep1 term)
273
274
275 pipeSep1 :: IParser a -> IParser (ExposedCommentedList a)
276 pipeSep1 =
277 spaceySepBy1 verticalBar
278
279
280 keyValue :: IParser sep -> IParser key -> IParser val -> IParser (Comments -> Comments -> (C2 before after key, C2 before' after' val) )
281 keyValue parseSep parseKey parseVal =
282 do
283 key <- parseKey
284 preSep <- whitespace <* parseSep
285 postSep <- whitespace
286 val <- parseVal
287 return $ \pre post ->
288 ( C (pre, preSep) key
289 , C (postSep, post) val
290 )
291
292
293 separated :: IParser sep -> IParser e -> IParser (Either e (R.Region, C0Eol e, Sequence e, Bool))
294 separated sep expr' =
295 let
296 subparser =
297 do start <- getMyPosition
298 t1 <- expr'
299 arrow <- optionMaybe $ try ((,) <$> restOfLine <*> whitespace <* sep)
300 case arrow of
301 Nothing ->
302 return $ \_multiline -> Left t1
303 Just (eolT1, preArrow) ->
304 do postArrow <- whitespace
305 t2 <- separated sep expr'
306 end <- getMyPosition
307 case t2 of
308 Right (_, C eolT2 t2', Sequence ts, _) ->
309 return $ \multiline -> Right
310 ( R.Region start end
311 , C eolT1 t1
312 , Sequence (C (preArrow, postArrow, eolT2) t2' : ts)
313 , multiline
314 )
315 Left t2' ->
316 do
317 eol <- restOfLine
318 return $ \multiline -> Right
319 ( R.Region start end
320 , C eolT1 t1
321 , Sequence [ C (preArrow, postArrow, eol) t2' ]
322 , multiline)
323 in
324 (\(f, multiline) -> f $ multilineToBool multiline) <$> trackNewline subparser
325
326
327 dotSep1 :: IParser a -> IParser [a]
328 dotSep1 p =
329 (:) <$> p <*> many (try (char '.') >> p)
330
331
332 spacePrefix :: IParser a -> IParser [C1 before a]
333 spacePrefix p =
334 fmap fst <$>
335 constrainedSpacePrefix' p (\_ -> return ())
336
337
338 constrainedSpacePrefix :: IParser a -> IParser [(C1 before a, Multiline)]
339 constrainedSpacePrefix parser =
340 constrainedSpacePrefix' parser constraint
341 where
342 constraint empty = if empty then notFollowedBy (char '-') else return ()
343
344
345 constrainedSpacePrefix' :: IParser a -> (Bool -> IParser b) -> IParser [(C1 before a, Multiline)]
346 constrainedSpacePrefix' parser constraint =
347 many $ trackNewline $ choice
348 [ C <$> try (const <$> spacing <*> lookAhead (oneOf "[({")) <*> parser
349 , try (C <$> spacing <*> parser)
350 ]
351 where
352 spacing = do
353 (n, comments) <- whitespace'
354 _ <- constraint (not n) <?> Syntax.whitespace
355 indented
356 return comments
357
358
359 -- SURROUNDED BY
360
361 betwixt :: Char -> Char -> IParser a -> IParser a
362 betwixt a b c =
363 do _ <- char a
364 out <- c
365 _ <- char b <?> "a closing '" ++ [b] ++ "'"
366 return out
367
368
369 surround :: Char -> Char -> String -> IParser (Comments -> Comments -> Bool -> a) -> IParser a
370 surround a z name p =
371 let
372 -- subparser :: IParser (Bool -> a)
373 subparser = do
374 _ <- char a
375 (C (pre, post) v) <- padded p
376 _ <- char z <?> unwords ["a closing", name, show z]
377 return $ \multiline -> v pre post multiline
378 in
379 (\(f, multiline) -> f (multilineToBool multiline)) <$> trackNewline subparser
380
381
382 -- TODO: push the Multiline type further up in the AST and get rid of this
383 multilineToBool :: Multiline -> Bool
384 multilineToBool multine =
385 case multine of
386 SplitAll -> True
387 JoinAll -> False
388
389
390 braces :: IParser (Comments -> Comments -> Bool -> a) -> IParser a
391 braces =
392 surround '[' ']' "brace"
393
394
395 parens :: IParser (Comments -> Comments -> Bool -> a) -> IParser a
396 parens =
397 surround '(' ')' "paren"
398
399
400 brackets :: IParser (Comments -> Comments -> Bool -> a) -> IParser a
401 brackets =
402 surround '{' '}' "bracket"
403
404
405 braces' :: IParser a -> IParser a
406 braces' =
407 surround' '[' ']' "brace"
408
409
410 brackets' :: IParser a -> IParser a
411 brackets' =
412 surround' '{' '}' "bracket"
413
414
415 surround' :: Char -> Char -> String -> IParser a -> IParser a
416 surround' a z name p = do
417 _ <- char a
418 v <- p
419 _ <- char z <?> unwords ["a closing", name, show z]
420 return v
421
422
423 parens' :: IParser a -> IParser a
424 parens' =
425 surround' '(' ')' "paren"
426
427
428 parens'' :: IParser a -> IParser (Either Comments [C2 before after a])
429 parens'' = surround'' '(' ')'
430
431
432 braces'' :: IParser a -> IParser (Either Comments [C2 before after a])
433 braces'' = surround'' '[' ']'
434
435
436 surround'' :: Char -> Char -> IParser a -> IParser (Either Comments [C2 before after a])
437 surround'' leftDelim rightDelim inner =
438 let
439 sep''' =
440 do
441 v <- (\pre a post -> C (pre, post) a) <$> whitespace <*> inner <*> whitespace
442 option [v] ((\x -> v : x) <$> (char ',' >> sep'''))
443 sep'' =
444 do
445 pre <- whitespace
446 v <- optionMaybe ((\a post -> C (pre, post) a) <$> inner <*> whitespace)
447 case v of
448 Nothing ->
449 return $ Left pre
450 Just v' ->
451 Right <$> option [v'] ((\x -> v' : x) <$> (char ',' >> sep'''))
452 in
453 do
454 _ <- char leftDelim
455 vs <- sep''
456 _ <- char rightDelim
457 return vs
458
459
460 -- HELPERS FOR EXPRESSIONS
461
462 getMyPosition :: IParser R.Position
463 getMyPosition =
464 R.fromSourcePos <$> getPosition
465
466
467 addLocation :: IParser a -> IParser (A.Located a)
468 addLocation expr =
469 do (start, e, end) <- located expr
470 return (A.at start end e)
471
472
473 located :: IParser a -> IParser (R.Position, a, R.Position)
474 located parser =
475 do start <- getMyPosition
476 value <- parser
477 end <- getMyPosition
478 return (start, value, end)
479
480
481 accessible :: ElmVersion -> IParser (FixAST A.Located typeRef ctorRef varRef 'ExpressionNK) -> IParser (FixAST A.Located typeRef ctorRef varRef 'ExpressionNK)
482 accessible elmVersion exprParser =
483 do start <- getMyPosition
484 rootExpr <- exprParser
485 access <- optionMaybe (try dot <?> "a field access like .name")
486
487 case access of
488 Nothing ->
489 return rootExpr
490
491 Just _ ->
492 accessible elmVersion $
493 do v <- lowVar elmVersion
494 end <- getMyPosition
495 return $ I.Fix $ A.at start end $ Access rootExpr v
496
497
498 dot :: IParser ()
499 dot =
500 do _ <- char '.'
501 notFollowedBy (char '.')
502
503
504 commentedKeyword :: ElmVersion -> String -> IParser a -> IParser (C2 beforeKeyword afterKeyword a)
505 commentedKeyword elmVersion word parser =
506 do
507 pre <- try (whitespace <* reserved elmVersion word)
508 post <- whitespace
509 value <- parser
510 return $ C (pre, post) value
511
512
513 -- ODD COMBINATORS
514
515 failure :: String -> IParser String
516 failure msg = do
517 inp <- getInput
518 setInput ('x':inp)
519 _ <- anyToken
520 fail msg
521
522
523 until :: IParser a -> IParser b -> IParser b
524 until p end =
525 go
526 where
527 go = end <|> (p >> go)
528
529
530 -- BASIC LANGUAGE LITERALS
531
532 shader :: IParser String
533 shader =
534 do _ <- try (string "[glsl|")
535 closeShader id
536
537
538 closeShader :: (String -> a) -> IParser a
539 closeShader builder =
540 choice
541 [ do _ <- try (string "|]")
542 return (builder "")
543 , do c <- anyChar
544 closeShader (builder . (c:))
545 ]
546
547
548 sandwich :: Char -> String -> String
549 sandwich delim s =
550 delim : s ++ [delim]
551
552
553 escaped :: Char -> IParser String
554 escaped delim =
555 try $ do
556 _ <- char '\\'
557 c <- char '\\' <|> char delim
558 return ['\\', c]
559
560
561 processAs :: IParser a -> String -> IParser a
562 processAs processor s =
563 calloutParser s processor
564 where
565 calloutParser :: String -> IParser a -> IParser a
566 calloutParser inp p =
567 either (fail . show) return (iParse p inp)