Added minimal tests for bare lexer

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,

test/Spec.hs

@@ -3,24 +3,14 @@
 
 import Test.Hspec
 
-import Data.String (IsString (..))
-import Data.Text (Text)
-
 import Identifier (Identifier)
 import Lexer
 import Parser
 import Types
 
-main :: IO ()
+import Data.String (IsString (..))
-main = hspec $ do
+import Data.Text (Text)
-  describe "Lexer" do
+import Text.Parsec.Pos
-    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 +20,54 @@ type Doc id = DocMarkup () id
 instance IsString (Doc String) where
   fromString = DocString
 
-file :: IO String
+shouldLexTo :: String -> [(Int, Int, Token)] -> Expectation
-file = readFile "test/markup.md"
+shouldLexTo input expected =
+  case lexer input of
+    Right tokens -> do
+      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")
+                  ]