Improved lexer funcs

src/Lexer.hs

@@ -6,7 +6,7 @@ module Lexer (
   emphasis,
 ) where
 
-import Control.Monad (mfilter)
+import Control.Monad (mfilter, void)
 import Data.Char (isAlphaNum, isPrint)
 import Data.Functor (($>))
 import Data.Text (Text)
@@ -26,6 +26,7 @@ data Token
   | Anchor
   | AngleOpen
   | AngleClose
+  | BirdTrack
   | BoldOpen
   | BoldClose
   | BracketOpen
@@ -54,13 +55,16 @@ lexText = go
       Just _ -> pure []
       Nothing -> do
         toks <-
-          choice
-            [ newlineToken
-            , spaceToken
-            , textElement
-            , identifier
-            , other
-            ]
+          choice $
+            Parsec.try
+              <$> [ newlineToken
+                  , spaceToken
+                  , quotes
+                  , textElement
+                  , identifier
+                  , birdTrack
+                  , other
+                  ]
         rest <- go
         pure (toks <> rest)
 
@@ -86,31 +90,40 @@ textElement =
           , angles
           ]
 
-delimited :: String -> String -> Token -> Token -> Parser [LocatedToken]
-delimited c1 c2 ot ct = do
-  (_, content) <- match $ between op cl any'
+delimitedMaybe :: Parser a -> Parser a -> Token -> Maybe Token -> Parser [LocatedToken]
+delimitedMaybe op cl ot ct = do
   pos <- getPosition
-  let openTok :: LocatedToken = (pos, ot)
-      closeTok :: LocatedToken = (pos, ct)
-      res :: LocatedToken = (pos, Token content)
+  (text, content) <- match $ between op cl any'
+  let openTok :: LocatedToken = (setSourceColumn pos 1, ot)
+      res :: LocatedToken = (setSourceColumn pos 2, Token content)
+      closeToks :: [LocatedToken] = case ct of
+        Just close -> [(setSourceColumn pos (Text.length text), close)]
+        Nothing -> []
 
-  pure [openTok, res, closeTok]
+  pure $ [openTok, res] <> closeToks
  where
-  op = string c1
-  cl = string c2
   any' = Text.pack <$> manyTill anyChar (lookAhead cl)
 
-delimited' :: String -> Token -> Token -> Parser [LocatedToken]
-delimited' s t1 t2 = delimited s s t1 t2
+delimited :: Parser a -> Parser a -> Token -> Token -> Parser [LocatedToken]
+delimited a b c d = delimitedMaybe a b c (Just d)
+
+delimitedSymmetric :: Parser a -> Token -> Token -> Parser [LocatedToken]
+delimitedSymmetric s t1 t2 = delimited s s t1 t2
+
+birdTrack :: Lexer
+birdTrack = delimitedMaybe (void ">> ") (void "\n" <|> Parsec.eof) BirdTrack Nothing
+
+quotes :: Lexer
+quotes = delimitedSymmetric "\"" QuoteOpen QuoteClose
 
 emphasis :: Lexer
-emphasis = delimited' "/" EmphasisOpen EmphasisClose
+emphasis = delimitedSymmetric "/" EmphasisOpen EmphasisClose
 
 bold :: Lexer
-bold = delimited' "__" BoldOpen BoldClose
+bold = delimitedSymmetric "__" BoldOpen BoldClose
 
 monospace :: Lexer
-monospace = delimited' "@" MonospaceOpen MonospaceClose
+monospace = delimitedSymmetric "@" MonospaceOpen MonospaceClose
 
 parens :: Parser [LocatedToken]
 parens = delimited "(" ")" ParenOpen ParenClose

test/Spec.hs

@@ -12,8 +12,87 @@ 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
+main :: IO ()
+main = hspec $ do
+  describe "Lexer" do
+    describe "minimal" do
+      it "space chars" space
+      it "bare string" someString
+      it "emphasis" emphatic
+      it "monospace" monospace
+      it "bird tracks" birdTracks
+      it "quotes" quotes
+      it "ignores nesting" ignoreNesting
+
+  describe "Parser" do
+    it "Bold" do
+      "__bold__" `shouldParseTo` (DocBold (DocString "bold"))
+    it "Emphasis" do
+      "/emphasis/" `shouldParseTo` (DocEmphasis (DocString "emphasis"))
+
+------------
+-- Tests
+------------
+
+ignoreNesting :: Expectation
+ignoreNesting =
+  ">/foo/"
+    `shouldLexTo` [ (1, 1, Token ">/foo/")
+                  ]
+
+birdTracks :: Expectation
+birdTracks =
+  ">> code"
+    `shouldLexTo` [ (1, 1, BirdTrack)
+                  , (1, 2, Token "code")
+                  ]
+
+quotes :: Expectation
+quotes =
+  "\"quoted\""
+    `shouldLexTo` [ (1, 1, QuoteOpen)
+                  , (1, 2, Token "quoted")
+                  , (1, 8, QuoteClose)
+                  ]
+
+space :: Expectation
+space = do
+  "\n "
+    `shouldLexTo` [ (1, 1, Newline)
+                  , (2, 1, Space)
+                  ]
+  " \n"
+    `shouldLexTo` [ (1, 1, Space)
+                  , (1, 2, Newline)
+                  ]
+
+monospace :: Expectation
+monospace =
+  "@mono@"
+    `shouldLexTo` [ (1, 1, MonospaceOpen)
+                  , (1, 2, Token "mono")
+                  , (1, 6, MonospaceClose)
+                  ]
+
+emphatic :: Expectation
+emphatic =
+  "/emphatic/"
+    `shouldLexTo` [ (1, 1, EmphasisOpen)
+                  , (1, 2, Token "emphatic")
+                  , (1, 10, EmphasisClose)
+                  ]
+
+someString :: Expectation
+someString =
+  "some string"
+    `shouldLexTo` [ (1, 1, Token "some")
+                  , (1, 5, Space)
+                  , (1, 6, Token "string")
+                  ]
+
+--------------
+-- Helpers
+--------------
 
 type Doc id = DocMarkup () id
 
@@ -28,46 +107,5 @@ shouldLexTo input expected =
       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")
-                  ]
+shouldParseTo :: Text -> DocMarkup mod Identifier -> Expectation
+shouldParseTo input ast = parseText input `shouldBe` ast