diff --git a/src/Lexer.hs b/src/Lexer.hs index aff9bce..2d37893 100644 --- a/src/Lexer.hs +++ b/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 diff --git a/test/Spec.hs b/test/Spec.hs index 0574666..dd5e325 100644 --- a/test/Spec.hs +++ b/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