git.iko.soy/elk
on 9b0c310 help sign in
elk/src/Parse/Expression.hs
341 lines 8.3 kB history raw
1module Parse.Expression (term, typeAnnotation, definition, expr) where
3import Control.Applicative ((<$>), (<*>))
4import qualified Data.List as List
5import Text.Parsec hiding (newline, spaces)
6import Text.Parsec.Indent (block, withPos)
8import qualified Parse.Binop as Binop
9import Parse.Helpers
10import qualified Parse.Helpers as Help
11import qualified Parse.Literal as Literal
12import qualified Parse.Pattern as Pattern
13import qualified Parse.Type as Type
15import qualified AST.Expression.General as E
16import qualified AST.Expression.Source as Source
17import qualified AST.Literal as L
18import qualified AST.Pattern as P
19import qualified AST.Variable as Var
20import qualified Reporting.Annotation as A
23-------- Basic Terms --------
25varTerm :: IParser Source.Expr'
26varTerm =
27 toVar <$> var <?> "variable"
30toVar :: String -> Source.Expr'
31toVar v =
32 case v of
33 "True" ->
34 E.Literal (L.Boolean True)
36 "False" ->
37 E.Literal (L.Boolean False)
39 _ ->
40 E.rawVar v
43accessor :: IParser Source.Expr'
44accessor =
45 do (start, lbl, end) <- located (try (string "." >> rLabel))
47 let ann value =
48 A.at start end value
50 return $
51 E.Lambda
52 (ann (P.Var "_"))
53 (ann (E.Access (ann (E.rawVar "_")) lbl))
56negative :: IParser Source.Expr'
57negative =
58 do (start, nTerm, end) <-
59 located (try (char '-' >> notFollowedBy (char '.' <|> char '-')) >> term)
61 let ann e =
62 A.at start end e
64 return $
65 E.Binop
66 (Var.Raw "-")
67 (ann (E.Literal (L.IntNum 0)))
68 nTerm
71-------- Complex Terms --------
73listTerm :: IParser Source.Expr'
74listTerm =
75 shader' <|> braces (try range <|> E.ExplicitList <$> commaSep expr)
76 where
77 range =
78 do lo <- expr
79 padded (string "..")
80 E.Range lo <$> expr
82 shader' =
83 do pos <- getPosition
84 let uid = show (sourceLine pos) ++ ":" ++ show (sourceColumn pos)
85 (rawSrc, tipe) <- Help.shader
86 return $ E.GLShader uid (filter (/='\r') rawSrc) tipe
89parensTerm :: IParser Source.Expr
90parensTerm =
91 choice
92 [ try (parens opFn)
93 , parens (tupleFn <|> parened)
94 ]
95 where
96 lambda start end x body =
97 A.at start end (E.Lambda (A.at start end (P.Var x)) body)
99 var start end x =
100 A.at start end (E.rawVar x)
102 opFn =
103 do (start, op, end) <- located anyOp
104 return $
105 lambda start end "x" $
106 lambda start end "y" $
107 A.at start end $
108 E.Binop (Var.Raw op) (var start end "x") (var start end "y")
110 tupleFn =
111 do (start, commas, end) <-
112 located (comma >> many (whitespace >> comma))
114 let vars = map (('v':) . show) [ 0 .. length commas + 1 ]
116 return $
117 foldr
118 (lambda start end)
119 (A.at start end (E.tuple (map (var start end) vars)))
120 vars
122 parened =
123 do (start, expressions, end) <- located (commaSep expr)
124 return $
125 case expressions of
126 [expression] ->
127 expression
128 _ ->
129 A.at start end (E.tuple expressions)
132recordTerm :: IParser Source.Expr
133recordTerm =
134 addLocation $
135 brackets $ choice [ misc, record ]
136 where
137 field =
138 do label <- rLabel
139 patterns <- spacePrefix Pattern.term
140 padded equals
141 body <- expr
142 return (label, makeFunction patterns body)
144 record =
145 E.Record <$> commaSep field
147 change =
148 do lbl <- rLabel
149 padded (string "<-")
150 (,) lbl <$> expr
152 remove r =
153 do string "-"
154 whitespace
155 E.Remove r <$> rLabel
157 insert r =
158 do string "|"
159 whitespace
160 E.Insert r <$> rLabel <*> (padded equals >> expr)
162 modify r =
163 do string "|"
164 whitespace
165 E.Modify r <$> commaSep1 change
167 misc =
168 try $ do
169 record <- addLocation (E.rawVar <$> rLabel)
170 opt <- padded (optionMaybe (addLocation (remove record)))
171 case opt of
172 Just e@(A.A _ e') ->
173 try (insert e) <|> return e'
174 Nothing ->
175 try (insert record) <|> try (modify record)
178term :: IParser Source.Expr
179term =
180 addLocation (choice [ E.Literal <$> Literal.literal, listTerm, accessor, negative ])
181 <|> accessible (addLocation varTerm <|> parensTerm <|> recordTerm)
182 <?> "basic term (4, x, 'c', etc.)"
185-------- Applications --------
187appExpr :: IParser Source.Expr
188appExpr =
189 do t <- term
190 ts <- constrainedSpacePrefix term $ \str ->
191 if null str then notFollowedBy (char '-') else return ()
192 return $
193 case ts of
194 [] -> t
195 _ -> List.foldl' (\f x -> A.merge f x $ E.App f x) t ts
198-------- Normal Expressions --------
200expr :: IParser Source.Expr
201expr =
202 addLocation (choice [ ifExpr, letExpr, caseExpr ])
203 <|> lambdaExpr
204 <|> binaryExpr
205 <?> "an expression"
208binaryExpr :: IParser Source.Expr
209binaryExpr =
210 Binop.binops appExpr lastExpr anyOp
211 where
212 lastExpr = addLocation (choice [ ifExpr, letExpr, caseExpr ])
213 <|> lambdaExpr
216ifExpr :: IParser Source.Expr'
217ifExpr =
218 do try (reserved "if")
219 whitespace
220 normal <|> multiIf
221 where
222 normal =
223 do bool <- expr
224 padded (reserved "then")
225 thenBranch <- expr
226 whitespace <?> "an 'else' branch"
227 reserved "else" <?> "an 'else' branch"
228 whitespace
229 elseBranch <- expr
230 return $ E.MultiIf
231 [ (bool, thenBranch)
232 , (A.sameAs elseBranch (E.Literal . L.Boolean $ True), elseBranch)
233 ]
235 multiIf =
236 E.MultiIf <$> spaceSep1 iff
237 where
238 iff =
239 do string "|" ; whitespace
240 b <- expr ; padded arrow
241 (,) b <$> expr
244lambdaExpr :: IParser Source.Expr
245lambdaExpr =
246 do char '\\' <|> char '\x03BB' <?> "anonymous function"
247 whitespace
248 args <- spaceSep1 Pattern.term
249 padded arrow
250 body <- expr
251 return (makeFunction args body)
254caseExpr :: IParser Source.Expr'
255caseExpr =
256 do try (reserved "case")
257 e <- padded expr
258 reserved "of"
259 whitespace
260 E.Case e <$> (with <|> without)
261 where
262 case_ =
263 do p <- Pattern.expr
264 padded arrow
265 (,) p <$> expr
267 with =
268 brackets (semiSep1 (case_ <?> "cases { x -> ... }"))
270 without =
271 block (do c <- case_ ; whitespace ; return c)
274-- LET
276letExpr :: IParser Source.Expr'
277letExpr =
278 do try (reserved "let")
279 whitespace
280 defs <-
281 block $
282 do def <- typeAnnotation <|> definition
283 whitespace
284 return def
285 padded (reserved "in")
286 E.Let defs <$> expr
289-- TYPE ANNOTATION
291typeAnnotation :: IParser Source.Def
292typeAnnotation =
293 addLocation (Source.TypeAnnotation <$> try start <*> Type.expr)
294 where
295 start =
296 do v <- lowVar <|> parens symOp
297 padded hasType
298 return v
301-- DEFINITION
303definition :: IParser Source.Def
304definition =
305 addLocation $
306 withPos $
307 do (name:args) <- defStart
308 padded equals
309 body <- expr
310 return . Source.Definition name $ makeFunction args body
313makeFunction :: [P.RawPattern] -> Source.Expr -> Source.Expr
314makeFunction args body@(A.A ann _) =
315 foldr (\arg body' -> A.A ann $ E.Lambda arg body') body args
318defStart :: IParser [P.RawPattern]
319defStart =
320 choice
321 [ do pattern <- try Pattern.term
322 infics pattern <|> func pattern
323 , do opPattern <- addLocation (P.Var <$> parens symOp)
324 func opPattern
325 ]
326 <?> "the definition of a variable (x = ...)"
327 where
328 func pattern =
329 case pattern of
330 A.A _ (P.Var _) ->
331 (pattern:) <$> spacePrefix Pattern.term
333 _ ->
334 return [pattern]
336 infics p1 =
337 do (start, o:p, end) <- try (whitespace >> located anyOp)
338 p2 <- (whitespace >> Pattern.term)
339 let opName =
340 if o == '`' then takeWhile (/='`') p else o:p
341 return [ A.at start end (P.Var opName), p1, p2 ]