never executed always true always false
1 {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
2
3 {-# HLINT ignore "Use <$>" #-}
4 module Conjure.Language.AST.ASTParser
5 ( parseProgram,
6 ParserError,
7 runASTParser,
8 parseExpression,
9 parseDomain,
10 parseTopLevels,
11 example,
12 exampleFile, -- For debugging
13 )
14 where
15
16 import Conjure.Language.AST.Helpers
17 import Conjure.Language.AST.Reformer (HighLevelTree (..), flattenSeq)
18 import Conjure.Language.AST.Syntax
19 import Conjure.Language.Expression.Op.Internal.Common
20 import Conjure.Language.Lexemes
21 import Conjure.Language.Lexer
22 import Conjure.Prelude hiding (many, some)
23 import Control.Monad.Combinators.Expr
24 import Data.Text qualified as T
25 import Data.Text.Lazy qualified as L
26 import Text.Megaparsec
27
28 newtype ParserError = ParserError (Doc)
29 deriving (Show)
30
31 runASTParser :: (HighLevelTree a) => Parser a -> ETokenStream -> Either ParserError a
32 runASTParser p str =
33 case runParser p "parser" str of
34 Left peb -> Left $ ParserError . pretty $ errorBundlePretty peb
35 Right res -> Right res
36
37 parseProgram :: Parser ProgramTree
38 parseProgram =
39 do
40 langV <- optional parseLangVersion
41 (tl, ending) <- manyTill_ parseTopLevel pEnding
42 return $ ProgramTree langV tl ending
43 <?> "Program"
44
45 parseLangVersion :: Parser LangVersionNode
46 parseLangVersion = do
47 lLang <- need L_language
48 lLName <- parseIdentifier
49 nums <- parseSequence L_Dot (StrictToken [] <$> intLiteral)
50 return $ LangVersionNode lLang lLName nums
51
52 parseTopLevels :: Parser [StatementNode]
53 parseTopLevels = manyTill parseTopLevel pEnding
54
55 parseTopLevel :: Parser StatementNode
56 parseTopLevel =
57 do
58 parseDeclaration
59 <|> parseBranching
60 <|> parseSuchThat
61 <|> parseWhere
62 <|> parseObjective
63 <|> parseHeuristic
64 <|> UnexpectedToken
65 <$> makeUnexpected
66
67 parseHeuristic :: Parser StatementNode
68 parseHeuristic = do
69 lHeuristic <- need L_heuristic
70 expr <- parseExpression
71 return $ HeuristicStatement lHeuristic expr
72
73 parseBranching :: Parser StatementNode
74 parseBranching = do
75 lBranching <- need L_branching
76 lOn <- want L_on
77 branchSts <- squareBracketList (commaList parseExpression)
78 return $ BranchingStatement $ BranchingStatementNode lBranching lOn branchSts
79
80 parseSuchThat :: Parser StatementNode
81 parseSuchThat = do
82 lSuch <- need L_such
83 lThat <- want L_that
84 exprs <- commaList1 parseExpression
85 return $ SuchThatStatement $ SuchThatStatementNode lSuch lThat exprs
86
87 parseWhere :: Parser StatementNode
88 parseWhere = do
89 lWhere <- need L_where
90 exprs <- commaList1 parseExpression
91 return $ WhereStatement $ WhereStatementNode lWhere exprs
92
93 parseObjective :: Parser StatementNode
94 parseObjective = do
95 ObjectiveStatement <$> parseObjectiveStatement
96
97 parseDeclaration :: Parser StatementNode
98 parseDeclaration =
99 DeclarationStatement
100 <$> choice
101 [ declaration LettingStatement L_letting parseLetting,
102 declaration GivenStatement L_given parseGiven,
103 declaration FindStatement L_find parseFind
104 ]
105 where
106 declaration :: (Null a, Show a) => (SToken -> Sequence a -> b) -> Lexeme -> Parser a -> Parser b
107 declaration c t p = do
108 l <- need t
109 seq <- option (Seq []) (commaList1 p)
110 return $ c l seq
111
112 parseLetting :: Parser LettingStatementNode
113 parseLetting = try $ do
114 names <- commaList1 parseIdentifier
115 lBe <- want L_be
116 guard $ not (isMissing names && isMissing lBe)
117 let start = LettingStatementNode names lBe
118 start
119 <$> choice
120 [ finishDomain,
121 try finishAnon,
122 try finishEnum,
123 LettingExpr <$> parseExpression
124 ]
125 where
126 finishDomain = do
127 lDomain <- need L_domain
128 domain <- parseDomain
129 return $ LettingDomain lDomain domain
130 finishAnon = try $ do
131 lNew <- want L_new
132 lType <- want L_type
133 lOf <- want L_of
134 lSize <- want L_size
135 guard (not $ all isMissing [lOf, lSize])
136 expr <- parseExpression
137 return $ LettingUnnamed lNew lType lOf lSize expr
138 finishEnum = do
139 lNew <- want L_new
140 lType <- want L_type
141 lEnum <- want L_enum
142 guard (not $ all isMissing [lNew, lType, lEnum])
143 members <- curlyBracketList $ commaList parseIdentifier
144 return $ LettingEnum lNew lType lEnum members
145
146 parseGiven :: Parser GivenStatementNode
147 parseGiven = do
148 names <- commaList1 parseIdentifier
149 choice
150 [ finishEnum (GivenEnumNode names),
151 finishDomain (GivenStatementNode names)
152 ]
153 where
154 finishEnum start = do
155 lNew <- want L_new
156 lType <- want L_type
157 lEnum <- want L_enum
158 guard (not $ all isMissing [lNew, lType, lEnum])
159 return $ start lNew lType lEnum
160 finishDomain start = do
161 lColon <- want L_Colon -- want here so that parse cannot fail
162 domain <- parseDomain
163 return $ start lColon domain
164
165 parseFind :: Parser FindStatementNode
166 parseFind =
167 do
168 names <- commaList1 parseIdentifier
169 lColon <- want L_Colon
170 domain <- parseDomain
171 return $ FindStatementNode names lColon domain
172 <?> "Find Statement"
173
174 parseObjectiveStatement :: Parser ObjectiveStatementNode
175 parseObjectiveStatement =
176 do
177 s <- eSymbol L_minimising <|> eSymbol L_maximising
178 e <- parseExpression
179 return $ case s of
180 (ETok {lexeme = L_minimising}) -> ObjectiveMin (StrictToken [] s) e
181 _ -> ObjectiveMax (StrictToken [] s) e
182 <?> "Objective Statement"
183
184 pEnding :: Parser SToken
185 pEnding = do
186 t <- lookAhead anySingle
187 case t of
188 ETok {lexeme = L_EOF} -> return $ StrictToken [] t
189 _ -> empty
190
191 ---------------------------------------
192
193 ---------------------------------------
194
195 parseExpression :: Parser ExpressionNode
196 parseExpression = try $ do
197 parseOperator
198 <|> parseAtomicExpression
199 <|> (MissingExpressionNode <$> makeMissing (L_Missing MissingExpression))
200
201 parseExpressionStrict :: Parser ExpressionNode -- can fail
202 parseExpressionStrict = try $ do
203 expr <- parseExpression
204 case expr of
205 MissingExpressionNode _ -> empty
206 _ -> return expr
207
208 parseAtomicExpression :: Parser ExpressionNode
209 parseAtomicExpression = do
210 try
211 $ choice
212 [ parseSpecialCase,
213 parseFunction, -- has to be first because true is overloaded
214 Literal <$> parseLiteral,
215 parseAttributeAsConstraint,
216 IdentifierNode <$> parseIdentifierStrict,
217 MetaVarExpr <$> parseMetaVar,
218 ParenExpression <$> parseParenExpression parensPair,
219 AbsExpression <$> parseAbsExpression,
220 QuantificationExpr <$> parseQuantificationStatement,
221 DomainExpression <$> parseDomainExpression,
222 MissingExpressionNode <$> makeMissing (L_Missing MissingExpression)
223 ]
224
225 parseDomainExpression :: Parser DomainExpressionNode
226 parseDomainExpression = try $ do
227 lTick <- needWeak L_BackTick
228 domain <- parseDomain
229 case domain of
230 MissingDomainNode _ -> empty
231 _ -> pure ()
232 rTick <- want L_BackTick
233 return $ DomainExpressionNode lTick domain rTick
234
235 -- [a,b,c : int (1..2)]
236 -- [a,b,c : int (1..4) | x < 3,letting x be int]
237
238 parseMatrixBasedExpression :: Parser LiteralNode
239 parseMatrixBasedExpression = do
240 openB <- needWeak L_OpenBracket
241 exprs <- commaList parseExpression
242 range <- optional pOverDomain
243 comprehension <- optional pComp
244 closeB <- want L_CloseBracket
245 let es = exprs
246 return $ MatrixLiteral $ MatrixLiteralNode openB es range comprehension closeB
247 where
248 pOverDomain = OverDomainNode <$> needWeak L_SemiColon <*> parseDomain
249 pComp = do
250 bar <- need L_Bar
251 body <- commaList parseComprehensionCondition
252 return $ ComprehensionNode bar body
253
254 -- TODO look into adding enviorment to the parser to configure forgiveness
255 parseAbsExpression :: Parser ParenExpressionNode
256 parseAbsExpression = try $ do
257 lParen <- needWeak L_Bar
258 expr <- parseExpression
259 rParen <- needWeak L_Bar
260 return $ ParenExpressionNode lParen expr rParen
261
262 parseParenExpression :: (Lexeme, Lexeme) -> Parser ParenExpressionNode
263 parseParenExpression (open, close) = try $ do
264 lParen <- needWeak open
265 body <- parseExpression
266 notFollowedBy $ need L_Comma
267 rParen <- want close
268 return $ ParenExpressionNode lParen body rParen
269
270 parseLiteral :: Parser LiteralNode
271 parseLiteral =
272 choice
273 [ parseIntLiteral,
274 parseBoolLiteral,
275 parseMatrixBasedExpression,
276 parseTupleLiteral,
277 parseShortTupleLiteral,
278 parseRecordLiteral,
279 parseVariantLiteral,
280 parseSetLiteral,
281 parseMSetLiteral,
282 parseFunctionLiteral,
283 parseSequenceLiteral,
284 parseRelationLiteral,
285 parsePartitionLiteral
286 ]
287
288 parseShortTupleLiteral :: Parser LiteralNode
289 parseShortTupleLiteral = try $ do
290 lOpen <- needWeak L_OpenParen
291 exprs <- commaList parseExpression
292 let Seq xs = exprs
293 guard (length xs > 1)
294 lClose <- want L_CloseParen
295 return $ TupleLiteralNodeShort $ ShortTuple (ListNode lOpen exprs lClose)
296
297 parseIntLiteral :: Parser LiteralNode
298 parseIntLiteral = IntLiteral . StrictToken [] <$> intLiteral
299
300 parseBoolLiteral :: Parser LiteralNode
301 parseBoolLiteral = BoolLiteral <$> (need L_true <|> need L_false)
302
303 parseTupleLiteral :: Parser LiteralNode
304 parseTupleLiteral = do
305 lTuple <- need L_tuple
306 members <- parenList $ commaList parseExpression
307 return $ TupleLiteralNode $ LongTuple lTuple members
308
309 parseRecordLiteral :: Parser LiteralNode
310 parseRecordLiteral = do
311 lRecord <- need L_record
312 members <- curlyBracketList (commaList parseRecordMember)
313 return $ RecordLiteral lRecord members
314
315 parseVariantLiteral :: Parser LiteralNode
316 parseVariantLiteral = do
317 lVariant <- need L_variant
318 members <- curlyBracketList (commaList parseRecordMember)
319 return $ VariantLiteral lVariant members
320
321 parseRecordMember :: Parser RecordMemberNode
322 parseRecordMember = do
323 name <- parseIdentifier
324 lEqual <- want L_Eq
325 val <- parseExpression
326 return $ RecordMemberNode name lEqual val
327
328 parseSetLiteral :: Parser LiteralNode
329 parseSetLiteral = do
330 -- cant just recycle list as it does not require first char
331 lOpen <- needWeak L_OpenCurly
332 members <- commaList parseExpression
333 lClose <- want L_CloseCurly
334 return $ SetLiteral (ListNode lOpen members lClose)
335
336 parseMSetLiteral :: Parser LiteralNode
337 parseMSetLiteral = do
338 lMSet <- need L_mset
339 members <- parenList (commaList parseExpression)
340 return $ MSetLiteral lMSet members
341
342 parseFunctionLiteral :: Parser LiteralNode
343 parseFunctionLiteral = do
344 lFunc <- need L_function
345 args <- parenList (commaList parseArrowPair)
346 return $ FunctionLiteral lFunc args
347
348 parseArrowPair :: Parser ArrowPairNode
349 parseArrowPair = try $ do
350 lhs <- parseExpression
351 arrow <- want L_LongArrow
352 rhs <- parseExpression
353 return $ ArrowPairNode lhs arrow rhs
354
355 parseSequenceLiteral :: Parser LiteralNode
356 parseSequenceLiteral = do
357 lSeq <- need L_sequence
358 members <- parenList (commaList parseExpression)
359 return $ SequenceLiteral lSeq members
360
361 parseRelationLiteral :: Parser LiteralNode
362 parseRelationLiteral = do
363 lRel <- need L_relation
364 members <- parenList (commaList parseRelationMember)
365 return $ RelationLiteral lRel members
366
367 parseRelationMember :: Parser RelationElemNode
368 parseRelationMember = try $ do
369 f <- optional $ need L_tuple
370 members <- parenList $ commaList parseExpression
371 case f of
372 Just lTup -> return $ RelationElemNodeLabeled $ LongTuple lTup members
373 Nothing -> case members of
374 ListNode l c r | (isMissing l || isMissing r) && isMissing c -> empty
375 _ -> return $ RelationElemNodeShort $ ShortTuple members
376
377 parsePartitionLiteral :: Parser LiteralNode
378 parsePartitionLiteral = do
379 lPartition <- need L_partition
380 members <- parenList (commaList parsePartitionElem)
381 return $ PartitionLiteral lPartition members
382
383 parsePartitionElem :: Parser PartitionElemNode
384 parsePartitionElem = PartitionElemNode <$> parseList L_OpenCurly L_CloseCurly (commaList parseExpression)
385
386 parseQuantificationStatement :: Parser QuantificationExpressionNode
387 parseQuantificationStatement = do
388 lType <- choice $ map need quantifiers
389 terms <- commaList parseAbstractPattern
390 over <- parseQuantificationOver
391 qGuard <- optional $ do
392 lComma <- need L_Comma
393 expr <- parseExpression
394 return $ QuanticationGuard lComma expr
395 lDot <- want L_Dot
396 expr <- parseExpression
397 return $ QuantificationExpressionNode lType terms over qGuard lDot expr
398 where
399 parseQuantificationOver :: Parser QuantificationOverNode
400 parseQuantificationOver =
401 choice
402 [ QuantifiedMemberOfNode <$> need L_in <*> parseExpression,
403 QuantifiedSubsetOfNode <$> need L_subsetEq <*> parseExpression,
404 QuantifiedDomainNode <$> (OverDomainNode <$> want L_Colon <*> parseDomain)
405 ]
406
407 parseAbstractPattern :: Parser AbstractPatternNode
408 parseAbstractPattern = do
409 choice
410 [ parseAbstractId,
411 parseAbstractMetaVar,
412 parseAbstractPatternTuple,
413 parseAbstractPatternMatrix,
414 parseAbstractPatternSet
415 ]
416 where
417 parseAbstractId :: Parser AbstractPatternNode
418 parseAbstractId = AbstractIdentifier <$> parseIdentifierStrict
419 parseAbstractMetaVar :: Parser AbstractPatternNode
420 parseAbstractMetaVar = AbstractMetaVar <$> parseMetaVar
421 parseAbstractPatternTuple :: Parser AbstractPatternNode
422 parseAbstractPatternTuple = do
423 lTuple <- optional $ needWeak L_tuple
424 openB <- (if null lTuple then needWeak else want) L_OpenParen
425 es <- commaList parseAbstractPattern
426 closeB <- want L_CloseParen
427 return $ AbstractPatternTuple lTuple (ListNode openB es closeB)
428 parseAbstractPatternMatrix :: Parser AbstractPatternNode
429 parseAbstractPatternMatrix = do
430 openB <- needWeak L_OpenBracket
431 es <- commaList parseAbstractPattern
432 closeB <- want L_CloseBracket
433 return $ AbstractPatternMatrix (ListNode openB es closeB)
434 parseAbstractPatternSet :: Parser AbstractPatternNode
435 parseAbstractPatternSet = do
436 openB <- needWeak L_OpenCurly
437 es <- commaList parseAbstractPattern
438 closeB <- want L_CloseCurly
439 return $ AbstractPatternSet (ListNode openB es closeB)
440
441 parseComprehensionCondition :: Parser ComprehensionBodyNode
442 parseComprehensionCondition = do
443 letting <|> generator <|> condition
444 where
445 letting = do
446 lLetting <- need L_letting
447 v <- parseAbstractPattern
448 lBe <- want L_be
449 expr <- parseExpression
450 return $ CompBodyLettingNode lLetting v lBe expr
451 generator = try $ do
452 pats <- commaList parseAbstractPattern
453 choice
454 [ try $ do
455 lColon <- need L_Colon
456 domain <- parseDomain
457 return $ CompBodyDomain pats lColon domain,
458 try $ do
459 lArrow <- need L_LeftArrow
460 expr <- parseExpression
461 return $ CompBodyGenExpr pats lArrow expr
462 ]
463
464 condition = CompBodyCondition <$> parseExpressionStrict
465
466 parseOperator :: Parser ExpressionNode
467 parseOperator = try (makeExprParser parseAtomicExpressionAndFixes operatorTable <?> "Expression")
468
469 parseFunction :: Parser ExpressionNode
470 parseFunction = try $ do
471 name <- choice $ map need functionals
472 let ol = isOverloaded name
473 let parenP = if ol then parenListStrict else parenList
474 args <- parenP $ commaList parseExpression
475 guard $ not ol || argsHasNoLeadingTrivia args
476 return $ FunctionalApplicationNode name args
477 where
478 isOverloaded (StrictToken _ ETok {lexeme = lex}) = lex `elem` overloadedFunctionals
479 argsHasNoLeadingTrivia (ListNode (RealToken (StrictToken [] ETok {trivia = []})) _ _) = True
480 argsHasNoLeadingTrivia _ = False
481
482 parseAttributeAsConstraint :: Parser ExpressionNode
483 parseAttributeAsConstraint = do
484 name <- parseAttributeLexeme
485 args <- parenList $ commaList parseExpression
486 return $ AttributeAsConstriant name args
487
488 parsePostfixOp :: Parser (ExpressionNode -> ExpressionNode)
489 parsePostfixOp = do
490 op <-
491 try
492 $ choice
493 [ indexed,
494 factorial,
495 application,
496 explicitDomain
497 ]
498 return $ \e -> OperatorExpressionNode $ PostfixOpNode e op
499 where
500 indexed = do
501 lBracket <- need L_OpenBracket
502 indexer <- commaList parseRange
503 rBracket <- want L_CloseBracket
504 return $ IndexedNode $ ListNode (RealToken lBracket) indexer rBracket
505 factorial = OpFactorial <$> need L_ExclamationMark
506 application = do
507 lBracket <- need L_OpenParen
508 args <- commaList parseExpression
509 rBracket <- want L_CloseParen
510 return $ ApplicationNode $ ListNode (RealToken lBracket) args rBracket
511 explicitDomain = try $ do
512 lColon <- need L_Colon
513 lTickl <- need L_BackTick
514 dom <- parseDomain
515 lTickr <- want L_BackTick
516 return $ ExplicitDomain lColon lTickl dom lTickr
517
518 -- TODO treat funcitonals differently or actually don't but why
519
520 operatorTable :: [[Operator Parser ExpressionNode]]
521 operatorTable =
522 let operatorsGrouped =
523 operators
524 |> sortBy (\(_, a) (_, b) -> compare a b)
525 |> groupBy (\(_, a) (_, b) -> a == b)
526 |> reverse
527 in postfixOps
528 : [ [ case descr of
529 BinaryOp op FLeft -> InfixL $ exprBinary <$> need op
530 BinaryOp op FNone -> InfixN $ exprBinary <$> need op
531 BinaryOp op FRight -> InfixR $ exprBinary <$> need op
532 UnaryPrefix op -> prefixOps op
533 | -- UnaryPrefix L_ExclamationMark -> Prefix $ prefixBinary--foldr1 (.) <$> some parseUnaryNot
534 -- UnaryPrefix l -> bug ("Unknown UnaryPrefix" <+> pretty (show l))
535 (descr, _) <- operatorsInGroup
536 ]
537 | operatorsInGroup <- operatorsGrouped
538 ]
539
540 parseAtomicExpressionAndFixes :: Parser ExpressionNode
541 parseAtomicExpressionAndFixes = try $ do
542 let prefixes = do
543 fs <- some parsePrefixes
544 return $ foldr1 (.) fs
545 postfixes = do
546 fs <- some parsePostfixOp
547 return $ foldr1 (.) (reverse fs)
548 withPrefix x = do f <- option id prefixes; i <- x; return $ f i
549 withPostfix x = do
550 i <- x
551 -- guard $ not $ isMissing i ;
552 mf <- optional postfixes
553 return $ fromMaybe id mf i
554 withPrefix (withPostfix parseAtomicExpression) <?> "expression"
555
556 parsePrefixes :: Parser (ExpressionNode -> ExpressionNode)
557 parsePrefixes = choice [parseUnary L_Minus, parseUnary L_ExclamationMark]
558 where
559 parseUnary l = (\e -> OperatorExpressionNode . PrefixOpNode e) <$> need l
560
561 exprBinary :: SToken -> ExpressionNode -> ExpressionNode -> ExpressionNode
562 exprBinary t l = OperatorExpressionNode . BinaryOpNode l t
563
564 prefixOps :: Lexeme -> Operator Parser ExpressionNode
565 prefixOps l = Prefix $ foldr1 (.) <$> some (try opBuilder)
566 where
567 opBuilder :: Parser (ExpressionNode -> ExpressionNode)
568 opBuilder = do
569 t <- need l
570 return (OperatorExpressionNode . PrefixOpNode t)
571
572 postfixOps :: [Operator Parser ExpressionNode]
573 postfixOps =
574 [ Postfix $ foldr1 (.) . reverse <$> some parsePostfixOp
575 ]
576
577 -- DOMAINS
578 parseDomain :: Parser DomainNode
579 parseDomain =
580 do
581 choice
582 [ BoolDomainNode <$> need L_bool,
583 parseIntDomain,
584 MetaVarDomain <$> parseMetaVar,
585 parseTuple,
586 parseRecord,
587 parseVariant,
588 parseMatrix,
589 parseSet,
590 parseMSet,
591 parseFunctionDomain,
592 parseSequenceDomain,
593 parseRelation,
594 parsePartition,
595 parseEnumDomain,
596 parseShortTuple
597 ]
598 <?> "Domain"
599 <|> parseMissingDomain
600 <?> "missingDomain"
601
602 parseSpecialCase :: Parser ExpressionNode
603 parseSpecialCase = do
604 SpecialCase <$> choice [parseWithDecls]
605 where
606 parseWithDecls = try
607 $ do
608 p1 <- need L_OpenCurly
609 exp1 <- parseExpression
610 lAt <- need L_At
611 (decsl, p2) <- manyTill_ parseTopLevel (need L_CloseCurly)
612
613 return $ ExprWithDecls p1 exp1 lAt decsl p2
614
615 parseIntDomain :: Parser DomainNode
616 parseIntDomain = do
617 lInt <- need L_int
618 ranges <- optional $ parenListStrict $ commaList parseRange
619 return $ RangedIntDomainNode lInt ranges
620
621 parseTuple :: Parser DomainNode
622 parseTuple = do
623 lTuple <- need L_tuple
624 members <- parenList $ commaList parseDomain
625 return $ TupleDomainNode lTuple members
626
627 parseShortTuple :: Parser DomainNode
628 parseShortTuple = do
629 openB <- need L_OpenParen
630 lst <- commaList parseDomain
631 closeB <- want L_CloseParen
632 return $ case lst of
633 Seq [SeqElem d Nothing] -> ParenDomainNode openB d closeB
634 Seq _ -> ShortTupleDomainNode $ ListNode (RealToken openB) lst closeB
635
636 parseRecord :: Parser DomainNode
637 parseRecord = do
638 lRecord <- need L_record
639 members <- curlyBracketList $ commaList parseNameDomain
640 return $ RecordDomainNode lRecord members
641
642 parseVariant :: Parser DomainNode
643 parseVariant = do
644 lVariant <- need L_variant
645 members <- curlyBracketList $ commaList parseNameDomain
646 return $ VariantDomainNode lVariant members
647
648 parseMatrix :: Parser DomainNode
649 parseMatrix = do
650 lMatrix <- need L_matrix
651 lIndexed <- want L_indexed
652 lBy <- want L_by
653 let indexByNode = case (lIndexed, lBy) of
654 (MissingToken _, MissingToken _) -> Nothing
655 _ -> Just (IndexedByNode lIndexed lBy)
656 members <- squareBracketList $ commaList parseDomain
657 lOf <- want L_of
658 domain <- parseDomain
659 return $ MatrixDomainNode lMatrix indexByNode members lOf domain
660
661 parseSet :: Parser DomainNode
662 parseSet = do
663 lSet <- need L_set
664 attributes <- optional parseAttributes
665 lOf <- want L_of
666 domain <- parseDomain
667 return $ SetDomainNode lSet attributes lOf domain
668
669 parseMSet :: Parser DomainNode
670 parseMSet = do
671 lMSet <- need L_mset
672 attributes <- optional parseAttributes
673 lOf <- want L_of
674 domain <- parseDomain
675 return $ MSetDomainNode lMSet attributes lOf domain
676
677 parseFunctionDomain :: Parser DomainNode
678 parseFunctionDomain = do
679 lFunction <- need L_function
680 attributes <- optional parseAttributes
681 fromDom <- parseDomain
682 arrow <- want L_LongArrow
683 toDom <- parseDomain
684 return $ FunctionDomainNode lFunction attributes fromDom arrow toDom
685
686 -- where
687 -- parseFunctionAttributes :: Parser (ListNode AttributeNode)
688 -- parseFunctionAttributes = try $ do
689 -- openB <- want L_OpenParen
690 -- lst <- commaList1 parseAttribute
691 -- closeB <- want L_CloseParen
692 -- return $ ListNode openB lst closeB
693
694 parseSequenceDomain :: Parser DomainNode
695 parseSequenceDomain = do
696 lSequence <- need L_sequence
697 attributes <- optional parseAttributes
698 lOf <- want L_of
699 domain <- parseDomain
700 return $ SequenceDomainNode lSequence attributes lOf domain
701
702 parseRelation :: Parser DomainNode
703 parseRelation = do
704 lRelation <- need L_relation
705 attributes <- optional parseAttributes
706 lOf <- want L_of
707 domains <- parenList $ parseSequence L_Times parseDomain
708 return $ RelationDomainNode lRelation attributes lOf domains
709
710 parsePartition :: Parser DomainNode
711 parsePartition = do
712 lPartition <- need L_partition
713 attributes <- optional $ try parseAttributes
714 lFrom <- want L_from
715 domain <- parseDomain
716 return $ PartitionDomainNode lPartition attributes lFrom domain
717
718 parseEnumDomain :: Parser DomainNode
719 parseEnumDomain = do
720 name <- parseIdentifierStrict
721 brackets <- optional $ parenListStrict (commaList parseRange)
722 return $ RangedEnumNode name brackets
723
724 -- (RangedEnumNode name <$> try (parenList (commaList parseRange)))
725 -- <|> return (EnumDomainNode name)
726
727 -- Util
728 parseNameDomain :: Parser NamedDomainNode
729 parseNameDomain = do
730 name <- parseIdentifier
731 lColon <- want L_Colon
732 domain <- parseDomain
733 let definedDomain = case (lColon, domain) of
734 (a, b) | isMissing a && isMissing b -> Nothing
735 (a, b) -> Just (a, b)
736 return $ NameDomainNode name definedDomain
737
738 parseRange :: Parser RangeNode
739 parseRange = ranged <|> singleR
740 where
741 ranged = try $ do
742 lExpr <- optional $ try parseExpressionStrict
743 dots <- need L_DoubleDot
744 rExpr <- optional parseExpressionStrict
745 case (lExpr, rExpr) of
746 (Nothing, Nothing) -> return $ OpenRangeNode dots
747 (Just l, Nothing) -> return $ RightUnboundedRangeNode l dots
748 (Nothing, Just r) -> return $ LeftUnboundedRangeNode dots r
749 (Just l, Just r) -> return $ BoundedRangeNode l dots r
750 singleR = SingleRangeNode <$> parseExpressionStrict
751
752 parseAttributes :: Parser (ListNode AttributeNode)
753 parseAttributes = try $ do
754 attrs <- parenList (commaList parseAttribute)
755 case attrs of
756 ListNode _ (Seq xs) _ | not (validInterior xs) -> empty
757 _ -> return attrs
758 where
759 validInterior :: [SeqElem AttributeNode] -> Bool
760 validInterior members =
761 not
762 $ null
763 [ x
764 | (SeqElem (NamedAttributeNode x _) _) <- members,
765 isNonIdentifier x
766 ]
767 isNonIdentifier :: SToken -> Bool
768 isNonIdentifier (StrictToken _ ETok {lexeme = (LIdentifier _)}) = False
769 isNonIdentifier _ = True
770
771 parseAttribute :: Parser AttributeNode
772 parseAttribute = do
773 name <- parseAttributeLexeme <|> StrictToken [] <$> identifier
774 expr <- optional parseExpressionStrict
775 return $ NamedAttributeNode name expr
776
777 parseMissingDomain :: Parser DomainNode
778 parseMissingDomain =
779 do
780 m <- makeMissing (L_Missing MissingDomain)
781 return $ MissingDomainNode m
782 <?> "Anything"
783
784 ---------------------------------------
785 ---EXAMPLES AND TESTING ----
786 ---------------------------------------
787 example :: String -> IO ()
788 example s = do
789 let str = s
790 let txt = T.pack str
791 let lexed = runParser eLex "lexer" txt
792 case lexed of
793 Left peb -> putStrLn "Lexer error:" >> putStrLn (errorBundlePretty peb)
794 Right ets -> do
795 putStrLn $ "Lexed " ++ show (length ets) ++ " symbols"
796 print $ take 100 ets
797 putStrLn "reformed"
798 -- putTextLn $ reformList ets
799 let stream = ETokenStream txt ets
800 case runParser parseProgram "parser" stream of
801 Left peb -> putStrLn "Parser error: " >> putStrLn (errorBundlePretty peb)
802 Right pt -> do
803 print $ show pt
804 putStrLn "Reforming"
805 print $ reformList (flattenSeq pt) == L.fromStrict txt
806
807 putStrLn "Pretty:"
808 let pp = renderAST 80 pt
809 putStrLn $ T.unpack pp
810
811 -- let flat = flatten pt
812 -- putStrLn $ show $ flat
813 -- putTextLn $ reformList $ flat
814
815 exampleFile :: String -> IO ()
816 exampleFile p = do
817 path <- readFileIfExists p
818 case path of
819 Nothing -> putStrLn "NO such file"
820 Just s -> example s
821 return ()