From 72986869976a912b2e6bda6994f39afcae9211cb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Fri, 26 Sep 2025 16:51:18 +0800 Subject: [PATCH 1/3] feat(lexer): implement numericEntity lexer --- src/Lexer.hs | 28 +++++++++++++++++++++++++++- test/Spec.hs | 13 +++++++++++++ 2 files changed, 40 insertions(+), 1 deletion(-) diff --git a/src/Lexer.hs b/src/Lexer.hs index 4a85fb5..47c4e1c 100644 --- a/src/Lexer.hs +++ b/src/Lexer.hs @@ -8,10 +8,11 @@ module Lexer ( where import Control.Monad (mfilter, void) +import Data.Char (ord, toLower) import Data.Functor (($>)) import Data.Text (Text, intercalate) import Data.Text qualified as Text -import GHC.Unicode (isAlphaNum, isControl, isPrint, isSpace, isUpper) +import GHC.Unicode (isAlphaNum, isControl, isDigit, isPrint, isSpace, isUpper) import ParserMonad (Parser, initialParserState) import Text.Parsec import Text.Parsec qualified as Parsec @@ -94,6 +95,7 @@ lexText = go , labeledLink , module_ , anchor + , numericEntity , textElement , quotes , birdTrack @@ -255,6 +257,30 @@ bold = delimitedSymmetric "__" BoldOpen BoldClose monospace :: Lexer monospace = delimitedSymmetric "@" MonospaceOpen MonospaceClose +decimal :: Parser Int +decimal = read . Text.unpack <$> takeWhile1_ isDigit + +hexadecimal :: Parser Int +hexadecimal = "x" *> (convert 0 . fmap (normalise . toLower) <$> many1 hexDigit) + where + normalise :: Char -> Int + normalise c + | ord '0' <= n && n <= ord '9' = n - ord '0' + | ord 'A' <= n && n <= ord 'F' = n - ord 'A' + 10 + | ord 'a' <= n && n <= ord 'f' = n - ord 'a' + 10 + | otherwise = error "unexpected: invalid hex number" + where + n = ord c + + convert :: Int -> [Int] -> Int + convert acc [] = acc + convert acc (x : xs) = convert (acc * 16 + x) xs + +numericEntity :: Lexer +numericEntity = do + x <- located $ between "&#" ";" (NumericEntity <$> (hexadecimal <|> decimal)) + pure [x] + other :: Lexer other = do pos <- getPosition diff --git a/test/Spec.hs b/test/Spec.hs index 7258a2d..03e1b81 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -30,6 +30,7 @@ main = hspec $ do it "bird tracks" birdTracks it "module names" modules it "quotes" quotes + it "numeric entity" numericEntity it "ignores nesting" ignoreNesting describe "Parser" do @@ -152,6 +153,18 @@ space = do , (1, 2, Newline) ] +numericEntity :: Expectation +numericEntity = do + "A λ" + `shouldLexTo` [ (1, 1, NumericEntity 65) + , (1, 6, Space) + , (1, 7, NumericEntity 955) -- lambda + ] + -- Hex + "e" + `shouldLexTo` [ (1, 1, NumericEntity 101) + ] + monospace :: Expectation monospace = "@mono@" From 08dc87a3076c0deab4703db6d51064f4d6a2e6b4 Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Sat, 27 Sep 2025 15:03:00 +0000 Subject: [PATCH 2/3] Add CI runner (#5) Reviewed-on: https://git.elland.me/elland/haddock2/pulls/5 Co-authored-by: Igor Ranieri Co-committed-by: Igor Ranieri --- .forgejo/workflows/test.yaml | 99 ++++++++++++++++++++++++++++++++++++ Dockerfile | 36 +++++++++++++ Makefile | 41 +++++++++++++-- src/Lexer.hs | 4 +- src/Parser/Util.hs | 4 +- src/Types.hs | 83 +++++++++++++++--------------- test/Spec.hs | 14 ++--- 7 files changed, 228 insertions(+), 53 deletions(-) create mode 100644 .forgejo/workflows/test.yaml create mode 100644 Dockerfile diff --git a/.forgejo/workflows/test.yaml b/.forgejo/workflows/test.yaml new file mode 100644 index 0000000..ee81782 --- /dev/null +++ b/.forgejo/workflows/test.yaml @@ -0,0 +1,99 @@ +name: Haskell CI +on: + pull_request: + branches: + - dev + - main + push: + branches: + - main + +jobs: + build: + runs-on: docker + container: + image: elland/haddock2:latest + steps: + - 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: elland/haddock2:latest + needs: build + steps: + - 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: elland/haddock2:latest + needs: build + steps: + - name: Checkout code + uses: actions/checkout@v4 + - 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: elland/haddock2:latest + needs: build + steps: + - name: Checkout code + uses: actions/checkout@v4 + - 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 diff --git a/Dockerfile b/Dockerfile new file mode 100644 index 0000000..c2919c5 --- /dev/null +++ b/Dockerfile @@ -0,0 +1,36 @@ +FROM haskell:9.10.2-bullseye AS builder + +RUN apt-get update && apt-get install -y curl git && rm -rf /var/lib/apt/lists/* + +RUN curl -fsSL https://deb.nodesource.com/setup_22.x | bash - && \ + apt-get install -y nodejs && \ + rm -rf /var/lib/apt/lists/* + +RUN cabal update && \ + cabal install --install-method=copy --installdir=/usr/local/bin \ + fourmolu hlint cabal-gild + +WORKDIR /workspace + +FROM haskell:9.10.2-bullseye + +RUN apt-get update && apt-get install -y \ + libgmp10 \ + curl \ + && rm -rf /var/lib/apt/lists/* + +RUN curl -fsSL https://deb.nodesource.com/setup_22.x | bash - && \ + apt-get install -y nodejs && \ + rm -rf /var/lib/apt/lists/* + +RUN cabal update + +COPY --from=builder /usr/local/bin/cabal /usr/local/bin/ +COPY --from=builder /usr/local/bin/fourmolu /usr/local/bin/ +COPY --from=builder /usr/local/bin/hlint /usr/local/bin/ +COPY --from=builder /usr/local/bin/cabal-gild /usr/local/bin/ + +WORKDIR /workspace + +CMD [ "bash" ] + diff --git a/Makefile b/Makefile index 62cad36..6bc9ca2 100644 --- a/Makefile +++ b/Makefile @@ -1,9 +1,44 @@ .PHONY: help -help: ## Show this 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: format -format: +.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 diff --git a/src/Lexer.hs b/src/Lexer.hs index 4a85fb5..84a8373 100644 --- a/src/Lexer.hs +++ b/src/Lexer.hs @@ -69,7 +69,7 @@ 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 @@ -146,7 +146,7 @@ delimitedNoTrailing openP closeP openTok = asList <$> delimitedAsTuple (openTok 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 diff --git a/src/Parser/Util.hs b/src/Parser/Util.hs index 4cf96cb..a75fcef 100644 --- a/src/Parser/Util.hs +++ b/src/Parser/Util.hs @@ -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_ diff --git a/src/Types.hs b/src/Types.hs index a41e38b..ec7a4e4 100644 --- a/src/Types.hs +++ b/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__: - - - __Auto-detected URLs__: - http://example.com - https://example.com - ftp://example.com - __Markdown style__ - [link text](http://example.com) - [link text]("Module.Name") + __marked__: + + + __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 - <> - <> + <> + <> - __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 diff --git a/test/Spec.hs b/test/Spec.hs index 7258a2d..683c56d 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,16 +1,15 @@ {-# 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 GHC.Stack +import Test.Hspec import Text.Parsec.Pos main :: IO () @@ -34,9 +33,9 @@ main = hspec $ do describe "Parser" do it "Bold" do - "__bold__" `shouldParseTo` (DocBold (DocString "bold")) + "__bold__" `shouldParseTo` DocBold (DocString "bold") it "Emphasis" do - "/emphasis/" `shouldParseTo` (DocEmphasis (DocString "emphasis")) + "/emphasis/" `shouldParseTo` DocEmphasis (DocString "emphasis") ------------ -- Tests @@ -57,6 +56,7 @@ modules = do `shouldLexTo` [ (1, 2, Module "OtherModule.Name") , (1, 18, Anchor "myAnchor") ] + link :: Expectation link = "[link to](http://some.website)" From f26b68cad46f55b7a505927675315315145bd375 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Fri, 26 Sep 2025 16:51:18 +0800 Subject: [PATCH 3/3] feat(lexer): implement numericEntity lexer --- src/Lexer.hs | 28 +++++++++++++++++++++++++++- test/Spec.hs | 13 +++++++++++++ 2 files changed, 40 insertions(+), 1 deletion(-) diff --git a/src/Lexer.hs b/src/Lexer.hs index 84a8373..77fc84a 100644 --- a/src/Lexer.hs +++ b/src/Lexer.hs @@ -8,10 +8,11 @@ module Lexer ( where import Control.Monad (mfilter, void) +import Data.Char (ord, toLower) import Data.Functor (($>)) import Data.Text (Text, intercalate) import Data.Text qualified as Text -import GHC.Unicode (isAlphaNum, isControl, isPrint, isSpace, isUpper) +import GHC.Unicode (isAlphaNum, isControl, isDigit, isPrint, isSpace, isUpper) import ParserMonad (Parser, initialParserState) import Text.Parsec import Text.Parsec qualified as Parsec @@ -94,6 +95,7 @@ lexText = go , labeledLink , module_ , anchor + , numericEntity , textElement , quotes , birdTrack @@ -255,6 +257,30 @@ bold = delimitedSymmetric "__" BoldOpen BoldClose monospace :: Lexer monospace = delimitedSymmetric "@" MonospaceOpen MonospaceClose +decimal :: Parser Int +decimal = read . Text.unpack <$> takeWhile1_ isDigit + +hexadecimal :: Parser Int +hexadecimal = "x" *> (convert 0 . fmap (normalise . toLower) <$> many1 hexDigit) + where + normalise :: Char -> Int + normalise c + | ord '0' <= n && n <= ord '9' = n - ord '0' + | ord 'A' <= n && n <= ord 'F' = n - ord 'A' + 10 + | ord 'a' <= n && n <= ord 'f' = n - ord 'a' + 10 + | otherwise = error "unexpected: invalid hex number" + where + n = ord c + + convert :: Int -> [Int] -> Int + convert acc [] = acc + convert acc (x : xs) = convert (acc * 16 + x) xs + +numericEntity :: Lexer +numericEntity = do + x <- located $ between "&#" ";" (NumericEntity <$> (hexadecimal <|> decimal)) + pure [x] + other :: Lexer other = do pos <- getPosition diff --git a/test/Spec.hs b/test/Spec.hs index 683c56d..2040e2f 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -29,6 +29,7 @@ main = hspec $ do it "bird tracks" birdTracks it "module names" modules it "quotes" quotes + it "numeric entity" numericEntity it "ignores nesting" ignoreNesting describe "Parser" do @@ -152,6 +153,18 @@ space = do , (1, 2, Newline) ] +numericEntity :: Expectation +numericEntity = do + "A λ" + `shouldLexTo` [ (1, 1, NumericEntity 65) + , (1, 6, Space) + , (1, 7, NumericEntity 955) -- lambda + ] + -- Hex + "e" + `shouldLexTo` [ (1, 1, NumericEntity 101) + ] + monospace :: Expectation monospace = "@mono@"