197 lines
5 KiB
Haskell
197 lines
5 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# OPTIONS_GHC -Wno-orphans #-}
|
|
|
|
import Data.String (IsString (..))
|
|
import Data.Text (Text)
|
|
import GHC.Stack
|
|
import Identifier (Identifier)
|
|
import Lexer
|
|
import Parser
|
|
import Test.Hspec
|
|
import Text.Parsec.Pos
|
|
import Types
|
|
|
|
main :: IO ()
|
|
main = hspec $ do
|
|
describe "Lexer" do
|
|
describe "minimal" do
|
|
it "handles unicode" unicode
|
|
it "escapes" escaping
|
|
it "maths" math
|
|
it "anchors" anchor
|
|
it "space chars" space
|
|
it "bare string" someString
|
|
it "emphasis" emphatic
|
|
it "monospace" monospace
|
|
it "labeled link" labeledLink
|
|
it "markdown link" link
|
|
it "bird tracks" birdTracks
|
|
it "module names" modules
|
|
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
|
|
------------
|
|
|
|
modules :: Expectation
|
|
modules = do
|
|
"\"MyModule.Name\""
|
|
`shouldLexTo` [ (1, 2, Module "MyModule.Name")
|
|
]
|
|
|
|
"\"OtherModule.Name#myAnchor\""
|
|
`shouldLexTo` [ (1, 2, Module "OtherModule.Name")
|
|
, (1, 18, Anchor "myAnchor")
|
|
]
|
|
|
|
"\"OtherModule.Name\\#myAnchor\""
|
|
`shouldLexTo` [ (1, 2, Module "OtherModule.Name")
|
|
, (1, 18, Anchor "myAnchor")
|
|
]
|
|
|
|
link :: Expectation
|
|
link =
|
|
"[link to](http://some.website)"
|
|
`shouldLexTo` [ (1, 1, LinkOpen)
|
|
, (1, 1, BracketOpen)
|
|
, (1, 2, Token "link to")
|
|
, (1, 9, BracketClose)
|
|
, (1, 10, ParenOpen)
|
|
, (1, 11, Token "http://some.website")
|
|
, (1, 30, ParenClose)
|
|
, (1, 30, LinkClose)
|
|
]
|
|
|
|
labeledLink :: Expectation
|
|
labeledLink =
|
|
"<[link here](http://to.here) label>"
|
|
`shouldLexTo` [ (1, 1, LabeledLinkOpen)
|
|
, (1, 2, BracketOpen)
|
|
, (1, 3, Token "link here")
|
|
, (1, 12, BracketClose)
|
|
, (1, 13, ParenOpen)
|
|
, (1, 14, Token "http://to.here")
|
|
, (1, 28, ParenClose)
|
|
, (1, 29, Token " label")
|
|
, (1, 35, LabeledLinkClose)
|
|
]
|
|
|
|
anchor :: Expectation
|
|
anchor =
|
|
"#myAnchor#"
|
|
`shouldLexTo` [ (1, 1, Anchor "myAnchor")
|
|
]
|
|
|
|
math :: IO ()
|
|
math = do
|
|
"\\[some math\\]"
|
|
`shouldLexTo` [ (1, 1, MathMultilineOpen)
|
|
, (1, 3, Token "some math")
|
|
, (1, 12, MathMultilineClose)
|
|
]
|
|
"\\(other maths\\)"
|
|
`shouldLexTo` [ (1, 1, MathInlineOpen)
|
|
, (1, 3, Token "other maths")
|
|
, (1, 14, MathInlineClose)
|
|
]
|
|
|
|
escaping :: Expectation
|
|
escaping = do
|
|
"\\("
|
|
`shouldLexTo` [ (1, 1, Escape)
|
|
, (1, 2, Token "(")
|
|
]
|
|
"\\(\r\n"
|
|
`shouldLexTo` [ (1, 1, Escape)
|
|
, (1, 2, Token "(")
|
|
]
|
|
|
|
unicode :: Expectation
|
|
unicode =
|
|
"ドラゴンクエストの冒険者🐉"
|
|
`shouldLexTo` [ (1, 1, Token "ドラゴンクエストの冒険者🐉")
|
|
]
|
|
|
|
ignoreNesting :: Expectation
|
|
ignoreNesting =
|
|
">/foo/"
|
|
`shouldLexTo` [ (1, 1, Token ">/foo/")
|
|
]
|
|
|
|
birdTracks :: Expectation
|
|
birdTracks =
|
|
">> code"
|
|
`shouldLexTo` [ (1, 1, BirdTrack)
|
|
, (1, 4, 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
|
|
|
|
instance IsString (Doc String) where
|
|
fromString = DocString
|
|
|
|
shouldLexTo :: String -> [(Int, Int, Token)] -> Expectation
|
|
shouldLexTo input expected =
|
|
withFrozenCallStack $
|
|
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
|
|
|
|
shouldParseTo :: Text -> DocMarkup mod Identifier -> Expectation
|
|
shouldParseTo input ast = parseText input `shouldBe` ast
|