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)
@@ -62,6 +63,7 @@ data Token
   | Module Text
   | QuoteOpen
   | QuoteClose
+  | Picture {href :: Text, altText :: Maybe Text}
   | Space
   | EOF
   deriving (Eq, Show)
@@ -90,6 +92,7 @@ lexText = go
                   , escape -- maths go before escape to avoid mismatch
                   , headers
                   , newlineToken
+                  , pictures
                   , spaceToken
                   , link
                   , labeledLink
@@ -127,6 +130,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)
 
@@ -177,6 +188,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 '.'
 
@@ -286,8 +318,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