never executed always true always false
1 {-# LANGUAGE DataKinds #-}
2 {-# LANGUAGE GADTs #-}
3
4 module Parse.Expression (term, typeAnnotation, definition, expr) where
5
6 import Data.Coapplicative
7 import qualified Data.Indexed as I
8 import Data.Maybe (fromMaybe)
9 import Text.Parsec hiding (newline, spaces)
10 import Text.Parsec.Indent (block, withPos, checkIndent)
11
12 import qualified Parse.Binop as Binop
13 import Parse.Helpers
14 import Parse.Common
15 import qualified Parse.Helpers as Help
16 import qualified Parse.Literal as Literal
17 import qualified Parse.Pattern as Pattern
18 import qualified Parse.Type as Type
19 import Parse.IParser
20 import Parse.Whitespace
21
22 import AST.V0_16
23 import AST.Structure
24 import ElmVersion
25 import Reporting.Annotation (Located)
26 import qualified Reporting.Annotation as A
27
28
29 -------- Basic Terms --------
30
31 varTerm :: ElmVersion -> IParser (ASTNS Located [UppercaseIdentifier] 'ExpressionNK)
32 varTerm elmVersion =
33 fmap I.Fix $ addLocation $
34 let
35 resolve v =
36 case v of
37 TagRef [] (UppercaseIdentifier "True") -> Literal $ Boolean True
38 TagRef [] (UppercaseIdentifier "False") -> Literal $ Boolean False
39 _ -> VarExpr v
40 in
41 resolve <$> var elmVersion
42
43
44 accessor :: ElmVersion -> IParser (ASTNS Located [UppercaseIdentifier] 'ExpressionNK)
45 accessor elmVersion =
46 fmap I.Fix $ addLocation $
47 do lbl <- try (string "." >> rLabel elmVersion)
48 return $ AccessFunction lbl
49
50
51 negative :: ElmVersion -> IParser (ASTNS Located [UppercaseIdentifier] 'ExpressionNK)
52 negative elmVersion =
53 fmap I.Fix $ addLocation $
54 do nTerm <-
55 try $
56 do _ <- char '-'
57 notFollowedBy (char '.' <|> char '-')
58 term elmVersion
59
60 return $ Unary Negative nTerm
61
62
63 -------- Complex Terms --------
64
65 listTerm :: ElmVersion -> IParser (ASTNS Located [UppercaseIdentifier] 'ExpressionNK)
66 listTerm elmVersion =
67 fmap I.Fix $ addLocation $
68 shader' <|> try (braces range) <|> commaSeparated
69 where
70 range =
71 do
72 lo <- expr elmVersion
73 (C (loPost, hiPre) _) <- padded (string "..")
74 hi <- expr elmVersion
75 return $ \loPre hiPost multiline ->
76 Range
77 (C (loPre, loPost) lo)
78 (C (hiPre, hiPost) hi)
79 multiline
80
81 shader' =
82 do rawSrc <- Help.shader
83 return $ GLShader (filter (/='\r') rawSrc)
84
85 commaSeparated =
86 braces' $ checkMultiline $
87 do
88 (terms, trailing) <- sectionedGroup (expr elmVersion)
89 return $ ExplicitList terms trailing
90
91
92 parensTerm :: ElmVersion -> IParser (ASTNS Located [UppercaseIdentifier] 'ExpressionNK)
93 parensTerm elmVersion =
94 fmap I.Fix $
95 choice
96 [ try (addLocation $ parens' opFn )
97 , try (addLocation $ parens' tupleFn)
98 , do
99 (start, e, end) <- located $ parens (parened <|> unit)
100 return $ A.at start end e
101 ]
102 where
103 opFn =
104 VarExpr <$> anyOp elmVersion
105
106 tupleFn =
107 do commas <- many1 comma
108 return $ TupleFunction (length commas + 1)
109
110 parened =
111 do expressions <- commaSep1 ((\e a b -> C (a, b) e) <$> expr elmVersion)
112 return $ \pre post multiline ->
113 case expressions pre post of
114 [single] ->
115 Parens single
116
117 expressions' ->
118 Tuple expressions' multiline
119
120 unit =
121 return $ \pre post _ -> Unit (pre ++ post)
122
123
124 recordTerm :: ElmVersion -> IParser (ASTNS Located [UppercaseIdentifier] 'ExpressionNK)
125 recordTerm elmVersion =
126 fmap I.Fix $
127 addLocation $ brackets' $ checkMultiline $
128 do
129 base <- optionMaybe $ try (commented (lowVar elmVersion) <* string "|")
130 (fields, trailing) <- sectionedGroup (pair (lowVar elmVersion) lenientEquals (expr elmVersion))
131 return $ Record base fields trailing
132
133
134 term :: ElmVersion -> IParser (ASTNS Located [UppercaseIdentifier] 'ExpressionNK)
135 term elmVersion =
136 (choice
137 [ fmap I.Fix $ addLocation (Literal <$> Literal.literal)
138 , listTerm elmVersion
139 , accessor elmVersion
140 , negative elmVersion
141 ]
142 )
143 <|> accessible elmVersion
144 (varTerm elmVersion
145 <|> parensTerm elmVersion
146 <|> recordTerm elmVersion
147 )
148 <?> "an expression"
149
150
151 -------- Applications --------
152
153 head' :: [a] -> Maybe a
154 head' [] = Nothing
155 head' (a:_) = Just a
156
157
158 appExpr :: ElmVersion -> IParser (ASTNS Located [UppercaseIdentifier] 'ExpressionNK)
159 appExpr elmVersion =
160 expecting "an expression" $
161 do start <- getMyPosition
162 (t, initialTermMultiline) <- trackNewline (term elmVersion)
163 ts <- constrainedSpacePrefix (term elmVersion)
164 end <- getMyPosition
165 return $
166 case ts of
167 [] ->
168 t
169 _ ->
170 let
171 multiline =
172 case
173 ( initialTermMultiline
174 , fromMaybe (JoinAll) $ fmap snd $ head' ts
175 , any (isMultiline . snd) $ tail ts
176 )
177 of
178 (SplitAll, _, _ ) -> FASplitFirst
179 (JoinAll, JoinAll, True) -> FAJoinFirst SplitAll
180 (JoinAll, JoinAll, False) -> FAJoinFirst JoinAll
181 (JoinAll, SplitAll, _) -> FASplitFirst
182 in
183 I.Fix $ A.at start end $ App t (fmap fst ts) multiline
184
185
186 -------- Normal Expressions --------
187
188 expr :: ElmVersion -> IParser (ASTNS Located [UppercaseIdentifier] 'ExpressionNK)
189 expr elmVersion =
190 choice [ letExpr elmVersion, caseExpr elmVersion, ifExpr elmVersion ]
191 <|> lambdaExpr elmVersion
192 <|> binaryExpr elmVersion
193 <?> "an expression"
194
195
196 binaryExpr :: ElmVersion -> IParser (ASTNS Located [UppercaseIdentifier] 'ExpressionNK)
197 binaryExpr elmVersion =
198 Binop.binops (appExpr elmVersion) lastExpr (anyOp elmVersion)
199 where
200 lastExpr =
201 choice [ letExpr elmVersion, caseExpr elmVersion, ifExpr elmVersion ]
202 <|> lambdaExpr elmVersion
203 <?> "an expression"
204
205
206 ifExpr :: ElmVersion -> IParser (ASTNS Located [UppercaseIdentifier] 'ExpressionNK)
207 ifExpr elmVersion =
208 let
209 elseKeyword =
210 (reserved elmVersion "else" <?> "an 'else' branch")
211 >> whitespace
212 in
213 fmap I.Fix $ addLocation $
214 do
215 first <- ifClause elmVersion
216 rest <- many (try $ C <$> elseKeyword <*> ifClause elmVersion)
217 final <- C <$> elseKeyword <*> expr elmVersion
218
219 return $ If first rest final
220
221
222 ifClause :: ElmVersion -> IParser (IfClause (ASTNS Located [UppercaseIdentifier] 'ExpressionNK))
223 ifClause elmVersion =
224 do
225 try (reserved elmVersion "if")
226 preCondition <- whitespace
227 condition <- expr elmVersion
228 (C (postCondition, bodyComments) _) <- padded (reserved elmVersion "then")
229 thenBranch <- expr elmVersion
230 preElse <- whitespace <?> "an 'else' branch"
231 return $ IfClause
232 (C (preCondition, postCondition) condition)
233 (C (bodyComments, preElse) thenBranch)
234
235
236 lambdaExpr :: ElmVersion -> IParser (ASTNS Located [UppercaseIdentifier] 'ExpressionNK)
237 lambdaExpr elmVersion =
238 let
239 subparser = do
240 _ <- char '\\' <|> char '\x03BB' <?> "an anonymous function"
241 args <- spacePrefix (Pattern.term elmVersion)
242 (C (preArrowComments, bodyComments) _) <- padded rightArrow
243 body <- expr elmVersion
244 return (args, preArrowComments, bodyComments, body)
245 in
246 fmap I.Fix $ addLocation $
247 do ((args, preArrowComments, bodyComments, body), multiline) <- trackNewline subparser
248 return $ Lambda args (preArrowComments ++ bodyComments) body $ multilineToBool multiline
249
250
251 caseExpr :: ElmVersion -> IParser (ASTNS Located [UppercaseIdentifier] 'ExpressionNK)
252 caseExpr elmVersion =
253 fmap I.Fix $ addLocation $
254 do try (reserved elmVersion "case")
255 (e, multilineSubject) <- trackNewline $ padded (expr elmVersion)
256 reserved elmVersion "of"
257 firstPatternComments <- whitespace
258 result <- cases firstPatternComments
259 return $ Case (e, multilineToBool multilineSubject) result
260 where
261 case_ preComments =
262 fmap I.Fix $ addLocation $
263 do
264 (patternComments, p, C (preArrowComments, bodyComments) _) <-
265 try ((,,)
266 <$> whitespace
267 <*> (checkIndent >> Pattern.expr elmVersion)
268 <*> padded rightArrow
269 )
270 result <- expr elmVersion
271 return $ CaseBranch
272 { beforePattern = preComments ++ patternComments
273 , beforeArrow = preArrowComments
274 , afterArrow = bodyComments
275 , pattern = p
276 , body = result
277 }
278
279 cases preComments =
280 withPos $
281 do
282 r1 <- case_ preComments
283 r <- many $ case_ []
284 return $ r1:r
285
286
287
288 -- LET
289
290
291 letExpr :: ElmVersion -> IParser (ASTNS Located [UppercaseIdentifier] 'ExpressionNK)
292 letExpr elmVersion =
293 fmap I.Fix $ addLocation $
294 do try (reserved elmVersion "let")
295 A.A cal commentsAfterLet' <- addLocation whitespace
296 let commentsAfterLet = fmap (I.Fix . A.A cal . LetComment) commentsAfterLet'
297 defs <-
298 block $
299 do def <- fmap I.Fix $ addLocation $ fmap (LetCommonDeclaration . I.Fix) $ addLocation (typeAnnotation elmVersion TypeAnnotation <|> definition elmVersion Definition)
300 A.A cad commentsAfterDef' <- addLocation whitespace
301 let commentsAfterDef = fmap (I.Fix . A.A cad . LetComment) commentsAfterDef'
302 return (def : commentsAfterDef)
303 _ <- reserved elmVersion "in"
304 bodyComments <- whitespace
305 Let (commentsAfterLet ++ concat defs) bodyComments <$> expr elmVersion
306
307
308
309 -- TYPE ANNOTATION
310
311 typeAnnotation :: ElmVersion -> (C1 after (Ref ()) -> C1 before (ASTNS Located [UppercaseIdentifier] 'TypeNK) -> a) -> IParser a
312 typeAnnotation elmVersion fn =
313 (\(v, pre, post) e -> fn (C pre v) (C post e)) <$> try start <*> Type.expr elmVersion
314 where
315 start =
316 do v <- (VarRef () <$> lowVar elmVersion) <|> (OpRef <$> symOpInParens)
317 (C (preColon, postColon) _) <- padded hasType
318 return (v, preColon, postColon)
319
320
321 -- DEFINITION
322
323 definition ::
324 ElmVersion
325 ->
326 (ASTNS Located [UppercaseIdentifier] 'PatternNK
327 -> [C1 before (ASTNS Located [UppercaseIdentifier] 'PatternNK)]
328 -> Comments
329 -> (ASTNS Located [UppercaseIdentifier] 'ExpressionNK)
330 -> a
331 )
332 -> IParser a
333 definition elmVersion fn =
334 withPos $
335 do
336 (name, args) <- defStart elmVersion
337 (C (preEqualsComments, postEqualsComments) _) <- padded equals
338 body <- expr elmVersion
339 return $ fn name args (preEqualsComments ++ postEqualsComments) body
340
341
342 defStart :: ElmVersion -> IParser (ASTNS Located [UppercaseIdentifier] 'PatternNK, [C1 before (ASTNS Located [UppercaseIdentifier] 'PatternNK)])
343 defStart elmVersion =
344 choice
345 [ do pattern <- try $ Pattern.term elmVersion
346 func $ pattern
347 , do opPattern <- fmap I.Fix $ addLocation (OpPattern <$> parens' symOp)
348 func opPattern
349 ]
350 <?> "the definition of a variable (x = ...)"
351 where
352 func pattern =
353 case extract $ I.unFix pattern of
354 VarPattern _ ->
355 ((,) pattern) <$> spacePrefix (Pattern.term elmVersion)
356
357 OpPattern _ ->
358 ((,) pattern) <$> spacePrefix (Pattern.term elmVersion)
359
360 _ ->
361 return (pattern, [])