git.iko.soy/elk
on 54dfb21 help sign in
elk/src/Parse/Expression.hs
314 lines 7.6 kB history raw
1module Parse.Expression (term, typeAnnotation, definition, expr) where
3import qualified Data.List as List
4import Text.Parsec hiding (newline, spaces)
5import qualified Text.Parsec.Indent as Indent
7import qualified Parse.Binop as Binop
8import Parse.Helpers
9import qualified Parse.Helpers as Help
10import qualified Parse.Literal as Literal
11import qualified Parse.Pattern as Pattern
12import qualified Parse.Type as Type
14import qualified AST.Expression.General as E
15import qualified AST.Expression.Source as Source
16import qualified AST.Literal as L
17import qualified AST.Pattern as P
18import qualified AST.Variable as Var
19import qualified Reporting.Annotation as A
22-------- Basic Terms --------
24varTerm :: IParser Source.Expr'
25varTerm =
26 toVar <$> var
29toVar :: String -> Source.Expr'
30toVar v =
31 case v of
32 "True" ->
33 E.Literal (L.Boolean True)
35 "False" ->
36 E.Literal (L.Boolean False)
38 _ ->
39 E.rawVar v
42accessor :: IParser Source.Expr'
43accessor =
44 do (start, lbl, end) <- located (try (string "." >> rLabel))
46 let ann value =
47 A.at start end value
49 return $
50 E.Lambda
51 (ann (P.Var "_"))
52 (ann (E.Access (ann (E.rawVar "_")) lbl))
55negative :: IParser Source.Expr'
56negative =
57 do (start, nTerm, end) <-
58 located $ try $
59 do char '-'
60 notFollowedBy (char '.' <|> char '-')
61 term
63 let ann e =
64 A.at start end e
66 return $
67 E.Binop
68 (Var.Raw "-")
69 (ann (E.Literal (L.IntNum 0)))
70 nTerm
73-------- Complex Terms --------
75listTerm :: IParser Source.Expr'
76listTerm =
77 shader' <|> braces (try range <|> E.ExplicitList <$> commaSep expr)
78 where
79 range =
80 do lo <- expr
81 padded (string "..")
82 E.Range lo <$> expr
84 shader' =
85 do pos <- getPosition
86 let uid = show (sourceLine pos) ++ ":" ++ show (sourceColumn pos)
87 (rawSrc, tipe) <- Help.shader
88 return $ E.GLShader uid (filter (/='\r') rawSrc) tipe
91parensTerm :: IParser Source.Expr
92parensTerm =
93 choice
94 [ try (parens opFn)
95 , parens (tupleFn <|> parened)
96 ]
97 where
98 lambda start end x body =
99 A.at start end (E.Lambda (A.at start end (P.Var x)) body)
101 var start end x =
102 A.at start end (E.rawVar x)
104 opFn =
105 do (start, op, end) <- located symOp
106 return $
107 lambda start end "x" $
108 lambda start end "y" $
109 A.at start end $
110 E.Binop (Var.Raw op) (var start end "x") (var start end "y")
112 tupleFn =
113 do (start, commas, end) <-
114 located (comma >> many (whitespace >> comma))
116 let vars = map (('v':) . show) [ 0 .. length commas + 1 ]
118 return $
119 foldr
120 (lambda start end)
121 (A.at start end (E.tuple (map (var start end) vars)))
122 vars
124 parened =
125 do (start, expressions, end) <- located (commaSep expr)
126 return $
127 case expressions of
128 [expression] ->
129 expression
130 _ ->
131 A.at start end (E.tuple expressions)
134recordTerm :: IParser Source.Expr
135recordTerm =
136 addLocation $ brackets $ choice $
137 [ do starter <- try (addLocation rLabel)
138 whitespace
139 choice
140 [ update starter
141 , literal starter
142 ]
143 , return (E.Record [])
144 ]
145 where
146 update (A.A ann starter) =
147 do try (string "|")
148 whitespace
149 fields <- commaSep1 field
150 return (E.Update (A.A ann (E.rawVar starter)) fields)
152 literal (A.A _ starter) =
153 do try equals
154 whitespace
155 value <- expr
156 whitespace
157 choice
158 [ do try comma
159 whitespace
160 fields <- commaSep field
161 return (E.Record ((starter, value) : fields))
162 , return (E.Record [(starter, value)])
163 ]
165 field =
166 do key <- rLabel
167 padded equals
168 value <- expr
169 return (key, value)
172term :: IParser Source.Expr
173term =
174 addLocation (choice [ E.Literal <$> Literal.literal, listTerm, accessor, negative ])
175 <|> accessible (addLocation varTerm <|> parensTerm <|> recordTerm)
176 <?> "an expression"
179-------- Applications --------
181appExpr :: IParser Source.Expr
182appExpr =
183 expecting "an expression" $
184 do t <- term
185 ts <- constrainedSpacePrefix term $ \str ->
186 if null str then notFollowedBy (char '-') else return ()
187 return $
188 case ts of
189 [] -> t
190 _ -> List.foldl' (\f x -> A.merge f x $ E.App f x) t ts
193-------- Normal Expressions --------
195expr :: IParser Source.Expr
196expr =
197 addLocation (choice [ letExpr, caseExpr, ifExpr ])
198 <|> lambdaExpr
199 <|> binaryExpr
200 <?> "an expression"
203binaryExpr :: IParser Source.Expr
204binaryExpr =
205 Binop.binops appExpr lastExpr anyOp
206 where
207 lastExpr =
208 addLocation (choice [ letExpr, caseExpr, ifExpr ])
209 <|> lambdaExpr
210 <?> "an expression"
213ifExpr :: IParser Source.Expr'
214ifExpr =
215 ifHelp []
218ifHelp :: [(Source.Expr, Source.Expr)] -> IParser Source.Expr'
219ifHelp branches =
220 do try (reserved "if")
221 whitespace
222 condition <- expr
223 padded (reserved "then")
224 thenBranch <- expr
225 whitespace <?> "an 'else' branch"
226 reserved "else" <?> "an 'else' branch"
227 whitespace
228 let newBranches = (condition, thenBranch) : branches
229 choice
230 [ ifHelp newBranches
231 , E.If (reverse newBranches) <$> expr
232 ]
235lambdaExpr :: IParser Source.Expr
236lambdaExpr =
237 do char '\\' <|> char '\x03BB' <?> "an anonymous function"
238 whitespace
239 args <- spaceSep1 Pattern.term
240 padded rightArrow
241 body <- expr
242 return (makeFunction args body)
245caseExpr :: IParser Source.Expr'
246caseExpr =
247 do try (reserved "case")
248 exp <- padded expr
249 reserved "of"
250 whitespace
251 Indent.withPos $
252 do firstBranch <- branch
253 branches <-
254 many $ do
255 try (whitespace >> Indent.checkIndent)
256 branch
257 return $ E.Case exp (firstBranch : branches)
258 where
259 branch =
260 do p <- Pattern.expr
261 padded rightArrow
262 (,) p <$> expr
265-- LET
267letExpr :: IParser Source.Expr'
268letExpr =
269 do try (reserved "let")
270 whitespace
271 defs <-
272 Indent.block $
273 do def <- typeAnnotation <|> definition
274 whitespace
275 return def
276 padded (reserved "in")
277 E.Let defs <$> expr
280-- TYPE ANNOTATION
282typeAnnotation :: IParser Source.Def
283typeAnnotation =
284 addLocation (Source.TypeAnnotation <$> try start <*> Type.expr)
285 where
286 start =
287 do v <- lowVar <|> parens symOp
288 padded hasType
289 return v
292-- DEFINITION
294definition :: IParser Source.Def
295definition =
296 addLocation $
297 Indent.withPos $
298 do (name, args) <- defStart
299 padded equals
300 body <- expr
301 return . Source.Definition name $ makeFunction args body
304makeFunction :: [P.RawPattern] -> Source.Expr -> Source.Expr
305makeFunction args body@(A.A ann _) =
306 foldr (\arg body' -> A.A ann $ E.Lambda arg body') body args
309defStart :: IParser (P.RawPattern, [P.RawPattern])
310defStart =
311 expecting "the definition of a value (x = ...)" $
312 do starter <- try Pattern.term <|> addLocation (P.Var <$> parens symOp)
313 args <- spacePrefix Pattern.term
314 return (starter, args)