git.iko.soy/elk
on e00a3f3 help sign in
elk/src/Parse/Expression.hs
547 lines 14 kB history raw
1{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Parse.Expression (term, expression, definition, rootPattern) where
5import Control.Monad (guard)
6import qualified Data.List as List
7import qualified Data.Text as Text
8import Data.Text (Text)
10import Parse.Helpers
11import qualified Parse.Literal as Literal
12import qualified Parse.Pattern as Pattern
13import qualified Parse.Type as Type
15import qualified AST.Expression.Source as Src
16import qualified AST.Pattern as P
17import qualified Reporting.Annotation as A
18import qualified Reporting.Error.Syntax as E
19import qualified Reporting.Region as R
23-- TERMS
26term :: Parser Src.RawExpr
27term =
28 hint E.Expr $
29 do start <- getPosition
30 oneOf
31 [ variable start >>= accessible start
32 , literal start
33 , Literal.shader start
34 , list start
35 , record start >>= accessible start
36 , tuple start >>= accessible start
37 , accessor start
38 ]
41literal :: R.Position -> Parser Src.RawExpr
42literal start =
43 do value <- Literal.literal
44 end <- getPosition
45 return (A.at start end (Src.Literal value))
48accessor :: R.Position -> Parser Src.RawExpr
49accessor start =
50 do dot
51 field <- lowVar
52 end <- getPosition
53 let ann x = A.at start end x
54 let body = ann (Src.Access (ann (Src.var "r")) field)
55 return (mkLambda start end "r" body)
58variable :: R.Position -> Parser Src.RawExpr
59variable start =
60 do var <- qualifiedVar
61 end <- getPosition
62 return (A.at start end (Src.var var))
65accessible :: R.Position -> Src.RawExpr -> Parser Src.RawExpr
66accessible start expr =
67 oneOf
68 [ do dot
69 field <- lowVar
70 end <- getPosition
71 let newExpr = A.at start end (Src.Access expr field)
72 accessible start newExpr
73 , return expr
74 ]
78-- LISTS
81list :: R.Position -> Parser Src.RawExpr
82list start =
83 do leftSquare
84 inContext start E.ExprList $
85 do spaces
86 oneOf
87 [ do (entry, _, pos) <- expression
88 checkSpace pos
89 listHelp start [entry]
90 , do rightSquare
91 end <- getPosition
92 return (A.at start end (Src.List []))
93 ]
96listHelp :: R.Position -> [Src.RawExpr] -> Parser Src.RawExpr
97listHelp start entries =
98 oneOf
99 [ do comma
100 spaces
101 (entry, _, pos) <- expression
102 checkSpace pos
103 listHelp start (entry:entries)
104 , do rightSquare
105 end <- getPosition
106 return (A.at start end (Src.List (reverse entries)))
107 ]
111-- TUPLES
114tuple :: R.Position -> Parser Src.RawExpr
115tuple start =
116 do leftParen
117 pos <- getPosition
118 spos <- whitespace
119 inContext start E.ExprTuple $ oneOf $
120 [ do noSpace pos spos
121 try (minus >> rightParen)
122 end <- getPosition
123 return $ A.at start end (Src.var "-")
125 , do checkSpace spos
126 (entry, _, spos2) <- expression
127 checkSpace spos2
128 tupleHelp start [entry]
130 , do noSpace pos spos
131 op <- infixOp
132 rightParen
133 end <- getPosition
134 return $ A.at start end (Src.var op)
136 , do noSpace pos spos
137 rightParen
138 end <- getPosition
139 return (A.at start end (Src.tuple []))
141 , do noSpace pos spos
142 comma
143 arity <- chompCommas 2
144 rightParen
145 end <- getPosition
146 let args = map (\n -> Text.pack ("v" ++ show n)) [ 1 .. arity ]
147 let ann x = A.at start end x
148 let result = ann (Src.tuple (map (ann . Src.var) args))
149 return (foldr (mkLambda start end) result args)
150 ]
153mkLambda :: R.Position -> R.Position -> Text -> Src.RawExpr -> Src.RawExpr
154mkLambda start end arg body =
155 A.at start end (Src.Lambda (A.at start end (P.Var arg)) body)
158chompCommas :: Int -> Parser Int
159chompCommas n =
160 oneOf
161 [ comma >> chompCommas (n + 1)
162 , return n
163 ]
166tupleHelp :: R.Position -> [Src.RawExpr] -> Parser Src.RawExpr
167tupleHelp start entries =
168 oneOf
169 [ do comma
170 spaces
171 (entry, _, pos) <- expression
172 checkSpace pos
173 tupleHelp start (entry:entries)
174 , do rightParen
175 end <- getPosition
176 case entries of
177 [entry] ->
178 return entry
180 _ ->
181 return (A.at start end (Src.tuple (reverse entries)))
182 ]
186-- RECORDS
189record :: R.Position -> Parser Src.RawExpr
190record start =
191 do leftCurly
192 inContext start E.ExprRecord $
193 do spaces
194 oneOf
195 [ do rightCurly
196 end <- getPosition
197 return (A.at start end (Src.Record []))
198 , do starter <- addLocation lowVar
199 spaces
200 oneOf
201 [ do pipe
202 spaces
203 firstField <- chompField
204 fields <- chompFields [firstField]
205 end <- getPosition
206 return (A.at start end (Src.Update (A.map Src.var starter) fields))
207 , do equals
208 spaces
209 (value, _, nextPos) <- expression
210 checkSpace nextPos
211 fields <- chompFields [(starter, value)]
212 end <- getPosition
213 return (A.at start end (Src.Record fields))
214 ]
215 ]
218type Field = ( A.Located Text, Src.RawExpr )
221chompFields :: [Field] -> Parser [Field]
222chompFields fields =
223 oneOf
224 [ do comma
225 spaces
226 f <- chompField
227 chompFields (f : fields)
228 , do rightCurly
229 return (reverse fields)
230 ]
233chompField :: Parser Field
234chompField =
235 do key <- addLocation lowVar
236 spaces
237 equals
238 spaces
239 (value, _, pos) <- expression
240 checkSpace pos
241 return (key, value)
245-- EXPRESSIONS
248type ExprParser =
249 SParser Src.RawExpr
252expression :: ExprParser
253expression =
254 hint E.Expr $
255 do start <- getPosition
256 oneOf
257 [ let_ start
258 , if_ start
259 , case_ start
260 , function start
261 , do starter <- possiblyNegativeTerm start
262 end <- getPosition
263 space <- whitespace
264 exprHelp start (State [] starter end space)
265 ]
268data State =
269 State
270 { _ops :: ![(Src.RawExpr, A.Located Text)]
271 , _last :: !Src.RawExpr
272 , _end :: !R.Position
273 , _pos :: !SPos
274 }
277exprHelp :: R.Position -> State -> ExprParser
278exprHelp start (State ops lastExpr end pos) =
279 oneOf
280 [ -- argument
281 hint E.Arg $
282 do checkSpace pos
283 arg <- term
284 newEnd <- getPosition
285 newPos <- whitespace
286 let newLast = A.merge lastExpr arg (Src.App lastExpr arg)
287 exprHelp start (State ops newLast newEnd newPos)
289 , -- infix operator
290 do checkSpace pos
291 opStart <- getPosition
292 opName <- infixOp
293 opEnd <- getPosition
294 let op = A.at opStart opEnd opName
295 spos <- whitespace
296 hint (E.AfterOpExpr opName) (checkSpace spos)
297 newStart <- getPosition
298 hint (E.AfterOpExpr opName) $ oneOf $
299 [ -- negative terms
300 do guard ("-" == opName && end /= opStart && opEnd == newStart)
301 rawTerm <- term
302 newEnd <- getPosition
303 newPos <- whitespace
305 let ann x = A.merge op rawTerm x
306 let negatedTerm = ann (Src.Binop [(ann Src.zero, op)] rawTerm)
307 let newLast = A.merge lastExpr rawTerm (Src.App lastExpr negatedTerm)
309 exprHelp start (State ops newLast newEnd newPos)
311 , -- term
312 do newLast <- possiblyNegativeTerm newStart
313 newEnd <- getPosition
314 newPos <- whitespace
315 let newOps = (lastExpr, op) : ops
316 exprHelp start (State newOps newLast 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 = (lastExpr, op) : ops
327 let finalExpr = A.at start newEnd (Src.Binop (reverse newOps) newLast)
328 return ( finalExpr, newEnd, newPos )
329 ]
331 , -- done
332 case ops of
333 [] ->
334 return ( lastExpr, end, pos )
336 _ ->
337 let
338 finalExpr =
339 A.at start end (Src.Binop (reverse ops) lastExpr)
340 in
341 return ( finalExpr, end, pos )
342 ]
345possiblyNegativeTerm :: R.Position -> Parser Src.RawExpr
346possiblyNegativeTerm start =
347 oneOf
348 [ do minus
349 expr <- term
350 end <- getPosition
351 let ann x = A.at start end x
352 return (ann (Src.Binop [(ann Src.zero, ann "-")] expr))
353 , term
354 ]
358-- IF EXPRESSION
361if_ :: R.Position -> ExprParser
362if_ start =
363 do keyword "if"
364 inContext start E.ExprIf $ ifHelp start []
367ifHelp :: R.Position -> [(Src.RawExpr, Src.RawExpr)] -> ExprParser
368ifHelp start branches =
369 do spaces
370 (condition, _, condPos) <- expression
371 checkSpace condPos
372 keyword "then"
373 spaces
374 (thenBranch, _, thenPos) <- expression
375 hint E.ElseBranch $ checkSpace thenPos
376 hint E.ElseBranch $ keyword "else"
377 spaces
378 let newBranches = (condition, thenBranch) : branches
379 oneOf
380 [ do keyword "if"
381 ifHelp start newBranches
382 , do (elseBranch, elseEnd, elseSpace) <- expression
383 let ifExpr = A.at start elseEnd (Src.If (reverse newBranches) elseBranch)
384 return ( ifExpr, elseEnd, elseSpace )
385 ]
389-- LAMBDA EXPRESSION
392function :: R.Position -> ExprParser
393function start =
394 do lambda
395 inContext start E.ExprFunc $
396 do spaces
397 arg <- Pattern.term
398 spaces
399 revArgs <- gatherArgs [arg]
400 spaces
401 (body, end, space) <- expression
402 let func = List.foldl' (\e x -> A.at start end (Src.Lambda x e)) body revArgs
403 return ( func, end, space )
406gatherArgs :: [P.Raw] -> Parser [P.Raw]
407gatherArgs args =
408 oneOf
409 [ do arg <- Pattern.term
410 spaces
411 gatherArgs (arg:args)
412 , do rightArrow
413 return args
414 ]
418-- CASE EXPRESSIONS
421case_ :: R.Position -> ExprParser
422case_ start =
423 do keyword "case"
424 inContext start E.ExprCase $
425 do spaces
426 (switcher, _, switcherPos) <- expression
427 checkSpace switcherPos
428 keyword "of"
429 spaces
430 oldIndent <- getIndent
431 newIndent <- getCol
432 setIndent newIndent
433 (firstBranch, firstEnd, firstPos) <- branchHelp
434 (branches, end, pos) <- caseHelp [firstBranch] firstEnd firstPos
435 setIndent oldIndent
436 return
437 ( A.at start end (Src.Case switcher branches)
438 , end
439 , pos
440 )
443branchHelp :: SParser (P.Raw, Src.RawExpr)
444branchHelp =
445 do (pattern, patternPos) <- Pattern.expression
446 checkSpace patternPos
447 rightArrow
448 spaces
449 (branchExpr, end, pos) <- expression
450 return ( (pattern, branchExpr), end, pos )
453caseHelp :: [(P.Raw, Src.RawExpr)] -> R.Position -> SPos -> SParser [(P.Raw, Src.RawExpr)]
454caseHelp branches end pos =
455 oneOf
456 [ do checkAligned pos
457 (branch, newEnd, newPos) <- branchHelp
458 caseHelp (branch:branches) newEnd newPos
459 , return ( reverse branches, end, pos )
460 ]
464-- LET EXPRESSION
467let_ :: R.Position -> ExprParser
468let_ start =
469 do oldIndent <- getIndent
470 letIndent <- getCol
471 keyword "let"
472 pushContext start E.ExprLet
473 setIndent letIndent
474 spaces
475 defIndent <- getCol
476 setIndent defIndent
477 (def, end, space) <- definition
478 letHelp start oldIndent [def] end space
481letHelp :: R.Position -> Int -> [Src.RawDef] -> R.Position -> SPos -> ExprParser
482letHelp start oldIndent revDefs end pos =
483 oneOf
484 [ do checkAligned pos
485 (def, newEnd, newPos) <- definition
486 letHelp start oldIndent (def:revDefs) newEnd newPos
488 , do setIndent oldIndent
489 checkSpace pos
490 keyword "in"
491 popContext ()
492 spaces
493 (body, newEnd, newPos) <- expression
494 let letExpr = A.at start end (Src.Let (reverse revDefs) body)
495 return ( letExpr, newEnd, newPos )
496 ]
500-- DEFINITIONS
503definition :: SParser Src.RawDef
504definition =
505 do start <- getPosition
506 root <- rootPattern start
507 spaces
508 case A.drop root of
509 P.Var name ->
510 oneOf
511 [ do hasType
512 inContext start (E.Annotation name) $
513 do spaces
514 (tipe, end, space) <- Type.expression
515 return ( A.at start end (Src.Annotation name tipe), end, space )
516 , inContext start (E.Definition name) $
517 definitionHelp start root []
518 ]
520 _ ->
521 definitionHelp start root []
524rootPattern :: R.Position -> Parser P.Raw
525rootPattern start =
526 oneOf
527 [ do op <- try (leftParen >> infixOp)
528 rightParen
529 end <- getPosition
530 return (A.at start end (P.Var op))
531 , Pattern.term
532 ]
535definitionHelp :: R.Position -> P.Raw -> [P.Raw] -> SParser Src.RawDef
536definitionHelp start root revArgs =
537 oneOf
538 [ do arg <- hint E.Arg Pattern.term
539 spaces
540 definitionHelp start root (arg : revArgs)
541 , do equals
542 spaces
543 (expr, end, space) <- expression
544 let body = List.foldl' (\e x -> A.at start end (Src.Lambda x e)) expr revArgs
545 let def = A.at start end (Src.Definition root body)
546 return ( def, end, space )
547 ]