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