never executed always true always false
1 {-# LANGUAGE DeriveGeneric #-}
2 {-# LANGUAGE TypeFamilies #-}
3 {-# LANGUAGE DataKinds #-}
4 {-# LANGUAGE TupleSections #-}
5 {-# LANGUAGE DuplicateRecordFields #-}
6 {-# OPTIONS_GHC -Wno-orphans #-}
7 module ElmFormat.AST.PublicAST.Expression (Expression(..), Definition(..), DefinitionBuilder, TypedParameter(..), mkDefinitions, fromDefinition) where
8
9 import ElmFormat.AST.PublicAST.Core
10 import ElmFormat.AST.PublicAST.Reference
11 import qualified AST.V0_16 as AST
12 import qualified Data.Indexed as I
13 import qualified Data.Map.Strict as Map
14 import Data.Map.Strict (Map)
15 import qualified ElmFormat.AST.PatternMatching as PatternMatching
16 import qualified Data.Maybe as Maybe
17 import ElmFormat.AST.PublicAST.Pattern
18 import ElmFormat.AST.PublicAST.Type
19 import ElmFormat.AST.PublicAST.Comment
20 import Data.Maybe (mapMaybe, fromMaybe)
21 import Data.Text (Text)
22 import qualified Data.Either as Either
23 import qualified Data.Text as Text
24 import qualified ElmFormat.AST.BinaryOperatorPrecedence as BinaryOperatorPrecedence
25
26
27 data BinaryOperation
28 = BinaryOperation
29 { operator :: Reference
30 , term :: LocatedIfRequested Expression
31 }
32
33 instance ToJSON BinaryOperation where
34 toJSON = undefined
35 toEncoding = \case
36 BinaryOperation operator term ->
37 pairs $ mconcat
38 [ "operator" .= operator
39 , "term" .= term
40 ]
41
42
43 data LetDeclaration
44 = LetDefinition Definition
45 | Comment_ld Comment
46
47 mkLetDeclarations :: Config -> List (ASTNS Located [UppercaseIdentifier] 'LetDeclarationNK) -> List (MaybeF LocatedIfRequested LetDeclaration)
48 mkLetDeclarations config decls =
49 let
50 toDefBuilder :: ASTNS1 Located [UppercaseIdentifier] 'LetDeclarationNK -> DefinitionBuilder LetDeclaration
51 toDefBuilder = \case
52 AST.LetCommonDeclaration (I.Fix (A _ def)) ->
53 Right def
54
55 AST.LetComment comment ->
56 Left $ Comment_ld (mkComment comment)
57 in
58 mkDefinitions config LetDefinition $ fmap (JustF . fmap toDefBuilder . fromLocated config . I.unFix) decls
59
60 fromLetDeclaration :: LetDeclaration -> List (ASTNS Identity [UppercaseIdentifier] 'LetDeclarationNK)
61 fromLetDeclaration = \case
62 LetDefinition def ->
63 I.Fix . Identity . AST.LetCommonDeclaration <$> fromDefinition def
64
65 Comment_ld comment ->
66 pure $ I.Fix $ Identity $ AST.LetComment (fromComment comment)
67
68
69 instance ToJSON LetDeclaration where
70 toJSON = undefined
71 toEncoding = pairs . toPairs
72
73 instance ToPairs LetDeclaration where
74 toPairs = \case
75 LetDefinition def ->
76 toPairs def
77
78 Comment_ld comment ->
79 toPairs comment
80
81 instance FromJSON LetDeclaration where
82 parseJSON = withObject "LetDeclaration" $ \obj -> do
83 tag :: Text <- obj .: "tag"
84 case tag of
85 "Definition" ->
86 LetDefinition <$> parseJSON (Object obj)
87
88 "Comment" ->
89 Comment_ld <$> parseJSON (Object obj)
90
91 _ ->
92 fail ("unexpected LetDeclaration tag: " <> Text.unpack tag)
93
94
95 data CaseBranch
96 = CaseBranch
97 { pattern_cb :: LocatedIfRequested Pattern
98 , body :: MaybeF LocatedIfRequested Expression
99 }
100
101 instance ToPublicAST 'CaseBranchNK where
102 type PublicAST 'CaseBranchNK = CaseBranch
103
104 fromRawAST' config = \case
105 AST.CaseBranch c1 c2 c3 pat body ->
106 CaseBranch
107 (fromRawAST config pat)
108 (JustF $ fromRawAST config body)
109
110 instance FromPublicAST 'CaseBranchNK where
111 toRawAST' = \case
112 CaseBranch pattern body ->
113 AST.CaseBranch [] [] []
114 (toRawAST pattern)
115 (maybeF (I.Fix . Identity . toRawAST') toRawAST body)
116
117 instance ToPairs CaseBranch where
118 toPairs = \case
119 CaseBranch pattern body ->
120 mconcat
121 [ "pattern" .= pattern
122 , "body" .= body
123 ]
124
125 instance ToJSON CaseBranch where
126 toJSON = undefined
127 toEncoding = pairs . toPairs
128
129 instance FromJSON CaseBranch where
130 parseJSON = withObject "CaseBranch" $ \obj -> do
131 CaseBranch
132 <$> obj .: "pattern"
133 <*> obj .: "body"
134
135
136 data Expression
137 = UnitLiteral
138 | LiteralExpression LiteralValue
139 | VariableReferenceExpression Reference
140 | FunctionApplication
141 { function :: MaybeF LocatedIfRequested Expression
142 , arguments :: List (MaybeF LocatedIfRequested Expression)
143 , display_fa :: FunctionApplicationDisplay
144 }
145 | UnaryOperator
146 { operator :: AST.UnaryOperator
147 }
148 | ListLiteral
149 { terms :: List (LocatedIfRequested Expression)
150 }
151 | TupleLiteral
152 { terms :: List (LocatedIfRequested Expression) -- At least two items
153 }
154 | RecordLiteral
155 { base :: Maybe LowercaseIdentifier
156 , fields :: Map LowercaseIdentifier (LocatedIfRequested Expression) -- Cannot be empty if base is present
157 , display_rl :: RecordDisplay
158 }
159 | RecordAccessFunction
160 { field :: LowercaseIdentifier
161 }
162 | AnonymousFunction
163 { parameters :: List (LocatedIfRequested Pattern) -- Non-empty
164 , body :: LocatedIfRequested Expression
165 }
166 | LetExpression
167 { declarations :: List (MaybeF LocatedIfRequested LetDeclaration)
168 , body :: LocatedIfRequested Expression
169 }
170 | CaseExpression
171 { subject :: LocatedIfRequested Expression
172 , branches :: List (LocatedIfRequested CaseBranch)
173 , display :: CaseDisplay
174 }
175 | GLShader
176 { shaderSource :: String
177 }
178
179
180 instance ToPublicAST 'ExpressionNK where
181 type PublicAST 'ExpressionNK = Expression
182
183 fromRawAST' config = \case
184 AST.Unit comments ->
185 UnitLiteral
186
187 AST.Literal lit ->
188 LiteralExpression lit
189
190 AST.VarExpr var ->
191 VariableReferenceExpression $ mkReference var
192
193 AST.App expr args multiline ->
194 FunctionApplication
195 (JustF $ fromRawAST config expr)
196 (fmap (\(C comments a) -> JustF $ fromRawAST config a) args)
197 (FunctionApplicationDisplay ShowAsFunctionApplication)
198
199 AST.Binops first rest multiline ->
200 case
201 BinaryOperatorPrecedence.parseElm0_19
202 first
203 ((\(AST.BinopsClause c1 op c2 expr) -> (op, expr)) <$> rest)
204 of
205 Right tree ->
206 extract $ buildTree tree
207
208 Left message ->
209 error ("invalid binary operator expression: " <> Text.unpack message)
210 where
211 buildTree :: BinaryOperatorPrecedence.Tree (Ref [UppercaseIdentifier ]) (ASTNS Located [UppercaseIdentifier] 'ExpressionNK) -> MaybeF LocatedIfRequested Expression
212 buildTree (BinaryOperatorPrecedence.Leaf e) =
213 JustF $ fromRawAST config e
214 buildTree (BinaryOperatorPrecedence.Branch op e1 e2) =
215 NothingF $ FunctionApplication
216 (NothingF $ VariableReferenceExpression $ mkReference op)
217 (buildTree <$> [ e1, e2 ])
218 (FunctionApplicationDisplay ShowAsInfix)
219
220 AST.Unary op expr ->
221 FunctionApplication
222 (NothingF $ UnaryOperator op)
223 [ JustF $ fromRawAST config expr ]
224 (FunctionApplicationDisplay ShowAsFunctionApplication)
225
226 AST.Parens (C comments expr) ->
227 fromRawAST' config $ extract $ I.unFix expr
228
229 AST.ExplicitList terms comments multiline ->
230 ListLiteral
231 ((\(C comments a) -> fromRawAST config a) <$> AST.toCommentedList terms)
232
233 AST.Tuple terms multiline ->
234 TupleLiteral
235 (fmap (\(C comments a) -> fromRawAST config a) terms)
236
237 AST.TupleFunction n | n <= 1 ->
238 error ("INVALID TUPLE CONSTRUCTOR: " ++ show n)
239
240 AST.TupleFunction n ->
241 VariableReferenceExpression
242 (mkReference $ OpRef $ SymbolIdentifier $ replicate (n-1) ',')
243
244 AST.Record base fields comments multiline ->
245 RecordLiteral
246 (fmap (\(C comments a) -> a) base)
247 (Map.fromList $ (\(C cp (Pair (C ck key) (C cv value) ml)) -> (key, fromRawAST config value)) <$> AST.toCommentedList fields)
248 $ RecordDisplay
249 (extract . _key . extract <$> AST.toCommentedList fields)
250
251 AST.Access base field ->
252 FunctionApplication
253 (NothingF $ RecordAccessFunction field)
254 [ JustF $ fromRawAST config base ]
255 (FunctionApplicationDisplay ShowAsRecordAccess)
256
257 AST.AccessFunction field ->
258 RecordAccessFunction field
259
260 AST.Lambda parameters comments body multiline ->
261 AnonymousFunction
262 (fmap (\(C c a) -> fromRawAST config a) parameters)
263 (fromRawAST config body)
264
265 AST.If (AST.IfClause cond' thenBody') rest' (C c3 elseBody) ->
266 ifThenElse cond' thenBody' rest'
267 where
268 ifThenElse (C c1 cond) (C c2 thenBody) rest =
269 CaseExpression
270 (fromRawAST config cond)
271 [ LocatedIfRequested $ NothingF $ CaseBranch
272 (LocatedIfRequested $ NothingF $ DataPattern (ExternalReference (ModuleName [UppercaseIdentifier "Basics"]) (TagRef () $ UppercaseIdentifier "True")) []) $
273 JustF $ fromRawAST config thenBody
274 , LocatedIfRequested $ NothingF $ CaseBranch
275 (LocatedIfRequested $ NothingF $ DataPattern (ExternalReference (ModuleName [UppercaseIdentifier "Basics"]) (TagRef () $ UppercaseIdentifier "False")) []) $
276 case rest of
277 [] -> JustF $ fromRawAST config elseBody
278 C c4 (AST.IfClause nextCond nextBody) : nextRest ->
279 NothingF $ ifThenElse nextCond nextBody nextRest
280 ]
281 (CaseDisplay True)
282
283 AST.Let decls comments body ->
284 LetExpression
285 (mkLetDeclarations config decls)
286 (fromRawAST config body)
287
288 AST.Case (C comments subject, multiline) branches ->
289 CaseExpression
290 (fromRawAST config subject)
291 (fromRawAST config <$> branches)
292 (CaseDisplay False)
293
294 AST.Range _ _ _ ->
295 error "Range syntax is not supported in Elm 0.19"
296
297 AST.GLShader shader ->
298 GLShader shader
299
300 instance FromPublicAST 'ExpressionNK where
301 toRawAST' = \case
302 UnitLiteral ->
303 AST.Unit []
304
305 LiteralExpression lit ->
306 AST.Literal lit
307
308 VariableReferenceExpression var ->
309 AST.VarExpr $ toRef var
310
311 FunctionApplication function args display ->
312 case (extract function, args) of
313 (UnaryOperator operator, [ single ]) ->
314 AST.Unary
315 operator
316 (maybeF (I.Fix . Identity . toRawAST') toRawAST single)
317
318 (UnaryOperator _, []) ->
319 undefined
320
321 (UnaryOperator _, _) ->
322 error "TODO: UnaryOperator with extra arguments"
323
324 _ ->
325 AST.App
326 (maybeF (I.Fix . Identity . toRawAST') toRawAST function)
327 (C [] . maybeF (I.Fix . Identity . toRawAST') toRawAST <$> args)
328 (AST.FAJoinFirst AST.JoinAll)
329
330 UnaryOperator _ ->
331 error "UnaryOperator is only valid as the \"function\" of a FunctionApplication node"
332
333 ListLiteral terms ->
334 AST.ExplicitList
335 (Either.fromRight undefined $ AST.fromCommentedList $ C ([], [], Nothing) . toRawAST <$> terms)
336 []
337 (AST.ForceMultiline True)
338
339 TupleLiteral terms ->
340 AST.Tuple
341 (C ([], []) . toRawAST <$> terms)
342 True
343
344 RecordLiteral base fields display ->
345 AST.Record
346 (C ([], []) <$> base)
347 (Either.fromRight undefined $ AST.fromCommentedList $ C ([], [], Nothing) . (\(field, expression) -> Pair (C [] field) (C [] $ toRawAST expression) (AST.ForceMultiline False)) <$> Map.toList fields)
348 []
349 (AST.ForceMultiline True)
350
351 RecordAccessFunction field ->
352 AST.AccessFunction field
353
354 AnonymousFunction parameters body ->
355 AST.Lambda
356 (C [] . toRawAST <$> parameters)
357 []
358 (toRawAST body)
359 False
360
361 CaseExpression subject branches display ->
362 AST.Case
363 (C ([], []) $ toRawAST subject, False)
364 (toRawAST <$> branches)
365
366 LetExpression declarations body ->
367 AST.Let
368 (mconcat $ fmap (fromLetDeclaration . extract) declarations)
369 []
370 (toRawAST body)
371
372 GLShader shaderSource ->
373 AST.GLShader shaderSource
374
375
376 instance ToJSON Expression where
377 toJSON = undefined
378 toEncoding = pairs . toPairs
379
380 instance ToPairs Expression where
381 toPairs = \case
382 UnitLiteral ->
383 mconcat
384 [ type_ "UnitLiteral"
385 ]
386
387 LiteralExpression lit ->
388 toPairs lit
389
390 VariableReferenceExpression ref ->
391 toPairs ref
392
393 FunctionApplication function arguments display ->
394 mconcat $ Maybe.catMaybes
395 [ Just $ type_ "FunctionApplication"
396 , Just $ "function" .= function
397 , Just $ "arguments" .= arguments
398 , pair "display" <$> toMaybeEncoding display
399 ]
400
401 UnaryOperator operator ->
402 mconcat
403 [ type_ "UnaryOperator"
404 , "operator" .= operator
405 ]
406
407 ListLiteral terms ->
408 mconcat
409 [ type_ "ListLiteral"
410 , "terms" .= terms
411 ]
412
413 TupleLiteral terms ->
414 mconcat
415 [ type_ "TupleLiteral"
416 , "terms" .= terms
417 ]
418
419 RecordLiteral Nothing fields display ->
420 mconcat
421 [ type_ "RecordLiteral"
422 , "fields" .= fields
423 , "display" .= display
424 ]
425
426 RecordLiteral (Just base) fields display ->
427 mconcat
428 [ type_ "RecordUpdate"
429 , "base" .= base
430 , "fields" .= fields
431 , "display" .= display
432 ]
433
434 RecordAccessFunction field ->
435 mconcat
436 [ type_ "RecordAccessFunction"
437 , "field" .= field
438 ]
439
440 AnonymousFunction parameters body ->
441 mconcat
442 [ type_ "AnonymousFunction"
443 , "parameters" .= parameters
444 , "body" .= body
445 ]
446
447 LetExpression declarations body ->
448 mconcat
449 [ type_ "LetExpression"
450 , "declarations" .= declarations
451 , "body" .= body
452 ]
453
454 CaseExpression subject branches display ->
455 mconcat $ Maybe.catMaybes
456 [ Just $ type_ "CaseExpression"
457 , Just $ "subject" .= subject
458 , Just $ "branches" .= branches
459 , pair "display" <$> toMaybeEncoding display
460 ]
461
462 GLShader shaderSource ->
463 mconcat
464 [ type_ "GLShader"
465 , "shaderSource" .= shaderSource
466 ]
467
468 instance FromJSON Expression where
469 parseJSON = withObject "Expression" $ \obj -> do
470 tag :: Text <- obj .: "tag"
471 case tag of
472 "UnitLiteral" ->
473 return UnitLiteral
474
475 "IntLiteral" ->
476 LiteralExpression <$> parseJSON (Object obj)
477
478 "FloatLiteral" ->
479 LiteralExpression <$> parseJSON (Object obj)
480
481 "StringLiteral" ->
482 LiteralExpression <$> parseJSON (Object obj)
483
484 "CharLiteral" ->
485 LiteralExpression <$> parseJSON (Object obj)
486
487 "VariableReference" ->
488 VariableReferenceExpression <$> parseJSON (Object obj)
489
490 "ExternalReference" ->
491 VariableReferenceExpression <$> parseJSON (Object obj)
492
493 "FunctionApplication" ->
494 FunctionApplication
495 <$> obj .: "function"
496 <*> obj .: "arguments"
497 <*> return (FunctionApplicationDisplay ShowAsFunctionApplication)
498
499 "UnaryOperator" ->
500 UnaryOperator
501 <$> obj .: "operator"
502
503 "ListLiteral" ->
504 ListLiteral
505 <$> obj .: "terms"
506
507 "TupleLiteral" ->
508 TupleLiteral
509 <$> obj .: "terms"
510
511 "RecordLiteral" ->
512 RecordLiteral Nothing
513 <$> obj .: "fields"
514 <*> return (RecordDisplay [])
515
516 "RecordUpdate" ->
517 RecordLiteral
518 <$> (Just <$> obj .: "base")
519 <*> obj .: "fields"
520 <*> return (RecordDisplay [])
521
522 "RecordAccessFunction" ->
523 RecordAccessFunction
524 <$> obj .: "field"
525
526 "AnonymousFunction" ->
527 AnonymousFunction
528 <$> obj .: "parameters"
529 <*> obj .: "body"
530
531 "CaseExpression" ->
532 CaseExpression
533 <$> obj .: "subject"
534 <*> obj .: "branches"
535 <*> return (CaseDisplay False)
536
537 "LetExpression" ->
538 LetExpression
539 <$> obj .: "declarations"
540 <*> obj .: "body"
541
542 "GLShader" ->
543 GLShader
544 <$> obj .: "shaderSource"
545
546 _ ->
547 return $ LiteralExpression $ Str ("TODO: " <> show (Object obj)) SingleQuotedString
548
549
550 newtype FunctionApplicationDisplay
551 = FunctionApplicationDisplay
552 { showAs :: FunctionApplicationShowAs
553 }
554
555 instance ToMaybeJSON FunctionApplicationDisplay where
556 toMaybeEncoding = \case
557 FunctionApplicationDisplay showAs ->
558 case
559 Maybe.catMaybes
560 [ case showAs of
561 ShowAsRecordAccess -> Just ("showAsRecordAccess" .= True)
562 ShowAsInfix -> Just ("showAsInfix" .= True)
563 ShowAsFunctionApplication -> Nothing
564 ]
565 of
566 [] -> Nothing
567 some -> Just $ pairs $ mconcat some
568
569
570 data FunctionApplicationShowAs
571 = ShowAsRecordAccess
572 | ShowAsInfix
573 | ShowAsFunctionApplication
574
575
576 newtype CaseDisplay
577 = CaseDisplay
578 { showAsIf :: Bool
579 }
580 deriving (Generic)
581
582 instance ToMaybeJSON CaseDisplay where
583 toMaybeEncoding = \case
584 CaseDisplay showAsIf ->
585 case
586 Maybe.catMaybes
587 [ if showAsIf
588 then Just ("showAsIf" .= True)
589 else Nothing
590 ]
591 of
592 [] -> Nothing
593 some -> Just $ pairs $ mconcat some
594
595
596 --
597 -- Definition
598 --
599
600
601 data TypedParameter
602 = TypedParameter
603 { pattern_tp :: LocatedIfRequested Pattern
604 , type_tp :: Maybe (LocatedIfRequested Type_)
605 }
606
607 instance ToJSON TypedParameter where
608 toJSON = undefined
609 toEncoding = \case
610 TypedParameter pattern typ ->
611 pairs $ mconcat
612 [ "pattern" .= pattern
613 , "type" .= typ
614 ]
615
616 instance FromJSON TypedParameter where
617 parseJSON = withObject "TypedParameter" $ \obj ->
618 TypedParameter
619 <$> obj .: "pattern"
620 <*> obj .:? "type"
621
622
623 data Definition
624 = Definition
625 { name_d :: LowercaseIdentifier
626 , parameters_d :: List TypedParameter
627 , returnType :: Maybe (LocatedIfRequested Type_)
628 , expression :: LocatedIfRequested Expression
629 }
630 | TODO_Definition (List String)
631
632 mkDefinition ::
633 Config
634 -> ASTNS1 Located [UppercaseIdentifier] 'PatternNK
635 -> List (AST.C1 'AST.BeforeTerm (ASTNS Located [UppercaseIdentifier] 'PatternNK))
636 -> Maybe (AST.C2 'AST.BeforeSeparator 'AST.AfterSeparator (ASTNS Located [UppercaseIdentifier] 'TypeNK))
637 -> ASTNS Located [UppercaseIdentifier] 'ExpressionNK
638 -> Definition
639 mkDefinition config pat args annotation expr =
640 case pat of
641 AST.VarPattern name ->
642 let
643 (typedParams, returnType) =
644 maybe
645 ( fmap (, Nothing) args, Nothing )
646 ((\(a,b) -> ( fmap (fmap Just) a, Just b )) . PatternMatching.matchType args . (\(C (c1, c2) t) -> t))
647 annotation
648 in
649 Definition
650 name
651 (fmap (\(C c pat, typ) -> TypedParameter (fromRawAST config pat) (fmap (fromRawAST config) typ)) typedParams)
652 (fmap (fromRawAST config) returnType)
653 (fromRawAST config expr)
654
655 _ ->
656 TODO_Definition
657 [ show pat
658 , show args
659 , show annotation
660 , show expr
661 ]
662
663 fromDefinition :: Definition -> List (ASTNS Identity [UppercaseIdentifier] 'CommonDeclarationNK)
664 fromDefinition = \case
665 Definition name parameters Nothing expression ->
666 pure $ I.Fix $ Identity $ AST.Definition
667 (I.Fix $ Identity $ AST.VarPattern name)
668 (C [] . toRawAST . pattern_tp <$> parameters)
669 []
670 (toRawAST expression)
671
672 Definition name [] (Just typ) expression ->
673 [ I.Fix $ Identity $ AST.TypeAnnotation
674 (C [] $ VarRef () name)
675 (C [] $ toRawAST typ)
676 , I.Fix $ Identity $ AST.Definition
677 (I.Fix $ Identity $ AST.VarPattern name)
678 []
679 []
680 (toRawAST expression)
681 ]
682
683 Definition name parameters (Just typ) expression ->
684 [ I.Fix $ Identity $ AST.TypeAnnotation
685 (C [] $ VarRef () name)
686 (C [] $ toRawAST $ LocatedIfRequested $ NothingF $ FunctionType typ (fromMaybe (LocatedIfRequested $ NothingF UnitType) . type_tp <$> parameters))
687 , I.Fix $ Identity $ AST.Definition
688 (I.Fix $ Identity $ AST.VarPattern name)
689 (C [] . toRawAST . pattern_tp <$> parameters)
690 []
691 (toRawAST expression)
692 ]
693
694 type DefinitionBuilder a
695 = Either a (ASTNS1 Located [UppercaseIdentifier] 'CommonDeclarationNK)
696
697 mkDefinitions ::
698 forall a.
699 Config
700 -> (Definition -> a)
701 -> List (MaybeF LocatedIfRequested (DefinitionBuilder a))
702 -> List (MaybeF LocatedIfRequested a)
703 mkDefinitions config fromDef items =
704 let
705 collectAnnotation :: DefinitionBuilder a -> Maybe (LowercaseIdentifier, AST.C2 'AST.BeforeSeparator 'AST.AfterSeparator (ASTNS Located [UppercaseIdentifier] 'TypeNK))
706 collectAnnotation decl =
707 case decl of
708 Right (AST.TypeAnnotation (C preColon (VarRef () name)) (C postColon typ)) ->
709 Just (name, C (preColon, postColon) typ)
710 _ -> Nothing
711
712 annotations :: Map LowercaseIdentifier (AST.C2 'AST.BeforeSeparator 'AST.AfterSeparator (ASTNS Located [UppercaseIdentifier] 'TypeNK))
713 annotations =
714 Map.fromList $ mapMaybe (collectAnnotation . extract) items
715
716 merge :: DefinitionBuilder a -> Maybe a
717 merge decl =
718 case decl of
719 Right (AST.Definition (I.Fix (A _ pat)) args comments expr) ->
720 let
721 annotation =
722 case pat of
723 AST.VarPattern name ->
724 Map.lookup name annotations
725 _ -> Nothing
726 in
727 Just $ fromDef $ mkDefinition config pat args annotation expr
728
729 Right (AST.TypeAnnotation _ _) ->
730 -- TODO: retain annotations that don't have a matching definition
731 Nothing
732
733 Left a ->
734 Just a
735 in
736 mapMaybe (traverse merge) items
737
738 instance ToJSON Definition where
739 toJSON = undefined
740 toEncoding = pairs . toPairs
741
742 instance ToPairs Definition where
743 toPairs = \case
744 Definition name parameters returnType expression ->
745 mconcat
746 [ type_ "Definition"
747 , "name" .= name
748 , "parameters" .= parameters
749 , "returnType" .= returnType
750 , "expression" .= expression
751 ]
752
753 TODO_Definition info ->
754 mconcat
755 [ type_ "TODO: Definition"
756 , "$" .= info
757 ]
758
759 instance FromJSON Definition where
760 parseJSON = withObject "Definition" $ \obj -> do
761 tag <- obj .: "tag"
762 case tag of
763 "Definition" ->
764 Definition
765 <$> obj .: "name"
766 <*> obj .:? "parameters" .!= []
767 <*> obj .:? "returnType"
768 <*> obj .: "expression"
769
770 _ ->
771 fail ("unexpected Definition tag: " <> tag)
772