Formatting
This commit is contained in:
parent
72909cb84b
commit
1b59bb9c25
2 changed files with 275 additions and 273 deletions
310
src/Lexer.hs
310
src/Lexer.hs
|
|
@ -1,10 +1,11 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
module Lexer (
|
module Lexer (
|
||||||
Token (..),
|
Token (..),
|
||||||
lexer,
|
lexer,
|
||||||
emphasis,
|
emphasis,
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import Control.Monad (mfilter, void)
|
import Control.Monad (mfilter, void)
|
||||||
import Data.Functor (($>))
|
import Data.Functor (($>))
|
||||||
|
|
@ -17,51 +18,52 @@ import Text.Parsec qualified as Parsec
|
||||||
import Text.Parsec.Pos (updatePosChar)
|
import Text.Parsec.Pos (updatePosChar)
|
||||||
|
|
||||||
type Located a = (SourcePos, a)
|
type Located a = (SourcePos, a)
|
||||||
|
|
||||||
type LocatedToken = (SourcePos, Token)
|
type LocatedToken = (SourcePos, Token)
|
||||||
|
|
||||||
type Lexer = Parser [LocatedToken]
|
type Lexer = Parser [LocatedToken]
|
||||||
|
|
||||||
data Level
|
data Level
|
||||||
= One
|
= One
|
||||||
| Two
|
| Two
|
||||||
| Three
|
| Three
|
||||||
| Four
|
| Four
|
||||||
| Five
|
| Five
|
||||||
| Six
|
| Six
|
||||||
deriving (Eq, Show)
|
deriving (Eq, Show)
|
||||||
|
|
||||||
data Token
|
data Token
|
||||||
= Token Text
|
= Token Text
|
||||||
| Anchor Text
|
| Anchor Text
|
||||||
| BirdTrack
|
| BirdTrack
|
||||||
| BoldOpen
|
| BoldOpen
|
||||||
| BoldClose
|
| BoldClose
|
||||||
| Escape
|
| Escape
|
||||||
| EmphasisOpen
|
| EmphasisOpen
|
||||||
| EmphasisClose
|
| EmphasisClose
|
||||||
| Header Level
|
| Header Level
|
||||||
| MonospaceOpen
|
| MonospaceOpen
|
||||||
| MonospaceClose
|
| MonospaceClose
|
||||||
| Newline
|
| Newline
|
||||||
| LinkOpen
|
| LinkOpen
|
||||||
| LinkClose
|
| LinkClose
|
||||||
| LabeledLinkOpen
|
| LabeledLinkOpen
|
||||||
| LabeledLinkClose
|
| LabeledLinkClose
|
||||||
| ParenOpen
|
| ParenOpen
|
||||||
| ParenClose
|
| ParenClose
|
||||||
| BracketOpen
|
| BracketOpen
|
||||||
| BracketClose
|
| BracketClose
|
||||||
| MathInlineOpen
|
| MathInlineOpen
|
||||||
| MathInlineClose
|
| MathInlineClose
|
||||||
| MathMultilineOpen
|
| MathMultilineOpen
|
||||||
| MathMultilineClose
|
| MathMultilineClose
|
||||||
| NumericEntity Int
|
| NumericEntity Int
|
||||||
| Module Text
|
| Module Text
|
||||||
| QuoteOpen
|
| QuoteOpen
|
||||||
| QuoteClose
|
| QuoteClose
|
||||||
| Space
|
| Space
|
||||||
| EOF
|
| EOF
|
||||||
deriving (Eq, Show)
|
deriving (Eq, Show)
|
||||||
|
|
||||||
located :: Parser a -> Parser (SourcePos, a)
|
located :: Parser a -> Parser (SourcePos, a)
|
||||||
located p = (,) <$> getPosition <*> p
|
located p = (,) <$> getPosition <*> p
|
||||||
|
|
@ -74,74 +76,74 @@ lexer = Parsec.runParser lexText initialParserState "input" . Text.pack
|
||||||
|
|
||||||
lexText :: Parser [LocatedToken]
|
lexText :: Parser [LocatedToken]
|
||||||
lexText = go
|
lexText = go
|
||||||
where
|
where
|
||||||
go = do
|
go = do
|
||||||
Parsec.optionMaybe Parsec.eof >>= \case
|
Parsec.optionMaybe Parsec.eof >>= \case
|
||||||
Just _ -> pure []
|
Just _ -> pure []
|
||||||
Nothing -> do
|
Nothing -> do
|
||||||
toks <-
|
toks <-
|
||||||
choice $
|
choice $
|
||||||
Parsec.try
|
Parsec.try
|
||||||
<$> [ mathMultiline
|
<$> [ mathMultiline
|
||||||
, mathInline
|
, mathInline
|
||||||
, escape -- maths go before escape to avoid mismatch
|
, escape -- maths go before escape to avoid mismatch
|
||||||
, headers
|
, headers
|
||||||
, newlineToken
|
, newlineToken
|
||||||
, spaceToken
|
, spaceToken
|
||||||
, link
|
, link
|
||||||
, labeledLink
|
, labeledLink
|
||||||
, module_
|
, module_
|
||||||
, anchor
|
, anchor
|
||||||
, textElement
|
, textElement
|
||||||
, quotes
|
, quotes
|
||||||
, birdTrack
|
, birdTrack
|
||||||
, other
|
, other
|
||||||
]
|
]
|
||||||
rest <- go
|
rest <- go
|
||||||
pure (toks <> rest)
|
pure (toks <> rest)
|
||||||
|
|
||||||
-- Tokens
|
-- Tokens
|
||||||
|
|
||||||
textElement :: Parser [LocatedToken]
|
textElement :: Parser [LocatedToken]
|
||||||
textElement =
|
textElement =
|
||||||
choice $
|
choice $
|
||||||
Parsec.try
|
Parsec.try
|
||||||
<$> [ emphasis
|
<$> [ emphasis
|
||||||
, bold
|
, bold
|
||||||
, monospace
|
, monospace
|
||||||
]
|
]
|
||||||
|
|
||||||
headers :: Parser [LocatedToken]
|
headers :: Parser [LocatedToken]
|
||||||
headers =
|
headers =
|
||||||
choice $
|
choice $
|
||||||
Parsec.try
|
Parsec.try
|
||||||
<$> [ header1
|
<$> [ header1
|
||||||
, header2
|
, header2
|
||||||
, header3
|
, header3
|
||||||
, header4
|
, header4
|
||||||
, header5
|
, header5
|
||||||
, header6
|
, header6
|
||||||
]
|
]
|
||||||
|
|
||||||
anyUntil :: Parser a -> Parser Text
|
anyUntil :: Parser a -> Parser Text
|
||||||
anyUntil p = Text.pack <$> manyTill anyChar (lookAhead p)
|
anyUntil p = Text.pack <$> manyTill anyChar (lookAhead p)
|
||||||
|
|
||||||
delimitedAsTuple :: Parser open -> Parser close -> Parser (Located open, LocatedToken, Located close)
|
delimitedAsTuple :: Parser open -> Parser close -> Parser (Located open, LocatedToken, Located close)
|
||||||
delimitedAsTuple openP closeP =
|
delimitedAsTuple openP closeP =
|
||||||
(,,)
|
(,,)
|
||||||
<$> located openP
|
<$> located openP
|
||||||
<*> located (Token <$> anyUntil closeP)
|
<*> located (Token <$> anyUntil closeP)
|
||||||
<*> located closeP
|
<*> located closeP
|
||||||
|
|
||||||
delimited :: Parser open -> Parser close -> Token -> Token -> Parser [LocatedToken]
|
delimited :: Parser open -> Parser close -> Token -> Token -> Parser [LocatedToken]
|
||||||
delimited openP closeP openTok closeTok = asList <$> delimitedAsTuple (openTok <$ openP) (closeTok <$ closeP)
|
delimited openP closeP openTok closeTok = asList <$> delimitedAsTuple (openTok <$ openP) (closeTok <$ closeP)
|
||||||
where
|
where
|
||||||
asList (a, tok, b) = [a, tok, b]
|
asList (a, tok, b) = [a, tok, b]
|
||||||
|
|
||||||
delimitedNoTrailing :: Parser open -> Parser close -> Token -> Parser [LocatedToken]
|
delimitedNoTrailing :: Parser open -> Parser close -> Token -> Parser [LocatedToken]
|
||||||
delimitedNoTrailing openP closeP openTok = asList <$> delimitedAsTuple (openTok <$ openP) (void closeP)
|
delimitedNoTrailing openP closeP openTok = asList <$> delimitedAsTuple (openTok <$ openP) (void closeP)
|
||||||
where
|
where
|
||||||
asList (a, tok, _) = [a, tok]
|
asList (a, tok, _) = [a, tok]
|
||||||
|
|
||||||
delimitedSymmetric :: Parser a -> Token -> Token -> Parser [LocatedToken]
|
delimitedSymmetric :: Parser a -> Token -> Token -> Parser [LocatedToken]
|
||||||
delimitedSymmetric s t1 t2 = delimited s s t1 t2
|
delimitedSymmetric s t1 t2 = delimited s s t1 t2
|
||||||
|
|
@ -170,9 +172,8 @@ header6 = delimitedNoTrailing "====== " eol (Header Six)
|
||||||
-- #anchors#
|
-- #anchors#
|
||||||
anchor :: Lexer
|
anchor :: Lexer
|
||||||
anchor = do
|
anchor = do
|
||||||
x <- located $ between "#" "#" (Anchor <$> anyUntil "#")
|
x <- located $ between "#" "#" (Anchor <$> anyUntil "#")
|
||||||
pure [x]
|
pure [x]
|
||||||
|
|
||||||
|
|
||||||
moduleNames :: Parser Text
|
moduleNames :: Parser Text
|
||||||
moduleNames = intercalate "." . fmap Text.pack <$> upperId `sepBy1` char '.'
|
moduleNames = intercalate "." . fmap Text.pack <$> upperId `sepBy1` char '.'
|
||||||
|
|
@ -188,47 +189,47 @@ identifierChar = satisfy (\c -> isAlphaNum c || c == '_')
|
||||||
-- "Module.Name\#anchor" -- known as "old anchor". this has been deprecated for 9 years, thanks Ben
|
-- "Module.Name\#anchor" -- known as "old anchor". this has been deprecated for 9 years, thanks Ben
|
||||||
module_ :: Lexer
|
module_ :: Lexer
|
||||||
module_ = between (char '"') (char '"') inner
|
module_ = between (char '"') (char '"') inner
|
||||||
where
|
where
|
||||||
inner = do
|
inner = do
|
||||||
m <- located $ Module <$> moduleNames
|
m <- located $ Module <$> moduleNames
|
||||||
mAnchor <- optionMaybe (located $ anchorHash *> (Anchor <$> anchorText))
|
mAnchor <- optionMaybe (located $ anchorHash *> (Anchor <$> anchorText))
|
||||||
pure $ case mAnchor of
|
pure $ case mAnchor of
|
||||||
Just anc -> [m, anc]
|
Just anc -> [m, anc]
|
||||||
Nothing -> [m]
|
Nothing -> [m]
|
||||||
|
|
||||||
anchorHash :: Parser Text
|
anchorHash :: Parser Text
|
||||||
anchorHash = "#" <|> try "\\#"
|
anchorHash = "#" <|> try "\\#"
|
||||||
|
|
||||||
anchorText :: Parser Text
|
anchorText :: Parser Text
|
||||||
anchorText = Text.pack <$> many (satisfy (\c -> c /= '"' && not (isSpace c)))
|
anchorText = Text.pack <$> many (satisfy (\c -> c /= '"' && not (isSpace c)))
|
||||||
|
|
||||||
linkRaw :: Lexer
|
linkRaw :: Lexer
|
||||||
linkRaw =
|
linkRaw =
|
||||||
tokenise
|
tokenise
|
||||||
[ BracketOpen <$ "["
|
[ BracketOpen <$ "["
|
||||||
, Token <$> anyUntil "]"
|
, Token <$> anyUntil "]"
|
||||||
, BracketClose <$ "]"
|
, BracketClose <$ "]"
|
||||||
, ParenOpen <$ "("
|
, ParenOpen <$ "("
|
||||||
, Token <$> anyUntil ")"
|
, Token <$> anyUntil ")"
|
||||||
, ParenClose <$ ")"
|
, ParenClose <$ ")"
|
||||||
]
|
]
|
||||||
|
|
||||||
link :: Lexer
|
link :: Lexer
|
||||||
link = do
|
link = do
|
||||||
pos <- getPosition
|
pos <- getPosition
|
||||||
l <- linkRaw
|
l <- linkRaw
|
||||||
-- register the position of the last token
|
-- register the position of the last token
|
||||||
pos' <- flip incSourceColumn (-1) <$> getPosition
|
pos' <- flip incSourceColumn (-1) <$> getPosition
|
||||||
pure $ (pos, LinkOpen) : l <> [(pos', LinkClose)]
|
pure $ (pos, LinkOpen) : l <> [(pos', LinkClose)]
|
||||||
|
|
||||||
labeledLink :: Lexer
|
labeledLink :: Lexer
|
||||||
labeledLink = do
|
labeledLink = do
|
||||||
open <- located $ LabeledLinkOpen <$ "<"
|
open <- located $ LabeledLinkOpen <$ "<"
|
||||||
linkRes <- linkRaw
|
linkRes <- linkRaw
|
||||||
labelRes <- located $ Token <$> anyUntil ">"
|
labelRes <- located $ Token <$> anyUntil ">"
|
||||||
close <- located $ LabeledLinkClose <$ ">"
|
close <- located $ LabeledLinkClose <$ ">"
|
||||||
pure $
|
pure $
|
||||||
open : linkRes <> [ labelRes , close ]
|
open : linkRes <> [labelRes, close]
|
||||||
|
|
||||||
mathMultiline :: Lexer
|
mathMultiline :: Lexer
|
||||||
mathMultiline = delimited "\\[" "\\]" MathMultilineOpen MathMultilineClose
|
mathMultiline = delimited "\\[" "\\]" MathMultilineOpen MathMultilineClose
|
||||||
|
|
@ -256,23 +257,23 @@ monospace = delimitedSymmetric "@" MonospaceOpen MonospaceClose
|
||||||
|
|
||||||
other :: Lexer
|
other :: Lexer
|
||||||
other = do
|
other = do
|
||||||
pos <- getPosition
|
pos <- getPosition
|
||||||
c <- takeWhile1_ isUnicodeAlphaNum
|
c <- takeWhile1_ isUnicodeAlphaNum
|
||||||
pure . pure $ (pos, Token c)
|
pure . pure $ (pos, Token c)
|
||||||
where
|
where
|
||||||
isUnicodeAlphaNum c = isPrint c && not (isControl c) && not (isSpace c)
|
isUnicodeAlphaNum c = isPrint c && not (isControl c) && not (isSpace c)
|
||||||
|
|
||||||
spaceToken :: Lexer
|
spaceToken :: Lexer
|
||||||
spaceToken = do
|
spaceToken = do
|
||||||
pos <- getPosition
|
pos <- getPosition
|
||||||
_ <- many1 (char ' ')
|
_ <- many1 (char ' ')
|
||||||
pure . pure $ (pos, Space)
|
pure . pure $ (pos, Space)
|
||||||
|
|
||||||
newlineToken :: Lexer
|
newlineToken :: Lexer
|
||||||
newlineToken = do
|
newlineToken = do
|
||||||
pos <- getPosition
|
pos <- getPosition
|
||||||
_ <- newline
|
_ <- newline
|
||||||
pure . pure $ (pos, Newline)
|
pure . pure $ (pos, Newline)
|
||||||
|
|
||||||
-------
|
-------
|
||||||
-- Helpers
|
-- Helpers
|
||||||
|
|
@ -281,11 +282,11 @@ newlineToken = do
|
||||||
-- | Like `takeWhile`, but unconditionally take escaped characters.
|
-- | Like `takeWhile`, but unconditionally take escaped characters.
|
||||||
takeWhile_ :: (Char -> Bool) -> Parser Text
|
takeWhile_ :: (Char -> Bool) -> Parser Text
|
||||||
takeWhile_ p = scan p_ False
|
takeWhile_ p = scan p_ False
|
||||||
where
|
where
|
||||||
p_ escaped c
|
p_ escaped c
|
||||||
| escaped = Just False
|
| escaped = Just False
|
||||||
| not $ p c = Nothing
|
| not $ p c = Nothing
|
||||||
| otherwise = Just (c == '\\')
|
| otherwise = Just (c == '\\')
|
||||||
|
|
||||||
-- | Like 'takeWhile1', but unconditionally take escaped characters.
|
-- | Like 'takeWhile1', but unconditionally take escaped characters.
|
||||||
takeWhile1_ :: (Char -> Bool) -> Parser Text
|
takeWhile1_ :: (Char -> Bool) -> Parser Text
|
||||||
|
|
@ -295,19 +296,20 @@ takeWhile1_ = mfilter (not . Text.null) . takeWhile_
|
||||||
function returns true.
|
function returns true.
|
||||||
-}
|
-}
|
||||||
scan ::
|
scan ::
|
||||||
-- | scan function
|
-- | scan function
|
||||||
(state -> Char -> Maybe state) ->
|
(state -> Char -> Maybe state) ->
|
||||||
-- | initial state
|
-- | initial state
|
||||||
state ->
|
state ->
|
||||||
Parser Text
|
Parser Text
|
||||||
scan f initState = do
|
scan f initState = do
|
||||||
parserState@State{stateInput = input, statePos = pos} <- Parsec.getParserState
|
parserState@State{stateInput = input, statePos = pos} <- Parsec.getParserState
|
||||||
(remaining, finalPos, ct) <- go input initState pos 0
|
|
||||||
let newState = parserState{stateInput = remaining, statePos = finalPos}
|
(remaining, finalPos, ct) <- go input initState pos 0
|
||||||
Parsec.setParserState newState $> Text.take ct input
|
let newState = parserState{stateInput = remaining, statePos = finalPos}
|
||||||
where
|
Parsec.setParserState newState $> Text.take ct input
|
||||||
go !input' !st !posAccum !count' = case Text.uncons input' of
|
where
|
||||||
Nothing -> pure (input', posAccum, count')
|
go !input' !st !posAccum !count' = case Text.uncons input' of
|
||||||
Just (char', input'') -> case f st char' of
|
Nothing -> pure (input', posAccum, count')
|
||||||
Nothing -> pure (input', posAccum, count')
|
Just (char', input'') -> case f st char' of
|
||||||
Just st' -> go input'' st' (updatePosChar posAccum char') (count' + 1)
|
Nothing -> pure (input', posAccum, count')
|
||||||
|
Just st' -> go input'' st' (updatePosChar posAccum char') (count' + 1)
|
||||||
|
|
|
||||||
238
test/Spec.hs
238
test/Spec.hs
|
|
@ -10,33 +10,33 @@ import Types
|
||||||
|
|
||||||
import Data.String (IsString (..))
|
import Data.String (IsString (..))
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import Text.Parsec.Pos
|
|
||||||
import GHC.Stack
|
import GHC.Stack
|
||||||
|
import Text.Parsec.Pos
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = hspec $ do
|
main = hspec $ do
|
||||||
describe "Lexer" do
|
describe "Lexer" do
|
||||||
describe "minimal" do
|
describe "minimal" do
|
||||||
it "handles unicode" unicode
|
it "handles unicode" unicode
|
||||||
it "escapes" escaping
|
it "escapes" escaping
|
||||||
it "maths" math
|
it "maths" math
|
||||||
it "anchors" anchor
|
it "anchors" anchor
|
||||||
it "space chars" space
|
it "space chars" space
|
||||||
it "bare string" someString
|
it "bare string" someString
|
||||||
it "emphasis" emphatic
|
it "emphasis" emphatic
|
||||||
it "monospace" monospace
|
it "monospace" monospace
|
||||||
it "labeled link" labeledLink
|
it "labeled link" labeledLink
|
||||||
it "markdown link" link
|
it "markdown link" link
|
||||||
it "bird tracks" birdTracks
|
it "bird tracks" birdTracks
|
||||||
it "module names" modules
|
it "module names" modules
|
||||||
it "quotes" quotes
|
it "quotes" quotes
|
||||||
it "ignores nesting" ignoreNesting
|
it "ignores nesting" ignoreNesting
|
||||||
|
|
||||||
describe "Parser" do
|
describe "Parser" do
|
||||||
it "Bold" do
|
it "Bold" do
|
||||||
"__bold__" `shouldParseTo` (DocBold (DocString "bold"))
|
"__bold__" `shouldParseTo` (DocBold (DocString "bold"))
|
||||||
it "Emphasis" do
|
it "Emphasis" do
|
||||||
"/emphasis/" `shouldParseTo` (DocEmphasis (DocString "emphasis"))
|
"/emphasis/" `shouldParseTo` (DocEmphasis (DocString "emphasis"))
|
||||||
|
|
||||||
------------
|
------------
|
||||||
-- Tests
|
-- Tests
|
||||||
|
|
@ -44,137 +44,137 @@ main = hspec $ do
|
||||||
|
|
||||||
modules :: Expectation
|
modules :: Expectation
|
||||||
modules = do
|
modules = do
|
||||||
"\"MyModule.Name\""
|
"\"MyModule.Name\""
|
||||||
`shouldLexTo` [ (1, 2, Module "MyModule.Name")
|
`shouldLexTo` [ (1, 2, Module "MyModule.Name")
|
||||||
]
|
]
|
||||||
|
|
||||||
"\"OtherModule.Name#myAnchor\""
|
"\"OtherModule.Name#myAnchor\""
|
||||||
`shouldLexTo` [ (1, 2, Module "OtherModule.Name")
|
`shouldLexTo` [ (1, 2, Module "OtherModule.Name")
|
||||||
, (1, 18, Anchor "myAnchor")
|
, (1, 18, Anchor "myAnchor")
|
||||||
]
|
]
|
||||||
|
|
||||||
"\"OtherModule.Name\\#myAnchor\""
|
"\"OtherModule.Name\\#myAnchor\""
|
||||||
`shouldLexTo` [ (1, 2, Module "OtherModule.Name")
|
`shouldLexTo` [ (1, 2, Module "OtherModule.Name")
|
||||||
, (1, 18, Anchor "myAnchor")
|
, (1, 18, Anchor "myAnchor")
|
||||||
]
|
]
|
||||||
link :: Expectation
|
link :: Expectation
|
||||||
link =
|
link =
|
||||||
"[link to](http://some.website)"
|
"[link to](http://some.website)"
|
||||||
`shouldLexTo` [ (1, 1, LinkOpen)
|
`shouldLexTo` [ (1, 1, LinkOpen)
|
||||||
, (1, 1, BracketOpen)
|
, (1, 1, BracketOpen)
|
||||||
, (1, 2, Token "link to")
|
, (1, 2, Token "link to")
|
||||||
, (1, 9, BracketClose)
|
, (1, 9, BracketClose)
|
||||||
, (1, 10, ParenOpen)
|
, (1, 10, ParenOpen)
|
||||||
, (1, 11, Token "http://some.website")
|
, (1, 11, Token "http://some.website")
|
||||||
, (1, 30, ParenClose)
|
, (1, 30, ParenClose)
|
||||||
, (1, 30, LinkClose)
|
, (1, 30, LinkClose)
|
||||||
]
|
]
|
||||||
|
|
||||||
labeledLink :: Expectation
|
labeledLink :: Expectation
|
||||||
labeledLink =
|
labeledLink =
|
||||||
"<[link here](http://to.here) label>"
|
"<[link here](http://to.here) label>"
|
||||||
`shouldLexTo` [ (1, 1, LabeledLinkOpen)
|
`shouldLexTo` [ (1, 1, LabeledLinkOpen)
|
||||||
, (1, 2, BracketOpen)
|
, (1, 2, BracketOpen)
|
||||||
, (1, 3, Token "link here")
|
, (1, 3, Token "link here")
|
||||||
, (1, 12, BracketClose)
|
, (1, 12, BracketClose)
|
||||||
, (1, 13, ParenOpen)
|
, (1, 13, ParenOpen)
|
||||||
, (1, 14, Token "http://to.here")
|
, (1, 14, Token "http://to.here")
|
||||||
, (1, 28, ParenClose)
|
, (1, 28, ParenClose)
|
||||||
, (1, 29, Token " label")
|
, (1, 29, Token " label")
|
||||||
, (1, 35, LabeledLinkClose)
|
, (1, 35, LabeledLinkClose)
|
||||||
]
|
]
|
||||||
|
|
||||||
anchor :: Expectation
|
anchor :: Expectation
|
||||||
anchor =
|
anchor =
|
||||||
"#myAnchor#"
|
"#myAnchor#"
|
||||||
`shouldLexTo` [ (1, 1, Anchor "myAnchor")
|
`shouldLexTo` [ (1, 1, Anchor "myAnchor")
|
||||||
]
|
]
|
||||||
|
|
||||||
math :: IO ()
|
math :: IO ()
|
||||||
math = do
|
math = do
|
||||||
"\\[some math\\]"
|
"\\[some math\\]"
|
||||||
`shouldLexTo` [ (1, 1, MathMultilineOpen)
|
`shouldLexTo` [ (1, 1, MathMultilineOpen)
|
||||||
, (1, 3, Token "some math")
|
, (1, 3, Token "some math")
|
||||||
, (1, 12, MathMultilineClose)
|
, (1, 12, MathMultilineClose)
|
||||||
]
|
]
|
||||||
"\\(other maths\\)"
|
"\\(other maths\\)"
|
||||||
`shouldLexTo` [ (1, 1, MathInlineOpen)
|
`shouldLexTo` [ (1, 1, MathInlineOpen)
|
||||||
, (1, 3, Token "other maths")
|
, (1, 3, Token "other maths")
|
||||||
, (1, 14, MathInlineClose)
|
, (1, 14, MathInlineClose)
|
||||||
]
|
]
|
||||||
|
|
||||||
escaping :: Expectation
|
escaping :: Expectation
|
||||||
escaping = do
|
escaping = do
|
||||||
"\\("
|
"\\("
|
||||||
`shouldLexTo` [ (1, 1, Escape)
|
`shouldLexTo` [ (1, 1, Escape)
|
||||||
, (1, 2, Token "(")
|
, (1, 2, Token "(")
|
||||||
]
|
]
|
||||||
"\\(\r\n"
|
"\\(\r\n"
|
||||||
`shouldLexTo` [ (1, 1, Escape)
|
`shouldLexTo` [ (1, 1, Escape)
|
||||||
, (1, 2, Token "(")
|
, (1, 2, Token "(")
|
||||||
]
|
]
|
||||||
|
|
||||||
unicode :: Expectation
|
unicode :: Expectation
|
||||||
unicode =
|
unicode =
|
||||||
"ドラゴンクエストの冒険者🐉"
|
"ドラゴンクエストの冒険者🐉"
|
||||||
`shouldLexTo` [ (1, 1, Token "ドラゴンクエストの冒険者🐉")
|
`shouldLexTo` [ (1, 1, Token "ドラゴンクエストの冒険者🐉")
|
||||||
]
|
]
|
||||||
|
|
||||||
ignoreNesting :: Expectation
|
ignoreNesting :: Expectation
|
||||||
ignoreNesting =
|
ignoreNesting =
|
||||||
">/foo/"
|
">/foo/"
|
||||||
`shouldLexTo` [ (1, 1, Token ">/foo/")
|
`shouldLexTo` [ (1, 1, Token ">/foo/")
|
||||||
]
|
]
|
||||||
|
|
||||||
birdTracks :: Expectation
|
birdTracks :: Expectation
|
||||||
birdTracks =
|
birdTracks =
|
||||||
">> code"
|
">> code"
|
||||||
`shouldLexTo` [ (1, 1, BirdTrack)
|
`shouldLexTo` [ (1, 1, BirdTrack)
|
||||||
, (1, 4, Token "code")
|
, (1, 4, Token "code")
|
||||||
]
|
]
|
||||||
|
|
||||||
quotes :: Expectation
|
quotes :: Expectation
|
||||||
quotes =
|
quotes =
|
||||||
"\"quoted\""
|
"\"quoted\""
|
||||||
`shouldLexTo` [ (1, 1, QuoteOpen)
|
`shouldLexTo` [ (1, 1, QuoteOpen)
|
||||||
, (1, 2, Token "quoted")
|
, (1, 2, Token "quoted")
|
||||||
, (1, 8, QuoteClose)
|
, (1, 8, QuoteClose)
|
||||||
]
|
]
|
||||||
|
|
||||||
space :: Expectation
|
space :: Expectation
|
||||||
space = do
|
space = do
|
||||||
"\n "
|
"\n "
|
||||||
`shouldLexTo` [ (1, 1, Newline)
|
`shouldLexTo` [ (1, 1, Newline)
|
||||||
, (2, 1, Space)
|
, (2, 1, Space)
|
||||||
]
|
]
|
||||||
" \n"
|
" \n"
|
||||||
`shouldLexTo` [ (1, 1, Space)
|
`shouldLexTo` [ (1, 1, Space)
|
||||||
, (1, 2, Newline)
|
, (1, 2, Newline)
|
||||||
]
|
]
|
||||||
|
|
||||||
monospace :: Expectation
|
monospace :: Expectation
|
||||||
monospace =
|
monospace =
|
||||||
"@mono@"
|
"@mono@"
|
||||||
`shouldLexTo` [ (1, 1, MonospaceOpen)
|
`shouldLexTo` [ (1, 1, MonospaceOpen)
|
||||||
, (1, 2, Token "mono")
|
, (1, 2, Token "mono")
|
||||||
, (1, 6, MonospaceClose)
|
, (1, 6, MonospaceClose)
|
||||||
]
|
]
|
||||||
|
|
||||||
emphatic :: Expectation
|
emphatic :: Expectation
|
||||||
emphatic =
|
emphatic =
|
||||||
"/emphatic/"
|
"/emphatic/"
|
||||||
`shouldLexTo` [ (1, 1, EmphasisOpen)
|
`shouldLexTo` [ (1, 1, EmphasisOpen)
|
||||||
, (1, 2, Token "emphatic")
|
, (1, 2, Token "emphatic")
|
||||||
, (1, 10, EmphasisClose)
|
, (1, 10, EmphasisClose)
|
||||||
]
|
]
|
||||||
|
|
||||||
someString :: Expectation
|
someString :: Expectation
|
||||||
someString =
|
someString =
|
||||||
"some string"
|
"some string"
|
||||||
`shouldLexTo` [ (1, 1, Token "some")
|
`shouldLexTo` [ (1, 1, Token "some")
|
||||||
, (1, 5, Space)
|
, (1, 5, Space)
|
||||||
, (1, 6, Token "string")
|
, (1, 6, Token "string")
|
||||||
]
|
]
|
||||||
|
|
||||||
--------------
|
--------------
|
||||||
-- Helpers
|
-- Helpers
|
||||||
|
|
@ -183,16 +183,16 @@ someString =
|
||||||
type Doc id = DocMarkup () id
|
type Doc id = DocMarkup () id
|
||||||
|
|
||||||
instance IsString (Doc String) where
|
instance IsString (Doc String) where
|
||||||
fromString = DocString
|
fromString = DocString
|
||||||
|
|
||||||
shouldLexTo :: String -> [(Int, Int, Token)] -> Expectation
|
shouldLexTo :: String -> [(Int, Int, Token)] -> Expectation
|
||||||
shouldLexTo input expected =
|
shouldLexTo input expected =
|
||||||
withFrozenCallStack $
|
withFrozenCallStack $
|
||||||
case lexer input of
|
case lexer input of
|
||||||
Right tokens -> do
|
Right tokens -> do
|
||||||
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
|
||||||
|
|
||||||
shouldParseTo :: Text -> DocMarkup mod Identifier -> Expectation
|
shouldParseTo :: Text -> DocMarkup mod Identifier -> Expectation
|
||||||
shouldParseTo input ast = parseText input `shouldBe` ast
|
shouldParseTo input ast = parseText input `shouldBe` ast
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue