git.iko.soy/elk
on c19392f help sign in
elk/src/Parse/Expression.hs
542 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)
10import qualified Data.List as List
11import Data.Text (Text)
13import Parse.Primitives
14import qualified Parse.Primitives.Keyword as Keyword
15import qualified Parse.Primitives.Symbol as Symbol
16import qualified Parse.Primitives.Variable as Var
17import qualified Parse.Primitives.Whitespace as W
18import qualified Parse.Literal as Literal
19import qualified Parse.Pattern as Pattern
20import qualified Parse.Type as Type
22import qualified AST.Expression.Source as Src
23import qualified AST.Pattern as P
24import qualified Reporting.Annotation as A
25import qualified Reporting.Error.Syntax as E
26import qualified Reporting.Region as R
30-- TERMS
33term :: Parser Src.Expr
34term =
35 hint E.Expr $
36 do start <- getPosition
37 oneOf
38 [ variable start >>= accessible start
39 , literal start
40 , Literal.shader start
41 , list start
42 , record start >>= accessible start
43 , tuple start >>= accessible start
44 , accessor start
45 ]
48literal :: R.Position -> Parser Src.Expr
49literal start =
50 do value <- Literal.literal
51 end <- getPosition
52 return (A.at start end (Src.Literal value))
55accessor :: R.Position -> Parser Src.Expr
56accessor start =
57 do Symbol.dot
58 field <- Var.lower
59 end <- getPosition
60 return (A.at start end (Src.Accessor field))
63variable :: R.Position -> Parser Src.Expr
64variable start =
65 do (maybePrefix, name) <- Var.foreignAlpha
66 end <- getPosition
67 return (A.at start end (Src.Var maybePrefix name))
70accessible :: R.Position -> Src.Expr -> Parser Src.Expr
71accessible start expr =
72 oneOf
73 [ do Symbol.dot
74 field <- Var.lower
75 end <- getPosition
76 let newExpr = A.at start end (Src.Access expr field)
77 accessible start newExpr
78 , return expr
79 ]
83-- LISTS
86list :: R.Position -> Parser Src.Expr
87list start =
88 do Symbol.leftSquare
89 inContext start E.ExprList $
90 do spaces
91 oneOf
92 [ do (entry, _, pos) <- expression
93 checkSpace pos
94 listHelp start [entry]
95 , do Symbol.rightSquare
96 end <- getPosition
97 return (A.at start end (Src.List []))
98 ]
101listHelp :: R.Position -> [Src.Expr] -> Parser Src.Expr
102listHelp start entries =
103 oneOf
104 [ do Symbol.comma
105 spaces
106 (entry, _, pos) <- expression
107 checkSpace pos
108 listHelp start (entry:entries)
109 , do Symbol.rightSquare
110 end <- getPosition
111 return (A.at start end (Src.List (reverse entries)))
112 ]
116-- TUPLES
119tuple :: R.Position -> Parser Src.Expr
120tuple start =
121 do Symbol.leftParen
122 pos <- getPosition
123 spos <- W.whitespace
124 inContext start E.ExprTuple $ oneOf $
125 [ do noSpace pos spos
126 try (Symbol.minus >> Symbol.rightParen)
127 end <- getPosition
128 return $ A.at start end (Src.Op "-")
130 , do checkSpace spos
131 (entry, _, spos2) <- expression
132 checkSpace spos2
133 tupleHelp start entry []
135 , do noSpace pos spos
136 op <- Symbol.binop
137 Symbol.rightParen
138 end <- getPosition
139 return $ A.at start end (Src.Op op)
141 , do noSpace pos spos
142 Symbol.rightParen
143 end <- getPosition
144 return (A.at start end Src.Unit)
146 ]
149tupleHelp :: R.Position -> Src.Expr -> [Src.Expr] -> Parser Src.Expr
150tupleHelp start firstExpr revExprs =
151 oneOf
152 [ do Symbol.comma
153 spaces
154 (entry, _, pos) <- expression
155 checkSpace pos
156 tupleHelp start firstExpr (entry : revExprs)
157 , do Symbol.rightParen
158 end <- getPosition
159 case reverse revExprs of
160 [] ->
161 return firstExpr
163 secondExpr : others ->
164 return (A.at start end (Src.Tuple firstExpr secondExpr others))
165 ]
169-- RECORDS
172record :: R.Position -> Parser Src.Expr
173record start =
174 do Symbol.leftCurly
175 inContext start E.ExprRecord $
176 do spaces
177 oneOf
178 [ do Symbol.rightCurly
179 end <- getPosition
180 return (A.at start end (Src.Record []))
181 , do starter <- addLocation Var.lower
182 spaces
183 oneOf
184 [ do Symbol.pipe
185 spaces
186 firstField <- chompField
187 fields <- chompFields [firstField]
188 end <- getPosition
189 return (A.at start end (Src.Update starter fields))
190 , do Symbol.equals
191 spaces
192 (value, _, nextPos) <- expression
193 checkSpace nextPos
194 fields <- chompFields [(starter, value)]
195 end <- getPosition
196 return (A.at start end (Src.Record fields))
197 ]
198 ]
201type Field = ( A.Located Text, Src.Expr )
204chompFields :: [Field] -> Parser [Field]
205chompFields fields =
206 oneOf
207 [ do Symbol.comma
208 spaces
209 f <- chompField
210 chompFields (f : fields)
211 , do Symbol.rightCurly
212 return (reverse fields)
213 ]
216chompField :: Parser Field
217chompField =
218 do key <- addLocation Var.lower
219 spaces
220 Symbol.equals
221 spaces
222 (value, _, pos) <- expression
223 checkSpace pos
224 return (key, value)
228-- EXPRESSIONS
231type ExprParser =
232 SParser Src.Expr
235expression :: ExprParser
236expression =
237 hint E.Expr $
238 do start <- getPosition
239 oneOf
240 [ let_ start
241 , if_ start
242 , case_ start
243 , function start
244 , do expr <- possiblyNegativeTerm start
245 end <- getPosition
246 space <- W.whitespace
247 exprHelp start (State [] expr [] end space)
248 ]
251data State =
252 State
253 { _ops :: ![(Src.Expr, A.Located Text)]
254 , _expr :: !Src.Expr
255 , _args :: ![Src.Expr]
256 , _end :: !R.Position
257 , _pos :: !SPos
258 }
261exprHelp :: R.Position -> State -> ExprParser
262exprHelp start (State ops expr args end pos) =
263 oneOf
264 [ -- argument
265 hint E.Arg $
266 do checkSpace pos
267 arg <- term
268 newEnd <- getPosition
269 newPos <- W.whitespace
270 exprHelp start (State ops expr (arg:args) newEnd newPos)
272 , -- infix operator
273 do checkSpace pos
274 opStart <- getPosition
275 opName <- Symbol.binop
276 opEnd <- getPosition
277 let op = A.at opStart opEnd opName
278 spos <- W.whitespace
279 hint (E.AfterOpExpr opName) (checkSpace spos)
280 newStart <- getPosition
281 hint (E.AfterOpExpr opName) $ oneOf $
282 [ -- negative terms
283 do guard ("-" == opName && end /= opStart && opEnd == newStart)
284 rawTerm <- term
285 newEnd <- getPosition
286 newPos <- W.whitespace
287 let arg = A.at opStart newEnd (Src.Negate rawTerm)
288 exprHelp start (State ops expr (arg:args) newEnd newPos)
290 , -- term
291 do newExpr <- possiblyNegativeTerm newStart
292 newEnd <- getPosition
293 newPos <- W.whitespace
294 let newOps = (toCall expr args, op) : ops
295 exprHelp start (State newOps newExpr [] newEnd newPos)
297 , -- final term
298 do (newLast, newEnd, newPos) <-
299 oneOf
300 [ let_ newStart
301 , case_ newStart
302 , if_ newStart
303 , function newStart
304 ]
305 let newOps = (toCall expr args, op) : ops
306 let finalExpr = A.at start newEnd (Src.Binops (reverse newOps) newLast)
307 return ( finalExpr, newEnd, newPos )
308 ]
310 , -- done
311 let finalExpr = toCall expr args in
312 case ops of
313 [] ->
314 return ( finalExpr, end, pos )
316 _ ->
317 return ( A.at start end (Src.Binops (reverse ops) finalExpr), end, pos )
318 ]
321possiblyNegativeTerm :: R.Position -> Parser Src.Expr
322possiblyNegativeTerm start =
323 oneOf
324 [ do Symbol.minus
325 expr <- term
326 end <- getPosition
327 return (A.at start end (Src.Negate expr))
328 , term
329 ]
332toCall :: Src.Expr -> [Src.Expr] -> Src.Expr
333toCall func revArgs =
334 case revArgs of
335 [] ->
336 func
338 lastArg : _ ->
339 A.merge func lastArg (Src.Call func (reverse revArgs))
343-- IF EXPRESSION
346if_ :: R.Position -> ExprParser
347if_ start =
348 do Keyword.if_
349 inContext start E.ExprIf $ ifHelp start []
352ifHelp :: R.Position -> [(Src.Expr, Src.Expr)] -> ExprParser
353ifHelp start branches =
354 do spaces
355 (condition, _, condPos) <- expression
356 checkSpace condPos
357 Keyword.then_
358 spaces
359 (thenBranch, _, thenPos) <- expression
360 hint E.ElseBranch $ checkSpace thenPos
361 hint E.ElseBranch $ Keyword.else_
362 spaces
363 let newBranches = (condition, thenBranch) : branches
364 oneOf
365 [ do Keyword.if_
366 ifHelp start newBranches
367 , do (elseBranch, elseEnd, elseSpace) <- expression
368 let ifExpr = A.at start elseEnd (Src.If (reverse newBranches) elseBranch)
369 return ( ifExpr, elseEnd, elseSpace )
370 ]
374-- LAMBDA EXPRESSION
377function :: R.Position -> ExprParser
378function start =
379 do Symbol.lambda
380 inContext start E.ExprFunc $
381 do spaces
382 arg <- Pattern.term
383 spaces
384 revArgs <- gatherArgs [arg]
385 spaces
386 (body, end, space) <- expression
387 let func = List.foldl' (\e x -> A.at start end (Src.Lambda x e)) body revArgs
388 return ( func, end, space )
391gatherArgs :: [P.Raw] -> Parser [P.Raw]
392gatherArgs args =
393 oneOf
394 [ do arg <- Pattern.term
395 spaces
396 gatherArgs (arg:args)
397 , do Symbol.rightArrow
398 return args
399 ]
403-- CASE EXPRESSIONS
406case_ :: R.Position -> ExprParser
407case_ start =
408 do Keyword.case_
409 inContext start E.ExprCase $
410 do spaces
411 (switcher, _, switcherPos) <- expression
412 checkSpace switcherPos
413 Keyword.of_
414 spaces
415 oldIndent <- getIndent
416 newIndent <- getCol
417 setIndent newIndent
418 (firstBranch, firstEnd, firstPos) <- branchHelp
419 (branches, end, pos) <- caseHelp [firstBranch] firstEnd firstPos
420 setIndent oldIndent
421 return
422 ( A.at start end (Src.Case switcher branches)
423 , end
424 , pos
425 )
428branchHelp :: SParser (P.Raw, Src.Expr)
429branchHelp =
430 do (pattern, patternPos) <- Pattern.expression
431 checkSpace patternPos
432 Symbol.rightArrow
433 spaces
434 (branchExpr, end, pos) <- expression
435 return ( (pattern, branchExpr), end, pos )
438caseHelp :: [(P.Raw, Src.Expr)] -> R.Position -> SPos -> SParser [(P.Raw, Src.Expr)]
439caseHelp branches end pos =
440 oneOf
441 [ do checkAligned pos
442 (branch, newEnd, newPos) <- branchHelp
443 caseHelp (branch:branches) newEnd newPos
444 , return ( reverse branches, end, pos )
445 ]
449-- LET EXPRESSION
452let_ :: R.Position -> ExprParser
453let_ start =
454 do oldIndent <- getIndent
455 letIndent <- getCol
456 Keyword.let_
457 pushContext start E.ExprLet
458 setIndent letIndent
459 spaces
460 defIndent <- getCol
461 setIndent defIndent
462 (def, end, space) <- letDef
463 letHelp start oldIndent [def] end space
466letHelp :: R.Position -> Int -> [A.Located Src.Def] -> R.Position -> SPos -> ExprParser
467letHelp start oldIndent revDefs end pos =
468 oneOf
469 [ do checkAligned pos
470 (def, newEnd, newPos) <- letDef
471 letHelp start oldIndent (def:revDefs) newEnd newPos
473 , do setIndent oldIndent
474 checkSpace pos
475 Keyword.in_
476 popContext ()
477 spaces
478 (body, newEnd, newPos) <- expression
479 let letExpr = A.at start end (Src.Let (reverse revDefs) body)
480 return ( letExpr, newEnd, newPos )
481 ]
485-- LET DEFINITIONS
488letDef :: SParser (A.Located Src.Def)
489letDef =
490 oneOf
491 [ definition
492 , destructure
493 ]
497-- DEFINITION
500definition :: SParser (A.Located Src.Def)
501definition =
502 do start <- getPosition
503 name <- Var.lower
504 spaces
505 oneOf
506 [ do Symbol.hasType
507 inContext start (E.Annotation name) $
508 do spaces
509 (tipe, end, space) <- Type.expression
510 return ( A.at start end (Src.Annotate name tipe), end, space )
511 , inContext start (E.Definition name) $
512 definitionHelp start name []
513 ]
516definitionHelp :: R.Position -> Text -> [P.Raw] -> SParser (A.Located Src.Def)
517definitionHelp start name revArgs =
518 oneOf
519 [ do arg <- hint E.Arg Pattern.term
520 spaces
521 definitionHelp start name (arg : revArgs)
522 , do Symbol.equals
523 spaces
524 (body, end, space) <- expression
525 let def = A.at start end (Src.Define name (reverse revArgs) body)
526 return ( def, end, space )
527 ]
531-- DESTRUCTURE
534destructure :: SParser (A.Located Src.Def)
535destructure =
536 do start <- getPosition
537 pattern <- Pattern.term
538 spaces
539 Symbol.equals
540 spaces
541 (expr, end, space) <- expression
542 return ( A.at start end (Src.Destruct pattern expr), end, space )