diff --git a/Dockerfile b/Dockerfile index c2919c5..5c84af4 100644 --- a/Dockerfile +++ b/Dockerfile @@ -1,36 +1,21 @@ -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 +FROM haskell:9.12.2-slim-bookworm RUN apt-get update && apt-get install -y \ - libgmp10 \ curl \ + git \ + libgmp10 \ && rm -rf /var/lib/apt/lists/* +# Install Node.js 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/ +# Install Haskell tools +RUN cabal update && \ + cabal install --install-method=copy --installdir=/usr/local/bin \ + fourmolu hlint cabal-gild && \ + rm -rf ~/.cabal/packages ~/.cabal/store WORKDIR /workspace - -CMD [ "bash" ] - +CMD ["bash"] diff --git a/shell.nix b/shell.nix index 61a931d..d67a849 100644 --- a/shell.nix +++ b/shell.nix @@ -12,7 +12,6 @@ pkgs.mkShell rec { with pkgs; [ haskell.packages.ghc912.ghc - haskell.packages.ghc912.haskell-language-server zlib ] ++ map haskell.lib.justStaticExecutables [ diff --git a/src/Lexer.hs b/src/Lexer.hs index 77fc84a..a43c034 100644 --- a/src/Lexer.hs +++ b/src/Lexer.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} module Lexer ( Token (..), @@ -7,7 +8,7 @@ module Lexer ( ) where -import Control.Monad (mfilter, void) +import Control.Monad (guard, mfilter, void) import Data.Char (ord, toLower) import Data.Functor (($>)) import Data.Text (Text, intercalate) @@ -42,6 +43,8 @@ data Token | Escape | EmphasisOpen | EmphasisClose + | Expression + | ResultLine Text | Header Level | MonospaceOpen | MonospaceClose @@ -62,6 +65,7 @@ data Token | Module Text | QuoteOpen | QuoteClose + | Picture {href :: Text, altText :: Maybe Text} | Space | EOF deriving (Eq, Show) @@ -90,6 +94,7 @@ lexText = go , escape -- maths go before escape to avoid mismatch , headers , newlineToken + , pictures , spaceToken , link , labeledLink @@ -99,6 +104,7 @@ lexText = go , textElement , quotes , birdTrack + , expression , other ] rest <- go @@ -127,6 +133,14 @@ headers = , header6 ] +pictures :: Parser [LocatedToken] +pictures = + choice $ + Parsec.try + <$> [ picture + , markdownPicture + ] + anyUntil :: Parser a -> Parser Text anyUntil p = Text.pack <$> manyTill anyChar (lookAhead p) @@ -153,6 +167,11 @@ delimitedSymmetric s = delimited s s eol :: Parser () eol = void "\n" <|> void "\r\n" <|> Parsec.eof +sol :: Parser () +sol = do + pos <- getPosition + guard $ sourceColumn pos == 1 + header1 :: Lexer header1 = delimitedNoTrailing "= " eol (Header One) @@ -177,6 +196,27 @@ anchor = do x <- located $ between "#" "#" (Anchor <$> anyUntil "#") 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 = intercalate "." . fmap Text.pack <$> upperId `sepBy1` char '.' @@ -240,7 +280,16 @@ mathInline :: Lexer mathInline = delimited "\\(" "\\)" MathInlineOpen MathInlineClose 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 = delimitedNoTrailing "\\" eol Escape @@ -286,8 +335,9 @@ other = do pos <- getPosition c <- takeWhile1_ isUnicodeAlphaNum 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 = do diff --git a/test/Spec.hs b/test/Spec.hs index 2040e2f..2794072 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE MultilineStrings #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -17,19 +18,24 @@ 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 "bold" bolded it "monospace" monospace + it "module names" modules it "labeled link" labeledLink it "markdown link" link - it "bird tracks" birdTracks - it "module names" modules - it "quotes" quotes + it "anchors" anchor + it "images" images + it "maths" math 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 describe "Parser" do @@ -42,6 +48,18 @@ main = hspec $ do -- Tests ------------ +images :: Expectation +images = do + "<>" + `shouldLexTo` [ (1, 3, Picture "image.png" Nothing) + ] + "<>" + `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 = do "\"MyModule.Name\"" @@ -127,6 +145,30 @@ ignoreNesting = `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 = ">> code" @@ -165,6 +207,18 @@ numericEntity = do `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 = "@mono@" @@ -173,6 +227,14 @@ monospace = , (1, 6, MonospaceClose) ] +bolded :: Expectation +bolded = + "__bold text__" + `shouldLexTo` [ (1, 1, BoldOpen) + , (1, 3, Token "bold text") + , (1, 12, BoldClose) + ] + emphatic :: Expectation emphatic = "/emphatic/"