git.iko.soy/elk
on 17618de help sign in
elk/src/Parse/Expression.hs
330 lines 7.7 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 shader' <|> braces (try range <|> E.ExplicitList <$> commaSep expr)
83 where
84 range =
85 do lo <- expr
86 padded (string "..")
87 E.Range lo <$> expr
89 shader' =
90 do pos <- getPosition
91 let uid = show (sourceLine pos) ++ ":" ++ show (sourceColumn pos)
92 (rawSrc, tipe) <- Help.shader
93 return $ E.GLShader uid (filter (/='\r') rawSrc) tipe
96parensTerm :: IParser Source.Expr
97parensTerm =
98 let
99 mkFunc args realBody start end =
100 foldr
101 (\arg body -> A.at start end (E.Lambda (A.at start end (P.Var arg)) body))
102 (A.at start end (realBody (A.at start end . E.rawVar)))
103 args
105 mkBinop op =
106 mkFunc ["x","y"] (\var -> E.Binop (Var.Raw op) (var "x") (var "y"))
108 tupleFn =
109 do commas <- many1 comma
110 let args = map (('v':) . show) [ 0 .. length commas ]
111 return $ mkFunc args (\var -> E.tuple (map var args))
113 parenedExpr =
114 do expressions <- padded (commaSep expr)
115 return $ \start end ->
116 case expressions of
117 [expression] ->
118 expression
119 _ ->
120 A.at start end (E.tuple expressions)
121 in
122 do (start, mkExpr, end) <-
123 located $ choice $
124 [ mkBinop <$> try (parens symOp)
125 , parens (tupleFn <|> parenedExpr)
126 ]
127 return (mkExpr start end)
130recordTerm :: IParser Source.Expr
131recordTerm =
132 addLocation $ brackets $ choice $
133 [ do starter <- try (addLocation rLabel)
134 whitespace
135 choice
136 [ update starter
137 , literal starter
138 ]
139 , return (E.Record [])
140 ]
141 where
142 update (A.A ann starter) =
143 do try (string "|")
144 whitespace
145 fields <- commaSep1 field
146 return (E.Update (A.A ann (E.rawVar starter)) fields)
148 literal (A.A _ starter) =
149 do try equals
150 whitespace
151 value <- expr
152 whitespace
153 choice
154 [ do try comma
155 whitespace
156 fields <- commaSep field
157 return (E.Record ((starter, value) : fields))
158 , return (E.Record [(starter, value)])
159 ]
161 field =
162 do key <- rLabel
163 padded equals
164 value <- expr
165 return (key, value)
168term :: IParser Source.Expr
169term =
170 addLocation (choice [ E.Literal <$> Literal.literal, listTerm, accessor, negative ])
171 <|> accessible (addLocation varTerm <|> parensTerm <|> recordTerm)
172 <?> "an expression"
176-------- Applications --------
179appExpr :: IParser Source.Expr
180appExpr =
181 expecting "an expression" $
182 do t <- term
183 ts <- constrainedSpacePrefix term $ \str ->
184 if null str then notFollowedBy (char '-') else return ()
185 return $
186 case ts of
187 [] -> t
188 _ -> List.foldl' (\f x -> A.merge f x $ E.App f x) t ts
192-------- 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 start <- getMyPosition
238 char '\\' <|> char '\x03BB' <?> "an anonymous function"
239 whitespace
240 args <- spaceSep1 Pattern.term
241 padded rightArrow
242 body <- expr
243 end <- getMyPosition
244 return (foldr (\a b -> A.at start end $ E.Lambda a b) body args)
247caseExpr :: IParser Source.Expr'
248caseExpr =
249 do try (reserved "case")
250 exp <- padded expr
251 reserved "of"
252 whitespace
253 Indent.withPos $
254 do firstBranch <- branch
255 branches <-
256 many $ do
257 try (whitespace >> Indent.checkIndent)
258 branch
259 return $ E.Case exp (firstBranch : branches)
260 where
261 branch =
262 do p <- Pattern.expr
263 padded rightArrow
264 (,) p <$> expr
268-- LET
271letExpr :: IParser Source.Expr'
272letExpr =
273 do try (reserved "let")
274 whitespace
275 defs <-
276 Indent.block (def <* whitespace)
277 whitespace
278 reserved "in"
279 whitespace
280 E.Let defs <$> expr
283def :: IParser Source.Def
284def =
285 choice
286 [ annotation Source.Annotation
287 , definition Source.Definition
288 ]
292-- TYPE ANNOTATION
295annotation :: (String -> T.Raw -> a) -> IParser (A.Located a)
296annotation creator =
297 let
298 start =
299 do v <- lowVar <|> parens symOp
300 padded hasType
301 return v
302 in
303 addLocation (creator <$> try start <*> Type.expr)
307-- DEFINITION
310definition :: (P.Raw -> Source.Expr -> a) -> IParser (A.Located a)
311definition creator =
312 addLocation $
313 Indent.withPos $
314 do (name, args) <- defStart
315 padded equals
316 body <- expr
317 return . creator name $ makeFunction args body
320makeFunction :: [P.Raw] -> Source.Expr -> Source.Expr
321makeFunction args body@(A.A ann _) =
322 foldr (\arg body' -> A.A ann $ E.Lambda arg body') body args
325defStart :: IParser (P.Raw, [P.Raw])
326defStart =
327 expecting "the definition of a value (x = ...)" $
328 do starter <- try Pattern.term <|> addLocation (P.Var <$> parens symOp)
329 args <- spacePrefix Pattern.term
330 return (starter, args)