Compare commits

..

4 commits

Author SHA1 Message Date
36e1955f06 Updated dockerfile.
Some checks failed
Haskell CI / build (pull_request) Failing after 2m50s
Haskell CI / test (pull_request) Has been skipped
Haskell CI / fourmolu (pull_request) Has been skipped
Haskell CI / hlint (pull_request) Has been skipped
2025-10-05 18:43:21 +02:00
43be9e3f7f lex: expressions
Some checks failed
Haskell CI / build (pull_request) Failing after 2m37s
Haskell CI / test (pull_request) Has been skipped
Haskell CI / fourmolu (pull_request) Has been skipped
Haskell CI / hlint (pull_request) Has been skipped
2025-10-05 16:45:04 +02:00
471de1c68a Tests
Some checks failed
Haskell CI / build (pull_request) Failing after 2m26s
Haskell CI / test (pull_request) Has been skipped
Haskell CI / fourmolu (pull_request) Has been skipped
Haskell CI / hlint (pull_request) Has been skipped
2025-10-05 15:19:24 +02:00
cae12ef4c0 Added picture support
All checks were successful
Haskell CI / build (pull_request) Successful in 2m54s
Haskell CI / test (pull_request) Successful in 2m29s
Haskell CI / fourmolu (pull_request) Successful in 6s
Haskell CI / hlint (pull_request) Successful in 6s
2025-10-05 15:17:57 +02:00
4 changed files with 134 additions and 38 deletions

View file

@ -1,36 +1,21 @@
FROM haskell:9.10.2-bullseye AS builder FROM haskell:9.12.2-slim-bookworm
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 \ RUN apt-get update && apt-get install -y \
libgmp10 \
curl \ curl \
git \
libgmp10 \
&& rm -rf /var/lib/apt/lists/* && rm -rf /var/lib/apt/lists/*
# Install Node.js
RUN curl -fsSL https://deb.nodesource.com/setup_22.x | bash - && \ RUN curl -fsSL https://deb.nodesource.com/setup_22.x | bash - && \
apt-get install -y nodejs && \ apt-get install -y nodejs && \
rm -rf /var/lib/apt/lists/* rm -rf /var/lib/apt/lists/*
RUN cabal update # Install Haskell tools
RUN cabal update && \
COPY --from=builder /usr/local/bin/cabal /usr/local/bin/ cabal install --install-method=copy --installdir=/usr/local/bin \
COPY --from=builder /usr/local/bin/fourmolu /usr/local/bin/ fourmolu hlint cabal-gild && \
COPY --from=builder /usr/local/bin/hlint /usr/local/bin/ rm -rf ~/.cabal/packages ~/.cabal/store
COPY --from=builder /usr/local/bin/cabal-gild /usr/local/bin/
WORKDIR /workspace WORKDIR /workspace
CMD ["bash"]
CMD [ "bash" ]

View file

@ -12,7 +12,6 @@ pkgs.mkShell rec {
with pkgs; with pkgs;
[ [
haskell.packages.ghc912.ghc haskell.packages.ghc912.ghc
haskell.packages.ghc912.haskell-language-server
zlib zlib
] ]
++ map haskell.lib.justStaticExecutables [ ++ map haskell.lib.justStaticExecutables [

View file

@ -1,4 +1,5 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Lexer ( module Lexer (
Token (..), Token (..),
@ -7,7 +8,7 @@ module Lexer (
) )
where where
import Control.Monad (mfilter, void) import Control.Monad (guard, mfilter, void)
import Data.Char (ord, toLower) import Data.Char (ord, toLower)
import Data.Functor (($>)) import Data.Functor (($>))
import Data.Text (Text, intercalate) import Data.Text (Text, intercalate)
@ -42,6 +43,8 @@ data Token
| Escape | Escape
| EmphasisOpen | EmphasisOpen
| EmphasisClose | EmphasisClose
| Expression
| ResultLine Text
| Header Level | Header Level
| MonospaceOpen | MonospaceOpen
| MonospaceClose | MonospaceClose
@ -62,6 +65,7 @@ data Token
| Module Text | Module Text
| QuoteOpen | QuoteOpen
| QuoteClose | QuoteClose
| Picture {href :: Text, altText :: Maybe Text}
| Space | Space
| EOF | EOF
deriving (Eq, Show) deriving (Eq, Show)
@ -90,6 +94,7 @@ lexText = go
, escape -- maths go before escape to avoid mismatch , escape -- maths go before escape to avoid mismatch
, headers , headers
, newlineToken , newlineToken
, pictures
, spaceToken , spaceToken
, link , link
, labeledLink , labeledLink
@ -99,6 +104,7 @@ lexText = go
, textElement , textElement
, quotes , quotes
, birdTrack , birdTrack
, expression
, other , other
] ]
rest <- go rest <- go
@ -127,6 +133,14 @@ headers =
, header6 , header6
] ]
pictures :: Parser [LocatedToken]
pictures =
choice $
Parsec.try
<$> [ picture
, markdownPicture
]
anyUntil :: Parser a -> Parser Text anyUntil :: Parser a -> Parser Text
anyUntil p = Text.pack <$> manyTill anyChar (lookAhead p) anyUntil p = Text.pack <$> manyTill anyChar (lookAhead p)
@ -153,6 +167,11 @@ delimitedSymmetric s = delimited s s
eol :: Parser () eol :: Parser ()
eol = void "\n" <|> void "\r\n" <|> Parsec.eof eol = void "\n" <|> void "\r\n" <|> Parsec.eof
sol :: Parser ()
sol = do
pos <- getPosition
guard $ sourceColumn pos == 1
header1 :: Lexer header1 :: Lexer
header1 = delimitedNoTrailing "= " eol (Header One) header1 = delimitedNoTrailing "= " eol (Header One)
@ -177,6 +196,27 @@ anchor = do
x <- located $ between "#" "#" (Anchor <$> anyUntil "#") x <- located $ between "#" "#" (Anchor <$> anyUntil "#")
pure [x] pure [x]
picture :: Lexer
picture = do
void $ string "<<"
pos <- getPosition
href <- anyUntil (string " " <|> string ">>")
altText <- optionMaybe do
void $ many1 space
anyUntil ">>"
void (string ">>")
pure [(pos, Picture{..})]
markdownPicture :: Lexer
markdownPicture = do
void $ string "!["
pos <- getPosition
altText <- optionMaybe $ anyUntil "]("
void $ string "]("
href <- anyUntil ")"
void $ string ")"
pure [(pos, Picture{..})]
moduleNames :: Parser Text moduleNames :: Parser Text
moduleNames = intercalate "." . fmap Text.pack <$> upperId `sepBy1` char '.' moduleNames = intercalate "." . fmap Text.pack <$> upperId `sepBy1` char '.'
@ -240,7 +280,16 @@ mathInline :: Lexer
mathInline = delimited "\\(" "\\)" MathInlineOpen MathInlineClose mathInline = delimited "\\(" "\\)" MathInlineOpen MathInlineClose
birdTrack :: Lexer birdTrack :: Lexer
birdTrack = delimitedNoTrailing ">> " eol BirdTrack birdTrack = sol *> delimitedNoTrailing ">> " eol BirdTrack
expression :: Lexer
expression = do
exprs <- sol *> delimitedNoTrailing ">>> " eol Expression
results <- manyTill resultLine endOfResults
pure $ exprs <> results
where
endOfResults = lookAhead $ void newline <|> eof
resultLine = located $ ResultLine <$> (anyUntil eol <* eol)
escape :: Lexer escape :: Lexer
escape = delimitedNoTrailing "\\" eol Escape escape = delimitedNoTrailing "\\" eol Escape
@ -286,8 +335,9 @@ other = do
pos <- getPosition pos <- getPosition
c <- takeWhile1_ isUnicodeAlphaNum c <- takeWhile1_ isUnicodeAlphaNum
pure . pure $ (pos, Token c) pure . pure $ (pos, Token c)
where
isUnicodeAlphaNum c = isPrint c && not (isControl c) && not (isSpace c) isUnicodeAlphaNum :: Char -> Bool
isUnicodeAlphaNum c = isPrint c && not (isControl c) && not (isSpace c)
spaceToken :: Lexer spaceToken :: Lexer
spaceToken = do spaceToken = do

View file

@ -1,3 +1,4 @@
{-# LANGUAGE MultilineStrings #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -Wno-orphans #-}
@ -17,19 +18,24 @@ main = hspec $ do
describe "Lexer" do describe "Lexer" do
describe "minimal" do describe "minimal" do
it "handles unicode" unicode 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 "emphasis" emphatic
it "bold" bolded
it "monospace" monospace it "monospace" monospace
it "module names" modules
it "labeled link" labeledLink it "labeled link" labeledLink
it "markdown link" link it "markdown link" link
it "bird tracks" birdTracks it "anchors" anchor
it "module names" modules it "images" images
it "quotes" quotes it "maths" math
it "numeric entity" numericEntity it "numeric entity" numericEntity
it "code blocks" codeBlocks
it "bird tracks" birdTracks
it "expressions" expressions
it "escapes" escaping
it "space chars" space
it "bare string" someString
it "quotes" quotes
it "ignores nesting" ignoreNesting it "ignores nesting" ignoreNesting
describe "Parser" do describe "Parser" do
@ -42,6 +48,18 @@ main = hspec $ do
-- Tests -- Tests
------------ ------------
images :: Expectation
images = do
"<<image.png>>"
`shouldLexTo` [ (1, 3, Picture "image.png" Nothing)
]
"<<image.png title text>>"
`shouldLexTo` [ (1, 3, Picture "image.png" (Just "title text"))
]
"![alt text](image.png)"
`shouldLexTo` [ (1, 3, Picture "image.png" (Just "alt text"))
]
modules :: Expectation modules :: Expectation
modules = do modules = do
"\"MyModule.Name\"" "\"MyModule.Name\""
@ -127,6 +145,30 @@ ignoreNesting =
`shouldLexTo` [ (1, 1, Token ">/foo/") `shouldLexTo` [ (1, 1, Token ">/foo/")
] ]
expressions :: Expectation
expressions = do
"""
>>> expression
result line 1
result line 2
"""
`shouldLexTo` [ (1, 1, Expression)
, (1, 5, Token "expression")
, (2, 1, ResultLine "result line 1")
, (3, 1, ResultLine "result line 2")
]
"""
>>> expression
result line 3
result line 4
"""
`shouldLexTo` [ (1, 1, Expression)
, (1, 5, Token "expression")
, (2, 1, ResultLine "result line 3")
, (3, 1, ResultLine "result line 4")
]
birdTracks :: Expectation birdTracks :: Expectation
birdTracks = birdTracks =
">> code" ">> code"
@ -165,6 +207,18 @@ numericEntity = do
`shouldLexTo` [ (1, 1, NumericEntity 101) `shouldLexTo` [ (1, 1, NumericEntity 101)
] ]
codeBlocks :: Expectation
codeBlocks =
"""
@
func call here
@
"""
`shouldLexTo` [ (1, 1, MonospaceOpen)
, (1, 2, Token "\nfunc call here\n")
, (3, 1, MonospaceClose)
]
monospace :: Expectation monospace :: Expectation
monospace = monospace =
"@mono@" "@mono@"
@ -173,6 +227,14 @@ monospace =
, (1, 6, MonospaceClose) , (1, 6, MonospaceClose)
] ]
bolded :: Expectation
bolded =
"__bold text__"
`shouldLexTo` [ (1, 1, BoldOpen)
, (1, 3, Token "bold text")
, (1, 12, BoldClose)
]
emphatic :: Expectation emphatic :: Expectation
emphatic = emphatic =
"/emphatic/" "/emphatic/"