never executed always true always false
1 {-# LANGUAGE DeriveDataTypeable #-}
2 module Conjure.Language.AST.Syntax where
3 import Data.Data
4 import Conjure.Language.Lexer (ETok(..), prettySplitComments)
5 import Conjure.Prelude hiding (Doc, group,Data,Typeable)
6
7 import Prettyprinter
8
9 import Prettyprinter.Render.Text (renderStrict)
10
11
12 data LToken
13 = RealToken SToken
14 | MissingToken ETok
15 | SkippedToken ETok
16 deriving (Eq, Ord, Show, Data)
17
18 data SToken
19 = StrictToken [ETok] ETok
20 deriving (Eq , Ord, Show, Data)
21 instance Null SToken where
22 isMissing = const False
23 instance Pretty SToken where
24 pretty (StrictToken _ r) = pretty r
25 makeStrict :: ETok -> LToken
26 makeStrict = RealToken . StrictToken []
27 instance Pretty LToken where
28 pretty (SkippedToken e) = pretty e
29 pretty (RealToken r) = pretty r
30 pretty _ = emptyDoc
31
32 instance Null LToken where
33 isMissing (MissingToken _) = True
34 isMissing _ = False
35
36
37 data ProgramTree = ProgramTree
38 { langVersionInfo :: Maybe LangVersionNode
39 , statements :: [StatementNode]
40 , eofToken :: SToken
41 }
42 deriving (Show, Data ,Typeable)
43
44 instance Pretty ProgramTree where
45 pretty (ProgramTree l s e) =
46 vcat
47 [ maybe "language Essence 1.3" pretty l <> line
48 , vcat $ map pretty s
49 , pretty e
50 ]
51
52 data LangVersionNode = LangVersionNode SToken NameNode (Sequence SToken)
53 deriving (Show, Data)
54 instance Pretty LangVersionNode where
55 pretty (LangVersionNode t n ns) = pretty t <+> pretty n <+> pretty ns
56
57 data StatementNode
58 = DeclarationStatement DeclarationStatementNode
59 | BranchingStatement BranchingStatementNode
60 | SuchThatStatement SuchThatStatementNode
61 | WhereStatement WhereStatementNode
62 | ObjectiveStatement ObjectiveStatementNode
63 | HeuristicStatement SToken ExpressionNode
64 | UnexpectedToken LToken
65 deriving (Show, Data , Typeable)
66 instance Pretty StatementNode where
67 pretty x = case x of
68 DeclarationStatement dsn -> pretty dsn
69 BranchingStatement bsn -> pretty bsn
70 SuchThatStatement stsn -> pretty stsn
71 WhereStatement wsn -> pretty wsn
72 ObjectiveStatement osn -> pretty osn
73 HeuristicStatement lt en -> pretty lt <+> pretty en
74 UnexpectedToken _ -> emptyDoc
75
76 data SuchThatStatementNode
77 = SuchThatStatementNode
78 SToken -- Such
79 LToken -- That
80 (Sequence ExpressionNode) -- constraints
81 deriving (Show, Data)
82
83 instance Pretty SuchThatStatementNode where
84 pretty (SuchThatStatementNode l1 l2 es) = topLevelPretty [RealToken l1, l2] (pretty es)
85
86 data WhereStatementNode
87 = WhereStatementNode
88 SToken -- where
89 (Sequence ExpressionNode) -- expresssions
90 deriving (Show, Data)
91
92 instance Pretty WhereStatementNode where
93 pretty (WhereStatementNode w se) = topLevelPretty [RealToken w] (pretty se)
94
95 data ObjectiveStatementNode
96 = ObjectiveMin SToken ExpressionNode
97 | ObjectiveMax SToken ExpressionNode
98 deriving (Show, Data)
99 instance Pretty ObjectiveStatementNode where
100 pretty x = case x of
101 ObjectiveMin lt en -> pretty lt <+> pretty en
102 ObjectiveMax lt en -> pretty lt <+> pretty en
103
104 -- Declaration statements
105 data DeclarationStatementNode
106 = FindStatement SToken (Sequence FindStatementNode)
107 | GivenStatement SToken (Sequence GivenStatementNode)
108 | LettingStatement SToken (Sequence LettingStatementNode)
109 deriving (Show, Data, Typeable)
110
111 instance Pretty DeclarationStatementNode where
112 pretty x = case x of
113 FindStatement lt se -> topLevelPretty [RealToken lt] (pretty se)
114 GivenStatement lt se -> topLevelPretty [RealToken lt] (pretty se)
115 LettingStatement lt se -> topLevelPretty [RealToken lt] (pretty se)
116 data FindStatementNode
117 = FindStatementNode
118 (Sequence NameNode) -- names
119 LToken -- colon
120 DomainNode -- domain
121 deriving (Show, Data)
122 instance Pretty FindStatementNode where
123 pretty (FindStatementNode names col dom) = pretty names <+> pretty col <+> pretty dom
124 instance Null FindStatementNode where
125 isMissing (FindStatementNode n l d) = isMissing n && isMissing l && isMissing d
126 data GivenStatementNode
127 = GivenStatementNode
128 (Sequence NameNode) -- name
129 LToken -- colon
130 DomainNode -- domain
131 | GivenEnumNode
132 (Sequence NameNode)
133 LToken -- new
134 LToken -- type
135 LToken -- enum
136 deriving (Show, Data)
137 instance Pretty GivenStatementNode where
138 pretty g = case g of
139 GivenStatementNode se lt dn -> pretty se <+> pretty lt <+> pretty dn
140 GivenEnumNode se lt lt' lt2 -> pretty se <+> pretty lt <+> pretty lt' <+> pretty lt2
141
142 instance Null GivenStatementNode where
143 isMissing (GivenStatementNode l t d) = isMissing l && isMissing t && isMissing d
144 isMissing (GivenEnumNode l a b c) = isMissing l && isMissing a && isMissing b && isMissing c
145
146 data LettingStatementNode
147 = LettingStatementNode
148 (Sequence NameNode)
149 LToken --
150 LettingAssignmentNode
151 deriving (Show, Data)
152 instance Pretty LettingStatementNode where
153 pretty (LettingStatementNode ns be assign) = pretty ns <+> pretty be <+> pretty assign
154
155 instance Null LettingStatementNode where
156 isMissing (LettingStatementNode l t a) = isMissing l && isMissing t && isMissing a
157 data LettingAssignmentNode
158 = LettingExpr
159 ExpressionNode
160 | LettingDomain
161 SToken -- domain
162 DomainNode
163 | LettingEnum
164 LToken -- lNew
165 LToken -- lType
166 LToken -- lEnum
167 (ListNode NameNode) -- nameList
168 | LettingUnnamed
169 LToken -- lNew
170 LToken -- lType
171 LToken -- lOf
172 LToken -- lSize
173 ExpressionNode -- expr
174 deriving (Show, Data)
175
176 instance Pretty LettingAssignmentNode where
177 pretty a = case a of
178 LettingExpr en -> pretty en
179 LettingDomain lt dn -> pretty lt <+> pretty dn
180 LettingEnum lt lt' lt2 ln -> pretty lt <+> pretty lt' <+> pretty lt2 <+> pretty ln
181 LettingUnnamed lt lt' lt2 lt3 en -> pretty lt <+> pretty lt' <+> pretty lt2 <+> pretty lt3 <+> pretty en
182 instance Null LettingAssignmentNode where
183 isMissing x = case x of
184 LettingExpr en -> isMissing en
185 LettingDomain lt dn -> isMissing lt && isMissing dn
186 LettingEnum l1 l2 l3 ln -> all isMissing [l1, l2, l3] && isMissing ln
187 LettingUnnamed l1 l2 l3 l4 en -> all isMissing [l1, l2, l3, l4] && isMissing en
188
189 -- Branching on
190
191 data BranchingStatementNode
192 = BranchingStatementNode
193 SToken
194 LToken
195 (ListNode ExpressionNode)
196 deriving (Show, Data)
197
198 instance Pretty BranchingStatementNode where
199 pretty (BranchingStatementNode br o exs) = pretty br <+> pretty o <+> pretty exs
200
201 -- Domains
202
203 type MAttributes = Maybe (ListNode AttributeNode)
204
205 data DomainNode
206 = ParenDomainNode SToken DomainNode LToken
207 | BoolDomainNode SToken
208 | RangedIntDomainNode SToken (Maybe (LToken, ETok)) (Maybe (ListNode RangeNode))
209 | RangedEnumNode NameNodeS (Maybe (ListNode RangeNode))
210 | MetaVarDomain SToken
211 | ShortTupleDomainNode (ListNode DomainNode)
212 | TupleDomainNode SToken (ListNode DomainNode)
213 | RecordDomainNode SToken (ListNode NamedDomainNode)
214 | VariantDomainNode SToken (ListNode NamedDomainNode)
215 | MatrixDomainNode SToken (Maybe IndexedByNode) (ListNode DomainNode) LToken DomainNode
216 | SetDomainNode SToken MAttributes LToken DomainNode
217 | MSetDomainNode SToken MAttributes LToken DomainNode
218 | FunctionDomainNode SToken MAttributes DomainNode LToken DomainNode
219 | SequenceDomainNode SToken MAttributes LToken DomainNode
220 | PermutationDomainNode SToken MAttributes LToken DomainNode
221 | RelationDomainNode SToken MAttributes LToken (ListNode DomainNode)
222 | PartitionDomainNode SToken MAttributes LToken DomainNode
223 | MissingDomainNode LToken
224 deriving (Show, Data)
225
226 instance Pretty DomainNode where
227 pretty x = case x of
228 ParenDomainNode op dom cl -> pretty op <> pretty dom <> pretty cl
229 BoolDomainNode lt -> pretty lt
230 RangedIntDomainNode lt Nothing m_ln -> pretty lt <> pretty m_ln
231 RangedIntDomainNode lt (Just (_, tag)) m_ln -> pretty lt <> ":" <> pretty tag <> pretty m_ln
232 RangedEnumNode nn m_ln -> pretty nn <> pretty m_ln
233 MetaVarDomain lt -> pretty lt
234 ShortTupleDomainNode ln -> pretty ln
235 TupleDomainNode lt ln -> pretty lt <> pretty ln
236 RecordDomainNode lt ln -> pretty lt <> pretty ln
237 VariantDomainNode lt ln -> pretty lt <> pretty ln
238 MatrixDomainNode lt m_ibn ln lt' dn ->
239 pretty lt
240 <+> pretty m_ibn
241 <+> pretty ln
242 <+> pretty lt'
243 <+> pretty dn
244 SetDomainNode lt m_ln lt' dn -> pretty lt <+> pretty m_ln <+> pretty lt' <+> pretty dn
245 MSetDomainNode lt m_ln lt' dn -> pretty lt <+> pretty m_ln <+> pretty lt' <+> pretty dn
246 FunctionDomainNode lt m_ln dn lt' dn' -> pretty lt <+> pretty m_ln <+> pretty dn <+> pretty lt' <+> pretty dn'
247 SequenceDomainNode lt m_ln lt' dn -> pretty lt <+> pretty m_ln <+> pretty lt' <+> pretty dn
248 PermutationDomainNode lt m_ln lt' dn -> pretty lt <+> pretty m_ln <+> pretty lt' <+> pretty dn
249 RelationDomainNode lt m_ln lt' ln -> pretty lt <+> pretty m_ln <+> pretty lt' <+> pretty ln
250 PartitionDomainNode lt m_ln lt' dn -> pretty lt <+> pretty m_ln <+> pretty lt' <+> pretty dn
251 MissingDomainNode _ -> emptyDoc
252 instance Null DomainNode where
253 isMissing (MissingDomainNode{}) = True
254 isMissing _ = False
255
256 data IndexedByNode = IndexedByNode LToken LToken
257 deriving (Show, Data)
258 instance Pretty IndexedByNode where
259 pretty (IndexedByNode a b) = pretty a <+> pretty b
260 data RangeNode
261 = SingleRangeNode ExpressionNode
262 | OpenRangeNode DoubleDotNode
263 | RightUnboundedRangeNode ExpressionNode DoubleDotNode
264 | LeftUnboundedRangeNode DoubleDotNode ExpressionNode
265 | BoundedRangeNode ExpressionNode DoubleDotNode ExpressionNode
266 deriving (Show, Data)
267
268 instance Pretty RangeNode where
269 pretty x = case x of
270 SingleRangeNode en -> pretty en
271 OpenRangeNode lt -> pretty lt
272 RightUnboundedRangeNode en lt -> pretty en <> pretty lt
273 LeftUnboundedRangeNode lt en -> pretty lt <> pretty en
274 BoundedRangeNode en lt en' -> pretty en <> pretty lt <> pretty en'
275 instance Null RangeNode where
276 isMissing (SingleRangeNode e) = isMissing e
277 isMissing _ = False
278
279 type DoubleDotNode = SToken
280
281 -- data DoubleDotNode = DoubleDotNode LToken LToken deriving (Show, Data)
282
283 data AttributeNode
284 = NamedAttributeNode SToken (Maybe ExpressionNode)
285 deriving (Show, Data)
286 instance Pretty AttributeNode where
287 pretty (NamedAttributeNode a m_e) = pretty a <+> pretty m_e
288
289 instance Null AttributeNode where
290 isMissing _ = False
291
292
293 data NamedDomainNode = NameDomainNode NameNode (Maybe (LToken, DomainNode))
294 deriving (Show, Data)
295 instance Pretty NamedDomainNode where
296 pretty (NameDomainNode nn Nothing) = pretty nn
297 pretty (NameDomainNode nn (Just (e, d))) = pretty nn <> pretty e <> pretty d
298
299 instance Null NamedDomainNode where
300 isMissing (NameDomainNode (a) Nothing) = isMissing a
301 isMissing (NameDomainNode (a) (Just (b, c))) = isMissing a && isMissing b && isMissing c
302
303 -- Common Statements
304 data NameNodeS = NameNodeS SToken
305 deriving (Show, Data)
306 instance Pretty NameNodeS where
307 pretty (NameNodeS n) = pretty n
308
309 instance Null NameNodeS where
310 isMissing = const False
311 data NameNode = NameNode NameNodeS | MissingNameNode LToken
312 deriving (Show, Data)
313
314
315 instance Pretty NameNode where
316 pretty (NameNode n) = pretty n
317 pretty _ = emptyDoc
318
319 instance Null NameNode where
320 isMissing (NameNode _) = False
321 isMissing (MissingNameNode _) = True
322
323 -- Expressions
324 data ExpressionNode
325 = Literal LiteralNode
326 | IdentifierNode NameNodeS
327 | MetaVarExpr SToken
328 | QuantificationExpr QuantificationExpressionNode
329 | OperatorExpressionNode OperatorExpressionNode
330 | DomainExpression DomainExpressionNode
331 | ParenExpression ParenExpressionNode
332 | AbsExpression ParenExpressionNode
333 | FunctionalApplicationNode SToken (ListNode ExpressionNode)
334 | AttributeAsConstriant SToken (ListNode ExpressionNode)
335 | MissingExpressionNode LToken
336 | SpecialCase SpecialCaseNode
337 deriving (Show, Data)
338
339 instance Pretty ExpressionNode where
340 pretty x = case x of
341 Literal ln -> pretty ln
342 IdentifierNode nn -> pretty nn
343 MetaVarExpr lt -> pretty lt
344 QuantificationExpr qen -> pretty qen
345 OperatorExpressionNode oen -> pretty oen
346 DomainExpression den -> pretty den
347 ParenExpression (ParenExpressionNode l e r) -> pretty l <> pretty e <> pretty r
348 AbsExpression (ParenExpressionNode l e r) -> pretty l <> pretty e <> pretty r
349 FunctionalApplicationNode lt ln -> pretty lt <> pretty ln
350 AttributeAsConstriant lt ln -> pretty lt <> pretty ln
351 MissingExpressionNode _ -> emptyDoc
352 SpecialCase scn -> pretty scn
353 instance Null ExpressionNode where
354 isMissing (MissingExpressionNode _) = True
355 isMissing _ = False
356
357 data SpecialCaseNode = ExprWithDecls SToken ExpressionNode SToken [StatementNode] SToken
358 deriving (Show, Data)
359 instance Pretty SpecialCaseNode where
360 pretty x = case x of
361 ExprWithDecls lt en lt' sns lt2 -> group $ cat [pretty lt, pretty en, pretty lt', pretty sns, pretty lt2]
362
363 data DomainExpressionNode
364 = DomainExpressionNode LToken DomainNode LToken
365 deriving (Show, Data)
366 instance Pretty DomainExpressionNode where
367 pretty (DomainExpressionNode l d r) = pretty l <> pretty d <> pretty r
368 data ParenExpressionNode = ParenExpressionNode LToken ExpressionNode LToken
369 deriving (Show, Data)
370
371 newtype ShortTuple = ShortTuple (ListNode ExpressionNode) deriving (Show, Data)
372 instance Pretty ShortTuple where
373 pretty (ShortTuple exps) = pretty exps
374 instance Null ShortTuple where
375 isMissing (ShortTuple ls) = isMissing ls
376
377 data LongTuple = LongTuple SToken (ListNode ExpressionNode) deriving (Show, Data)
378 instance Pretty LongTuple where
379 pretty (LongTuple t exps) = pretty t <> pretty exps
380
381 instance Null LongTuple where
382 isMissing (LongTuple s ls) = isMissing s && isMissing ls
383
384 -- Literals
385 data LiteralNode
386 = IntLiteral SToken (Maybe (LToken, ETok)) -- the IntTag
387 | BoolLiteral SToken
388 | MatrixLiteral MatrixLiteralNode
389 | TupleLiteralNode LongTuple
390 | TupleLiteralNodeShort ShortTuple
391 | RecordLiteral SToken (ListNode RecordMemberNode)
392 | VariantLiteral SToken (ListNode RecordMemberNode) -- catch later
393 | SetLiteral (ListNode ExpressionNode)
394 | MSetLiteral SToken (ListNode ExpressionNode)
395 | FunctionLiteral SToken (ListNode ArrowPairNode)
396 | SequenceLiteral SToken (ListNode ExpressionNode)
397 | PermutationLiteral SToken (ListNode PermutationElemNode)
398 | RelationLiteral SToken (ListNode RelationElemNode)
399 | PartitionLiteral SToken (ListNode PartitionElemNode)
400 deriving (Show, Data)
401
402 instance Pretty LiteralNode where
403 pretty l = case l of
404 IntLiteral lt Nothing -> pretty lt
405 IntLiteral lt (Just (_, tag)) -> pretty lt <> ":" <> pretty tag
406 BoolLiteral lt -> pretty lt
407 MatrixLiteral mln -> pretty mln
408 TupleLiteralNode lt -> pretty lt
409 TupleLiteralNodeShort st -> pretty st
410 RecordLiteral lt ln -> pretty lt <> pretty ln
411 VariantLiteral lt ln -> pretty lt <> pretty ln
412 SetLiteral ln -> pretty ln
413 MSetLiteral lt ln -> pretty lt <> pretty ln
414 FunctionLiteral lt ln -> pretty lt <> pretty ln
415 SequenceLiteral lt ln -> pretty lt <> pretty ln
416 PermutationLiteral lt ln -> pretty lt <> pretty ln
417 RelationLiteral lt ln -> pretty lt <> pretty ln
418 PartitionLiteral lt ln -> pretty lt <> pretty ln
419
420 data MatrixLiteralNode
421 = MatrixLiteralNode
422 LToken -- openBracket
423 (Sequence ExpressionNode)
424 (Maybe OverDomainNode) -- explicitDomain
425 (Maybe ComprehensionNode) -- compBody
426 LToken -- close
427 deriving (Show, Data)
428
429 instance Pretty MatrixLiteralNode where
430 pretty (MatrixLiteralNode bl es d c br) =
431 group $
432 align (cat (pretty bl : prettyElems es ++ catMaybes ((pretty <$> d) : comps) ++ [pretty br]))
433 where
434 comps = case c of
435 Nothing -> []
436 Just (ComprehensionNode l seq) -> pure <$> pretty l : prettyElems seq
437
438 data ComprehensionNode
439 = ComprehensionNode
440 SToken
441 (Sequence ComprehensionBodyNode)
442 deriving (Show, Data)
443
444 instance Pretty ComprehensionNode where
445 pretty (ComprehensionNode bar es) = align $ pretty bar <+> pretty es
446
447 data RecordMemberNode = RecordMemberNode NameNode LToken ExpressionNode
448 deriving (Show, Data)
449 instance Pretty RecordMemberNode where
450 pretty (RecordMemberNode n t e) = pretty n <> pretty t <> pretty e
451
452 instance Null RecordMemberNode where
453 isMissing (RecordMemberNode n t e) = isMissing n && isMissing t && isMissing e
454
455 data ArrowPairNode = ArrowPairNode ExpressionNode LToken ExpressionNode
456 deriving (Show, Data)
457 instance Pretty ArrowPairNode where
458 pretty (ArrowPairNode l a r) = pretty l <> pretty a <> pretty r
459 instance Null ArrowPairNode where
460 isMissing (ArrowPairNode l a b) = isMissing l && isMissing a && isMissing b
461
462 data RelationElemNode
463 = RelationElemNodeLabeled LongTuple
464 | RelationElemNodeShort ShortTuple
465 deriving (Show, Data)
466 instance Pretty RelationElemNode where
467 pretty x = case x of
468 RelationElemNodeLabeled lt -> pretty lt
469 RelationElemNodeShort st -> pretty st
470 instance Null RelationElemNode where
471 isMissing (RelationElemNodeLabeled lt) = isMissing lt
472 isMissing (RelationElemNodeShort st) = isMissing st
473
474 newtype PermutationElemNode = PermutationElemNode (ListNode ExpressionNode)
475 deriving (Show, Data)
476 instance Pretty PermutationElemNode where
477 pretty (PermutationElemNode l) = pretty l
478 instance Null PermutationElemNode where
479 isMissing (PermutationElemNode l) = isMissing l
480
481 newtype PartitionElemNode = PartitionElemNode (ListNode ExpressionNode)
482 deriving (Show, Data)
483 instance Pretty PartitionElemNode where
484 pretty (PartitionElemNode l) = pretty l
485 instance Null PartitionElemNode where
486 isMissing (PartitionElemNode l) = isMissing l
487
488 data QuantificationExpressionNode
489 = QuantificationExpressionNode
490 SToken
491 (Sequence AbstractPatternNode)
492 QuantificationOverNode
493 (Maybe QuanticationGuard)
494 LToken -- dot
495 ExpressionNode
496 deriving (Show, Data) -- MAYBE?
497
498 instance Pretty QuantificationExpressionNode where
499 pretty (QuantificationExpressionNode q pats over m_guard lDot body) =
500 group $ hd <+> flatIndent 4 (pretty body)
501 where
502 hd = group $ pretty q <+> pretty pats <+> pretty over <+> pretty m_guard <+> pretty lDot
503 data QuantificationOverNode
504 = QuantifiedSubsetOfNode SToken ExpressionNode
505 | QuantifiedMemberOfNode SToken ExpressionNode
506 | QuantifiedDomainNode OverDomainNode
507 deriving (Show, Data)
508 instance Pretty QuantificationOverNode where
509 pretty q = case q of
510 QuantifiedSubsetOfNode lt en -> pretty lt <+> pretty en
511 QuantifiedMemberOfNode lt en -> pretty lt <+> pretty en
512 QuantifiedDomainNode odn -> pretty odn
513
514 data OverDomainNode = OverDomainNode LToken DomainNode
515 deriving (Show, Data)
516 instance Pretty OverDomainNode where
517 pretty (OverDomainNode a b) = pretty a <+> pretty b
518 data AbstractPatternNode
519 = AbstractIdentifier NameNodeS
520 | AbstractMetaVar SToken
521 | AbstractPatternTuple (Maybe LToken) (ListNode AbstractPatternNode)
522 | AbstractPatternMatrix (ListNode AbstractPatternNode)
523 | AbstractPatternSet (ListNode AbstractPatternNode)
524 deriving (Show, Data)
525 instance Pretty AbstractPatternNode where
526 pretty a = case a of
527 AbstractIdentifier nn -> pretty nn
528 AbstractMetaVar lt -> pretty lt
529 AbstractPatternTuple m_lt ln -> pretty m_lt <> pretty ln
530 AbstractPatternMatrix ln -> pretty ln
531 AbstractPatternSet ln -> pretty ln
532
533 instance Null AbstractPatternNode where
534 isMissing (_) = False
535 data QuanticationGuard = QuanticationGuard SToken ExpressionNode
536 deriving (Show, Data)
537 instance Pretty QuanticationGuard where
538 pretty (QuanticationGuard a e) = pretty a <+> pretty e
539 data QuantificationPattern
540 = QuantificationPattern ExpressionNode
541 deriving (Show, Data)
542
543 data ComprehensionExpressionNode
544 = ComprehensionExpressionNode
545 LToken
546 ExpressionNode
547 LToken
548 (Sequence ComprehensionBodyNode)
549 LToken
550 deriving (Show, Data)
551
552 data ComprehensionBodyNode
553 = CompBodyCondition ExpressionNode
554 | CompBodyDomain (Sequence AbstractPatternNode) SToken DomainNode
555 | CompBodyGenExpr (Sequence AbstractPatternNode) SToken ExpressionNode
556 | CompBodyLettingNode SToken AbstractPatternNode LToken ExpressionNode
557 deriving (Show, Data)
558
559 instance Pretty ComprehensionBodyNode where
560 pretty x = case x of
561 CompBodyCondition en -> pretty en
562 CompBodyDomain se lt dn -> pretty se <+> pretty lt <+> pretty dn
563 CompBodyGenExpr se lt en -> pretty se <+> pretty lt <+> pretty en
564 CompBodyLettingNode lt apn lt' en -> pretty lt <+> pretty apn <+> pretty lt' <+> pretty en
565
566 instance Null ComprehensionBodyNode where
567 isMissing (CompBodyCondition a) = isMissing a
568 isMissing (CompBodyDomain a b c) = isMissing a && isMissing b && isMissing c
569 isMissing (CompBodyGenExpr s t e) = isMissing s && isMissing t && isMissing e
570 isMissing (CompBodyLettingNode t p l e) = isMissing t && isMissing p && isMissing l && isMissing e
571 data OperatorExpressionNode
572 = PostfixOpNode ExpressionNode PostfixOpNode
573 | PrefixOpNode SToken ExpressionNode
574 | BinaryOpNode ExpressionNode SToken ExpressionNode
575 deriving (Show, Data)
576
577 instance Pretty OperatorExpressionNode where
578 pretty x = case x of
579 PostfixOpNode en pon -> pretty en <> pretty pon
580 PrefixOpNode lt en -> pretty lt <> pretty en
581 BinaryOpNode en lt en' -> group $ sep [pretty en, pretty lt, pretty en']
582
583 data PostfixOpNode
584 = IndexedNode (ListNode RangeNode)
585 | OpFactorial SToken
586 | ExplicitDomain SToken SToken DomainNode LToken
587 | ApplicationNode (ListNode ExpressionNode)
588 deriving (Show, Data)
589
590 instance Pretty PostfixOpNode where
591 pretty o = case o of
592 IndexedNode ln -> pretty ln
593 OpFactorial lt -> pretty lt
594 ExplicitDomain lt lt' dn lt2 -> pretty lt <+> pretty lt' <> pretty dn <> pretty lt2
595 ApplicationNode ln -> pretty ln
596
597 -- data FunctionApplicationNode
598 -- = FunctionApplicationNode LToken (ListNode ExpressionNode)
599
600 data IndexerNode
601 = Indexer
602 deriving (Show, Data)
603
604 data ListNode itemType = ListNode
605 { lOpBracket :: LToken
606 , items :: Sequence itemType
607 , lClBracket :: LToken
608 }
609 deriving (Show, Data)
610
611 instance Pretty a => Pretty (ListNode a) where
612 pretty (ListNode start es end) =
613 group $
614 align $
615 cat $
616 [ pretty start
617 , flatAlt (indent 4 $ pretty es) (pretty es)
618 , pretty end
619 ]
620
621 instance (Null a) => Null (ListNode a) where
622 isMissing (ListNode l1 s l2) = isMissing l1 && isMissing s && isMissing l2
623
624 newtype Sequence itemType = Seq
625 { elems :: [SeqElem itemType]
626 }
627 deriving (Show, Data)
628
629 instance Pretty a => Pretty (Sequence a) where
630 pretty (Seq xs) = align $ sep $ map pretty xs
631
632 prettyElems :: (Pretty a) => Sequence a -> [Doc ann]
633 prettyElems (Seq xs) = map pretty xs
634
635 instance (Null a) => Null (SeqElem a) where
636 isMissing (SeqElem i Nothing) = isMissing i
637 isMissing (SeqElem i x) = isMissing i && isMissing x
638 isMissing (MissingSeqElem _ c) = isMissing c
639
640 instance (Null a) => Null (Sequence a) where
641 isMissing (Seq []) = True
642 isMissing (Seq [a]) = isMissing a
643 isMissing (Seq _) = False
644
645 -- deriving (Show, Data)
646 -- instance (Show a) => Show (Sequence a) where
647 -- show (Seq e) = "Seq:\n" ++ intercalate "\n\t" (map show e) ++ "\n"
648
649 data SeqElem itemType
650 = SeqElem
651 { item :: itemType
652 , separator :: Maybe LToken
653 }
654 | MissingSeqElem LToken LToken
655 deriving (Show, Data)
656 instance Pretty a => Pretty (SeqElem a) where
657 pretty (SeqElem i s) = pretty i <> pretty s
658 pretty _ = emptyDoc
659
660 class Null a where
661 isMissing :: a -> Bool
662
663 instance (Null a) => Null (Maybe a) where
664 isMissing Nothing = True
665 isMissing (Just s) = isMissing s
666
667 prettyTokenAndComments :: LToken -> (Doc ann, Doc ann)
668 prettyTokenAndComments (RealToken (StrictToken [] t)) = prettySplitComments t
669 prettyTokenAndComments (o) = (emptyDoc, pretty o)
670
671 topLevelPretty :: [LToken] -> Doc ann -> Doc ann
672 topLevelPretty (t : (map pretty -> xs)) exprs =
673 let (cs, ps) = prettyTokenAndComments t
674 dec = ps <+> hsep xs
675 in cs <> group (fill 7 dec <+> flatIndent 4 exprs) <> line
676 topLevelPretty _ exprs = group (fill 7 emptyDoc <+> flatIndent 4 exprs) <> line
677
678 flatIndent :: Int -> Doc ann -> Doc ann
679 flatIndent amt d = flatAlt (line <> indent amt d) d
680
681 renderAST :: Int -> ProgramTree -> Text
682 renderAST n = renderStrict . layoutSmart (LayoutOptions $ AvailablePerLine n 0.8) . pretty
683
684