never executed always true always false
1 {-# LANGUAGE DuplicateRecordFields #-}
2 {-# LANGUAGE KindSignatures #-}
3 {-# LANGUAGE DataKinds #-}
4 {-# LANGUAGE Rank2Types #-}
5 {-# LANGUAGE StandaloneDeriving #-}
6 {-# LANGUAGE GADTs #-}
7 {-# LANGUAGE PolyKinds #-}
8 {-# LANGUAGE TypeFamilies #-}
9
10 module AST.V0_16 (module AST.V0_16, module ElmFormat.AST.Shared) where
11
12 import Data.Bifunctor
13 import Data.Coapplicative
14 import Data.Foldable
15 import Data.Functor.Const
16 import Data.Functor.Compose
17 import qualified Data.Indexed as I
18 import qualified Cheapskate.Types as Markdown
19 import ElmFormat.AST.Shared
20 import qualified Data.Maybe as Maybe
21 import Data.Text (Text)
22
23
24 newtype ForceMultiline =
25 ForceMultiline Bool
26 deriving (Eq, Show)
27
28 instance Semigroup ForceMultiline where
29 (ForceMultiline a) <> (ForceMultiline b) = ForceMultiline (a || b)
30
31
32 data Comment
33 = BlockComment (List String)
34 | LineComment String
35 | CommentTrickOpener
36 | CommentTrickCloser
37 | CommentTrickBlock String
38 deriving (Eq, Ord, Show)
39
40 type Comments = List Comment
41
42 eolToComment :: Maybe String -> Comments
43 eolToComment eol =
44 Maybe.maybeToList (fmap LineComment eol)
45
46
47 data CommentType
48 = BeforeTerm
49 | AfterTerm
50 | Inside
51 | BeforeSeparator
52 | AfterSeparator
53
54 type C1 (l1 :: CommentType) = Commented Comments
55 type C2 (l1 :: CommentType) (l2 :: CommentType) = Commented (Comments, Comments)
56 type C3 (l1 :: CommentType) (l2 :: CommentType) (l3 :: CommentType) = Commented (Comments, Comments, Comments)
57
58 type C0Eol = Commented (Maybe String)
59 type C1Eol (l1 :: CommentType) = Commented (Comments, Maybe String)
60 type C2Eol (l1 :: CommentType) (l2 :: CommentType) = Commented (Comments, Comments, Maybe String)
61
62 class AsCommentedList f where
63 type CommentsFor f :: * -> *
64 toCommentedList :: f a -> List (CommentsFor f a)
65 fromCommentedList :: List (CommentsFor f a) -> Either Text (f a)
66
67
68 {-| This represents a list of things separated by comments.
69
70 Currently, the first item will never have leading comments.
71 However, if Elm ever changes to allow optional leading delimiters, then
72 comments before the first delimiter will go there.
73 -}
74 newtype Sequence a =
75 Sequence (List (C2Eol 'BeforeSeparator 'AfterSeparator a))
76 deriving (Eq, Functor, Show)
77
78 instance Foldable Sequence where
79 foldMap f (Sequence items) = foldMap (f . extract) items
80
81 instance Semigroup (Sequence a) where
82 (Sequence left) <> (Sequence right) = Sequence (left <> right)
83
84 instance Monoid (Sequence a) where
85 mempty = Sequence []
86
87 instance AsCommentedList Sequence where
88 type CommentsFor Sequence = C2Eol 'BeforeSeparator 'AfterSeparator
89 toCommentedList (Sequence items) = items
90 fromCommentedList = Right . Sequence
91
92
93 {-| This represents a list of things between clear start and end delimiters.
94 Comments can appear before and after any item, or alone if there are no items.
95
96 For example:
97 ( {- nothing -} )
98 ( a, b )
99
100 TODO: this should be replaced with (Sequence a, Comments)
101 -}
102 data ContainedCommentedList a
103 = Empty (C1 'Inside ())
104 | Items [C2 'BeforeTerm 'AfterTerm a]
105
106
107 {-| This represents a list of things that have no clear start and end
108 delimiters.
109
110 If there is more than one item in the list, then comments can appear.
111 Comments can appear after the first item, before the last item, and
112 around any other item.
113 An end-of-line comment can appear after the last item.
114
115 If there is only one item in the list, an end-of-line comment can appear after the item.
116
117 TODO: this should be replaced with (Sequence a)
118 -}
119 data ExposedCommentedList a
120 = Single (C0Eol a)
121 | Multiple (C1Eol 'AfterTerm a) [C2Eol 'BeforeTerm 'AfterTerm a] (C1Eol 'BeforeTerm a)
122
123
124 {-| This represents a list of things that have a clear start delimiter but no
125 clear end delimiter.
126 There must be at least one item.
127 Comments can appear before the last item, or around any other item.
128 An end-of-line comment can also appear after the last item.
129
130 For example:
131 = a
132 = a, b, c
133
134 TODO: this should be replaced with (Sequence a)
135 -}
136 data OpenCommentedList a
137 = OpenCommentedList [C2Eol 'BeforeTerm 'AfterTerm a] (C1Eol 'BeforeTerm a)
138 deriving (Eq, Show, Functor)
139
140 instance Foldable OpenCommentedList where
141 foldMap f (OpenCommentedList rest last) = foldMap (f . extract) rest <> (f . extract) last
142
143 instance AsCommentedList OpenCommentedList where
144 type CommentsFor OpenCommentedList = C2Eol 'BeforeTerm 'AfterTerm
145 toCommentedList (OpenCommentedList rest (C (cLast, eolLast) last)) =
146 rest ++ [ C (cLast, [], eolLast) last ]
147 fromCommentedList list =
148 case reverse list of
149 C (cLast, cLastInvalid, eolLast) last : revRest ->
150 Right $ OpenCommentedList
151 (reverse revRest)
152 (C (cLast ++ cLastInvalid, eolLast) last)
153
154 [] ->
155 Left "AsCommentedList may not be empty"
156
157
158 exposedToOpen :: Comments -> ExposedCommentedList a -> OpenCommentedList a
159 exposedToOpen pre exposed =
160 case exposed of
161 Single (C eol item) ->
162 OpenCommentedList [] (C (pre, eol) item)
163
164 Multiple (C (postFirst, eol) first') rest' lst ->
165 OpenCommentedList (C (pre, postFirst, eol) first' : rest') lst
166
167
168 {-| Represents a delimiter-separated pair.
169
170 Comments can appear after the key or before the value.
171
172 For example:
173
174 key = value
175 key : value
176 -}
177 data Pair key value =
178 Pair
179 { _key :: C1 'AfterTerm key
180 , _value :: C1 'BeforeTerm value
181 , forceMultiline :: ForceMultiline
182 }
183 deriving (Show, Eq, Functor)
184
185
186 data Multiline
187 = JoinAll
188 | SplitAll
189 deriving (Eq, Show)
190
191
192 isMultiline :: Multiline -> Bool
193 isMultiline JoinAll = False
194 isMultiline SplitAll = True
195
196
197 data FunctionApplicationMultiline
198 = FASplitFirst
199 | FAJoinFirst Multiline
200 deriving (Eq, Show)
201
202
203 data Assoc = L | N | R
204 deriving (Eq, Show)
205
206 assocToString :: Assoc -> String
207 assocToString assoc =
208 case assoc of
209 L -> "left"
210 N -> "non"
211 R -> "right"
212
213
214 data NameWithArgs name arg =
215 NameWithArgs name [C1 'BeforeTerm arg]
216 deriving (Eq, Show, Functor)
217 instance Foldable (NameWithArgs name) where
218 foldMap f (NameWithArgs _ args) = foldMap (f . extract) args
219
220
221 data TypeConstructor ctorRef
222 = NamedConstructor ctorRef
223 | TupleConstructor Int -- will be 2 or greater, indicating the number of elements in the tuple
224 deriving (Eq, Show, Functor)
225
226
227 data BinopsClause varRef expr =
228 BinopsClause Comments varRef Comments expr
229 deriving (Eq, Show, Functor)
230
231 instance Bifunctor BinopsClause where
232 bimap fvr fe = \case
233 BinopsClause c1 vr c2 e -> BinopsClause c1 (fvr vr) c2 (fe e)
234
235
236 data IfClause e =
237 IfClause (C2 'BeforeTerm 'AfterTerm e) (C2 'BeforeTerm 'AfterTerm e)
238 deriving (Eq, Show, Functor)
239
240
241 data TopLevelStructure a
242 = DocComment Markdown.Blocks
243 | BodyComment Comment
244 | Entry a
245 deriving (Eq, Show, Functor)
246
247 instance Foldable TopLevelStructure where
248 foldMap _ (DocComment _) = mempty
249 foldMap _ (BodyComment _) = mempty
250 foldMap f (Entry a) = f a
251
252
253 data LocalName
254 = TypeName UppercaseIdentifier
255 | CtorName UppercaseIdentifier
256 | VarName LowercaseIdentifier
257 deriving (Eq, Ord, Show)
258
259
260 data NodeKind
261 = TopLevelNK
262 | CommonDeclarationNK
263 | TopLevelDeclarationNK
264 | ExpressionNK
265 | LetDeclarationNK
266 | CaseBranchNK
267 | PatternNK
268 | TypeNK
269
270
271 data AST typeRef ctorRef varRef (getType :: NodeKind -> *) (kind :: NodeKind) where
272
273 TopLevel ::
274 [TopLevelStructure (getType 'TopLevelDeclarationNK)]
275 -> AST typeRef ctorRef varRef getType 'TopLevelNK
276
277 --
278 -- Declarations
279 --
280
281 Definition ::
282 getType 'PatternNK
283 -> [C1 'BeforeTerm (getType 'PatternNK)]
284 -> Comments
285 -> getType 'ExpressionNK
286 -> AST typeRef ctorRef varRef getType 'CommonDeclarationNK
287 TypeAnnotation ::
288 C1 'AfterTerm (Ref ())
289 -> C1 'BeforeTerm (getType 'TypeNK)
290 -> AST typeRef ctorRef varRef getType 'CommonDeclarationNK
291 CommonDeclaration ::
292 getType 'CommonDeclarationNK
293 -> AST typeRef ctorRef varRef getType 'TopLevelDeclarationNK
294 Datatype ::
295 { nameWithArgs :: C2 'BeforeTerm 'AfterTerm (NameWithArgs UppercaseIdentifier LowercaseIdentifier)
296 , tags :: OpenCommentedList (NameWithArgs UppercaseIdentifier (getType 'TypeNK))
297 }
298 -> AST typeRef ctorRef varRef getType 'TopLevelDeclarationNK
299 TypeAlias ::
300 Comments
301 -> C2 'BeforeTerm 'AfterTerm (NameWithArgs UppercaseIdentifier LowercaseIdentifier)
302 -> C1 'BeforeTerm (getType 'TypeNK)
303 -> AST typeRef ctorRef varRef getType 'TopLevelDeclarationNK
304 PortAnnotation ::
305 C2 'BeforeTerm 'AfterTerm LowercaseIdentifier
306 -> Comments
307 -> getType 'TypeNK
308 -> AST typeRef ctorRef varRef getType 'TopLevelDeclarationNK
309 PortDefinition_until_0_16 ::
310 C2 'BeforeTerm 'AfterTerm LowercaseIdentifier
311 -> Comments
312 -> getType 'ExpressionNK
313 -> AST typeRef ctorRef varRef getType 'TopLevelDeclarationNK
314 Fixity_until_0_18 ::
315 Assoc
316 -> Comments
317 -> Int
318 -> Comments
319 -> varRef
320 -> AST typeRef ctorRef varRef getType 'TopLevelDeclarationNK
321 Fixity ::
322 C1 'BeforeTerm Assoc
323 -> C1 'BeforeTerm Int
324 -> C2 'BeforeTerm 'AfterTerm SymbolIdentifier
325 -> C1 'BeforeTerm LowercaseIdentifier
326 -> AST typeRef ctorRef varRef getType 'TopLevelDeclarationNK
327
328 --
329 -- Expressions
330 --
331
332 Unit ::
333 Comments
334 -> AST typeRef ctorRef varRef getType 'ExpressionNK
335 Literal ::
336 LiteralValue
337 -> AST typeRef ctorRef varRef getType 'ExpressionNK
338 VarExpr ::
339 varRef
340 -> AST typeRef ctorRef varRef getType 'ExpressionNK
341
342 App ::
343 getType 'ExpressionNK
344 -> [C1 'BeforeTerm (getType 'ExpressionNK)]
345 -> FunctionApplicationMultiline
346 -> AST typeRef ctorRef varRef getType 'ExpressionNK
347 Unary ::
348 UnaryOperator
349 -> getType 'ExpressionNK
350 -> AST typeRef ctorRef varRef getType 'ExpressionNK
351 Binops ::
352 getType 'ExpressionNK
353 -> List (BinopsClause varRef (getType 'ExpressionNK)) -- Non-empty
354 -> Bool
355 -> AST typeRef ctorRef varRef getType 'ExpressionNK
356 Parens ::
357 C2 'BeforeTerm 'AfterTerm (getType 'ExpressionNK)
358 -> AST typeRef ctorRef varRef getType 'ExpressionNK
359
360 ExplicitList ::
361 { terms :: Sequence (getType 'ExpressionNK)
362 , trailingComments_el :: Comments
363 , forceMultiline_el :: ForceMultiline
364 }
365 -> AST typeRef ctorRef varRef getType 'ExpressionNK
366 Range ::
367 C2 'BeforeTerm 'AfterTerm (getType 'ExpressionNK)
368 -> C2 'BeforeTerm 'AfterTerm (getType 'ExpressionNK)
369 -> Bool
370 -> AST typeRef ctorRef varRef getType 'ExpressionNK
371
372 Tuple ::
373 [C2 'BeforeTerm 'AfterTerm (getType 'ExpressionNK)]
374 -> Bool
375 -> AST typeRef ctorRef varRef getType 'ExpressionNK
376 TupleFunction ::
377 Int -- will be 2 or greater, indicating the number of elements in the tuple
378 -> AST typeRef ctorRef varRef getType 'ExpressionNK
379
380 Record ::
381 { base_r :: Maybe (C2 'BeforeTerm 'AfterTerm LowercaseIdentifier)
382 , fields_r :: Sequence (Pair LowercaseIdentifier (getType 'ExpressionNK))
383 , trailingComments_r :: Comments
384 , forceMultiline_r :: ForceMultiline
385 }
386 -> AST typeRef ctorRef varRef getType 'ExpressionNK
387 Access ::
388 getType 'ExpressionNK
389 -> LowercaseIdentifier
390 -> AST typeRef ctorRef varRef getType 'ExpressionNK
391 AccessFunction ::
392 LowercaseIdentifier
393 -> AST typeRef ctorRef varRef getType 'ExpressionNK
394
395 Lambda ::
396 [C1 'BeforeTerm (getType 'PatternNK)]
397 -> Comments
398 -> getType 'ExpressionNK
399 -> Bool
400 -> AST typeRef ctorRef varRef getType 'ExpressionNK
401 If ::
402 IfClause (getType 'ExpressionNK)
403 -> [C1 'BeforeTerm (IfClause (getType 'ExpressionNK))]
404 -> C1 'BeforeTerm (getType 'ExpressionNK)
405 -> AST typeRef ctorRef varRef getType 'ExpressionNK
406 Let ::
407 [getType 'LetDeclarationNK]
408 -> Comments
409 -> getType 'ExpressionNK
410 -> AST typeRef ctorRef varRef getType 'ExpressionNK
411 LetCommonDeclaration ::
412 getType 'CommonDeclarationNK
413 -> AST typeRef ctorRef varRef getType 'LetDeclarationNK
414 LetComment ::
415 Comment
416 -> AST typeRef ctorRef varRef getType 'LetDeclarationNK
417 Case ::
418 (C2 'BeforeTerm 'AfterTerm (getType 'ExpressionNK), Bool)
419 -> [getType 'CaseBranchNK]
420 -> AST typeRef ctorRef varRef getType 'ExpressionNK
421 CaseBranch ::
422 { beforePattern :: Comments
423 , beforeArrow :: Comments
424 , afterArrow :: Comments
425 , pattern :: getType 'PatternNK
426 , body :: getType 'ExpressionNK
427 }
428 -> AST typeRef ctorRef varRef getType 'CaseBranchNK
429
430 -- for type checking and code gen only
431 GLShader ::
432 String
433 -> AST typeRef ctorRef varRef getType 'ExpressionNK
434
435
436 --
437 -- Patterns
438 --
439
440 Anything ::
441 AST typeRef ctorRef varRef getType 'PatternNK
442 UnitPattern ::
443 Comments
444 -> AST typeRef ctorRef varRef getType 'PatternNK
445 LiteralPattern ::
446 LiteralValue
447 -> AST typeRef ctorRef varRef getType 'PatternNK
448 VarPattern ::
449 LowercaseIdentifier
450 -> AST typeRef ctorRef varRef getType 'PatternNK
451 OpPattern ::
452 SymbolIdentifier
453 -> AST typeRef ctorRef varRef getType 'PatternNK
454 DataPattern ::
455 ctorRef
456 -> [C1 'BeforeTerm (getType 'PatternNK)]
457 -> AST typeRef ctorRef varRef getType 'PatternNK
458 PatternParens ::
459 C2 'BeforeTerm 'AfterTerm (getType 'PatternNK)
460 -> AST typeRef ctorRef varRef getType 'PatternNK
461 TuplePattern ::
462 [C2 'BeforeTerm 'AfterTerm (getType 'PatternNK)]
463 -> AST typeRef ctorRef varRef getType 'PatternNK
464 EmptyListPattern ::
465 Comments
466 -> AST typeRef ctorRef varRef getType 'PatternNK
467 ListPattern ::
468 [C2 'BeforeTerm 'AfterTerm (getType 'PatternNK)]
469 -> AST typeRef ctorRef varRef getType 'PatternNK
470 ConsPattern ::
471 { first_cp :: C0Eol (getType 'PatternNK)
472 , rest_cp :: Sequence (getType 'PatternNK)
473 }
474 -> AST typeRef ctorRef varRef getType 'PatternNK
475 EmptyRecordPattern ::
476 Comments
477 -> AST typeRef ctorRef varRef getType 'PatternNK
478 RecordPattern ::
479 [C2 'BeforeTerm 'AfterTerm LowercaseIdentifier]
480 -> AST typeRef ctorRef varRef getType 'PatternNK
481 Alias ::
482 C1 'AfterTerm (getType 'PatternNK)
483 -> C1 'BeforeTerm LowercaseIdentifier
484 -> AST typeRef ctorRef varRef getType 'PatternNK
485
486
487 --
488 -- Types
489 --
490
491 UnitType ::
492 Comments
493 -> AST typeRef ctorRef varRef getType 'TypeNK
494 TypeVariable ::
495 LowercaseIdentifier
496 -> AST typeRef ctorRef varRef getType 'TypeNK
497 TypeConstruction ::
498 TypeConstructor typeRef
499 -> [C1 'BeforeTerm (getType 'TypeNK)]
500 -> ForceMultiline
501 -> AST typeRef ctorRef varRef getType 'TypeNK
502 TypeParens ::
503 C2 'BeforeTerm 'AfterTerm (getType 'TypeNK)
504 -> AST typeRef ctorRef varRef getType 'TypeNK
505 TupleType ::
506 [C2Eol 'BeforeTerm 'AfterTerm (getType 'TypeNK)]
507 -> ForceMultiline
508 -> AST typeRef ctorRef varRef getType 'TypeNK
509 RecordType ::
510 { base_rt :: Maybe (C2 'BeforeTerm 'AfterTerm LowercaseIdentifier)
511 , fields_rt :: Sequence (Pair LowercaseIdentifier (getType 'TypeNK))
512 , trailingComments_rt :: Comments
513 , forceMultiline_rt :: ForceMultiline
514 }
515 -> AST typeRef ctorRef varRef getType 'TypeNK
516 FunctionType ::
517 { first_ft :: C0Eol (getType 'TypeNK)
518 , rest_ft :: Sequence (getType 'TypeNK)
519 , forceMultiline_ft :: ForceMultiline
520 }
521 -> AST typeRef ctorRef varRef getType 'TypeNK
522
523 deriving instance
524 ( Eq typeRef, Eq ctorRef, Eq varRef
525 , Eq (getType 'CommonDeclarationNK)
526 , Eq (getType 'TopLevelDeclarationNK)
527 , Eq (getType 'ExpressionNK)
528 , Eq (getType 'LetDeclarationNK)
529 , Eq (getType 'CaseBranchNK)
530 , Eq (getType 'PatternNK)
531 , Eq (getType 'TypeNK)
532 ) =>
533 Eq (AST typeRef ctorRef varRef getType kind)
534 deriving instance
535 ( Show typeRef, Show ctorRef, Show varRef
536 , Show (getType 'CommonDeclarationNK)
537 , Show (getType 'TopLevelDeclarationNK)
538 , Show (getType 'ExpressionNK)
539 , Show (getType 'LetDeclarationNK)
540 , Show (getType 'CaseBranchNK)
541 , Show (getType 'PatternNK)
542 , Show (getType 'TypeNK)
543 ) =>
544 Show (AST typeRef ctorRef varRef getType kind)
545
546
547 mapAll ::
548 (typeRef1 -> typeRef2) -> (ctorRef1 -> ctorRef2) -> (varRef1 -> varRef2)
549 -> (forall kind. getType1 kind -> getType2 kind)
550 -> (forall kind.
551 AST typeRef1 ctorRef1 varRef1 getType1 kind
552 -> AST typeRef2 ctorRef2 varRef2 getType2 kind
553 )
554 mapAll ftyp fctor fvar fast = \case
555 TopLevel tls -> TopLevel (fmap (fmap fast) tls)
556
557 -- Declaration
558 Definition name args c e -> Definition (fast name) (fmap (fmap fast) args) c (fast e)
559 TypeAnnotation name t -> TypeAnnotation name (fmap fast t)
560 CommonDeclaration d -> CommonDeclaration (fast d)
561 Datatype nameWithArgs ctors -> Datatype nameWithArgs (fmap (fmap fast) ctors)
562 TypeAlias c nameWithArgs t -> TypeAlias c nameWithArgs (fmap fast t)
563 PortAnnotation name c t -> PortAnnotation name c (fast t)
564 PortDefinition_until_0_16 name c e -> PortDefinition_until_0_16 name c (fast e)
565 Fixity_until_0_18 a c n c' name -> Fixity_until_0_18 a c n c' (fvar name)
566 Fixity a n op name -> Fixity a n op name
567
568 -- Expressions
569 Unit c -> Unit c
570 Literal l -> Literal l
571 VarExpr var -> VarExpr (fvar var)
572 App first rest ml -> App (fast first) (fmap (fmap fast) rest) ml
573 Unary op e -> Unary op (fast e)
574 Binops first ops ml -> Binops (fast first) (fmap (bimap fvar fast) ops) ml
575 Parens e -> Parens (fmap fast e)
576 ExplicitList terms c ml -> ExplicitList (fmap fast terms) c ml
577 Range left right ml -> Range (fmap fast left) (fmap fast right) ml
578 Tuple terms ml -> Tuple (fmap (fmap fast) terms) ml
579 TupleFunction n -> TupleFunction n
580 Record base fields c ml -> Record base (fmap (fmap fast) fields) c ml
581 Access e field -> Access (fast e) field
582 AccessFunction field -> AccessFunction field
583 Lambda args c e ml -> Lambda (fmap (fmap fast) args) c (fast e) ml
584 If cond elsifs els -> If (fmap fast cond) (fmap (fmap $ fmap fast) elsifs) (fmap fast els)
585 Let decls c e -> Let (fmap fast decls) c (fast e)
586 LetCommonDeclaration d -> LetCommonDeclaration (fast d)
587 LetComment c -> LetComment c
588 Case (cond, ml) branches -> Case (fmap fast cond, ml) (fmap fast branches)
589 CaseBranch c1 c2 c3 p e -> CaseBranch c1 c2 c3 (fast p) (fast e)
590 GLShader s -> GLShader s
591
592 -- Patterns
593 Anything -> Anything
594 UnitPattern c -> UnitPattern c
595 LiteralPattern l -> LiteralPattern l
596 VarPattern l -> VarPattern l
597 OpPattern s -> OpPattern s
598 DataPattern ctor pats -> DataPattern (fctor ctor) (fmap (fmap fast) pats)
599 PatternParens pat -> PatternParens (fmap fast pat)
600 TuplePattern pats -> TuplePattern (fmap (fmap fast) pats)
601 EmptyListPattern c -> EmptyListPattern c
602 ListPattern pats -> ListPattern (fmap (fmap fast) pats)
603 ConsPattern first rest -> ConsPattern (fmap fast first) (fmap fast rest)
604 EmptyRecordPattern c -> EmptyRecordPattern c
605 RecordPattern fields -> RecordPattern fields
606 Alias pat name -> Alias (fmap fast pat) name
607
608 -- Types
609 UnitType c -> UnitType c
610 TypeVariable name -> TypeVariable name
611 TypeConstruction name args forceMultiline -> TypeConstruction (fmap ftyp name) (fmap (fmap fast) args) forceMultiline
612 TypeParens typ -> TypeParens (fmap fast typ)
613 TupleType typs forceMultiline -> TupleType (fmap (fmap fast) typs) forceMultiline
614 RecordType base fields c ml -> RecordType base (fmap (fmap fast) fields) c ml
615 FunctionType first rest ml -> FunctionType (fmap fast first) (fmap fast rest) ml
616
617
618 instance I.IFunctor (AST typeRef ctorRef varRef) where
619 -- TODO: it's probably worth making an optimized version of this
620 imap fast = mapAll id id id fast
621
622
623
624 --
625 -- Recursion schemes
626 --
627
628
629 topDownReferencesWithContext ::
630 forall
631 context ns
632 typeRef2 ctorRef2 varRef2
633 ann kind.
634 Functor ann =>
635 Coapplicative ann =>
636 (LocalName -> context -> context) -- TODO: since the caller typically passes a function that builds a Map or Set, this could be optimized by taking `List (LocalName)` instead of one at a time
637 -> (context -> (ns, UppercaseIdentifier) -> typeRef2)
638 -> (context -> (ns, UppercaseIdentifier) -> ctorRef2)
639 -> (context -> (Ref ns) -> varRef2)
640 -> context
641 -> I.Fix ann (AST (ns, UppercaseIdentifier) (ns, UppercaseIdentifier) (Ref ns)) kind
642 -> I.Fix ann (AST typeRef2 ctorRef2 varRef2) kind
643 topDownReferencesWithContext defineLocal fType fCtor fVar initialContext initialAst =
644 let
645 namesFromPattern' ::
646 forall a b c kind'. -- We actually only care about PatternNK' here
647 AST a b c (Const [LocalName]) kind'
648 -> Const [LocalName] kind'
649 namesFromPattern' = \case
650 Anything -> mempty
651 UnitPattern _ -> mempty
652 LiteralPattern _ -> mempty
653 VarPattern l -> Const $ pure $ VarName l
654 OpPattern _ -> mempty
655 DataPattern _ args -> foldMap extract args
656 PatternParens p -> extract p
657 TuplePattern ps -> foldMap extract ps
658 EmptyListPattern _ -> mempty
659 ListPattern ps -> foldMap extract ps
660 ConsPattern p ps -> extract p <> fold ps
661 EmptyRecordPattern _ -> mempty
662 RecordPattern ps -> Const $ fmap (VarName . extract) ps
663 Alias p name -> extract p <> Const (pure $ VarName $ extract name)
664
665 namesFromPattern ::
666 Coapplicative ann' =>
667 I.Fix ann' (AST a b c) kind'
668 -> [LocalName]
669 namesFromPattern =
670 getConst . I.cata (namesFromPattern' . extract)
671
672 namesFrom ::
673 Coapplicative ann' =>
674 I.Fix ann' (AST a b c) kind'
675 -> [LocalName]
676 namesFrom decl =
677 case extract $ I.unFix decl of
678 Definition p _ _ _ -> namesFromPattern p
679 TypeAnnotation _ _ -> mempty
680
681 CommonDeclaration d -> namesFrom d
682 Datatype (C _ (NameWithArgs name _)) tags ->
683 TypeName name
684 : fmap (\(NameWithArgs name _) -> CtorName name) (toList tags)
685 TypeAlias _ (C _ (NameWithArgs name _)) _ -> [TypeName name]
686 PortAnnotation (C _ name) _ _ -> [VarName name]
687 PortDefinition_until_0_16 (C _ name) _ _ -> [VarName name]
688 Fixity_until_0_18 _ _ _ _ _ -> []
689 Fixity _ _ _ _ -> []
690
691 LetCommonDeclaration d -> namesFrom d
692 LetComment _ -> mempty
693
694 newDefinitionsAtNode ::
695 forall kind'.
696 AST (ns, UppercaseIdentifier) (ns, UppercaseIdentifier) (Ref ns)
697 (I.Fix ann (AST (ns, UppercaseIdentifier) (ns, UppercaseIdentifier) (Ref ns)))
698 kind'
699 -> [LocalName]
700 newDefinitionsAtNode node =
701 case node of
702 TopLevel decls ->
703 foldMap (foldMap namesFrom) decls
704
705 CommonDeclaration d ->
706 newDefinitionsAtNode (extract $ I.unFix d)
707
708 Definition first rest _ _ ->
709 foldMap namesFromPattern (first : fmap extract rest)
710
711 Lambda args _ _ _ ->
712 foldMap (namesFromPattern . extract) args
713
714 Let decls _ _ ->
715 foldMap namesFrom decls
716
717 LetCommonDeclaration d ->
718 newDefinitionsAtNode (extract $ I.unFix d)
719
720 CaseBranch _ _ _ p _ ->
721 namesFromPattern p
722
723 -- TODO: actually implement this for all node types
724 _ -> []
725
726 step ::
727 forall kind'.
728 context
729 -> AST (ns, UppercaseIdentifier) (ns, UppercaseIdentifier) (Ref ns)
730 (I.Fix ann (AST (ns, UppercaseIdentifier) (ns, UppercaseIdentifier) (Ref ns)))
731 kind'
732 -> AST typeRef2 ctorRef2 varRef2
733 (Compose
734 ((,) context)
735 (I.Fix ann (AST (ns, UppercaseIdentifier) (ns, UppercaseIdentifier) (Ref ns)))
736 )
737 kind'
738 step context node =
739 let
740 context' = foldl (flip defineLocal) context (newDefinitionsAtNode node)
741 in
742 mapAll (fType context') (fCtor context') (fVar context') id
743 $ I.imap (Compose . (,) context') node
744 in
745 I.ana
746 (\(Compose (context, ast)) -> step context <$> I.unFix ast)
747 (Compose (initialContext, initialAst))