Parser.hs (22606B)
1 module Parser where 2 3 import Lexer 4 import Research 5 6 import Control.Monad (void) 7 import Data.Void (Void) 8 import Text.Megaparsec 9 10 import qualified Data.List.NonEmpty as NE 11 import qualified Data.Set as Set 12 13 type TokParser = Parsec Void [LToken] 14 15 data Context = Top | Nested 16 deriving (Eq, Show) 17 18 reservedNames :: Set.Set String 19 reservedNames = Set.fromList ["t", "!result", "let", "in", "where", "do"] 20 21 parseTricu :: String -> [TricuAST] 22 parseTricu input = 23 let toks = lexTricu input 24 in case runParser programP "" toks of 25 Left err -> errorWithoutStackTrace (handleParseError toks err) 26 Right asts -> asts 27 28 parseSingle :: String -> TricuAST 29 parseSingle input = 30 let toks = lexTricu input 31 in case parseSingleExpr toks of 32 Left err -> errorWithoutStackTrace (handleParseError toks err) 33 Right ast -> ast 34 35 parseProgram :: [LToken] -> Either (ParseErrorBundle [LToken] Void) [TricuAST] 36 parseProgram = runParser programP "" 37 38 parseSingleExpr :: [LToken] -> Either (ParseErrorBundle [LToken] Void) TricuAST 39 parseSingleExpr = runParser singleP "" 40 41 programP :: TokParser [TricuAST] 42 programP = do 43 skipTopNewlines 44 imports <- many (importP <* skipTopNewlines) 45 items <- manyItemsP 46 eof 47 pure (imports ++ items) 48 49 singleP :: TokParser TricuAST 50 singleP = do 51 skipTopNewlines 52 item <- topItemP 53 skipTopNewlines 54 eof 55 pure item 56 57 manyItemsP :: TokParser [TricuAST] 58 manyItemsP = do 59 skipTopNewlines 60 done <- atEndP 61 if done 62 then pure [] 63 else do 64 item <- topItemP 65 skipTopNewlines 66 rest <- manyItemsP 67 pure (item : rest) 68 69 topItemP :: TokParser TricuAST 70 topItemP = do 71 toks <- getInput 72 case definitionHeadTop toks of 73 Just _ -> definitionP 74 Nothing -> exprTopP 75 76 definitionHeadTop :: [LToken] -> Maybe (String, [String]) 77 definitionHeadTop toks = 78 case toks of 79 LIdentifier name : rest 80 | name `Set.notMember` reservedNames 81 , definitionAssignOnLine rest -> Just (name, []) 82 _ -> Nothing 83 84 -- A top-level definition head is any identifier-led line containing `=` or `=@`. 85 -- Detailed validation happens in definitionP. 86 definitionAssignOnLine :: [LToken] -> Bool 87 definitionAssignOnLine [] = False 88 definitionAssignOnLine (LNewline : _) = False 89 definitionAssignOnLine (LAssign : _) = True 90 definitionAssignOnLine (LAssignAt : _) = True 91 definitionAssignOnLine (LIdentifier "where" : _) = False 92 definitionAssignOnLine (LIdentifier "in" : _) = False 93 definitionAssignOnLine (_ : rest) = definitionAssignOnLine rest 94 95 definitionP :: TokParser TricuAST 96 definitionP = do 97 name <- identifierNameP 98 (args, annotated) <- definitionArgsP False 99 ret <- optional returnAnnotationP 100 bodyIndent <- skipNestedNewlinesGetIndent 101 body <- exprAtIndentP bodyIndent 102 if annotated || ret /= Nothing 103 then pure (SDefAnn name args ret body) 104 else pure (SDef name (binderNames args) body) 105 106 binderNames :: [DefArg] -> [String] 107 binderNames [] = [] 108 binderNames (DefBinder name _ : rest) = name : binderNames rest 109 binderNames (DefPhantom _ : rest) = binderNames rest 110 111 definitionArgsP :: Bool -> TokParser ([DefArg], Bool) 112 definitionArgsP seenPhantom = do 113 mt <- peekP 114 case mt of 115 Just LAssign -> do 116 void (tok (== LAssign) "=") 117 pure ([], False) 118 Just LAssignAt -> pure ([], False) 119 Just (LIdentifier _) | not seenPhantom -> do 120 name <- identifierNameP 121 mAnn <- optional (try (tok (== LAt) "@" *> annotationTypeP)) 122 (rest, ann) <- definitionArgsP seenPhantom 123 pure (DefBinder name mAnn : rest, ann || mAnn /= Nothing) 124 Just LAt -> do 125 void (tok (== LAt) "@") 126 ty <- annotationTypeP 127 (rest, ann) <- definitionArgsP True 128 pure (DefPhantom ty : rest, True || ann) 129 Just (LIdentifier _) -> fail "named binders cannot appear after phantom type annotations" 130 _ -> fail "expected definition argument or assignment" 131 132 returnAnnotationP :: TokParser ViewExpr 133 returnAnnotationP = do 134 void (tok (== LAssignAt) "=@") 135 annotationTypeP 136 137 annotationTypeP :: TokParser ViewExpr 138 annotationTypeP = 139 atomicTypeP 140 <|> parenTypeP 141 142 parenTypeP :: TokParser ViewExpr 143 parenTypeP = do 144 void (tok (== LOpenParen) "(") 145 ty <- typeP 146 void (tok (== LCloseParen) ")") 147 pure ty 148 149 typeP :: TokParser ViewExpr 150 typeP = appTypeP 151 152 appTypeP :: TokParser ViewExpr 153 appTypeP = do 154 first <- typeAtomP 155 rest <- many typeAtomP 156 pure (foldl VEApp first rest) 157 158 typeAtomP :: TokParser ViewExpr 159 typeAtomP = 160 typeListP 161 <|> typeStringP 162 <|> typeIntP 163 <|> atomicTypeP 164 <|> parenTypeP 165 166 typeListP :: TokParser ViewExpr 167 typeListP = do 168 void (tok (== LOpenBracket) "[") 169 args <- many typeP 170 void (tok (== LCloseBracket) "]") 171 pure (VEList args) 172 173 typeIntP :: TokParser ViewExpr 174 typeIntP = do 175 n <- tok isInt "integer" 176 case n of 177 LIntegerLiteral i -> pure (VEInt (fromIntegral i)) 178 _ -> fail "internal parser error: expected integer" 179 where 180 isInt (LIntegerLiteral _) = True 181 isInt _ = False 182 183 typeStringP :: TokParser ViewExpr 184 typeStringP = do 185 s <- tok isString "string" 186 case s of 187 LStringLiteral value -> pure (VEString value) 188 _ -> fail "internal parser error: expected string" 189 where 190 isString (LStringLiteral _) = True 191 isString _ = False 192 193 atomicTypeP :: TokParser ViewExpr 194 atomicTypeP = do 195 t <- tok isTypeName "type name" 196 case t of 197 LNamespace name -> pure (VEName name) 198 LIdentifier name 199 | isViewVarName name -> pure (VEVar name) 200 | otherwise -> pure (VEName name) 201 _ -> fail "internal parser error: expected type name" 202 where 203 isViewVarName ('_' : rest) = not (null rest) 204 isViewVarName _ = False 205 206 isTypeName :: LToken -> Bool 207 isTypeName (LNamespace _) = True 208 isTypeName (LIdentifier _) = True 209 isTypeName _ = False 210 211 importP :: TokParser TricuAST 212 importP = do 213 t <- tok isImport "import" 214 case t of 215 LImport path ns -> pure (SImport path ns) 216 _ -> fail "internal parser error: expected import token" 217 where 218 isImport (LImport _ _) = True 219 isImport _ = False 220 221 exprTopP :: TokParser TricuAST 222 exprTopP = do 223 toks <- getInput 224 case lambdaHeadTop toks of 225 Just params -> lambdaP Top params 226 Nothing -> whereChainP pipeTopP 227 228 exprNestedP :: TokParser TricuAST 229 exprNestedP = do 230 skipNestedNewlines 231 toks <- getInput 232 case lambdaHeadNested toks of 233 Just params -> lambdaP Nested params 234 Nothing -> whereChainP pipeNestedP 235 236 exprAtIndentP :: Int -> TokParser TricuAST 237 exprAtIndentP n = do 238 toks <- getInput 239 case lambdaHeadTop toks of 240 Just params -> lambdaP Top params 241 Nothing -> whereChainP (pipeAtIndentP n) 242 243 lambdaP :: Context -> [String] -> TokParser TricuAST 244 lambdaP ctx params = do 245 consumeLambdaHead ctx params 246 body <- case ctx of 247 Top -> exprTopP 248 Nested -> exprNestedP 249 pure (foldr (\p acc -> SLambda [p] acc) body params) 250 251 lambdaHeadTop :: [LToken] -> Maybe [String] 252 lambdaHeadTop toks = 253 case collectIdentifiersNoNewlines toks of 254 (params@(_:_), LColon : _) -> Just params 255 _ -> Nothing 256 257 lambdaHeadNested :: [LToken] -> Maybe [String] 258 lambdaHeadNested toks = 259 case collectIdentifiersWithNewlines (dropNewlines toks) of 260 (params@(_:_), rest) -> 261 case dropNewlines rest of 262 LColon : _ -> Just params 263 _ -> Nothing 264 _ -> Nothing 265 266 collectIdentifiersNoNewlines :: [LToken] -> ([String], [LToken]) 267 collectIdentifiersNoNewlines (LIdentifier name : rest) 268 | name `Set.notMember` reservedNames = 269 let (names, final) = collectIdentifiersNoNewlines rest 270 in (name : names, final) 271 collectIdentifiersNoNewlines rest = ([], rest) 272 273 collectIdentifiersWithNewlines :: [LToken] -> ([String], [LToken]) 274 collectIdentifiersWithNewlines (LIdentifier name : rest) 275 | name `Set.notMember` reservedNames = 276 let (names, final) = collectIdentifiersWithNewlines (dropNewlines rest) 277 in (name : names, final) 278 collectIdentifiersWithNewlines rest = ([], rest) 279 280 consumeLambdaHead :: Context -> [String] -> TokParser () 281 consumeLambdaHead ctx params = do 282 case ctx of 283 Top -> pure () 284 Nested -> skipNestedNewlines 285 286 mapM_ consumeParam params 287 288 case ctx of 289 Top -> pure () 290 Nested -> skipNestedNewlines 291 292 void (tok (== LColon) ":") 293 skipNestedNewlines 294 where 295 consumeParam _ = do 296 void identifierNameP 297 case ctx of 298 Top -> pure () 299 Nested -> skipNestedNewlines 300 301 data PipeOp = PipeBackward | PipeForward 302 deriving (Eq, Show) 303 304 applyPipe :: TricuAST -> (PipeOp, TricuAST) -> TricuAST 305 applyPipe acc (PipeBackward, rhs) = 306 SApp acc rhs 307 308 applyPipe acc (PipeForward, rhs) = 309 SApp rhs acc 310 311 pipeTopP :: TokParser TricuAST 312 pipeTopP = 313 pipeAtIndentP 0 314 315 pipeAtIndentP :: Int -> TokParser TricuAST 316 pipeAtIndentP n = 317 pipeChainP (appAtIndentP n) (appAtIndentP n) 318 319 pipeNestedP :: TokParser TricuAST 320 pipeNestedP = 321 pipeChainP appNestedP appNestedP 322 323 pipeChainP :: TokParser TricuAST -> TokParser TricuAST -> TokParser TricuAST 324 pipeChainP parseFirst parseOperand = do 325 first <- parseFirst 326 rest <- many (try pipeSegmentP) 327 pure (foldl applyPipe first rest) 328 where 329 pipeSegmentP = do 330 skipNestedNewlines 331 op <- pipeOpP 332 skipNestedNewlines 333 rhs <- parseOperand 334 pure (op, rhs) 335 336 pipeOpP :: TokParser PipeOp 337 pipeOpP = 338 (tok (== LArrowLeft) "<|" *> pure PipeBackward) 339 <|> (tok (== LArrowRight) "|>" *> pure PipeForward) 340 341 appTopP :: TokParser TricuAST 342 appTopP = appAtIndentP 0 343 344 appAtIndentP :: Int -> TokParser TricuAST 345 appAtIndentP n = do 346 first <- atomTopP 347 appRestAtIndentP n first 348 349 appRestAtIndentP :: Int -> TricuAST -> TokParser TricuAST 350 appRestAtIndentP currentIndent acc = do 351 toks <- getInput 352 let shouldContinue = case toks of 353 LNewline : LIndent n : rest 354 | currentIndent > 0 355 , n > currentIndent 356 , not (isIndentedTerminator rest) 357 , Just t <- firstNonLayout rest -> startsAtom t && not (isExprTerminator t) 358 _ -> False 359 if shouldContinue 360 then do 361 indentedNewlineP 362 arg <- atomTopP 363 appRestAtIndentP currentIndent (SApp acc arg) 364 else do 365 mt <- peekP 366 case mt of 367 Just t | startsAtom t && not (isExprTerminator t) -> do 368 arg <- atomTopP 369 appRestAtIndentP currentIndent (SApp acc arg) 370 _ -> pure acc 371 372 isIndentedTerminator :: [LToken] -> Bool 373 isIndentedTerminator toks = 374 case dropLayout toks of 375 LIdentifier "where" : _ -> True 376 rest -> definitionHeadTop rest /= Nothing 377 378 firstNonLayout :: [LToken] -> Maybe LToken 379 firstNonLayout toks = 380 case dropLayout toks of 381 [] -> Nothing 382 x : _ -> Just x 383 384 dropLayout :: [LToken] -> [LToken] 385 dropLayout (LNewline : rest) = dropLayout rest 386 dropLayout (LIndent _ : rest) = dropLayout rest 387 dropLayout rest = rest 388 389 appNestedP :: TokParser TricuAST 390 appNestedP = do 391 first <- atomNestedP 392 appRestNestedP first 393 394 appRestNestedP :: TricuAST -> TokParser TricuAST 395 appRestNestedP acc = do 396 skipNestedNewlines 397 mt <- peekP 398 case mt of 399 Just t | startsAtom t && not (isExprTerminator t) -> do 400 arg <- atomNestedP 401 appRestNestedP (SApp acc arg) 402 _ -> pure acc 403 404 startsAtom :: LToken -> Bool 405 startsAtom LOpenParen = True 406 startsAtom LOpenBracket = True 407 startsAtom (LIdentifier _) = True 408 startsAtom (LIdentifierWithHash _ _) = True 409 startsAtom (LNamespace _) = True 410 startsAtom LKeywordT = True 411 startsAtom (LIntegerLiteral _) = True 412 startsAtom (LStringLiteral _) = True 413 startsAtom _ = False 414 415 isExprTerminator :: LToken -> Bool 416 isExprTerminator (LIdentifier "in") = True 417 isExprTerminator (LIdentifier "where") = True 418 isExprTerminator _ = False 419 420 atomTopP :: TokParser TricuAST 421 atomTopP = do 422 toks <- getInput 423 case toks of 424 LOpenParen : _ -> groupedP 425 LOpenBracket : _ -> listP 426 LIdentifier _ : LDot : _ -> namespacedVarP 427 LNamespace _ : LDot : _ -> namespacedVarP 428 LIdentifier "let" : _ -> letP 429 LIdentifier "do" : _ -> doP 430 LIdentifier name : _ 431 | name == "in" || name == "where" -> fail ("unexpected reserved word: " ++ name) 432 | otherwise -> plainVarP 433 LIdentifierWithHash _ _ : _ -> plainVarP 434 LKeywordT : _ -> leafP 435 LIntegerLiteral _ : _ -> intP 436 LStringLiteral _ : _ -> strP 437 _ -> fail "expected expression atom" 438 439 atomNestedP :: TokParser TricuAST 440 atomNestedP = skipNestedNewlines *> atomTopP 441 442 groupedP :: TokParser TricuAST 443 groupedP = do 444 void (tok (== LOpenParen) "(") 445 skipNestedNewlines 446 expr <- exprNestedP 447 skipNestedNewlines 448 void (tok (== LCloseParen) ")") 449 pure expr 450 451 listP :: TokParser TricuAST 452 listP = do 453 void (tok (== LOpenBracket) "[") 454 skipNestedNewlines 455 xs <- listElementsP 456 skipNestedNewlines 457 void (tok (== LCloseBracket) "]") 458 pure (SList xs) 459 460 listElementsP :: TokParser [TricuAST] 461 listElementsP = do 462 skipNestedNewlines 463 mt <- peekP 464 case mt of 465 Just LCloseBracket -> pure [] 466 Just t | startsAtom t -> do 467 x <- listElementP 468 xs <- listElementsP 469 pure (x : xs) 470 _ -> pure [] 471 472 listElementP :: TokParser TricuAST 473 listElementP = do 474 toks <- getInput 475 case toks of 476 LOpenParen : _ -> groupedP 477 LOpenBracket : _ -> listP 478 LIdentifier _ : LDot : _ -> namespacedVarP 479 LNamespace _ : LDot : _ -> namespacedVarP 480 LIdentifier "let" : _ -> letP 481 LIdentifier "do" : _ -> doP 482 LIdentifier name : _ 483 | name == "in" || name == "where" -> fail ("unexpected reserved word: " ++ name) 484 | otherwise -> plainVarP 485 LIdentifierWithHash _ _ : _ -> plainVarP 486 LKeywordT : _ -> leafP 487 LIntegerLiteral _ : _ -> intP 488 LStringLiteral _ : _ -> strP 489 _ -> fail "expected list element" 490 491 whereChainP :: TokParser TricuAST -> TokParser TricuAST 492 whereChainP parseBody = do 493 body <- parseBody 494 mWhere <- optional (try whereBindingP) 495 case mWhere of 496 Nothing -> pure body 497 Just (name, args, value) -> 498 let boundValue = foldr (\p acc -> SLambda [p] acc) value args 499 in pure (SLet name boundValue body) 500 501 whereBindingP :: TokParser (String, [String], TricuAST) 502 whereBindingP = do 503 skipNestedNewlines 504 void (keywordIdentifierP "where") 505 skipNestedNewlines 506 name <- identifierNameP 507 args <- many identifierNameP 508 void (tok (== LAssign) "=") 509 valueIndent <- skipNestedNewlinesGetIndent 510 value <- exprAtIndentP valueIndent 511 pure (name, args, value) 512 513 letP :: TokParser TricuAST 514 letP = do 515 void (keywordIdentifierP "let") 516 skipNestedNewlines 517 name <- identifierNameP 518 args <- many identifierNameP 519 void (tok (== LAssign) "=") 520 valueIndent <- skipNestedNewlinesGetIndent 521 value <- exprAtIndentP valueIndent 522 skipNestedNewlines 523 void (keywordIdentifierP "in") 524 bodyIndent <- skipNestedNewlinesGetIndent 525 body <- exprAtIndentP bodyIndent 526 let boundValue = foldr (\p acc -> SLambda [p] acc) value args 527 pure (SLet name boundValue body) 528 529 data DoStmt 530 = DoBind String TricuAST 531 | DoExpr TricuAST 532 deriving (Eq, Show) 533 534 doP :: TokParser TricuAST 535 doP = do 536 void (keywordIdentifierP "do") 537 skipNestedNewlines 538 bindOp <- atomTopP 539 blockIndent <- requireIndentedBlockP 540 stmts <- doBlockP blockIndent 541 lowerDo bindOp stmts 542 543 doBlockP :: Int -> TokParser [DoStmt] 544 doBlockP blockIndent = do 545 first <- doStmtP blockIndent 546 rest <- many (try (sameIndentP blockIndent *> doStmtP blockIndent)) 547 pure (first : rest) 548 549 doStmtP :: Int -> TokParser DoStmt 550 doStmtP blockIndent = do 551 toks <- getInput 552 case toks of 553 LIdentifier name : LBindArrow : _ -> do 554 void identifierNameP 555 void (tok (== LBindArrow) "<-") 556 exprIndent <- skipNestedNewlinesGetIndent 557 DoBind name <$> exprAtIndentP (max blockIndent exprIndent) 558 _ -> DoExpr <$> exprAtIndentP blockIndent 559 560 lowerDo :: TricuAST -> [DoStmt] -> TokParser TricuAST 561 lowerDo _ [] = fail "do block must contain at least one statement" 562 lowerDo _ [DoExpr expr] = pure expr 563 lowerDo bindOp [DoBind _ _] = fail "last do statement must be an expression" 564 lowerDo bindOp (DoBind name action : rest) = do 565 body <- lowerDo bindOp rest 566 pure (SApp (SApp bindOp action) (SLambda [name] body)) 567 lowerDo bindOp (DoExpr action : rest) = do 568 body <- lowerDo bindOp rest 569 pure (SApp (SApp bindOp action) (SLambda ["_"] body)) 570 571 requireIndentedBlockP :: TokParser Int 572 requireIndentedBlockP = do 573 void (tok (== LNewline) "newline") 574 t <- tok isIndent "indent" 575 case t of 576 LIndent n | n > 0 -> pure n 577 _ -> fail "expected indented do block" 578 579 sameIndentP :: Int -> TokParser () 580 sameIndentP n = do 581 void (tok (== LNewline) "newline") 582 t <- tok isIndent "indent" 583 case t of 584 LIndent m | m == n -> pure () 585 _ -> fail "expected do statement at same indentation" 586 587 keywordIdentifierP :: String -> TokParser LToken 588 keywordIdentifierP name = tok (== LIdentifier name) name 589 590 leafP :: TokParser TricuAST 591 leafP = tok (== LKeywordT) "t" *> pure TLeaf 592 593 plainVarP :: TokParser TricuAST 594 plainVarP = do 595 t <- tok isVar "identifier" 596 case t of 597 LIdentifier name -> pure (SVar name Nothing) 598 LIdentifierWithHash name hash -> pure (SVar name (Just hash)) 599 _ -> fail "internal parser error: expected identifier" 600 where 601 isVar (LIdentifier _) = True 602 isVar (LIdentifierWithHash _ _) = True 603 isVar _ = False 604 605 namespacedVarP :: TokParser TricuAST 606 namespacedVarP = do 607 nsTok <- tok isNamespace "namespace" 608 void (tok (== LDot) ".") 609 nameTok <- tok isVar "identifier" 610 case (nsTok, nameTok) of 611 (LIdentifier ns, LIdentifier name) -> 612 pure (SVar (ns ++ "." ++ name) Nothing) 613 (LIdentifier ns, LIdentifierWithHash name hash) -> 614 pure (SVar (ns ++ "." ++ name) (Just hash)) 615 (LNamespace ns, LIdentifier name) -> 616 pure (SVar (ns ++ "." ++ name) Nothing) 617 (LNamespace ns, LIdentifierWithHash name hash) -> 618 pure (SVar (ns ++ "." ++ name) (Just hash)) 619 _ -> fail "internal parser error: expected namespaced identifier" 620 where 621 isNamespace (LIdentifier name) = name `Set.notMember` reservedNames 622 isNamespace (LNamespace _) = True 623 isNamespace _ = False 624 625 isVar (LIdentifier _) = True 626 isVar (LIdentifierWithHash _ _) = True 627 isVar _ = False 628 629 intP :: TokParser TricuAST 630 intP = do 631 t <- tok isInt "integer" 632 case t of 633 LIntegerLiteral n -> pure (SInt (fromIntegral n)) 634 _ -> fail "internal parser error: expected integer" 635 where 636 isInt (LIntegerLiteral _) = True 637 isInt _ = False 638 639 strP :: TokParser TricuAST 640 strP = do 641 t <- tok isStr "string" 642 case t of 643 LStringLiteral s -> pure (SStr s) 644 _ -> fail "internal parser error: expected string" 645 where 646 isStr (LStringLiteral _) = True 647 isStr _ = False 648 649 identifierNameP :: TokParser String 650 identifierNameP = do 651 t <- tok isIdentifier "identifier" 652 case t of 653 LIdentifier name 654 | name `Set.member` reservedNames -> 655 fail ("reserved name cannot be used as identifier: " ++ name) 656 | otherwise -> 657 pure name 658 _ -> fail "internal parser error: expected identifier" 659 where 660 isIdentifier (LIdentifier _) = True 661 isIdentifier _ = False 662 663 tok :: (LToken -> Bool) -> String -> TokParser LToken 664 tok predicate expected = satisfy predicate <?> expected 665 666 peekP :: TokParser (Maybe LToken) 667 peekP = do 668 toks <- getInput 669 pure $ case toks of 670 [] -> Nothing 671 x : _ -> Just x 672 673 atEndP :: TokParser Bool 674 atEndP = null <$> getInput 675 676 skipTopNewlines :: TokParser () 677 skipTopNewlines = skipMany newlineWithOptionalIndentP 678 679 skipNestedNewlines :: TokParser () 680 skipNestedNewlines = void skipNestedNewlinesGetIndent 681 682 skipNestedNewlinesGetIndent :: TokParser Int 683 skipNestedNewlinesGetIndent = go 0 684 where 685 go lastIndent = do 686 mt <- optional (try newlineWithOptionalIndentValueP) 687 case mt of 688 Nothing -> pure lastIndent 689 Just n -> go n 690 691 newlineWithOptionalIndentP :: TokParser () 692 newlineWithOptionalIndentP = void newlineWithOptionalIndentValueP 693 694 newlineWithOptionalIndentValueP :: TokParser Int 695 newlineWithOptionalIndentValueP = do 696 void (tok (== LNewline) "newline") 697 mt <- optional indentP 698 pure $ case mt of 699 Just (LIndent n) -> n 700 _ -> 0 701 702 indentedNewlineP :: TokParser () 703 indentedNewlineP = do 704 void (tok (== LNewline) "newline") 705 t <- tok isIndent "indent" 706 case t of 707 LIndent n | n > 0 -> pure () 708 _ -> fail "expected indented continuation" 709 710 indentP :: TokParser LToken 711 indentP = tok isIndent "indent" 712 713 isIndent :: LToken -> Bool 714 isIndent (LIndent _) = True 715 isIndent _ = False 716 717 dropNewlines :: [LToken] -> [LToken] 718 dropNewlines (LNewline : LIndent _ : rest) = dropNewlines rest 719 dropNewlines (LNewline : rest) = dropNewlines rest 720 dropNewlines rest = rest 721 722 handleParseError :: [LToken] -> ParseErrorBundle [LToken] Void -> String 723 handleParseError toks bundle = 724 unlines 725 ( "Parse error(s) encountered:" 726 : map (formatError toks) (NE.toList (bundleErrors bundle)) 727 ) 728 729 formatError :: [LToken] -> ParseError [LToken] Void -> String 730 formatError toks err = 731 case err of 732 TrivialError offset unexpected expected -> 733 let unexpectedMsg = 734 case unexpected of 735 Nothing -> "unexpected end of input" 736 Just x -> "unexpected " ++ show x 737 expectedMsg = 738 if Set.null expected 739 then "" 740 else "; expected one of " ++ show (Set.toList expected) 741 in 742 "Parse error at token offset " ++ show offset ++ ": " ++ unexpectedMsg ++ expectedMsg 743 ++ "\nToken context:\n" ++ tokenContext toks offset 744 745 FancyError offset fancy -> 746 "Parse error at token offset " ++ show offset ++ ": " ++ show (Set.toList fancy) 747 ++ "\nToken context:\n" ++ tokenContext toks offset 748 749 tokenContext :: [LToken] -> Int -> String 750 tokenContext toks off = 751 let start = max 0 (off - 5) 752 end = min (length toks) (off + 6) 753 rows = zip [start ..] (take (end - start) (drop start toks)) 754 in unlines (map render rows) 755 where 756 render (i, token) 757 | i == off = ">>> " ++ show i ++ ": " ++ show token 758 | otherwise = " " ++ show i ++ ": " ++ show token