From 39cfe2035d8af4ec1edecccb2974d778dedc79b8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Wed, 24 Sep 2025 11:01:52 +0000 Subject: [PATCH 1/7] test: freeze the callstack for better failure messages (#1) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This would make the function `shouldLexTo` be transparent in the error reporting! Before all errors would point to this line. Reviewed-on: https://git.elland.me/elland/haddock2/pulls/1 Co-authored-by: Léana 江 Co-committed-by: Léana 江 --- test/Spec.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/test/Spec.hs b/test/Spec.hs index d202ac2..0a7653d 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -11,6 +11,7 @@ import Types import Data.String (IsString (..)) import Data.Text (Text) import Text.Parsec.Pos +import GHC.Stack main :: IO () main = hspec $ do @@ -185,6 +186,7 @@ instance IsString (Doc String) where shouldLexTo :: String -> [(Int, Int, Token)] -> Expectation shouldLexTo input expected = + withFrozenCallStack $ case lexer input of Right tokens -> do let actual = map (\(pos, tok) -> (sourceLine pos, sourceColumn pos, tok)) tokens From fdb9070e99045c0e44b07df2d1a591fa5396d13c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Wed, 24 Sep 2025 18:35:15 +0800 Subject: [PATCH 2/7] fix(lexer): handle crlf in newline MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Do we support windows 🤔 --- src/Lexer.hs | 2 +- test/Spec.hs | 6 +++++- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/src/Lexer.hs b/src/Lexer.hs index e12324b..87f0ee0 100644 --- a/src/Lexer.hs +++ b/src/Lexer.hs @@ -152,7 +152,7 @@ delimitedSymmetric :: Parser a -> Token -> Token -> Parser [LocatedToken] delimitedSymmetric s t1 t2 = delimited s s t1 t2 eol :: Parser () -eol = void "\n" <|> Parsec.eof +eol = void "\n" <|> void "\r\n" <|> Parsec.eof header1 :: Lexer header1 = delimitedMaybe (void $ "= ") eol (Header One) Nothing diff --git a/test/Spec.hs b/test/Spec.hs index 0a7653d..fb9d8b2 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -107,11 +107,15 @@ maths = do ] escaping :: Expectation -escaping = +escaping = do "\\(" `shouldLexTo` [ (1, 1, Escape) , (1, 2, Token "(") ] + "\\(\r\n" + `shouldLexTo` [ (1, 1, Escape) + , (1, 2, Token "(") + ] unicode :: Expectation unicode = From d6087ec3d606f3d1937149ff1cce769ea4d775c0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Wed, 24 Sep 2025 20:15:41 +0800 Subject: [PATCH 3/7] ref(lexer): simplify delimited logic --- src/Lexer.hs | 56 +++++++++++++++++++++++++--------------------------- 1 file changed, 27 insertions(+), 29 deletions(-) diff --git a/src/Lexer.hs b/src/Lexer.hs index 87f0ee0..31f3ac0 100644 --- a/src/Lexer.hs +++ b/src/Lexer.hs @@ -16,6 +16,7 @@ import Text.Parsec import Text.Parsec qualified as Parsec import Text.Parsec.Pos (updatePosChar) +type Located a = (SourcePos, a) type LocatedToken = (SourcePos, Token) type Lexer = Parser [LocatedToken] @@ -125,28 +126,25 @@ headers = , header6 ] -delimitedMaybe :: Parser a -> Parser a -> Token -> Maybe Token -> Parser [LocatedToken] -delimitedMaybe openMark closeMark openToken closeToken = do - openPos <- getPosition - void openMark - tokenPos <- getPosition - content <- anyUntil closeMark - closePos <- getPosition - void closeMark - - let openTok :: LocatedToken = (openPos, openToken) - res :: LocatedToken = (tokenPos, Token content) - closeToks :: [LocatedToken] = case closeToken of - Just close -> [(closePos, close)] - Nothing -> [] - - pure $ [openTok, res] <> closeToks - anyUntil :: Parser a -> Parser Text anyUntil p = Text.pack <$> manyTill anyChar (lookAhead p) -delimited :: Parser a -> Parser a -> Token -> Token -> Parser [LocatedToken] -delimited a b c d = delimitedMaybe a b c (Just d) +delimitedAsTuple :: Parser open -> Parser close -> Parser (Located open, LocatedToken, Located close) +delimitedAsTuple openP closeP = + (,,) + <$> located openP + <*> located (Token <$> anyUntil closeP) + <*> located closeP + +delimited :: Parser a -> Parser b -> Token -> Token -> Parser [LocatedToken] +delimited openP closeP openTok closeTok = asList <$> delimitedAsTuple (openTok <$ openP) (closeTok <$ closeP) + where + asList (a, tok, b) = [a, tok, b] + +delimitedNoTrailing :: Parser a -> Parser b -> Token -> Parser [LocatedToken] +delimitedNoTrailing openP closeP openTok = asList <$> delimitedAsTuple (openTok <$ openP) (void closeP) + where + asList (a, tok, _) = [a, tok] delimitedSymmetric :: Parser a -> Token -> Token -> Parser [LocatedToken] delimitedSymmetric s t1 t2 = delimited s s t1 t2 @@ -155,22 +153,22 @@ eol :: Parser () eol = void "\n" <|> void "\r\n" <|> Parsec.eof header1 :: Lexer -header1 = delimitedMaybe (void $ "= ") eol (Header One) Nothing +header1 = delimitedNoTrailing "= " eol (Header One) header2 :: Lexer -header2 = delimitedMaybe (void $ "== ") eol (Header Two) Nothing +header2 = delimitedNoTrailing "== " eol (Header Two) header3 :: Lexer -header3 = delimitedMaybe (void $ "=== ") eol (Header Three) Nothing +header3 = delimitedNoTrailing "=== " eol (Header Three) header4 :: Lexer -header4 = delimitedMaybe (void $ "==== ") eol (Header Four) Nothing +header4 = delimitedNoTrailing "==== " eol (Header Four) header5 :: Lexer -header5 = delimitedMaybe (void $ "===== ") eol (Header Five) Nothing +header5 = delimitedNoTrailing "===== " eol (Header Five) header6 :: Lexer -header6 = delimitedMaybe (void $ "====== ") eol (Header Six) Nothing +header6 = delimitedNoTrailing "====== " eol (Header Six) -- #anchors# anchors :: Lexer @@ -247,16 +245,16 @@ labeledLink = do ] mathsBracket :: Lexer -mathsBracket = delimited (void $ "\\[") (void "\\]") MathsBracketOpen MathsBracketClose +mathsBracket = delimited "\\[" "\\]" MathsBracketOpen MathsBracketClose mathsParens :: Lexer -mathsParens = delimited (void $ "\\(") (void "\\)") MathsParenOpen MathsParenClose +mathsParens = delimited "\\(" "\\)" MathsParenOpen MathsParenClose birdTrack :: Lexer -birdTrack = delimitedMaybe (void ">> ") eol BirdTrack Nothing +birdTrack = delimitedNoTrailing ">> " eol BirdTrack escape :: Lexer -escape = delimitedMaybe (void "\\") eol Escape Nothing +escape = delimitedNoTrailing "\\" eol Escape quotes :: Lexer quotes = delimitedSymmetric "\"" QuoteOpen QuoteClose From 368e5bc9a0eb923ee2c79d59d7b6cafff3093cc1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Wed, 24 Sep 2025 20:25:48 +0800 Subject: [PATCH 4/7] ref(lexer): simplify anchor --- src/Lexer.hs | 16 +++++++--------- 1 file changed, 7 insertions(+), 9 deletions(-) diff --git a/src/Lexer.hs b/src/Lexer.hs index 31f3ac0..d89ad53 100644 --- a/src/Lexer.hs +++ b/src/Lexer.hs @@ -152,6 +152,9 @@ delimitedSymmetric s t1 t2 = delimited s s t1 t2 eol :: Parser () eol = void "\n" <|> void "\r\n" <|> Parsec.eof +anchorHash :: Parser Text +anchorHash = "#" <|> try "\\#" + header1 :: Lexer header1 = delimitedNoTrailing "= " eol (Header One) @@ -172,15 +175,10 @@ header6 = delimitedNoTrailing "====== " eol (Header Six) -- #anchors# anchors :: Lexer -anchors = do - pos <- getPosition - void $ try anchor' - txt <- anyUntil anchor' - void $ try anchor' - - pure [(pos, Anchor txt)] - where - anchor' = (string "#" <|> string "\\#") +anchors = + tokenise + [ between anchorHash anchorHash (Anchor <$> anyUntil anchorHash) + ] -- "Module.Name" -- "Module.Name#anchor" From 7ceb9b0277f440565436f84a076cd57582dc59e3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Wed, 24 Sep 2025 20:47:55 +0800 Subject: [PATCH 5/7] ref(moduleName): break into multiple smaller functions upperId has been changed to only use isUpper because an non alphabetical character would be false anyway --- src/Lexer.hs | 40 ++++++++++++++++++++-------------------- test/Spec.hs | 9 +++------ 2 files changed, 23 insertions(+), 26 deletions(-) diff --git a/src/Lexer.hs b/src/Lexer.hs index d89ad53..89bafc5 100644 --- a/src/Lexer.hs +++ b/src/Lexer.hs @@ -56,7 +56,7 @@ data Token | MathsBracketOpen | MathsBracketClose | NumericEntity Int - | Module + | Module Text | QuoteOpen | QuoteClose | Space @@ -180,31 +180,31 @@ anchors = [ between anchorHash anchorHash (Anchor <$> anyUntil anchorHash) ] + +moduleName :: Parser Text +moduleName = intercalate "." . fmap Text.pack <$> upperId `sepBy1` char '.' + +upperId :: Parser String +upperId = (:) <$> satisfy isUpper <*> many1 identifierChar + +identifierChar :: Parser Char +identifierChar = satisfy (\c -> isAlphaNum c || c == '_') + -- "Module.Name" -- "Module.Name#anchor" -- "Module.Name\#anchor" -- this has been deprecated for 9 years, thanks Ben modules :: Lexer -modules = do - startPos <- startPosition $ char '"' - (modPos, modName) <- located modId - anch <- option [] do - anchPos <- startPosition (string "#" <|> string' "\\#") - txt <- Text.pack <$> many (satisfy (\c -> c /= '"' && not (isSpace c))) - pure [(anchPos, Anchor txt)] - - void $ char '"' - pure $ [(startPos, Module), (modPos, Token modName)] <> anch +modules = between (char '"') (char '"') inner where - modId = intercalate "." <$> (fmap Text.pack <$> (conId `sepBy1` (char '.'))) + inner = do + module_ <- located $ Module <$> moduleName + mAnchor <- optionMaybe (located $ anchorHash *> (Anchor <$> anchorText)) + pure $ case mAnchor of + Just anchor -> [module_, anchor] + Nothing -> [module_] - conId :: Parser String - conId = - (:) - <$> satisfy (\c -> isAlpha c && isUpper c) - <*> many1 conChar - - conChar :: Parser Char - conChar = satisfy (\c -> isAlphaNum c || c == '_') + anchorText :: Parser Text + anchorText = Text.pack <$> many (satisfy (\c -> c /= '"' && not (isSpace c))) linkRaw :: Lexer linkRaw = diff --git a/test/Spec.hs b/test/Spec.hs index fb9d8b2..a09489e 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -45,19 +45,16 @@ main = hspec $ do modules :: Expectation modules = do "\"MyModule.Name\"" - `shouldLexTo` [ (1, 1, Module) - , (1, 2, Token "MyModule.Name") + `shouldLexTo` [ (1, 2, Module "MyModule.Name") ] "\"OtherModule.Name#myAnchor\"" - `shouldLexTo` [ (1, 1, Module) - , (1, 2, Token "OtherModule.Name") + `shouldLexTo` [ (1, 2, Module "OtherModule.Name") , (1, 18, Anchor "myAnchor") ] "\"OtherModule.Name\\#myAnchor\"" - `shouldLexTo` [ (1, 1, Module) - , (1, 2, Token "OtherModule.Name") + `shouldLexTo` [ (1, 2, Module "OtherModule.Name") , (1, 18, Anchor "myAnchor") ] link :: Expectation From 75c48171669cc973c14e5252d1bbb9a1c117ee58 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Wed, 24 Sep 2025 20:51:05 +0800 Subject: [PATCH 6/7] style(lexer): pluralize moduleNames parser --- src/Lexer.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Lexer.hs b/src/Lexer.hs index 89bafc5..3e98cce 100644 --- a/src/Lexer.hs +++ b/src/Lexer.hs @@ -181,8 +181,8 @@ anchors = ] -moduleName :: Parser Text -moduleName = intercalate "." . fmap Text.pack <$> upperId `sepBy1` char '.' +moduleNames :: Parser Text +moduleNames = intercalate "." . fmap Text.pack <$> upperId `sepBy1` char '.' upperId :: Parser String upperId = (:) <$> satisfy isUpper <*> many1 identifierChar @@ -197,7 +197,7 @@ modules :: Lexer modules = between (char '"') (char '"') inner where inner = do - module_ <- located $ Module <$> moduleName + module_ <- located $ Module <$> moduleNames mAnchor <- optionMaybe (located $ anchorHash *> (Anchor <$> anchorText)) pure $ case mAnchor of Just anchor -> [module_, anchor] From 6c0b4a4288242d72820805e4acd3c122f5d1fe2d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Wed, 24 Sep 2025 21:21:59 +0800 Subject: [PATCH 7/7] doc(lexer): explain the use of incSourceColumn I think it is clearer to phrase it this way so it is clear that we are not unconsuming (i.e. changing the state of the parser). --- src/Lexer.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Lexer.hs b/src/Lexer.hs index 3e98cce..273a0fe 100644 --- a/src/Lexer.hs +++ b/src/Lexer.hs @@ -221,7 +221,7 @@ link :: Lexer link = do pos <- getPosition l <- linkRaw - -- "unconsume" the last token + -- register the position of the last token pos' <- flip incSourceColumn (-1) <$> getPosition pure $ (pos, LinkOpen) : l <> [(pos', LinkClose)]