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 (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 | RelationDomainNode SToken MAttributes LToken (ListNode DomainNode)
221 | PartitionDomainNode SToken MAttributes LToken DomainNode
222 | MissingDomainNode LToken
223 deriving (Show, Data)
224
225 instance Pretty DomainNode where
226 pretty x = case x of
227 ParenDomainNode op dom cl -> pretty op <> pretty dom <> pretty cl
228 BoolDomainNode lt -> pretty lt
229 RangedIntDomainNode lt m_ln -> pretty lt <> pretty m_ln
230 RangedEnumNode nn m_ln -> pretty nn <> pretty m_ln
231 MetaVarDomain lt -> pretty lt
232 ShortTupleDomainNode ln -> pretty ln
233 TupleDomainNode lt ln -> pretty lt <> pretty ln
234 RecordDomainNode lt ln -> pretty lt <> pretty ln
235 VariantDomainNode lt ln -> pretty lt <> pretty ln
236 MatrixDomainNode lt m_ibn ln lt' dn ->
237 pretty lt
238 <+> pretty m_ibn
239 <+> pretty ln
240 <+> pretty lt'
241 <+> pretty dn
242 SetDomainNode lt m_ln lt' dn -> pretty lt <+> pretty m_ln <+> pretty lt' <+> pretty dn
243 MSetDomainNode lt m_ln lt' dn -> pretty lt <+> pretty m_ln <+> pretty lt' <+> pretty dn
244 FunctionDomainNode lt m_ln dn lt' dn' -> pretty lt <+> pretty m_ln <+> pretty dn <+> pretty lt' <+> pretty dn'
245 SequenceDomainNode lt m_ln lt' dn -> pretty lt <+> pretty m_ln <+> pretty lt' <+> pretty dn
246 RelationDomainNode lt m_ln lt' ln -> pretty lt <+> pretty m_ln <+> pretty lt' <+> pretty ln
247 PartitionDomainNode lt m_ln lt' dn -> pretty lt <+> pretty m_ln <+> pretty lt' <+> pretty dn
248 MissingDomainNode _ -> emptyDoc
249 instance Null DomainNode where
250 isMissing (MissingDomainNode{}) = True
251 isMissing _ = False
252
253 data IndexedByNode = IndexedByNode LToken LToken
254 deriving (Show, Data)
255 instance Pretty IndexedByNode where
256 pretty (IndexedByNode a b) = pretty a <+> pretty b
257 data RangeNode
258 = SingleRangeNode ExpressionNode
259 | OpenRangeNode DoubleDotNode
260 | RightUnboundedRangeNode ExpressionNode DoubleDotNode
261 | LeftUnboundedRangeNode DoubleDotNode ExpressionNode
262 | BoundedRangeNode ExpressionNode DoubleDotNode ExpressionNode
263 deriving (Show, Data)
264
265 instance Pretty RangeNode where
266 pretty x = case x of
267 SingleRangeNode en -> pretty en
268 OpenRangeNode lt -> pretty lt
269 RightUnboundedRangeNode en lt -> pretty en <> pretty lt
270 LeftUnboundedRangeNode lt en -> pretty lt <> pretty en
271 BoundedRangeNode en lt en' -> pretty en <> pretty lt <> pretty en'
272 instance Null RangeNode where
273 isMissing (SingleRangeNode e) = isMissing e
274 isMissing _ = False
275
276 type DoubleDotNode = SToken
277
278 -- data DoubleDotNode = DoubleDotNode LToken LToken deriving (Show, Data)
279
280 data AttributeNode
281 = NamedAttributeNode SToken (Maybe ExpressionNode)
282 deriving (Show, Data)
283 instance Pretty AttributeNode where
284 pretty (NamedAttributeNode a m_e) = pretty a <+> pretty m_e
285
286 instance Null AttributeNode where
287 isMissing _ = False
288
289
290 data NamedDomainNode = NameDomainNode NameNode (Maybe (LToken, DomainNode))
291 deriving (Show, Data)
292 instance Pretty NamedDomainNode where
293 pretty (NameDomainNode nn Nothing) = pretty nn
294 pretty (NameDomainNode nn (Just (e, d))) = pretty nn <> pretty e <> pretty d
295
296 instance Null NamedDomainNode where
297 isMissing (NameDomainNode (a) Nothing) = isMissing a
298 isMissing (NameDomainNode (a) (Just (b, c))) = isMissing a && isMissing b && isMissing c
299
300 -- Common Statements
301 data NameNodeS = NameNodeS SToken
302 deriving (Show, Data)
303 instance Pretty NameNodeS where
304 pretty (NameNodeS n) = pretty n
305
306 instance Null NameNodeS where
307 isMissing = const False
308 data NameNode = NameNode NameNodeS | MissingNameNode LToken
309 deriving (Show, Data)
310
311
312 instance Pretty NameNode where
313 pretty (NameNode n) = pretty n
314 pretty _ = emptyDoc
315
316 instance Null NameNode where
317 isMissing (NameNode _) = False
318 isMissing (MissingNameNode _) = True
319
320 -- Expressions
321 data ExpressionNode
322 = Literal LiteralNode
323 | IdentifierNode NameNodeS
324 | MetaVarExpr SToken
325 | QuantificationExpr QuantificationExpressionNode
326 | OperatorExpressionNode OperatorExpressionNode
327 | DomainExpression DomainExpressionNode
328 | ParenExpression ParenExpressionNode
329 | AbsExpression ParenExpressionNode
330 | FunctionalApplicationNode SToken (ListNode ExpressionNode)
331 | AttributeAsConstriant SToken (ListNode ExpressionNode)
332 | MissingExpressionNode LToken
333 | SpecialCase SpecialCaseNode
334 deriving (Show, Data)
335
336 instance Pretty ExpressionNode where
337 pretty x = case x of
338 Literal ln -> pretty ln
339 IdentifierNode nn -> pretty nn
340 MetaVarExpr lt -> pretty lt
341 QuantificationExpr qen -> pretty qen
342 OperatorExpressionNode oen -> pretty oen
343 DomainExpression den -> pretty den
344 ParenExpression (ParenExpressionNode l e r) -> pretty l <> pretty e <> pretty r
345 AbsExpression (ParenExpressionNode l e r) -> pretty l <> pretty e <> pretty r
346 FunctionalApplicationNode lt ln -> pretty lt <> pretty ln
347 AttributeAsConstriant lt ln -> pretty lt <> pretty ln
348 MissingExpressionNode _ -> emptyDoc
349 SpecialCase scn -> pretty scn
350 instance Null ExpressionNode where
351 isMissing (MissingExpressionNode _) = True
352 isMissing _ = False
353
354 data SpecialCaseNode = ExprWithDecls SToken ExpressionNode SToken [StatementNode] SToken
355 deriving (Show, Data)
356 instance Pretty SpecialCaseNode where
357 pretty x = case x of
358 ExprWithDecls lt en lt' sns lt2 -> group $ cat [pretty lt, pretty en, pretty lt', pretty sns, pretty lt2]
359
360 data DomainExpressionNode
361 = DomainExpressionNode LToken DomainNode LToken
362 deriving (Show, Data)
363 instance Pretty DomainExpressionNode where
364 pretty (DomainExpressionNode l d r) = pretty l <> pretty d <> pretty r
365 data ParenExpressionNode = ParenExpressionNode LToken ExpressionNode LToken
366 deriving (Show, Data)
367
368 newtype ShortTuple = ShortTuple (ListNode ExpressionNode) deriving (Show, Data)
369 instance Pretty ShortTuple where
370 pretty (ShortTuple exps) = pretty exps
371 instance Null ShortTuple where
372 isMissing (ShortTuple ls) = isMissing ls
373
374 data LongTuple = LongTuple SToken (ListNode ExpressionNode) deriving (Show, Data)
375 instance Pretty LongTuple where
376 pretty (LongTuple t exps) = pretty t <> pretty exps
377
378 instance Null LongTuple where
379 isMissing (LongTuple s ls) = isMissing s && isMissing ls
380
381 -- Literals
382 data LiteralNode
383 = IntLiteral SToken
384 | BoolLiteral SToken
385 | MatrixLiteral MatrixLiteralNode
386 | TupleLiteralNode LongTuple
387 | TupleLiteralNodeShort ShortTuple
388 | RecordLiteral SToken (ListNode RecordMemberNode)
389 | VariantLiteral SToken (ListNode RecordMemberNode) -- catch later
390 | SetLiteral (ListNode ExpressionNode)
391 | MSetLiteral SToken (ListNode ExpressionNode)
392 | FunctionLiteral SToken (ListNode ArrowPairNode)
393 | SequenceLiteral SToken (ListNode ExpressionNode)
394 | RelationLiteral SToken (ListNode RelationElemNode)
395 | PartitionLiteral SToken (ListNode PartitionElemNode)
396 deriving (Show, Data)
397
398 instance Pretty LiteralNode where
399 pretty l = case l of
400 IntLiteral lt -> pretty lt
401 BoolLiteral lt -> pretty lt
402 MatrixLiteral mln -> pretty mln
403 TupleLiteralNode lt -> pretty lt
404 TupleLiteralNodeShort st -> pretty st
405 RecordLiteral lt ln -> pretty lt <> pretty ln
406 VariantLiteral lt ln -> pretty lt <> pretty ln
407 SetLiteral ln -> pretty ln
408 MSetLiteral lt ln -> pretty lt <> pretty ln
409 FunctionLiteral lt ln -> pretty lt <> pretty ln
410 SequenceLiteral lt ln -> pretty lt <> pretty ln
411 RelationLiteral lt ln -> pretty lt <> pretty ln
412 PartitionLiteral lt ln -> pretty lt <> pretty ln
413
414 data MatrixLiteralNode
415 = MatrixLiteralNode
416 LToken -- openBracket
417 (Sequence ExpressionNode)
418 (Maybe OverDomainNode) -- explicitDomain
419 (Maybe ComprehensionNode) -- compBody
420 LToken -- close
421 deriving (Show, Data)
422
423 instance Pretty MatrixLiteralNode where
424 pretty (MatrixLiteralNode bl es d c br) =
425 group $
426 align (cat (pretty bl : prettyElems es ++ catMaybes ((pretty <$> d) : comps) ++ [pretty br]))
427 where
428 comps = case c of
429 Nothing -> []
430 Just (ComprehensionNode l seq) -> pure <$> pretty l : prettyElems seq
431
432 data ComprehensionNode
433 = ComprehensionNode
434 SToken
435 (Sequence ComprehensionBodyNode)
436 deriving (Show, Data)
437
438 instance Pretty ComprehensionNode where
439 pretty (ComprehensionNode bar es) = align $ pretty bar <+> pretty es
440
441 data RecordMemberNode = RecordMemberNode NameNode LToken ExpressionNode
442 deriving (Show, Data)
443 instance Pretty RecordMemberNode where
444 pretty (RecordMemberNode n t e) = pretty n <> pretty t <> pretty e
445
446 instance Null RecordMemberNode where
447 isMissing (RecordMemberNode n t e) = isMissing n && isMissing t && isMissing e
448
449 data ArrowPairNode = ArrowPairNode ExpressionNode LToken ExpressionNode
450 deriving (Show, Data)
451 instance Pretty ArrowPairNode where
452 pretty (ArrowPairNode l a r) = pretty l <> pretty a <> pretty r
453 instance Null ArrowPairNode where
454 isMissing (ArrowPairNode l a b) = isMissing l && isMissing a && isMissing b
455
456 data RelationElemNode
457 = RelationElemNodeLabeled LongTuple
458 | RelationElemNodeShort ShortTuple
459 deriving (Show, Data)
460 instance Pretty RelationElemNode where
461 pretty x = case x of
462 RelationElemNodeLabeled lt -> pretty lt
463 RelationElemNodeShort st -> pretty st
464 instance Null RelationElemNode where
465 isMissing (RelationElemNodeLabeled lt) = isMissing lt
466 isMissing (RelationElemNodeShort st) = isMissing st
467
468 newtype PartitionElemNode = PartitionElemNode (ListNode ExpressionNode)
469 deriving (Show, Data)
470 instance Pretty PartitionElemNode where
471 pretty (PartitionElemNode l) = pretty l
472 instance Null PartitionElemNode where
473 isMissing (PartitionElemNode l) = isMissing l
474
475 data QuantificationExpressionNode
476 = QuantificationExpressionNode
477 SToken
478 (Sequence AbstractPatternNode)
479 QuantificationOverNode
480 (Maybe QuanticationGuard)
481 LToken -- dot
482 ExpressionNode
483 deriving (Show, Data) -- MAYBE?
484
485 instance Pretty QuantificationExpressionNode where
486 pretty (QuantificationExpressionNode q pats over m_guard lDot body) =
487 group $ hd <+> flatIndent 4 (pretty body)
488 where
489 hd = group $ pretty q <+> pretty pats <+> pretty over <+> pretty m_guard <+> pretty lDot
490 data QuantificationOverNode
491 = QuantifiedSubsetOfNode SToken ExpressionNode
492 | QuantifiedMemberOfNode SToken ExpressionNode
493 | QuantifiedDomainNode OverDomainNode
494 deriving (Show, Data)
495 instance Pretty QuantificationOverNode where
496 pretty q = case q of
497 QuantifiedSubsetOfNode lt en -> pretty lt <+> pretty en
498 QuantifiedMemberOfNode lt en -> pretty lt <+> pretty en
499 QuantifiedDomainNode odn -> pretty odn
500
501 data OverDomainNode = OverDomainNode LToken DomainNode
502 deriving (Show, Data)
503 instance Pretty OverDomainNode where
504 pretty (OverDomainNode a b) = pretty a <+> pretty b
505 data AbstractPatternNode
506 = AbstractIdentifier NameNodeS
507 | AbstractMetaVar SToken
508 | AbstractPatternTuple (Maybe LToken) (ListNode AbstractPatternNode)
509 | AbstractPatternMatrix (ListNode AbstractPatternNode)
510 | AbstractPatternSet (ListNode AbstractPatternNode)
511 deriving (Show, Data)
512 instance Pretty AbstractPatternNode where
513 pretty a = case a of
514 AbstractIdentifier nn -> pretty nn
515 AbstractMetaVar lt -> pretty lt
516 AbstractPatternTuple m_lt ln -> pretty m_lt <> pretty ln
517 AbstractPatternMatrix ln -> pretty ln
518 AbstractPatternSet ln -> pretty ln
519
520 instance Null AbstractPatternNode where
521 isMissing (_) = False
522 data QuanticationGuard = QuanticationGuard SToken ExpressionNode
523 deriving (Show, Data)
524 instance Pretty QuanticationGuard where
525 pretty (QuanticationGuard a e) = pretty a <+> pretty e
526 data QuantificationPattern
527 = QuantificationPattern ExpressionNode
528 deriving (Show, Data)
529
530 data ComprehensionExpressionNode
531 = ComprehensionExpressionNode
532 LToken
533 ExpressionNode
534 LToken
535 (Sequence ComprehensionBodyNode)
536 LToken
537 deriving (Show, Data)
538
539 data ComprehensionBodyNode
540 = CompBodyCondition ExpressionNode
541 | CompBodyDomain (Sequence AbstractPatternNode) SToken DomainNode
542 | CompBodyGenExpr (Sequence AbstractPatternNode) SToken ExpressionNode
543 | CompBodyLettingNode SToken AbstractPatternNode LToken ExpressionNode
544 deriving (Show, Data)
545
546 instance Pretty ComprehensionBodyNode where
547 pretty x = case x of
548 CompBodyCondition en -> pretty en
549 CompBodyDomain se lt dn -> pretty se <+> pretty lt <+> pretty dn
550 CompBodyGenExpr se lt en -> pretty se <+> pretty lt <+> pretty en
551 CompBodyLettingNode lt apn lt' en -> pretty lt <+> pretty apn <+> pretty lt' <+> pretty en
552
553 instance Null ComprehensionBodyNode where
554 isMissing (CompBodyCondition a) = isMissing a
555 isMissing (CompBodyDomain a b c) = isMissing a && isMissing b && isMissing c
556 isMissing (CompBodyGenExpr s t e) = isMissing s && isMissing t && isMissing e
557 isMissing (CompBodyLettingNode t p l e) = isMissing t && isMissing p && isMissing l && isMissing e
558 data OperatorExpressionNode
559 = PostfixOpNode ExpressionNode PostfixOpNode
560 | PrefixOpNode SToken ExpressionNode
561 | BinaryOpNode ExpressionNode SToken ExpressionNode
562 deriving (Show, Data)
563
564 instance Pretty OperatorExpressionNode where
565 pretty x = case x of
566 PostfixOpNode en pon -> pretty en <> pretty pon
567 PrefixOpNode lt en -> pretty lt <> pretty en
568 BinaryOpNode en lt en' -> group $ sep [pretty en, pretty lt, pretty en']
569
570 data PostfixOpNode
571 = IndexedNode (ListNode RangeNode)
572 | OpFactorial SToken
573 | ExplicitDomain SToken SToken DomainNode LToken
574 | ApplicationNode (ListNode ExpressionNode)
575 deriving (Show, Data)
576
577 instance Pretty PostfixOpNode where
578 pretty o = case o of
579 IndexedNode ln -> pretty ln
580 OpFactorial lt -> pretty lt
581 ExplicitDomain lt lt' dn lt2 -> pretty lt <+> pretty lt' <> pretty dn <> pretty lt2
582 ApplicationNode ln -> pretty ln
583
584 -- data FunctionApplicationNode
585 -- = FunctionApplicationNode LToken (ListNode ExpressionNode)
586
587 data IndexerNode
588 = Indexer
589 deriving (Show, Data)
590 data ListNode itemType = ListNode
591 { lOpBracket :: LToken
592 , items :: Sequence itemType
593 , lClBracket :: LToken
594 }
595 deriving (Show, Data)
596
597 -- prettyList :: Pretty a => ListNode a > Doc
598 -- prettyList (ListNode start es end) = group $ align $ cat $
599 -- [
600 -- pretty start ,
601 -- flatAlt (indent 4 $ pretty es) (pretty es) ,
602 -- pretty end
603 -- ]
604 instance Pretty a => Pretty (ListNode a) where
605 pretty (ListNode start es end) =
606 group $
607 align $
608 cat $
609 [ pretty start
610 , flatAlt (indent 4 $ pretty es) (pretty es)
611 , pretty end
612 ]
613
614 instance (Null a) => Null (ListNode a) where
615 isMissing (ListNode l1 s l2) = isMissing l1 && isMissing s && isMissing l2
616 newtype Sequence itemType = Seq
617 { elems :: [SeqElem itemType]
618 }
619 deriving (Show, Data)
620
621 instance Pretty a => Pretty (Sequence a) where
622 pretty (Seq xs) = align $ sep $ map pretty xs
623
624 prettyElems :: (Pretty a) => Sequence a -> [Doc ann]
625 prettyElems (Seq xs) = map pretty xs
626
627 instance (Null a) => Null (SeqElem a) where
628 isMissing (SeqElem i Nothing) = isMissing i
629 isMissing (SeqElem i x) = isMissing i && isMissing x
630 isMissing (MissingSeqElem _ c) = isMissing c
631
632 instance (Null a) => Null (Sequence a) where
633 isMissing (Seq []) = True
634 isMissing (Seq [a]) = isMissing a
635 isMissing (Seq _) = False
636
637 -- deriving (Show, Data)
638 -- instance (Show a) => Show (Sequence a) where
639 -- show (Seq e) = "Seq:\n" ++ intercalate "\n\t" (map show e) ++ "\n"
640
641 data SeqElem itemType
642 = SeqElem
643 { item :: itemType
644 , separator :: Maybe LToken
645 }
646 | MissingSeqElem LToken LToken
647 deriving (Show, Data)
648 instance Pretty a => Pretty (SeqElem a) where
649 pretty (SeqElem i s) = pretty i <> pretty s
650 pretty _ = emptyDoc
651
652 class Null a where
653 isMissing :: a -> Bool
654
655 instance (Null a) => Null (Maybe a) where
656 isMissing Nothing = True
657 isMissing (Just s) = isMissing s
658
659 prettyTokenAndComments :: LToken -> (Doc ann, Doc ann)
660 prettyTokenAndComments (RealToken (StrictToken [] t)) = prettySplitComments t
661 prettyTokenAndComments (o) = (emptyDoc, pretty o)
662
663 topLevelPretty :: [LToken] -> Doc ann -> Doc ann
664 topLevelPretty (t : (map pretty -> xs)) exprs =
665 let (cs, ps) = prettyTokenAndComments t
666 dec = ps <+> hsep xs
667 in cs <> group (fill 7 dec <+> flatIndent 4 exprs) <> line
668 topLevelPretty _ exprs = group (fill 7 emptyDoc <+> flatIndent 4 exprs) <> line
669
670 flatIndent :: Int -> Doc ann -> Doc ann
671 flatIndent amt d = flatAlt (line <> indent amt d) d
672
673 renderAST :: Int -> ProgramTree -> Text
674 renderAST n = renderStrict . layoutSmart (LayoutOptions $ AvailablePerLine n 0.8) . pretty
675
676