primrose/haddock2
1
0
Fork 0
forked from elland/haddock2
Code Pull requests Activity

Added minimal tests for bare lexer

Browse source
This commit is contained in:
Igor Ranieri 2025-09-21 10:01:12 +02:00
parent c299af1c06
commit f586b90434
1 changed files with 44 additions and 13 deletions
Download patch file Download diff file Expand all files Collapse all files

57
test/Spec.hs
View file

@ -20,19 +20,6 @@ type Doc id = DocMarkup () id
instance IsString (Doc String) where instance IsString (Doc String) where
fromString = DocString 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 :: String -> [(Int, Int, Token)] -> Expectation
shouldLexTo input expected = shouldLexTo input expected =
case lexer input of case lexer input of
@ -40,3 +27,47 @@ shouldLexTo input expected =
let actual = map (\(pos, tok) -> (sourceLine pos, sourceColumn pos, tok)) tokens let actual = map (\(pos, tok) -> (sourceLine pos, sourceColumn pos, tok)) tokens
actual `shouldBe` expected actual `shouldBe` expected
Left err -> expectationFailure $ "Parse error: " <> show err 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")
]