From 68f9b88c83f6f20a8ac5e98f43eb5be52e542443 Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Sun, 21 Sep 2025 09:54:10 +0200 Subject: [PATCH 1/3] Basic lexer testing --- haddock2.cabal | 1 + test/Spec.hs | 40 +++++++++++++++++++++++++++------------- 2 files changed, 28 insertions(+), 13 deletions(-) diff --git a/haddock2.cabal b/haddock2.cabal index 9ba514f..7fe124c 100644 --- a/haddock2.cabal +++ b/haddock2.cabal @@ -46,6 +46,7 @@ test-suite haddock2-test type: exitcode-stdio-1.0 main-is: Spec.hs build-depends: + parsec ^>=3.1.18.0, base >=4.20.1.0, haddock2:{haddock2-lib}, hspec ^>=2.11.0, diff --git a/test/Spec.hs b/test/Spec.hs index 21ff624..dfd0d6b 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -5,23 +5,14 @@ import Test.Hspec import Data.String (IsString (..)) import Data.Text (Text) +import Text.Parsec.Pos +import Control.Monad (zipWithM_) import Identifier (Identifier) import Lexer import Parser import Types -main :: IO () -main = hspec $ do - describe "Lexer" do - it "lexes" do - lexer "This is string" `shouldBe` undefined - describe "Parser" do - it "Bold" do - "__bold__" `shouldParseTo` (DocBold (DocString "bold")) - it "Emphasis" do - "/emphasis/" `shouldParseTo` (DocEmphasis (DocString "emphasis")) - shouldParseTo :: Text -> DocMarkup mod Identifier -> Expectation shouldParseTo input ast = parseText input `shouldBe` ast @@ -30,5 +21,28 @@ type Doc id = DocMarkup () id instance IsString (Doc String) where fromString = DocString -file :: IO String -file = readFile "test/markup.md" +main :: IO () +main = hspec $ do + describe "Lexer" do + it "bare string" do + "some string" `shouldLexTo` [(1, 1, Token "some"), (1, 5, Space), (1, 6, Token "string")] + it "emphasis" do + "has /emphatic/ content" `shouldLexTo` replicate 7 (0, 0, Space) + describe "Parser" do + it "Bold" do + "__bold__" `shouldParseTo` (DocBold (DocString "bold")) + it "Emphasis" do + "/emphasis/" `shouldParseTo` (DocEmphasis (DocString "emphasis")) + +shouldLexTo :: String -> [(Int, Int, Token)] -> Expectation +shouldLexTo input expected = + case lexer input of + Right tokens -> do + length tokens `shouldBe` length expected + zipWithM_ checkToken tokens expected + Left err -> expectationFailure $ "Parse error: " <> show err + where + checkToken (pos, tok) (line, col, expectedTok) = do + tok `shouldBe` expectedTok + sourceLine pos `shouldBe` line + sourceColumn pos `shouldBe` col From c299af1c0601a76f2166fae1b0efca957e66b320 Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Sun, 21 Sep 2025 09:54:45 +0200 Subject: [PATCH 2/3] Hspec error for lexer --- test/Spec.hs | 18 ++++++------------ 1 file changed, 6 insertions(+), 12 deletions(-) diff --git a/test/Spec.hs b/test/Spec.hs index dfd0d6b..2721680 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -3,16 +3,15 @@ import Test.Hspec -import Data.String (IsString (..)) -import Data.Text (Text) -import Text.Parsec.Pos - -import Control.Monad (zipWithM_) import Identifier (Identifier) import Lexer import Parser import Types +import Data.String (IsString (..)) +import Data.Text (Text) +import Text.Parsec.Pos + shouldParseTo :: Text -> DocMarkup mod Identifier -> Expectation shouldParseTo input ast = parseText input `shouldBe` ast @@ -38,11 +37,6 @@ shouldLexTo :: String -> [(Int, Int, Token)] -> Expectation shouldLexTo input expected = case lexer input of Right tokens -> do - length tokens `shouldBe` length expected - zipWithM_ checkToken tokens expected + let actual = map (\(pos, tok) -> (sourceLine pos, sourceColumn pos, tok)) tokens + actual `shouldBe` expected Left err -> expectationFailure $ "Parse error: " <> show err - where - checkToken (pos, tok) (line, col, expectedTok) = do - tok `shouldBe` expectedTok - sourceLine pos `shouldBe` line - sourceColumn pos `shouldBe` col From f586b904349d030bd96c09bb34181d5e8fcea08e Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Sun, 21 Sep 2025 10:01:12 +0200 Subject: [PATCH 3/3] Added minimal tests for bare lexer --- test/Spec.hs | 57 ++++++++++++++++++++++++++++++++++++++++------------ 1 file changed, 44 insertions(+), 13 deletions(-) diff --git a/test/Spec.hs b/test/Spec.hs index 2721680..0574666 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -20,19 +20,6 @@ type Doc id = DocMarkup () id instance IsString (Doc String) where fromString = DocString -main :: IO () -main = hspec $ do - describe "Lexer" do - it "bare string" do - "some string" `shouldLexTo` [(1, 1, Token "some"), (1, 5, Space), (1, 6, Token "string")] - it "emphasis" do - "has /emphatic/ content" `shouldLexTo` replicate 7 (0, 0, Space) - describe "Parser" do - it "Bold" do - "__bold__" `shouldParseTo` (DocBold (DocString "bold")) - it "Emphasis" do - "/emphasis/" `shouldParseTo` (DocEmphasis (DocString "emphasis")) - shouldLexTo :: String -> [(Int, Int, Token)] -> Expectation shouldLexTo input expected = case lexer input of @@ -40,3 +27,47 @@ shouldLexTo input expected = let actual = map (\(pos, tok) -> (sourceLine pos, sourceColumn pos, tok)) tokens actual `shouldBe` expected Left err -> expectationFailure $ "Parse error: " <> show err + +main :: IO () +main = hspec $ do + describe "Lexer" do + describe "minimal" do + it "bare string" someString + it "emphasis" emphatic + it "monospace" monospace + it "ignores nesting" ignoreNesting + describe "Parser" do + it "Bold" do + "__bold__" `shouldParseTo` (DocBold (DocString "bold")) + it "Emphasis" do + "/emphasis/" `shouldParseTo` (DocEmphasis (DocString "emphasis")) + +monospace :: Expectation +monospace = + "@mono@" + `shouldLexTo` [ (1, 7, MonospaceOpen) + , (1, 7, Token "mono") + , (1, 7, MonospaceClose) + ] + +ignoreNesting :: Expectation +ignoreNesting = + ">/foo/" + `shouldLexTo` [ (1, 1, Token ">/foo/") + ] + +emphatic :: Expectation +emphatic = + "/emphatic/" + `shouldLexTo` [ (1, 11, EmphasisOpen) + , (1, 11, Token "emphatic") + , (1, 11, EmphasisClose) + ] + +someString :: Expectation +someString = + "some string" + `shouldLexTo` [ (1, 1, Token "some") + , (1, 5, Space) + , (1, 6, Token "string") + ]