Skip to content

Commit 84e8e99

Browse files
Simre1Simre1
committed
Fix parsing stop after math & verbatim modifiers
1 parent ff79a8d commit 84e8e99

File tree

3 files changed

+104
-68
lines changed

3 files changed

+104
-68
lines changed

‎Readme.md

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -34,7 +34,7 @@ Here, I have used the `neorg-pandoc-linux86` binary to transform my `norg` file
3434
## Implementation status
3535

3636
- Attached Modifiers :heavy_check_mark:
37-
- Intersecting modifiers :x:
37+
- Intersecting modifiers :white_check_mark:
3838
- Detached Modifiers :white_check_mark:
3939
- Heading :heavy_check_mark:
4040
- List :heavy_check_mark:

‎src/Neorg/Parser.hs

Lines changed: 93 additions & 66 deletions
Original file line numberDiff line numberDiff line change
@@ -2,38 +2,45 @@
22
{-# LANGUAGE DeriveFunctor #-}
33
{-# LANGUAGE TemplateHaskell #-}
44

5-
65
module Neorg.Parser where
76

8-
import Control.Applicative
7+
import Control.Applicative (Alternative (many, (<|>)))
98
import Control.Arrow (left)
10-
import Control.Monad
11-
import Control.Monad.Trans.Class
9+
import Control.Monad (guard, void)
10+
import Control.Monad.Trans.Class (MonadTrans (lift))
1211
import Control.Monad.Trans.State
12+
( State,
13+
StateT (runStateT),
14+
evalStateT,
15+
get,
16+
gets,
17+
modify,
18+
put,
19+
)
1320
import Data.Bool (bool)
1421
import Data.Char (isLetter)
1522
import Data.Foldable (foldl')
16-
import Data.Functor
17-
import Data.Functor.Identity
18-
import Data.Maybe ( catMaybes )
23+
import Data.Functor (($>), (<&>))
24+
import Data.Functor.Identity (Identity (runIdentity))
25+
import Data.Maybe (catMaybes)
1926
import qualified Data.Set as S
2027
import Data.Text (Text, pack, unpack)
2128
import qualified Data.Text as T
2229
import Data.Time (dayOfWeek, defaultTimeLocale, parseTimeM)
2330
import qualified Data.Vector as V
2431
import Data.Vector.Generic.Mutable (clear)
25-
import Data.Void
32+
import Data.Void (Void)
2633
import Debug.Trace
2734
import Neorg.Document
2835
import Neorg.Document.Tag (GenerateTagParser, parseTag)
2936
import Neorg.ParsingUtils (embedParser)
30-
import Optics.Core
31-
import Optics.TH
37+
import Optics.Core (view, (%~), (&), (.~), (<&>), (?~), (^.))
38+
import Optics.TH (makeLenses)
3239
import Text.Megaparsec (parseErrorPretty)
3340
import qualified Text.Megaparsec as P
3441
import qualified Text.Megaparsec.Char as P
3542
import qualified Text.Megaparsec.Char.Lexer as P
36-
import Text.Megaparsec.Internal
43+
import Text.Megaparsec.Internal (ParsecT (..))
3744

3845
data ParserState = ParserState
3946
{ _parserHeadingLevel :: IndentationLevel,
@@ -43,9 +50,9 @@ data ParserState = ParserState
4350

4451
data InlineState = InlineState {_modifierInline :: ModifierInline, _delimitedActive :: Bool} deriving (Show)
4552

46-
data ModifierInline = NoModifier Inline | OpenModifier String Inline ModifierInline deriving (Show)
53+
data ModifierInline = NoModifier Inline | OpenModifier Text Inline ModifierInline deriving (Show)
4754

48-
hasModifier :: String -> ModifierInline -> Bool
55+
hasModifier :: Text -> ModifierInline -> Bool
4956
hasModifier c (NoModifier _) = False
5057
hasModifier c1 (OpenModifier c2 i b) = c1 == c2 || hasModifier c1 b
5158

@@ -72,12 +79,11 @@ parse fileName fileContent =
7279

7380
document :: GenerateTagParser tags => Parser (Document tags)
7481
document = do
75-
blocks <- blocks
76-
pure $ Document blocks
82+
Document <$> blocks
7783

7884
blocks :: GenerateTagParser tags => Parser (Blocks tags)
7985
blocks = do
80-
blocks <- P.many $ singleBlock
86+
blocks <- P.many singleBlock
8187
pure $ V.fromList $ catMaybes blocks
8288

8389
singleBlock :: GenerateTagParser tags => Parser (Maybe (Block tags))
@@ -261,12 +267,12 @@ runInline p = fmap canonalizeInline $ do
261267
where
262268
reduceModifierInline :: ModifierInline -> Inline
263269
reduceModifierInline (NoModifier i) = i
264-
reduceModifierInline (OpenModifier c i b) = ConcatInline $ V.fromList [reduceModifierInline b, Text $ pack c, i]
270+
reduceModifierInline (OpenModifier c i b) = ConcatInline $ V.fromList [reduceModifierInline b, Text c, i]
265271

266272
paragraph' :: forall p. (MonadFail p, P.MonadParsec Void Text p) => StateT InlineState p () -> StateT InlineState p ()
267273
paragraph' end' = do
268274
(end >> pure ())
269-
<|> (lookChar >>= \c -> openings c <|> word c)
275+
<|> (lookChar >>= \c -> attachedOpenings c <|> word c)
270276
where
271277
end = do
272278
end' <|> P.eof
@@ -276,20 +282,41 @@ paragraph' end' = do
276282
modifierInline %~ \case
277283
NoModifier i -> NoModifier $ i <> t
278284
OpenModifier c i b -> OpenModifier c (i <> t) b
279-
280-
openings :: Char -> StateT InlineState p ()
281-
openings = \case
285+
popStack :: Text -> (Inline -> Inline) -> StateT InlineState p ()
286+
popStack c f = do
287+
s <- gets (view modifierInline)
288+
new <- close s
289+
modify $ modifierInline .~ new
290+
where
291+
close (NoModifier b) = fail "No closing"
292+
close (OpenModifier cm i b) =
293+
case b of
294+
(OpenModifier cd id bd) -> if c == cm then pure (OpenModifier cd (id <> f i) bd) else close (OpenModifier cd (id <> Text cm <> i) bd)
295+
(NoModifier id) -> if c == cm then pure (NoModifier (id <> f i)) else fail "No closing"
296+
pushStack :: Text -> StateT InlineState p ()
297+
pushStack c = do
298+
s <- gets (view modifierInline)
299+
new <- case s of
300+
NoModifier i -> pure $ OpenModifier c mempty (NoModifier i)
301+
stack@(OpenModifier cm i b) ->
302+
if not $ hasModifier c stack
303+
then pure $ OpenModifier c mempty stack
304+
else fail "No open modifier"
305+
modify $ modifierInline .~ new
306+
307+
attachedOpenings :: Char -> StateT InlineState p ()
308+
attachedOpenings = \case
282309
'*' -> parseOpening "*"
283310
'/' -> parseOpening "/"
284311
'_' -> parseOpening "_"
285312
'-' -> parseOpening "-"
286-
'^' -> parseOpening "^"
287313
',' -> parseOpening ","
288314
'|' -> parseOpening "|"
315+
'^' -> parseOpening "^"
289316
'`' -> parseTextModifier "`" Verbatim
290317
'$' -> parseTextModifier "$" Math
291318
-- '=' -> parseOpening TODO: Behavior unclear
292-
_ -> fail "No openings"
319+
_ -> fail "No attachedOpenings"
293320
where
294321
parseTextModifier :: Text -> (Text -> Inline) -> StateT InlineState p ()
295322
parseTextModifier char f = P.try (go "") <|> word (T.head char)
@@ -299,59 +326,48 @@ paragraph' end' = do
299326
P.string char
300327
text <- P.takeWhileP (Just "Inline Text modifier") (\c -> c /= T.head char && c /= '\n')
301328
let fullText = previousText <> text
302-
(P.string char >> appendInlineToStack (f fullText)) <|> (P.newline >> P.hspace >> P.newline >> fail "No Text modifier") <|> (P.newline >> P.hspace >> go fullText)
303-
pushStack c = do
304-
s <- gets (view modifierInline)
305-
new <- case s of
306-
NoModifier i -> pure $ OpenModifier c mempty (NoModifier i)
307-
stack@(OpenModifier cm i b) ->
308-
if not $ hasModifier c stack
309-
then pure $ OpenModifier c mempty stack
310-
else fail "No open modifier"
311-
modify $ modifierInline .~ new
329+
( do
330+
P.string char
331+
followedBy
332+
( singleSpace <|> newline
333+
<|> withNextChar
334+
(guard . flip S.member (punctuationSymbols <> attachedModifierSymbols))
335+
)
336+
appendInlineToStack (f fullText)
337+
modify (delimitedActive .~ False)
338+
withNextChar $ \c -> parWhitespace c <|> attachedClosings c <|> attachedOpenings c <|> word c
339+
)
340+
<|> (P.newline >> P.hspace >> P.newline >> fail "No Text modifier")
341+
<|> (P.newline >> P.hspace >> go fullText)
312342
parseOpening c = do
313343
P.try $ do
314344
anyChar >> withNextChar (\c -> guard $ isLetter c || S.member c specialSymbols)
315345
pushStack c
316346
modify (delimitedActive .~ False)
317-
withNextChar (\c -> P.choice [parNewline c, openings c, word c])
318-
319-
space :: Char -> StateT InlineState p ()
320-
space = \case
321-
' ' -> do
322-
P.hspace >> appendInlineToStack Space
323-
withNextChar $ \c -> parNewline c <|> openings c <|> word c
324-
_ -> fail "No space"
347+
withNextChar (\c -> P.choice [attachedOpenings c, word c])
325348

326-
closings :: Char -> StateT InlineState p ()
327-
closings = \case
349+
attachedClosings :: Char -> StateT InlineState p ()
350+
attachedClosings = \case
328351
'*' -> parseClosing "*" Bold
329352
'/' -> parseClosing "/" Italic
330353
'_' -> parseClosing "_" Underline
331354
'-' -> parseClosing "-" Strikethrough
332355
'^' -> parseClosing "^" Superscript
333356
',' -> parseClosing "," Subscript
334357
'|' -> parseClosing "|" Spoiler
335-
_ -> fail "No closings"
358+
_ -> fail "No attached closings"
336359
where
337360
parseClosing c f = do
338361
P.try $ do
339-
anyChar >> followedBy (singleSpace <|> newline <|> withNextChar punctuationOrModifier)
362+
P.string c
363+
>> followedBy
364+
( singleSpace <|> newline
365+
<|> withNextChar
366+
(guard . flip S.member (punctuationSymbols <> attachedModifierSymbols))
367+
)
340368
popStack c f
341369
modify (delimitedActive .~ False)
342-
withNextChar $ \c -> parNewline c <|> closings c <|> openings c <|> space c <|> punctuationOrModifier c
343-
344-
popStack :: String -> (Inline -> Inline) -> StateT InlineState p ()
345-
popStack c f = do
346-
s <- gets (view modifierInline)
347-
new <- close s
348-
modify $ modifierInline .~ new
349-
where
350-
close (NoModifier b) = fail "No closing"
351-
close (OpenModifier cm i b) =
352-
case b of
353-
(OpenModifier cd id bd) -> if c == cm then pure (OpenModifier cd (id <> f i) bd) else close (OpenModifier cd (id <> Text (pack cm) <> i) bd)
354-
(NoModifier id) -> if c == cm then pure (NoModifier (id <> f i)) else fail "No closing"
370+
withNextChar $ \c -> parWhitespace c <|> attachedClosings c <|> attachedOpenings c <|> word c
355371

356372
word :: Char -> StateT InlineState p ()
357373
word c = do
@@ -361,13 +377,13 @@ paragraph' end' = do
361377
( do
362378
p <- lift anyChar <&> pack . (: [])
363379
appendInlineToStack (Text p)
364-
withNextChar $ \c -> space c <|> parNewline c <|> closings c <|> openings c <|> word c
380+
withNextChar $ \c -> parWhitespace c <|> attachedClosings c <|> attachedOpenings c <|> word c
365381
)
366382
else
367383
( do
368384
w <- P.takeWhile1P (Just "Word") (\c -> c > ' ' && S.notMember c (punctuationSymbols <> attachedModifierSymbols))
369385
appendInlineToStack (Text w)
370-
withNextChar $ \c -> space c <|> parNewline c <|> closings c <|> word c
386+
withNextChar $ \c -> parWhitespace c <|> attachedClosings c <|> word c
371387
)
372388
punctuationSymbols = S.fromList "?!:;,.<>()[]{}'\"/#%&$£€-*\\~"
373389
attachedModifierSymbols = S.fromList "*/_-^,|`$="
@@ -377,25 +393,32 @@ paragraph' end' = do
377393
withNextChar :: (Char -> StateT InlineState p ()) -> StateT InlineState p ()
378394
withNextChar f = end <|> (lookChar >>= f)
379395

380-
parNewline :: Char -> StateT InlineState p ()
381-
parNewline = \case
396+
intersectingModifier :: Char -> StateT InlineState p ()
397+
intersectingModifier = \case
398+
_ -> fail "No intersecting modifier"
399+
400+
parWhitespace :: Char -> StateT InlineState p ()
401+
parWhitespace = \case
402+
' ' -> do
403+
appendInlineToStack Space
404+
next
382405
'~' -> do
383406
P.try (anyChar >> P.hspace >> P.newline)
384407
next
385408
'\n' -> do
386409
newline
387410
modify (delimitedActive .~ True)
388411
next
389-
_ -> fail "No newline"
412+
_ -> fail "No newline or space"
390413
where
391414
next = do
392415
P.hspace
393-
withNextChar (\c -> openings c <|> word c)
416+
withNextChar (\c -> parWhitespace c <|> attachedOpenings c <|> word c)
394417
punctuationOrModifier c = do
395418
if S.member c (S.fromList "?!:;,.<>()[]{}'\"/#%&$£€-*\\~" <> S.fromList "*/_-^,|`$=")
396419
then do
397420
modify (delimitedActive .~ False)
398-
anyChar >> withNextChar (\c -> space c <|> parNewline c <|> closings c <|> openings c <|> word c)
421+
anyChar >> withNextChar (\c -> parWhitespace c <|> attachedClosings c <|> attachedOpenings c <|> word c)
399422
else fail ""
400423

401424
many1 p = p >>= \a -> (a :) <$> many p
@@ -505,4 +528,8 @@ instance ParseTagContent "table" where
505528
in P.try delimiter <|> inlines
506529
cellParagraph = runInline $ do
507530
modify $ delimitedActive .~ False
508-
paragraph' $ void (P.string " | ") <|> (P.try $ P.string " |" >> P.lookAhead (void P.newline <|> P.eof)) <|> void (P.lookAhead P.newline)
531+
paragraph' $
532+
void (P.string " | ")
533+
<|> P.try
534+
(P.string " |" >> P.lookAhead (void P.newline <|> P.eof))
535+
<|> void (P.lookAhead P.newline)

‎test/Parser.hs

Lines changed: 10 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -124,7 +124,16 @@ paragraphTests =
124124
( ConcatInline $
125125
V.fromList [Text "Another", Space, Text "sentence."]
126126
)
127-
]
127+
],
128+
testCase "Single-Line intersecting Bold" $ parse singleLineParagraph ":*bold*:" @?= Bold (Text "bold"),
129+
testCase "Single-Line intersecting Italic" $ parse singleLineParagraph ":/italic/:" @?= Italic (Text "italic"),
130+
testCase "Single-Line intersecting Underline" $ parse singleLineParagraph ":_underline_:" @?= Underline (Text "underline"),
131+
testCase "Single-Line intersecting Strikethrough" $ parse singleLineParagraph ":-strike-:" @?= Strikethrough (Text "strike"),
132+
testCase "Single-Line intersecting Superscript" $ parse singleLineParagraph ":^super^:" @?= Superscript (Text "super"),
133+
testCase "Single-Line intersecting Subscript" $ parse singleLineParagraph ":,sub,:" @?= Subscript (Text "sub"),
134+
testCase "Single-Line intersecting Spoiler" $ parse singleLineParagraph ":|spoiler|:" @?= Spoiler (Text "spoiler"),
135+
testCase "Single-Line intersecting Math" $ parse singleLineParagraph ":$math$:" @?= Math "math",
136+
testCase "Single-Line intersecting Verbatim" $ parse singleLineParagraph ":`verbatim`:" @?= Verbatim "verbatim"
128137
]
129138

130139
markerTests :: TestTree

0 commit comments

Comments
 (0)