chore: add hls (#10)

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

Dockerfile

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

shell.nix

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

src/Lexer.hs

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

test/Spec.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE MultilineStrings #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 
@@ -18,24 +17,19 @@ main = hspec $ do
   describe "Lexer" do
     describe "minimal" do
       it "handles unicode" unicode
-      it "emphasis" emphatic
-      it "bold" bolded
-      it "monospace" monospace
-      it "module names" modules
-      it "labeled link" labeledLink
-      it "markdown link" link
-      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 "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 "numeric entity" numericEntity
       it "ignores nesting" ignoreNesting
 
   describe "Parser" do
@@ -48,18 +42,6 @@ main = hspec $ do
 -- 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 = do
   "\"MyModule.Name\""
@@ -145,30 +127,6 @@ 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"
@@ -207,18 +165,6 @@ 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@"
@@ -227,14 +173,6 @@ 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/"