feat(lexer): implement numericEntity lexer

Reviewed-on: #5
Co-authored-by: Igor Ranieri <igor@elland.me>
Co-committed-by: Igor Ranieri <igor@elland.me>

.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

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" ]
+

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
+.PHONY: build
-format:
+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

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
@@ -69,7 +70,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
@@ -94,6 +95,7 @@ lexText = go
                   , labeledLink
                   , module_
                   , anchor
+                  , numericEntity
                   , textElement
                   , quotes
                   , birdTrack
@@ -146,7 +148,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
@@ -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

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_
 

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
@@ -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

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 Test.Hspec
-import Data.Text (Text)
-import GHC.Stack
 import Text.Parsec.Pos
 
 main :: IO ()
@@ -30,13 +29,14 @@ 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
     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 +57,7 @@ modules = do
     `shouldLexTo` [ (1, 2, Module "OtherModule.Name")
                   , (1, 18, Anchor "myAnchor")
                   ]
+
 link :: Expectation
 link =
   "[link to](http://some.website)"
@@ -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@"