Add located combinator; improved anchor matches with tests

src/Lexer.hs

@@ -31,7 +31,7 @@ data Level
 
 data Token
     = Token Text
-  | Anchor
+    | Anchor Text
     | BirdTrack
     | BoldOpen
     | BoldClose
@@ -54,6 +54,7 @@ data Token
     | MathsParenClose
     | MathsBracketOpen
     | MathsBracketClose
+    | NumericEntity Int
     | Module
     | QuoteOpen
     | QuoteClose
@@ -167,37 +168,33 @@ anchors :: Lexer
 anchors = do
     pos <- getPosition
     void $ try anchor'
-  pos' <- getPosition
     txt <- anyUntil anchor'
-  pos'' <- getPosition
     void $ try anchor'
 
-  pure
+    pure [(pos, Anchor txt)]
-    [ (pos, Anchor)
-    , (pos', Token txt)
-    , (pos'', Anchor)
-    ]
   where
     anchor' = (string "#" <|> string "\\#")
 
+located :: Parser a -> Parser (SourcePos, a)
+located p = (,) <$> getPosition <*> p
+
+startPosition :: Parser a -> Parser SourcePos
+startPosition = fmap fst . located
+
 -- "Module.Name"
 -- "Module.Name#anchor"
--- "Module.Name#anchor"
+-- "Module.Name\#anchor" -- this has been deprecated for 9 years, thanks Ben
 modules :: Lexer
 modules = do
-  pos <- getPosition
+    startPos <- startPosition $ char '"'
-  void $ char '"'
+    (modPos, modName) <- located modId
-  pos' <- getPosition
-  modName <- modId
     anch <- option [] do
-    pos'' <- getPosition
+        anchPos <- startPosition (string "#" <|> string' "\\#")
-    void $ try (string "#" <|> string "\\#")
+        txt <- Text.pack <$> many (satisfy (\c -> c /= '"' && not (isSpace c)))
-    pos''' <- getPosition
+        pure [(anchPos, Anchor txt)]
-    a <- Text.pack <$> many (satisfy (\c -> c /= '"' && not (isSpace c)))
-    pure [(pos'', Anchor), (pos''', Token a)]
 
     void $ char '"'
-  pure $ [(pos, Module), (pos', Token modName)] <> anch
+    pure $ [(startPos, Module), (modPos, Token modName)] <> anch
   where
     modId = intercalate "." <$> (fmap Text.pack <$> (conId `sepBy1` (char '.')))
 

test/Spec.hs

@@ -51,10 +51,14 @@ modules = do
     "\"OtherModule.Name#myAnchor\""
         `shouldLexTo` [ (1, 1, Module)
                       , (1, 2, Token "OtherModule.Name")
-                  , (1, 18, Anchor)
+                      , (1, 18, Anchor "myAnchor")
-                  , (1, 19, Token "myAnchor")
                       ]
 
+    "\"OtherModule.Name\\#myAnchor\""
+        `shouldLexTo` [ (1, 1, Module)
+                      , (1, 2, Token "OtherModule.Name")
+                      , (1, 18, Anchor "myAnchor")
+                      ]
 link :: Expectation
 link =
     "[link to](http://some.website)"
@@ -85,9 +89,7 @@ labeledLink =
 anchors :: Expectation
 anchors =
     "#myAnchor#"
-    `shouldLexTo` [ (1, 1, Anchor)
+        `shouldLexTo` [ (1, 1, Anchor "myAnchor")
-                  , (1, 2, Token "myAnchor")
-                  , (1, 10, Anchor)
                       ]
 
 maths :: IO ()

test/markup.md

@@ -27,8 +27,16 @@ ftp\://example.com
 
 ![alt text](image.png)
 
-\(mathematical expression\)
+\(mathematical 1+3 expression\)
-\[mathematical expression\]
+
+\[mathematical
+ expression
+ accross lines with + addition and such
+\]
+
+&#123
+&#x65
+&#165
 
 @
 code block content