git.iko.soy/elk
on 267f708 help sign in
elk/src/Parse/Expression.hs
325 lines 7.6 kB history raw
1module Parse.Expression (term, annotation, definition, expr, def) 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.Type as T
19import qualified AST.Variable as Var
20import qualified Reporting.Annotation as A
24-------- Basic Terms --------
27varTerm :: IParser Source.Expr'
28varTerm =
29 toVar <$> var
32toVar :: String -> Source.Expr'
33toVar v =
34 case v of
35 "True" ->
36 E.Literal (L.Boolean True)
38 "False" ->
39 E.Literal (L.Boolean False)
41 _ ->
42 E.rawVar v
45accessor :: IParser Source.Expr'
46accessor =
47 do (start, lbl, end) <- located (try (string "." >> rLabel))
49 let ann value =
50 A.at start end value
52 return $
53 E.Lambda
54 (ann (P.Var "_"))
55 (ann (E.Access (ann (E.rawVar "_")) lbl))
58negative :: IParser Source.Expr'
59negative =
60 do (start, nTerm, end) <-
61 located $ try $
62 do char '-'
63 notFollowedBy (char '.' <|> char '-')
64 term
66 let ann e =
67 A.at start end e
69 return $
70 E.Binop
71 (Var.Raw "-")
72 (ann (E.Literal (L.IntNum 0)))
73 nTerm
77-------- Complex Terms --------
80listTerm :: IParser Source.Expr'
81listTerm =
82 choice
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
87 , braces (E.ExplicitList <$> commaSep expr)
88 ]
91parensTerm :: IParser Source.Expr
92parensTerm =
93 let
94 mkFunc args realBody start end =
95 foldr
96 (\arg body -> A.at start end (E.Lambda (A.at start end (P.Var arg)) body))
97 (A.at start end (realBody (A.at start end . E.rawVar)))
98 args
100 mkBinop op =
101 mkFunc ["x","y"] (\var -> E.Binop (Var.Raw op) (var "x") (var "y"))
103 tupleFn =
104 do commas <- many1 comma
105 let args = map (('v':) . show) [ 0 .. length commas ]
106 return $ mkFunc args (\var -> E.tuple (map var args))
108 parenedExpr =
109 do expressions <- padded (commaSep expr)
110 return $ \start end ->
111 case expressions of
112 [expression] ->
113 expression
114 _ ->
115 A.at start end (E.tuple expressions)
116 in
117 do (start, mkExpr, end) <-
118 located $ choice $
119 [ mkBinop <$> try (parens Binop.infixOp)
120 , parens (tupleFn <|> parenedExpr)
121 ]
122 return (mkExpr start end)
125recordTerm :: IParser Source.Expr
126recordTerm =
127 addLocation $ brackets $ choice $
128 [ do starter <- try (addLocation rLabel)
129 whitespace
130 choice
131 [ update starter
132 , literal starter
133 ]
134 , return (E.Record [])
135 ]
136 where
137 update (A.A ann starter) =
138 do try (string "|")
139 whitespace
140 fields <- commaSep1 field
141 return (E.Update (A.A ann (E.rawVar starter)) fields)
143 literal (A.A _ starter) =
144 do try equals
145 whitespace
146 value <- expr
147 whitespace
148 choice
149 [ do try comma
150 whitespace
151 fields <- commaSep field
152 return (E.Record ((starter, value) : fields))
153 , return (E.Record [(starter, value)])
154 ]
156 field =
157 do key <- rLabel
158 padded equals
159 value <- expr
160 return (key, value)
163term :: IParser Source.Expr
164term =
165 addLocation (choice [ E.Literal <$> Literal.literal, listTerm, accessor, negative ])
166 <|> accessible (addLocation varTerm <|> parensTerm <|> recordTerm)
167 <?> "an expression"
171-------- Applications --------
174appExpr :: IParser Source.Expr
175appExpr =
176 expecting "an expression" $
177 do t <- term
178 ts <- constrainedSpacePrefix term $ \str ->
179 if null str then notFollowedBy (char '-') else return ()
180 return $
181 case ts of
182 [] -> t
183 _ -> List.foldl' (\f x -> A.merge f x $ E.App f x) t ts
187-------- Normal Expressions --------
190expr :: IParser Source.Expr
191expr =
192 addLocation (choice [ letExpr, caseExpr, ifExpr ])
193 <|> lambdaExpr
194 <|> binaryExpr
195 <?> "an expression"
198binaryExpr :: IParser Source.Expr
199binaryExpr =
200 Binop.binops appExpr lastExpr
201 where
202 lastExpr =
203 addLocation (choice [ letExpr, caseExpr, ifExpr ])
204 <|> lambdaExpr
205 <?> "an expression"
208ifExpr :: IParser Source.Expr'
209ifExpr =
210 ifHelp []
213ifHelp :: [(Source.Expr, Source.Expr)] -> IParser Source.Expr'
214ifHelp branches =
215 do try (reserved "if")
216 whitespace
217 condition <- expr
218 padded (reserved "then")
219 thenBranch <- expr
220 whitespace <?> "an 'else' branch"
221 reserved "else" <?> "an 'else' branch"
222 whitespace
223 let newBranches = (condition, thenBranch) : branches
224 choice
225 [ ifHelp newBranches
226 , E.If (reverse newBranches) <$> expr
227 ]
230lambdaExpr :: IParser Source.Expr
231lambdaExpr =
232 do start <- getMyPosition
233 char '\\' <|> char '\x03BB' <?> "an anonymous function"
234 whitespace
235 args <- spaceSep1 Pattern.term
236 padded rightArrow
237 body <- expr
238 end <- getMyPosition
239 return (foldr (\a b -> A.at start end $ E.Lambda a b) body args)
242caseExpr :: IParser Source.Expr'
243caseExpr =
244 do try (reserved "case")
245 exp <- padded expr
246 reserved "of"
247 whitespace
248 Indent.withPos $
249 do firstBranch <- branch
250 branches <-
251 many $ do
252 try (whitespace >> Indent.checkIndent)
253 branch
254 return $ E.Case exp (firstBranch : branches)
255 where
256 branch =
257 do p <- Pattern.expr
258 padded rightArrow
259 (,) p <$> expr
263-- LET
266letExpr :: IParser Source.Expr'
267letExpr =
268 do try (reserved "let")
269 whitespace
270 defs <-
271 Indent.block (def <* whitespace)
272 whitespace
273 reserved "in"
274 whitespace
275 E.Let defs <$> expr
278def :: IParser Source.Def
279def =
280 choice
281 [ annotation Source.Annotation
282 , definition Source.Definition
283 ]
287-- TYPE ANNOTATION
290annotation :: (String -> T.Raw -> a) -> IParser (A.Located a)
291annotation creator =
292 let
293 start =
294 do v <- lowVar <|> parens Binop.infixOp
295 padded hasType
296 return v
297 in
298 addLocation (creator <$> try start <*> Type.expr)
302-- DEFINITION
305definition :: (P.Raw -> Source.Expr -> a) -> IParser (A.Located a)
306definition creator =
307 addLocation $
308 Indent.withPos $
309 do (name, args) <- defStart
310 padded equals
311 body <- expr
312 return . creator name $ makeFunction args body
315makeFunction :: [P.Raw] -> Source.Expr -> Source.Expr
316makeFunction args body@(A.A ann _) =
317 foldr (\arg body' -> A.A ann $ E.Lambda arg body') body args
320defStart :: IParser (P.Raw, [P.Raw])
321defStart =
322 expecting "the definition of a value (x = ...)" $
323 do starter <- try Pattern.term <|> addLocation (P.Var <$> parens Binop.infixOp)
324 args <- spacePrefix Pattern.term
325 return (starter, args)