git.iko.soy/elk
on 00a3069 help sign in
elk/src/Parse/Expression.hs
564 lines 14 kB history raw
1{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Parse.Expression
4 ( expression
5 )
6 where
9import Control.Monad (guard)
11import qualified AST.Source as Src
12import qualified Elm.Name as N
13import Parse.Primitives
14import qualified Parse.Primitives.Keyword as Keyword
15import qualified Parse.Primitives.Number as Number
16import qualified Parse.Primitives.Symbol as Symbol
17import qualified Parse.Primitives.Utf8 as Utf8
18import qualified Parse.Primitives.Variable as Var
19import qualified Parse.Primitives.Whitespace as W
20import qualified Parse.Pattern as Pattern
21import qualified Parse.Shader as Shader
22import qualified Parse.Type as Type
23import qualified Reporting.Annotation as A
24import qualified Reporting.Error.Syntax as E
25import qualified Reporting.Region as R
29-- TERMS
32term :: Parser Src.Expr
33term =
34 hint E.Expr $
35 do start <- getPosition
36 oneOf
37 [ variable start >>= accessible start
38 , string start
39 , number start
40 , Shader.shader start
41 , list start
42 , record start >>= accessible start
43 , tuple start >>= accessible start
44 , accessor start
45 , character start
46 ]
49string :: R.Position -> Parser Src.Expr
50string start =
51 do str <- Utf8.string
52 end <- getPosition
53 return (A.at start end (Src.Str str))
56character :: R.Position -> Parser Src.Expr
57character start =
58 do chr <- Utf8.character
59 end <- getPosition
60 return (A.at start end (Src.Chr chr))
63number :: R.Position -> Parser Src.Expr
64number start =
65 do nmbr <- Number.number
66 end <- getPosition
67 return $ A.at start end $
68 case nmbr of
69 Number.Int int ->
70 Src.Int int
72 Number.Float float ->
73 Src.Float float
76accessor :: R.Position -> Parser Src.Expr
77accessor start =
78 do Symbol.dot
79 field <- Var.lower
80 end <- getPosition
81 return (A.at start end (Src.Accessor field))
84variable :: R.Position -> Parser Src.Expr
85variable start =
86 do var <- Var.foreignAlpha
87 end <- getPosition
88 return (A.at start end var)
91accessible :: R.Position -> Src.Expr -> Parser Src.Expr
92accessible start expr =
93 oneOf
94 [ do Symbol.dot
95 field <- Var.lower
96 end <- getPosition
97 let newExpr = A.at start end (Src.Access expr field)
98 accessible start newExpr
99 , return expr
100 ]
104-- LISTS
107list :: R.Position -> Parser Src.Expr
108list start =
109 do Symbol.leftSquare
110 inContext start E.ExprList $
111 do spaces
112 oneOf
113 [ do (entry, _, pos) <- expression
114 checkSpace pos
115 listHelp start [entry]
116 , do Symbol.rightSquare
117 end <- getPosition
118 return (A.at start end (Src.List []))
119 ]
122listHelp :: R.Position -> [Src.Expr] -> Parser Src.Expr
123listHelp start entries =
124 oneOf
125 [ do Symbol.comma
126 spaces
127 (entry, _, pos) <- expression
128 checkSpace pos
129 listHelp start (entry:entries)
130 , do Symbol.rightSquare
131 end <- getPosition
132 return (A.at start end (Src.List (reverse entries)))
133 ]
137-- TUPLES
140tuple :: R.Position -> Parser Src.Expr
141tuple start =
142 do Symbol.leftParen
143 pos <- getPosition
144 spos <- W.whitespace
145 inContext start E.ExprTuple $ oneOf $
146 [ do noSpace pos spos
147 try (Symbol.minus >> Symbol.rightParen)
148 end <- getPosition
149 return $ A.at start end (Src.Op "-")
151 , do checkSpace spos
152 (entry, _, spos2) <- expression
153 checkSpace spos2
154 tupleHelp start entry []
156 , do noSpace pos spos
157 op <- Symbol.binop
158 Symbol.rightParen
159 end <- getPosition
160 return $ A.at start end (Src.Op op)
162 , do noSpace pos spos
163 Symbol.rightParen
164 end <- getPosition
165 return (A.at start end Src.Unit)
167 ]
170tupleHelp :: R.Position -> Src.Expr -> [Src.Expr] -> Parser Src.Expr
171tupleHelp start firstExpr revExprs =
172 oneOf
173 [ do Symbol.comma
174 spaces
175 (entry, _, pos) <- expression
176 checkSpace pos
177 tupleHelp start firstExpr (entry : revExprs)
178 , do Symbol.rightParen
179 end <- getPosition
180 case reverse revExprs of
181 [] ->
182 return firstExpr
184 secondExpr : others ->
185 return (A.at start end (Src.Tuple firstExpr secondExpr others))
186 ]
190-- RECORDS
193record :: R.Position -> Parser Src.Expr
194record start =
195 do Symbol.leftCurly
196 inContext start E.ExprRecord $
197 do spaces
198 oneOf
199 [ do Symbol.rightCurly
200 end <- getPosition
201 return (A.at start end (Src.Record []))
202 , do starter <- addLocation Var.lower
203 spaces
204 oneOf
205 [ do Symbol.pipe
206 spaces
207 firstField <- chompField
208 fields <- chompFields [firstField]
209 end <- getPosition
210 return (A.at start end (Src.Update starter fields))
211 , do Symbol.equals
212 spaces
213 (value, _, nextPos) <- expression
214 checkSpace nextPos
215 fields <- chompFields [(starter, value)]
216 end <- getPosition
217 return (A.at start end (Src.Record fields))
218 ]
219 ]
222type Field = ( A.Located N.Name, Src.Expr )
225chompFields :: [Field] -> Parser [Field]
226chompFields fields =
227 oneOf
228 [ do Symbol.comma
229 spaces
230 f <- chompField
231 chompFields (f : fields)
232 , do Symbol.rightCurly
233 return (reverse fields)
234 ]
237chompField :: Parser Field
238chompField =
239 do key <- addLocation Var.lower
240 spaces
241 Symbol.equals
242 spaces
243 (value, _, pos) <- expression
244 checkSpace pos
245 return (key, value)
249-- EXPRESSIONS
252type ExprParser =
253 SParser Src.Expr
256expression :: ExprParser
257expression =
258 hint E.Expr $
259 do start <- getPosition
260 oneOf
261 [ let_ start
262 , if_ start
263 , case_ start
264 , function start
265 , do expr <- possiblyNegativeTerm start
266 end <- getPosition
267 space <- W.whitespace
268 exprHelp start (State [] expr [] end space)
269 ]
272data State =
273 State
274 { _ops :: ![(Src.Expr, A.Located N.Name)]
275 , _expr :: !Src.Expr
276 , _args :: ![Src.Expr]
277 , _end :: !R.Position
278 , _pos :: !SPos
279 }
282exprHelp :: R.Position -> State -> ExprParser
283exprHelp start (State ops expr args end pos) =
284 oneOf
285 [ -- argument
286 hint E.Arg $
287 do checkSpace pos
288 arg <- term
289 newEnd <- getPosition
290 newPos <- W.whitespace
291 exprHelp start (State ops expr (arg:args) newEnd newPos)
293 , -- infix operator
294 do checkSpace pos
295 opStart <- getPosition
296 opName <- Symbol.binop
297 opEnd <- getPosition
298 let op = A.at opStart opEnd opName
299 spos <- W.whitespace
300 hint (E.AfterOpExpr opName) (checkSpace spos)
301 newStart <- getPosition
302 hint (E.AfterOpExpr opName) $ oneOf $
303 [ -- negative terms
304 do guard ("-" == opName && end /= opStart && opEnd == newStart)
305 rawTerm <- term
306 newEnd <- getPosition
307 newPos <- W.whitespace
308 let arg = A.at opStart newEnd (Src.Negate rawTerm)
309 exprHelp start (State ops expr (arg:args) newEnd newPos)
311 , -- term
312 do newExpr <- possiblyNegativeTerm newStart
313 newEnd <- getPosition
314 newPos <- W.whitespace
315 let newOps = (toCall expr args, op) : ops
316 exprHelp start (State newOps newExpr [] newEnd newPos)
318 , -- final term
319 do (newLast, newEnd, newPos) <-
320 oneOf
321 [ let_ newStart
322 , case_ newStart
323 , if_ newStart
324 , function newStart
325 ]
326 let newOps = (toCall expr args, op) : ops
327 let finalExpr = A.at start newEnd (Src.Binops (reverse newOps) newLast)
328 return ( finalExpr, newEnd, newPos )
329 ]
331 , -- done
332 let finalExpr = toCall expr args in
333 case ops of
334 [] ->
335 return ( finalExpr, end, pos )
337 _ ->
338 return ( A.at start end (Src.Binops (reverse ops) finalExpr), end, pos )
339 ]
342possiblyNegativeTerm :: R.Position -> Parser Src.Expr
343possiblyNegativeTerm start =
344 oneOf
345 [ do Symbol.minus
346 expr <- term
347 end <- getPosition
348 return (A.at start end (Src.Negate expr))
349 , term
350 ]
353toCall :: Src.Expr -> [Src.Expr] -> Src.Expr
354toCall func revArgs =
355 case revArgs of
356 [] ->
357 func
359 lastArg : _ ->
360 A.merge func lastArg (Src.Call func (reverse revArgs))
364-- IF EXPRESSION
367if_ :: R.Position -> ExprParser
368if_ start =
369 do Keyword.if_
370 inContext start E.ExprIf $ ifHelp start []
373ifHelp :: R.Position -> [(Src.Expr, Src.Expr)] -> ExprParser
374ifHelp start branches =
375 do spaces
376 (condition, _, condPos) <- expression
377 checkSpace condPos
378 Keyword.then_
379 spaces
380 (thenBranch, _, thenPos) <- expression
381 hint E.ElseBranch $ checkSpace thenPos
382 hint E.ElseBranch $ Keyword.else_
383 spaces
384 let newBranches = (condition, thenBranch) : branches
385 oneOf
386 [ do Keyword.if_
387 ifHelp start newBranches
388 , do (elseBranch, elseEnd, elseSpace) <- expression
389 let ifExpr = A.at start elseEnd (Src.If (reverse newBranches) elseBranch)
390 return ( ifExpr, elseEnd, elseSpace )
391 ]
395-- LAMBDA EXPRESSION
398function :: R.Position -> ExprParser
399function start =
400 do Symbol.lambda
401 inContext start E.ExprFunc $
402 do spaces
403 arg <- Pattern.term
404 spaces
405 revArgs <- gatherArgs [arg]
406 spaces
407 (body, end, space) <- expression
408 let func = A.at start end (Src.Lambda (reverse revArgs) body)
409 return ( func, end, space )
412gatherArgs :: [Src.Pattern] -> Parser [Src.Pattern]
413gatherArgs args =
414 oneOf
415 [ do arg <- Pattern.term
416 spaces
417 gatherArgs (arg:args)
418 , do Symbol.rightArrow
419 return args
420 ]
424-- CASE EXPRESSIONS
427case_ :: R.Position -> ExprParser
428case_ start =
429 do Keyword.case_
430 inContext start E.ExprCase $
431 do spaces
432 (switcher, _, switcherPos) <- expression
433 checkSpace switcherPos
434 Keyword.of_
435 spaces
436 oldIndent <- getIndent
437 newIndent <- getCol
438 setIndent newIndent
439 (firstBranch, firstEnd, firstPos) <- branchHelp
440 (branches, end, pos) <- caseHelp [firstBranch] firstEnd firstPos
441 setIndent oldIndent
442 return
443 ( A.at start end (Src.Case switcher branches)
444 , end
445 , pos
446 )
449branchHelp :: SParser (Src.Pattern, Src.Expr)
450branchHelp =
451 do (pattern, patternPos) <- Pattern.expression
452 checkSpace patternPos
453 Symbol.rightArrow
454 spaces
455 (branchExpr, end, pos) <- expression
456 return ( (pattern, branchExpr), end, pos )
459caseHelp :: [(Src.Pattern, Src.Expr)] -> R.Position -> SPos -> SParser [(Src.Pattern, Src.Expr)]
460caseHelp branches end pos =
461 oneOf
462 [ do checkAligned pos
463 (branch, newEnd, newPos) <- branchHelp
464 caseHelp (branch:branches) newEnd newPos
465 , return ( reverse branches, end, pos )
466 ]
470-- LET EXPRESSION
473let_ :: R.Position -> ExprParser
474let_ start =
475 do oldIndent <- getIndent
476 letIndent <- getCol
477 Keyword.let_
478 pushContext start E.ExprLet
479 setIndent letIndent
480 spaces
481 defIndent <- getCol
482 setIndent defIndent
483 (def, end, space) <- letDef
484 letHelp start oldIndent [def] end space
487letHelp :: R.Position -> Int -> [A.Located Src.Def] -> R.Position -> SPos -> ExprParser
488letHelp start oldIndent revDefs end pos =
489 oneOf
490 [ do checkAligned pos
491 (def, newEnd, newPos) <- letDef
492 letHelp start oldIndent (def:revDefs) newEnd newPos
494 , do setIndent oldIndent
495 checkSpace pos
496 Keyword.in_
497 popContext ()
498 spaces
499 (body, newEnd, newPos) <- expression
500 let letExpr = A.at start end (Src.Let (reverse revDefs) body)
501 return ( letExpr, newEnd, newPos )
502 ]
506-- LET DEFINITIONS
509letDef :: SParser (A.Located Src.Def)
510letDef =
511 oneOf
512 [ definition
513 , destructure
514 ]
518-- DEFINITION
521definition :: SParser (A.Located Src.Def)
522definition =
523 do start <- getPosition
524 name <- Var.lower
525 nameEnd <- getPosition
526 spaces
527 oneOf
528 [ do Symbol.hasType
529 inContext start (E.Annotation name) $
530 do spaces
531 (tipe, end, space) <- Type.expression
532 return ( A.at start end (Src.Annotate name tipe), end, space )
533 , inContext start (E.Definition name) $
534 definitionHelp start (A.at start nameEnd name) []
535 ]
538definitionHelp :: R.Position -> A.Located N.Name -> [Src.Pattern] -> SParser (A.Located Src.Def)
539definitionHelp start name revArgs =
540 oneOf
541 [ do arg <- hint E.Arg Pattern.term
542 spaces
543 definitionHelp start name (arg : revArgs)
544 , do Symbol.equals
545 spaces
546 (body, end, space) <- expression
547 let def = A.at start end (Src.Define name (reverse revArgs) body)
548 return ( def, end, space )
549 ]
553-- DESTRUCTURE
556destructure :: SParser (A.Located Src.Def)
557destructure =
558 do start <- getPosition
559 pattern <- Pattern.term
560 spaces
561 Symbol.equals
562 spaces
563 (expr, end, space) <- expression
564 return ( A.at start end (Src.Destruct pattern expr), end, space )