Compare commits
17 commits
29f6eac7cb
...
de969f461b
| Author | SHA1 | Date | |
|---|---|---|---|
| de969f461b | |||
| 7756aa7867 | |||
| 114c8cdb96 | |||
| e21f9712d5 | |||
| 797eb1cb32 | |||
| dafcd0f6ab | |||
| 5d82d6ad0a | |||
| 5ea8d9b57a | |||
| 46f7ef70e2 | |||
| f464d65052 | |||
| 63760034cf | |||
| f05c93a5a7 | |||
| 7a7bc4d882 | |||
| 3ff0b61851 | |||
| c427f8c320 | |||
| 986af3583c | |||
| d8ba47a8b6 |
8 changed files with 524 additions and 323 deletions
121
.forgejo/workflows/test.yaml
Normal file
121
.forgejo/workflows/test.yaml
Normal 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
30
Dockerfile
Normal 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
44
Makefile
Normal 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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
314
src/Lexer.hs
314
src/Lexer.hs
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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_
|
||||
|
||||
|
|
|
|||
83
src/Types.hs
83
src/Types.hs
|
|
@ -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__
|
||||
|
||||

|
||||

|
||||
-}
|
||||
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
|
||||
|
|
|
|||
249
test/Spec.hs
249
test/Spec.hs
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue