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 parsePermutationLiteral,
285 parseRelationLiteral,
286 parsePartitionLiteral
287 ]
288
289 parseShortTupleLiteral :: Parser LiteralNode
290 parseShortTupleLiteral = try $ do
291 lOpen <- needWeak L_OpenParen
292 exprs <- commaList parseExpression
293 let Seq xs = exprs
294 guard (length xs > 1)
295 lClose <- want L_CloseParen
296 return $ TupleLiteralNodeShort $ ShortTuple (ListNode lOpen exprs lClose)
297
298 parseIntLiteral :: Parser LiteralNode
299 parseIntLiteral = do
300 lit <- intLiteral
301 maybe_tag <- optional $ do
302 cln <- want L_Colon
303 idn <- identifier
304 return (cln, idn)
305 return $ IntLiteral (StrictToken [] lit) maybe_tag
306
307 parseBoolLiteral :: Parser LiteralNode
308 parseBoolLiteral = BoolLiteral <$> (need L_true <|> need L_false)
309
310 parseTupleLiteral :: Parser LiteralNode
311 parseTupleLiteral = do
312 lTuple <- need L_tuple
313 members <- parenList $ commaList parseExpression
314 return $ TupleLiteralNode $ LongTuple lTuple members
315
316 parseRecordLiteral :: Parser LiteralNode
317 parseRecordLiteral = do
318 lRecord <- need L_record
319 members <- curlyBracketList (commaList parseRecordMember)
320 return $ RecordLiteral lRecord members
321
322 parseVariantLiteral :: Parser LiteralNode
323 parseVariantLiteral = do
324 lVariant <- need L_variant
325 members <- curlyBracketList (commaList parseRecordMember)
326 return $ VariantLiteral lVariant members
327
328 parseRecordMember :: Parser RecordMemberNode
329 parseRecordMember = do
330 name <- parseIdentifier
331 lEqual <- want L_Eq
332 val <- parseExpression
333 return $ RecordMemberNode name lEqual val
334
335 parseSetLiteral :: Parser LiteralNode
336 parseSetLiteral = do
337 -- cant just recycle list as it does not require first char
338 lOpen <- needWeak L_OpenCurly
339 members <- commaList parseExpression
340 lClose <- want L_CloseCurly
341 return $ SetLiteral (ListNode lOpen members lClose)
342
343 parseMSetLiteral :: Parser LiteralNode
344 parseMSetLiteral = do
345 lMSet <- need L_mset
346 members <- parenList (commaList parseExpression)
347 return $ MSetLiteral lMSet members
348
349 parseFunctionLiteral :: Parser LiteralNode
350 parseFunctionLiteral = do
351 lFunc <- need L_function
352 args <- parenList (commaList parseArrowPair)
353 return $ FunctionLiteral lFunc args
354
355 parseArrowPair :: Parser ArrowPairNode
356 parseArrowPair = try $ do
357 lhs <- parseExpression
358 arrow <- want L_LongArrow
359 rhs <- parseExpression
360 return $ ArrowPairNode lhs arrow rhs
361
362 parseSequenceLiteral :: Parser LiteralNode
363 parseSequenceLiteral = do
364 lSeq <- need L_sequence
365 members <- parenList (commaList parseExpression)
366 return $ SequenceLiteral lSeq members
367
368 parsePermutationLiteral :: Parser LiteralNode
369 parsePermutationLiteral = do
370 lPer <- need L_permutation
371 members <- parenList (commaList parsePermutationElem)
372 return $ PermutationLiteral lPer members
373
374 parseRelationLiteral :: Parser LiteralNode
375 parseRelationLiteral = do
376 lRel <- need L_relation
377 members <- parenList (commaList parseRelationMember)
378 return $ RelationLiteral lRel members
379
380 parseRelationMember :: Parser RelationElemNode
381 parseRelationMember = try $ do
382 f <- optional $ need L_tuple
383 members <- parenList $ commaList parseExpression
384 case f of
385 Just lTup -> return $ RelationElemNodeLabeled $ LongTuple lTup members
386 Nothing -> case members of
387 ListNode l c r | (isMissing l || isMissing r) && isMissing c -> empty
388 _ -> return $ RelationElemNodeShort $ ShortTuple members
389
390 parsePartitionLiteral :: Parser LiteralNode
391 parsePartitionLiteral = do
392 lPartition <- need L_partition
393 members <- parenList (commaList parsePartitionElem)
394 return $ PartitionLiteral lPartition members
395
396 parsePermutationElem :: Parser PermutationElemNode
397 parsePermutationElem = try $ do
398 lOpen <- needWeak L_OpenParen
399 exprs <- commaList parseExpression
400 let Seq xs = exprs
401 guard (length xs >= 2)
402 lClose <- want L_CloseParen
403 return $ PermutationElemNode $ ListNode lOpen exprs lClose
404
405 parsePartitionElem :: Parser PartitionElemNode
406 parsePartitionElem = PartitionElemNode <$> parseList L_OpenCurly L_CloseCurly (commaList parseExpression)
407
408 parseQuantificationStatement :: Parser QuantificationExpressionNode
409 parseQuantificationStatement = do
410 lType <- choice $ map need quantifiers
411 terms <- commaList parseAbstractPattern
412 over <- parseQuantificationOver
413 qGuard <- optional $ do
414 lComma <- need L_Comma
415 expr <- parseExpression
416 return $ QuanticationGuard lComma expr
417 lDot <- want L_Dot
418 expr <- parseExpression
419 return $ QuantificationExpressionNode lType terms over qGuard lDot expr
420 where
421 parseQuantificationOver :: Parser QuantificationOverNode
422 parseQuantificationOver =
423 choice
424 [ QuantifiedMemberOfNode <$> need L_in <*> parseExpression,
425 QuantifiedSubsetOfNode <$> need L_subsetEq <*> parseExpression,
426 QuantifiedDomainNode <$> (OverDomainNode <$> want L_Colon <*> parseDomain)
427 ]
428
429 parseAbstractPattern :: Parser AbstractPatternNode
430 parseAbstractPattern = do
431 choice
432 [ parseAbstractId,
433 parseAbstractMetaVar,
434 parseAbstractPatternTuple,
435 parseAbstractPatternMatrix,
436 parseAbstractPatternSet
437 ]
438 where
439 parseAbstractId :: Parser AbstractPatternNode
440 parseAbstractId = AbstractIdentifier <$> parseIdentifierStrict
441 parseAbstractMetaVar :: Parser AbstractPatternNode
442 parseAbstractMetaVar = AbstractMetaVar <$> parseMetaVar
443 parseAbstractPatternTuple :: Parser AbstractPatternNode
444 parseAbstractPatternTuple = do
445 lTuple <- optional $ needWeak L_tuple
446 openB <- (if null lTuple then needWeak else want) L_OpenParen
447 es <- commaList parseAbstractPattern
448 closeB <- want L_CloseParen
449 return $ AbstractPatternTuple lTuple (ListNode openB es closeB)
450 parseAbstractPatternMatrix :: Parser AbstractPatternNode
451 parseAbstractPatternMatrix = do
452 openB <- needWeak L_OpenBracket
453 es <- commaList parseAbstractPattern
454 closeB <- want L_CloseBracket
455 return $ AbstractPatternMatrix (ListNode openB es closeB)
456 parseAbstractPatternSet :: Parser AbstractPatternNode
457 parseAbstractPatternSet = do
458 openB <- needWeak L_OpenCurly
459 es <- commaList parseAbstractPattern
460 closeB <- want L_CloseCurly
461 return $ AbstractPatternSet (ListNode openB es closeB)
462
463 parseComprehensionCondition :: Parser ComprehensionBodyNode
464 parseComprehensionCondition = do
465 letting <|> generator <|> condition
466 where
467 letting = do
468 lLetting <- need L_letting
469 v <- parseAbstractPattern
470 lBe <- want L_be
471 expr <- parseExpression
472 return $ CompBodyLettingNode lLetting v lBe expr
473 generator = try $ do
474 pats <- commaList parseAbstractPattern
475 choice
476 [ try $ do
477 lColon <- need L_Colon
478 domain <- parseDomain
479 return $ CompBodyDomain pats lColon domain,
480 try $ do
481 lArrow <- need L_LeftArrow
482 expr <- parseExpression
483 return $ CompBodyGenExpr pats lArrow expr
484 ]
485
486 condition = CompBodyCondition <$> parseExpressionStrict
487
488 parseOperator :: Parser ExpressionNode
489 parseOperator = try (makeExprParser parseAtomicExpressionAndFixes operatorTable <?> "Expression")
490
491 parseFunction :: Parser ExpressionNode
492 parseFunction = try $ do
493 name <- choice $ map need functionals
494 let ol = isOverloaded name
495 let parenP = if ol then parenListStrict else parenList
496 args <- parenP $ commaList parseExpression
497 guard $ not ol || argsHasNoLeadingTrivia args
498 return $ FunctionalApplicationNode name args
499 where
500 isOverloaded (StrictToken _ ETok {lexeme = lex}) = lex `elem` overloadedFunctionals
501 argsHasNoLeadingTrivia (ListNode (RealToken (StrictToken [] ETok {trivia = []})) _ _) = True
502 argsHasNoLeadingTrivia _ = False
503
504 parseAttributeAsConstraint :: Parser ExpressionNode
505 parseAttributeAsConstraint = do
506 name <- parseAttributeLexeme
507 args <- parenList $ commaList parseExpression
508 return $ AttributeAsConstriant name args
509
510 parsePostfixOp :: Parser (ExpressionNode -> ExpressionNode)
511 parsePostfixOp = do
512 op <-
513 try
514 $ choice
515 [ indexed,
516 factorial,
517 application,
518 explicitDomain
519 ]
520 return $ \e -> OperatorExpressionNode $ PostfixOpNode e op
521 where
522 indexed = do
523 lBracket <- need L_OpenBracket
524 indexer <- commaList parseRange
525 rBracket <- want L_CloseBracket
526 return $ IndexedNode $ ListNode (RealToken lBracket) indexer rBracket
527 factorial = OpFactorial <$> need L_ExclamationMark
528 application = do
529 lBracket <- need L_OpenParen
530 args <- commaList parseExpression
531 rBracket <- want L_CloseParen
532 return $ ApplicationNode $ ListNode (RealToken lBracket) args rBracket
533 explicitDomain = try $ do
534 lColon <- need L_Colon
535 lTickl <- need L_BackTick
536 dom <- parseDomain
537 lTickr <- want L_BackTick
538 return $ ExplicitDomain lColon lTickl dom lTickr
539
540 -- TODO treat funcitonals differently or actually don't but why
541
542 operatorTable :: [[Operator Parser ExpressionNode]]
543 operatorTable =
544 let operatorsGrouped =
545 operators
546 |> sortBy (\(_, a) (_, b) -> compare a b)
547 |> groupBy (\(_, a) (_, b) -> a == b)
548 |> reverse
549 in postfixOps
550 : [ [ case descr of
551 BinaryOp op FLeft -> InfixL $ exprBinary <$> need op
552 BinaryOp op FNone -> InfixN $ exprBinary <$> need op
553 BinaryOp op FRight -> InfixR $ exprBinary <$> need op
554 UnaryPrefix op -> prefixOps op
555 | -- UnaryPrefix L_ExclamationMark -> Prefix $ prefixBinary--foldr1 (.) <$> some parseUnaryNot
556 -- UnaryPrefix l -> bug ("Unknown UnaryPrefix" <+> pretty (show l))
557 (descr, _) <- operatorsInGroup
558 ]
559 | operatorsInGroup <- operatorsGrouped
560 ]
561
562 parseAtomicExpressionAndFixes :: Parser ExpressionNode
563 parseAtomicExpressionAndFixes = try $ do
564 let prefixes = do
565 fs <- some parsePrefixes
566 return $ foldr1 (.) fs
567 postfixes = do
568 fs <- some parsePostfixOp
569 return $ foldr1 (.) (reverse fs)
570 withPrefix x = do f <- option id prefixes; i <- x; return $ f i
571 withPostfix x = do
572 i <- x
573 -- guard $ not $ isMissing i ;
574 mf <- optional postfixes
575 return $ fromMaybe id mf i
576 withPrefix (withPostfix parseAtomicExpression) <?> "expression"
577
578 parsePrefixes :: Parser (ExpressionNode -> ExpressionNode)
579 parsePrefixes = choice [parseUnary L_Minus, parseUnary L_ExclamationMark]
580 where
581 parseUnary l = (\e -> OperatorExpressionNode . PrefixOpNode e) <$> need l
582
583 exprBinary :: SToken -> ExpressionNode -> ExpressionNode -> ExpressionNode
584 exprBinary t l = OperatorExpressionNode . BinaryOpNode l t
585
586 prefixOps :: Lexeme -> Operator Parser ExpressionNode
587 prefixOps l = Prefix $ foldr1 (.) <$> some (try opBuilder)
588 where
589 opBuilder :: Parser (ExpressionNode -> ExpressionNode)
590 opBuilder = do
591 t <- need l
592 return (OperatorExpressionNode . PrefixOpNode t)
593
594 postfixOps :: [Operator Parser ExpressionNode]
595 postfixOps =
596 [ Postfix $ foldr1 (.) . reverse <$> some parsePostfixOp
597 ]
598
599 -- DOMAINS
600 parseDomain :: Parser DomainNode
601 parseDomain =
602 do
603 choice
604 [ BoolDomainNode <$> need L_bool,
605 parseIntDomain,
606 MetaVarDomain <$> parseMetaVar,
607 parseTuple,
608 parseRecord,
609 parseVariant,
610 parseMatrix,
611 parseSet,
612 parseMSet,
613 parseFunctionDomain,
614 parseSequenceDomain,
615 parsePermutationDomain,
616 parseRelation,
617 parsePartition,
618 parseEnumDomain,
619 parseShortTuple
620 ]
621 <?> "Domain"
622 <|> parseMissingDomain
623 <?> "missingDomain"
624
625 parseSpecialCase :: Parser ExpressionNode
626 parseSpecialCase = do
627 SpecialCase <$> choice [parseWithDecls]
628 where
629 parseWithDecls = try
630 $ do
631 p1 <- need L_OpenCurly
632 exp1 <- parseExpression
633 lAt <- need L_At
634 (decsl, p2) <- manyTill_ parseTopLevel (need L_CloseCurly)
635 return $ ExprWithDecls p1 exp1 lAt decsl p2
636
637 parseIntDomain :: Parser DomainNode
638 parseIntDomain = do
639 lInt <- need L_int
640 maybe_tag <- optional $ do
641 cln <- want L_Colon
642 idn <- identifier
643 return (cln, idn)
644 ranges <- optional $ parenListStrict $ commaList parseRange
645 return $ RangedIntDomainNode lInt maybe_tag ranges
646
647 parseTuple :: Parser DomainNode
648 parseTuple = do
649 lTuple <- need L_tuple
650 members <- parenList $ commaList parseDomain
651 return $ TupleDomainNode lTuple members
652
653 parseShortTuple :: Parser DomainNode
654 parseShortTuple = do
655 openB <- need L_OpenParen
656 lst <- commaList parseDomain
657 closeB <- want L_CloseParen
658 return $ case lst of
659 Seq [SeqElem d Nothing] -> ParenDomainNode openB d closeB
660 Seq _ -> ShortTupleDomainNode $ ListNode (RealToken openB) lst closeB
661
662 parseRecord :: Parser DomainNode
663 parseRecord = do
664 lRecord <- need L_record
665 members <- curlyBracketList $ commaList parseNameDomain
666 return $ RecordDomainNode lRecord members
667
668 parseVariant :: Parser DomainNode
669 parseVariant = do
670 lVariant <- need L_variant
671 members <- curlyBracketList $ commaList parseNameDomain
672 return $ VariantDomainNode lVariant members
673
674 parseMatrix :: Parser DomainNode
675 parseMatrix = do
676 lMatrix <- need L_matrix
677 lIndexed <- want L_indexed
678 lBy <- want L_by
679 let indexByNode = case (lIndexed, lBy) of
680 (MissingToken _, MissingToken _) -> Nothing
681 _ -> Just (IndexedByNode lIndexed lBy)
682 members <- squareBracketList $ commaList parseDomain
683 lOf <- want L_of
684 domain <- parseDomain
685 return $ MatrixDomainNode lMatrix indexByNode members lOf domain
686
687 parseSet :: Parser DomainNode
688 parseSet = do
689 lSet <- need L_set
690 attributes <- optional parseAttributes
691 lOf <- want L_of
692 domain <- parseDomain
693 return $ SetDomainNode lSet attributes lOf domain
694
695 parseMSet :: Parser DomainNode
696 parseMSet = do
697 lMSet <- need L_mset
698 attributes <- optional parseAttributes
699 lOf <- want L_of
700 domain <- parseDomain
701 return $ MSetDomainNode lMSet attributes lOf domain
702
703 parseFunctionDomain :: Parser DomainNode
704 parseFunctionDomain = do
705 lFunction <- need L_function
706 attributes <- optional parseAttributes
707 fromDom <- parseDomain
708 arrow <- want L_LongArrow
709 toDom <- parseDomain
710 return $ FunctionDomainNode lFunction attributes fromDom arrow toDom
711
712 -- where
713 -- parseFunctionAttributes :: Parser (ListNode AttributeNode)
714 -- parseFunctionAttributes = try $ do
715 -- openB <- want L_OpenParen
716 -- lst <- commaList1 parseAttribute
717 -- closeB <- want L_CloseParen
718 -- return $ ListNode openB lst closeB
719
720 parseSequenceDomain :: Parser DomainNode
721 parseSequenceDomain = do
722 lSequence <- need L_sequence
723 attributes <- optional parseAttributes
724 lOf <- want L_of
725 domain <- parseDomain
726 return $ SequenceDomainNode lSequence attributes lOf domain
727
728 parsePermutationDomain :: Parser DomainNode
729 parsePermutationDomain = do
730 lPermutation <- need L_permutation
731 attributes <- optional parseAttributes
732 lOf <- want L_of
733 domain <- parseDomain
734 return $ PermutationDomainNode lPermutation attributes lOf domain
735
736 parseRelation :: Parser DomainNode
737 parseRelation = do
738 lRelation <- need L_relation
739 attributes <- optional parseAttributes
740 lOf <- want L_of
741 domains <- parenList $ parseSequence L_Times parseDomain
742 return $ RelationDomainNode lRelation attributes lOf domains
743
744 parsePartition :: Parser DomainNode
745 parsePartition = do
746 lPartition <- need L_partition
747 attributes <- optional $ try parseAttributes
748 lFrom <- want L_from
749 domain <- parseDomain
750 return $ PartitionDomainNode lPartition attributes lFrom domain
751
752 parseEnumDomain :: Parser DomainNode
753 parseEnumDomain = do
754 name <- parseIdentifierStrict
755 brackets <- optional $ parenListStrict (commaList parseRange)
756 return $ RangedEnumNode name brackets
757
758 -- (RangedEnumNode name <$> try (parenList (commaList parseRange)))
759 -- <|> return (EnumDomainNode name)
760
761 -- Util
762 parseNameDomain :: Parser NamedDomainNode
763 parseNameDomain = do
764 name <- parseIdentifier
765 lColon <- want L_Colon
766 domain <- parseDomain
767 let definedDomain = case (lColon, domain) of
768 (a, b) | isMissing a && isMissing b -> Nothing
769 (a, b) -> Just (a, b)
770 return $ NameDomainNode name definedDomain
771
772 parseRange :: Parser RangeNode
773 parseRange = ranged <|> singleR
774 where
775 ranged = try $ do
776 lExpr <- optional $ try parseExpressionStrict
777 dots <- need L_DoubleDot
778 rExpr <- optional parseExpressionStrict
779 case (lExpr, rExpr) of
780 (Nothing, Nothing) -> return $ OpenRangeNode dots
781 (Just l, Nothing) -> return $ RightUnboundedRangeNode l dots
782 (Nothing, Just r) -> return $ LeftUnboundedRangeNode dots r
783 (Just l, Just r) -> return $ BoundedRangeNode l dots r
784 singleR = SingleRangeNode <$> parseExpressionStrict
785
786 parseAttributes :: Parser (ListNode AttributeNode)
787 parseAttributes = try $ do
788 attrs <- parenList (commaList parseAttribute)
789 case attrs of
790 ListNode _ (Seq xs) _ | not (validInterior xs) -> empty
791 _ -> return attrs
792 where
793 validInterior :: [SeqElem AttributeNode] -> Bool
794 validInterior members =
795 not
796 $ null
797 [ x
798 | (SeqElem (NamedAttributeNode x _) _) <- members,
799 isNonIdentifier x
800 ]
801 isNonIdentifier :: SToken -> Bool
802 isNonIdentifier (StrictToken _ ETok {lexeme = (LIdentifier _)}) = False
803 isNonIdentifier _ = True
804
805 parseAttribute :: Parser AttributeNode
806 parseAttribute = do
807 name <- parseAttributeLexeme <|> StrictToken [] <$> identifier
808 expr <- optional parseExpressionStrict
809 return $ NamedAttributeNode name expr
810
811 parseMissingDomain :: Parser DomainNode
812 parseMissingDomain =
813 do
814 m <- makeMissing (L_Missing MissingDomain)
815 return $ MissingDomainNode m
816 <?> "Anything"
817
818 ---------------------------------------
819 ---EXAMPLES AND TESTING ----
820 ---------------------------------------
821 example :: String -> IO ()
822 example s = do
823 let str = s
824 let txt = T.pack str
825 let lexed = runParser eLex "lexer" txt
826 case lexed of
827 Left peb -> putStrLn "Lexer error:" >> putStrLn (errorBundlePretty peb)
828 Right ets -> do
829 putStrLn $ "Lexed " ++ show (length ets) ++ " symbols"
830 print $ take 100 ets
831 putStrLn "reformed"
832 -- putTextLn $ reformList ets
833 let stream = ETokenStream txt ets
834 case runParser parseProgram "parser" stream of
835 Left peb -> putStrLn "Parser error: " >> putStrLn (errorBundlePretty peb)
836 Right pt -> do
837 print $ show pt
838 putStrLn "Reforming"
839 print $ reformList (flattenSeq pt) == L.fromStrict txt
840
841 putStrLn "Pretty:"
842 let pp = renderAST 80 pt
843 putStrLn $ T.unpack pp
844
845 -- let flat = flatten pt
846 -- putStrLn $ show $ flat
847 -- putTextLn $ reformList $ flat
848
849 exampleFile :: String -> IO ()
850 exampleFile p = do
851 path <- readFileIfExists p
852 case path of
853 Nothing -> putStrLn "NO such file"
854 Just s -> example s
855 return ()