Compare commits

...

17 commits

Author SHA1 Message Date
de969f461b Adding docker image
Some checks failed
Haskell CI / build (pull_request) Has been cancelled
Haskell CI / test (pull_request) Has been cancelled
Haskell CI / fourmolu (pull_request) Has been cancelled
Haskell CI / hlint (pull_request) Has been cancelled
2025-09-27 09:56:44 +02:00
7756aa7867 Added missing cabal-update steps 2025-09-27 09:56:44 +02:00
114c8cdb96 Remove hlint hard-coded version 2025-09-27 09:56:44 +02:00
e21f9712d5 Improved makefile, formatting 2025-09-27 09:56:44 +02:00
797eb1cb32 Try more steps 2025-09-27 09:56:44 +02:00
dafcd0f6ab Split jobs 2025-09-27 09:56:44 +02:00
5d82d6ad0a Update .forgejo/workflows/test.yaml 2025-09-27 09:56:11 +02:00
5ea8d9b57a try again 2025-09-27 09:56:11 +02:00
46f7ef70e2 Fixed ci.yml 2025-09-27 09:56:11 +02:00
f464d65052 Updated ci 2025-09-27 09:56:11 +02:00
63760034cf update ci action 2025-09-27 09:56:11 +02:00
f05c93a5a7 Run on docker 2025-09-27 09:56:11 +02:00
7a7bc4d882 Renamed file 2025-09-27 09:56:11 +02:00
3ff0b61851 New rules 2025-09-27 09:56:11 +02:00
c427f8c320 Updated ci.yml 2025-09-27 09:56:11 +02:00
986af3583c Runner base config 2025-09-27 09:56:11 +02:00
d8ba47a8b6 Applied more formatting; added Makefile (#4)
Reviewed-on: #4
Co-authored-by: Igor Ranieri <igor@elland.me>
Co-committed-by: Igor Ranieri <igor@elland.me>
2025-09-27 07:51:09 +00:00
8 changed files with 524 additions and 323 deletions

View file

@ -0,0 +1,121 @@
name: Haskell CI
on:
pull_request:
branches:
- dev
- main
push:
branches:
- main
jobs:
build:
runs-on: docker
container:
image: haskell:9.10
steps:
- name: Install Node.js (for actions)
run: |
curl -fsSL https://deb.nodesource.com/setup_22.x | bash -
apt-get install -y nodejs
- name: Checkout code
uses: actions/checkout@v4
- name: Check versions
run: |
ghc --version
cabal --version
node --version
- name: Cache Cabal packages
uses: actions/cache@v4
with:
path: |
~/.cabal/packages
~/.cabal/store
dist-newstyle
key: ${{ runner.os }}-haskell-9.10-cabal-${{ hashFiles('**/*.cabal', '**/cabal.project') }}
restore-keys: |
${{ runner.os }}-haskell-9.10-cabal-
- name: Update Cabal package index
run: cabal update
- name: Configure project
run: cabal configure --enable-tests --enable-benchmarks
- name: Build dependencies
run: cabal build --only-dependencies --enable-tests --enable-benchmarks
- name: Build project
run: cabal build --enable-tests --enable-benchmarks
- name: Run documentation build
run: cabal haddock
test:
runs-on: docker
container:
image: haskell:9.10
needs: build
steps:
- name: Install Node.js (for actions)
run: |
curl -fsSL https://deb.nodesource.com/setup_22.x | bash -
apt-get install -y nodejs
- name: Checkout code
uses: actions/checkout@v4
- name: Cache Cabal packages
uses: actions/cache@v4
with:
path: |
~/.cabal/packages
~/.cabal/store
dist-newstyle
key: ${{ runner.os }}-haskell-9.10-cabal-${{ hashFiles('**/*.cabal', '**/cabal.project') }}
restore-keys: |
${{ runner.os }}-haskell-9.10-cabal-
- name: Update Cabal package index
run: cabal update
- name: Configure project
run: cabal configure --enable-tests --enable-benchmarks
- name: Build dependencies
run: cabal build --only-dependencies --enable-tests --enable-benchmarks
- name: Build project
run: cabal build --enable-tests --enable-benchmarks
- name: Run tests
run: cabal test --test-show-details=direct
fourmolu:
runs-on: docker
container:
image: haskell:9.10
steps:
- name: Install Node.js (for actions)
run: |
curl -fsSL https://deb.nodesource.com/setup_22.x | bash -
apt-get install -y nodejs
- name: Checkout code
uses: actions/checkout@v4
- name: Update Cabal package index
run: cabal update
- name: Install fourmolu
run: cabal install fourmolu-0.18.0.0
- name: Run fourmolu
run: |
find src test app -name "*.hs" -exec fourmolu --check-idempotence {} \; 2>/dev/null || true
find src test app -name "*.hs" -exec fourmolu --mode check {} \;
hlint:
runs-on: docker
container:
image: haskell:9.10
steps:
- name: Install Node.js (for actions)
run: |
curl -fsSL https://deb.nodesource.com/setup_22.x | bash -
apt-get install -y nodejs
- name: Checkout code
uses: actions/checkout@v4
- name: Update Cabal package index
run: cabal update
- name: Install hlint
run: cabal install hlint
- name: Run hlint
run: |
if [ -d src ]; then hlint src/; fi
if [ -d test ]; then hlint test/; fi
if [ -d app ]; then hlint app/; fi

30
Dockerfile Normal file
View file

@ -0,0 +1,30 @@
FROM haskell:9.10
# Install system dependencies
RUN apt-get update && apt-get install -y \
git \
curl \
&& rm -rf /var/lib/apt/lists/*
# Install Node.js (for GitHub Actions compatibility)
RUN curl -fsSL https://deb.nodesource.com/setup_22.x | bash - && \
apt-get install -y nodejs && \
rm -rf /var/lib/apt/lists/*
# Update cabal and install Haskell tools
RUN cabal update && \
cabal install --install-method=copy --installdir=/usr/local/bin \
fourmolu \
hlint \
cabal-gild
# Verify installations
RUN ghc --version && \
cabal --version && \
node --version && \
fourmolu --version && \
hlint --version && \
cabal-gild --version
# Set working directory
WORKDIR /workspace

44
Makefile Normal file
View file

@ -0,0 +1,44 @@
.PHONY: help
help: ## Show this help
@grep -E '^[a-zA-Z_-]+:.*?## .*$$' $(MAKEFILE_LIST) | sort | awk 'BEGIN {FS = ":.*?## "}; {printf "\033[36m%-30s\033[0m %s\n", $$1, $$2}'
.PHONY: build
build: ## Build the project
cabal build
.PHONY: test
test: ## Run tests
cabal test --test-show-details=direct
.PHONY: clean
clean: ## Clean build artifacts
cabal clean
.PHONY: fourmolu
fourmolu: ## Format Haskell code
find . -type f -name "*.hs" ! -path "./dist-newstyle/*" -exec fourmolu -i {} +
.PHONY: fourmolu-check
fourmolu-check: ## Check if code is formatted
find . -type f -name "*.hs" ! -path "./dist-newstyle/*" -exec fourmolu --mode check {} \;
.PHONY: lint
lint: ## Run hlint
hlint src test app
.PHONY: cabal-gild
cabal-gild: ## Format cabal file
cabal-gild --io=haddock2.cabal
.PHONY: format
format: fourmolu cabal-gild ## Run all formatters
.PHONY: check
check: fourmolu-check lint ## Run all checks (CI-style)
.PHONY: ci
ci: build test check ## Run full CI pipeline locally
.PHONY: docs
docs: ## Generate documentation
cabal haddock --haddock-hyperlink-source

View file

@ -46,10 +46,10 @@ test-suite haddock2-test
type: exitcode-stdio-1.0
main-is: Spec.hs
build-depends:
parsec ^>=3.1.18.0,
base >=4.20.1.0,
haddock2:{haddock2-lib},
hspec ^>=2.11.0,
parsec ^>=3.1.18.0,
text ^>=2.1.2,
hs-source-dirs: test

View file

@ -1,10 +1,11 @@
{-# LANGUAGE OverloadedStrings #-}
module Lexer (
Token (..),
lexer,
emphasis,
) where
Token (..),
lexer,
emphasis,
)
where
import Control.Monad (mfilter, void)
import Data.Functor (($>))
@ -17,134 +18,135 @@ import Text.Parsec qualified as Parsec
import Text.Parsec.Pos (updatePosChar)
type Located a = (SourcePos, a)
type LocatedToken = (SourcePos, Token)
type Lexer = Parser [LocatedToken]
data Level
= One
| Two
| Three
| Four
| Five
| Six
deriving (Eq, Show)
= One
| Two
| Three
| Four
| Five
| Six
deriving (Eq, Show)
data Token
= Token Text
| Anchor Text
| BirdTrack
| BoldOpen
| BoldClose
| Escape
| EmphasisOpen
| EmphasisClose
| Header Level
| MonospaceOpen
| MonospaceClose
| Newline
| LinkOpen
| LinkClose
| LabeledLinkOpen
| LabeledLinkClose
| ParenOpen
| ParenClose
| BracketOpen
| BracketClose
| MathInlineOpen
| MathInlineClose
| MathMultilineOpen
| MathMultilineClose
| NumericEntity Int
| Module Text
| QuoteOpen
| QuoteClose
| Space
| EOF
deriving (Eq, Show)
= Token Text
| Anchor Text
| BirdTrack
| BoldOpen
| BoldClose
| Escape
| EmphasisOpen
| EmphasisClose
| Header Level
| MonospaceOpen
| MonospaceClose
| Newline
| LinkOpen
| LinkClose
| LabeledLinkOpen
| LabeledLinkClose
| ParenOpen
| ParenClose
| BracketOpen
| BracketClose
| MathInlineOpen
| MathInlineClose
| MathMultilineOpen
| MathMultilineClose
| NumericEntity Int
| Module Text
| QuoteOpen
| QuoteClose
| Space
| EOF
deriving (Eq, Show)
located :: Parser a -> Parser (SourcePos, a)
located p = (,) <$> getPosition <*> p
tokenise :: [Parser a] -> Parser [(SourcePos, a)]
tokenise = sequence . map located
tokenise = mapM located
lexer :: String -> Either ParseError [LocatedToken]
lexer = Parsec.runParser lexText initialParserState "input" . Text.pack
lexText :: Parser [LocatedToken]
lexText = go
where
go = do
Parsec.optionMaybe Parsec.eof >>= \case
Just _ -> pure []
Nothing -> do
toks <-
choice $
Parsec.try
<$> [ mathMultiline
, mathInline
, escape -- maths go before escape to avoid mismatch
, headers
, newlineToken
, spaceToken
, link
, labeledLink
, module_
, anchor
, textElement
, quotes
, birdTrack
, other
]
rest <- go
pure (toks <> rest)
where
go = do
Parsec.optionMaybe Parsec.eof >>= \case
Just _ -> pure []
Nothing -> do
toks <-
choice $
Parsec.try
<$> [ mathMultiline
, mathInline
, escape -- maths go before escape to avoid mismatch
, headers
, newlineToken
, spaceToken
, link
, labeledLink
, module_
, anchor
, textElement
, quotes
, birdTrack
, other
]
rest <- go
pure (toks <> rest)
-- Tokens
textElement :: Parser [LocatedToken]
textElement =
choice $
Parsec.try
<$> [ emphasis
, bold
, monospace
]
choice $
Parsec.try
<$> [ emphasis
, bold
, monospace
]
headers :: Parser [LocatedToken]
headers =
choice $
Parsec.try
<$> [ header1
, header2
, header3
, header4
, header5
, header6
]
choice $
Parsec.try
<$> [ header1
, header2
, header3
, header4
, header5
, header6
]
anyUntil :: Parser a -> Parser Text
anyUntil p = Text.pack <$> manyTill anyChar (lookAhead p)
delimitedAsTuple :: Parser open -> Parser close -> Parser (Located open, LocatedToken, Located close)
delimitedAsTuple openP closeP =
(,,)
<$> located openP
<*> located (Token <$> anyUntil closeP)
<*> located closeP
(,,)
<$> located openP
<*> located (Token <$> anyUntil closeP)
<*> located closeP
delimited :: Parser open -> Parser close -> Token -> Token -> Parser [LocatedToken]
delimited openP closeP openTok closeTok = asList <$> delimitedAsTuple (openTok <$ openP) (closeTok <$ closeP)
where
asList (a, tok, b) = [a, tok, b]
where
asList (a, tok, b) = [a, tok, b]
delimitedNoTrailing :: Parser open -> Parser close -> Token -> Parser [LocatedToken]
delimitedNoTrailing openP closeP openTok = asList <$> delimitedAsTuple (openTok <$ openP) (void closeP)
where
asList (a, tok, _) = [a, tok]
where
asList (a, tok, _) = [a, tok]
delimitedSymmetric :: Parser a -> Token -> Token -> Parser [LocatedToken]
delimitedSymmetric s t1 t2 = delimited s s t1 t2
delimitedSymmetric s = delimited s s
eol :: Parser ()
eol = void "\n" <|> void "\r\n" <|> Parsec.eof
@ -170,9 +172,8 @@ header6 = delimitedNoTrailing "====== " eol (Header Six)
-- #anchors#
anchor :: Lexer
anchor = do
x <- located $ between "#" "#" (Anchor <$> anyUntil "#")
pure [x]
x <- located $ between "#" "#" (Anchor <$> anyUntil "#")
pure [x]
moduleNames :: Parser Text
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_ :: Lexer
module_ = between (char '"') (char '"') inner
where
inner = do
m <- located $ Module <$> moduleNames
mAnchor <- optionMaybe (located $ anchorHash *> (Anchor <$> anchorText))
pure $ case mAnchor of
Just anc -> [m, anc]
Nothing -> [m]
where
inner = do
m <- located $ Module <$> moduleNames
mAnchor <- optionMaybe (located $ anchorHash *> (Anchor <$> anchorText))
pure $ case mAnchor of
Just anc -> [m, anc]
Nothing -> [m]
anchorHash :: Parser Text
anchorHash = "#" <|> try "\\#"
anchorHash :: Parser Text
anchorHash = "#" <|> try "\\#"
anchorText :: Parser Text
anchorText = Text.pack <$> many (satisfy (\c -> c /= '"' && not (isSpace c)))
anchorText :: Parser Text
anchorText = Text.pack <$> many (satisfy (\c -> c /= '"' && not (isSpace c)))
linkRaw :: Lexer
linkRaw =
tokenise
[ BracketOpen <$ "["
, Token <$> anyUntil "]"
, BracketClose <$ "]"
, ParenOpen <$ "("
, Token <$> anyUntil ")"
, ParenClose <$ ")"
]
tokenise
[ BracketOpen <$ "["
, Token <$> anyUntil "]"
, BracketClose <$ "]"
, ParenOpen <$ "("
, Token <$> anyUntil ")"
, ParenClose <$ ")"
]
link :: Lexer
link = do
pos <- getPosition
l <- linkRaw
-- register the position of the last token
pos' <- flip incSourceColumn (-1) <$> getPosition
pure $ (pos, LinkOpen) : l <> [(pos', LinkClose)]
pos <- getPosition
l <- linkRaw
-- register the position of the last token
pos' <- flip incSourceColumn (-1) <$> getPosition
pure $ (pos, LinkOpen) : l <> [(pos', LinkClose)]
labeledLink :: Lexer
labeledLink = do
open <- located $ LabeledLinkOpen <$ "<"
linkRes <- linkRaw
labelRes <- located $ Token <$> anyUntil ">"
close <- located $ LabeledLinkClose <$ ">"
pure $
open : linkRes <> [ labelRes , close ]
open <- located $ LabeledLinkOpen <$ "<"
linkRes <- linkRaw
labelRes <- located $ Token <$> anyUntil ">"
close <- located $ LabeledLinkClose <$ ">"
pure $
open : linkRes <> [labelRes, close]
mathMultiline :: Lexer
mathMultiline = delimited "\\[" "\\]" MathMultilineOpen MathMultilineClose
@ -256,23 +257,23 @@ monospace = delimitedSymmetric "@" MonospaceOpen MonospaceClose
other :: Lexer
other = do
pos <- getPosition
c <- takeWhile1_ isUnicodeAlphaNum
pure . pure $ (pos, Token c)
where
isUnicodeAlphaNum c = isPrint c && not (isControl c) && not (isSpace c)
pos <- getPosition
c <- takeWhile1_ isUnicodeAlphaNum
pure . pure $ (pos, Token c)
where
isUnicodeAlphaNum c = isPrint c && not (isControl c) && not (isSpace c)
spaceToken :: Lexer
spaceToken = do
pos <- getPosition
_ <- many1 (char ' ')
pure . pure $ (pos, Space)
pos <- getPosition
_ <- many1 (char ' ')
pure . pure $ (pos, Space)
newlineToken :: Lexer
newlineToken = do
pos <- getPosition
_ <- newline
pure . pure $ (pos, Newline)
pos <- getPosition
_ <- newline
pure . pure $ (pos, Newline)
-------
-- Helpers
@ -281,11 +282,11 @@ newlineToken = do
-- | Like `takeWhile`, but unconditionally take escaped characters.
takeWhile_ :: (Char -> Bool) -> Parser Text
takeWhile_ p = scan p_ False
where
p_ escaped c
| escaped = Just False
| not $ p c = Nothing
| otherwise = Just (c == '\\')
where
p_ escaped c
| escaped = Just False
| not $ p c = Nothing
| otherwise = Just (c == '\\')
-- | Like 'takeWhile1', but unconditionally take escaped characters.
takeWhile1_ :: (Char -> Bool) -> Parser Text
@ -295,19 +296,20 @@ takeWhile1_ = mfilter (not . Text.null) . takeWhile_
function returns true.
-}
scan ::
-- | scan function
(state -> Char -> Maybe state) ->
-- | initial state
state ->
Parser Text
-- | scan function
(state -> Char -> Maybe state) ->
-- | initial state
state ->
Parser Text
scan f initState = do
parserState@State{stateInput = input, statePos = pos} <- Parsec.getParserState
(remaining, finalPos, ct) <- go input initState pos 0
let newState = parserState{stateInput = remaining, statePos = finalPos}
Parsec.setParserState newState $> Text.take ct input
where
go !input' !st !posAccum !count' = case Text.uncons input' of
Nothing -> pure (input', posAccum, count')
Just (char', input'') -> case f st char' of
Nothing -> pure (input', posAccum, count')
Just st' -> go input'' st' (updatePosChar posAccum char') (count' + 1)
parserState@State{stateInput = input, statePos = pos} <- Parsec.getParserState
(remaining, finalPos, ct) <- go input initState pos 0
let newState = parserState{stateInput = remaining, statePos = finalPos}
Parsec.setParserState newState $> Text.take ct input
where
go !input' !st !posAccum !count' = case Text.uncons input' of
Nothing -> pure (input', posAccum, count')
Just (char', input'') -> case f st char' of
Nothing -> pure (input', posAccum, count')
Just st' -> go input'' st' (updatePosChar posAccum char') (count' + 1)

View file

@ -13,7 +13,9 @@ import Text.Parsec.Pos (updatePosChar)
Return everything consumed except for the end pattern itself.
-}
takeUntil :: Text -> Parser Text
takeUntil end_ = Text.dropEnd (Text.length end_) <$> requireEnd (scan p (False, end)) >>= gotSome
takeUntil end_ =
requireEnd (scan p (False, end))
>>= gotSome . Text.dropEnd (Text.length end_)
where
end = Text.unpack end_

View file

@ -9,6 +9,8 @@ module Types (
)
where
import Data.Foldable (fold)
newtype Document = Document
{ meta :: Meta
}
@ -28,6 +30,7 @@ data Since = Since
-- Could have a better type?
type Version = [Int]
type Package = String
data DocMarkup mod id
@ -51,78 +54,78 @@ data DocMarkup mod id
| -- | Bold __bold text__
DocBold (DocMarkup mod id)
| {- | Unordered lists
* this
or
- this
* this
or
- this
-}
DocUnorderedList [DocMarkup mod id]
| {- | Ordered lists
1. this
or
(1) this
1. this
or
(1) this
-}
DocOrderedList [(Int, DocMarkup mod id)]
| {- | Definition lists
[term] a term
[another term] another definition
[term] a term
[another term] another definition
-}
DocDefinitionList [(DocMarkup mod id, DocMarkup mod id)]
| {- | Code blocks
@
a code block in here
with multiple lines
@
@
a code block in here
with multiple lines
@
Or with bird tracks:
> some code
> goes here
Or with bird tracks:
> some code
> goes here
-}
DocCodeBlock (DocMarkup mod id)
| {- | Hyperlinks
__marked__:
<http://example.com>
<http://example.com label text>
__Auto-detected URLs__:
http://example.com
https://example.com
ftp://example.com
__Markdown style__
[link text](http://example.com)
[link text]("Module.Name")
__marked__:
<http://example.com>
<http://example.com label text>
__Auto-detected URLs__:
http://example.com
https://example.com
ftp://example.com
__Markdown style__
[link text](http://example.com)
[link text]("Module.Name")
-}
DocHyperlink (Hyperlink (DocMarkup mod id))
| {- | Pictures
<<image.png>>
<<image.png title text>>
<<image.png>>
<<image.png title text>>
__Markdown Images__
__Markdown Images__
![alt text](image.png)
![alt text](image.png)
-}
DocPicture Picture
| {- | Inline math expressions
\(mathematical expression\)
\(mathematical expression\)
-}
DocMathInline String
| {- | Math multiline display
\[
mathematical expression
in multiple lines
\]
\[
mathematical expression
in multiple lines
\]
-}
DocMathDisplay String
| {- | Anchors, no spaces allowed
#anchor-name#
#anchor-name#
-}
DocAnchor String
| {- | Property descriptions
prop> property description
prop> property description
-}
DocProperty String
| {- | Examples
>>> expression
result line 1
result line 2
>>> expression
result line 1
result line 2
-}
DocExamples [Example]
| -- | Header
@ -136,7 +139,7 @@ instance Semigroup (DocMarkup mod id) where
instance Monoid (DocMarkup mod id) where
mempty = DocEmpty
mconcat = foldr (<>) mempty
mconcat = fold
data ModuleLink id = ModuleLink
{ name :: String

View file

@ -1,42 +1,40 @@
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wno-orphans #-}
import Test.Hspec
import Data.String (IsString (..))
import Data.Text (Text)
import GHC.Stack
import Identifier (Identifier)
import Lexer
import Parser
import Types
import Data.String (IsString (..))
import Data.Text (Text)
import Test.Hspec
import Text.Parsec.Pos
import GHC.Stack
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 "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"))
describe "Parser" do
it "Bold" do
"__bold__" `shouldParseTo` DocBold (DocString "bold")
it "Emphasis" do
"/emphasis/" `shouldParseTo` DocEmphasis (DocString "emphasis")
------------
-- Tests
@ -44,137 +42,138 @@ main = hspec $ do
modules :: Expectation
modules = do
"\"MyModule.Name\""
`shouldLexTo` [ (1, 2, Module "MyModule.Name")
]
"\"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")
]
"\"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)
]
"[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)
]
"<[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")
]
"#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)
]
"\\[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 "(")
]
"\\("
`shouldLexTo` [ (1, 1, Escape)
, (1, 2, Token "(")
]
"\\(\r\n"
`shouldLexTo` [ (1, 1, Escape)
, (1, 2, Token "(")
]
unicode :: Expectation
unicode =
"ドラゴンクエストの冒険者🐉"
`shouldLexTo` [ (1, 1, Token "ドラゴンクエストの冒険者🐉")
]
"ドラゴンクエストの冒険者🐉"
`shouldLexTo` [ (1, 1, Token "ドラゴンクエストの冒険者🐉")
]
ignoreNesting :: Expectation
ignoreNesting =
">/foo/"
`shouldLexTo` [ (1, 1, Token ">/foo/")
]
">/foo/"
`shouldLexTo` [ (1, 1, Token ">/foo/")
]
birdTracks :: Expectation
birdTracks =
">> code"
`shouldLexTo` [ (1, 1, BirdTrack)
, (1, 4, Token "code")
]
">> code"
`shouldLexTo` [ (1, 1, BirdTrack)
, (1, 4, Token "code")
]
quotes :: Expectation
quotes =
"\"quoted\""
`shouldLexTo` [ (1, 1, QuoteOpen)
, (1, 2, Token "quoted")
, (1, 8, QuoteClose)
]
"\"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)
]
"\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)
]
"@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)
]
"/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")
]
"some string"
`shouldLexTo` [ (1, 1, Token "some")
, (1, 5, Space)
, (1, 6, Token "string")
]
--------------
-- Helpers
@ -183,16 +182,16 @@ someString =
type Doc id = DocMarkup () id
instance IsString (Doc String) where
fromString = DocString
fromString = DocString
shouldLexTo :: String -> [(Int, Int, Token)] -> Expectation
shouldLexTo input expected =
withFrozenCallStack $
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
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