Skip to content

Commit 86a5af5

Browse files
janmasrovirajanmasrovira
committed
testing
1 parent d3dd17a commit 86a5af5

File tree

8 files changed

+206
-52
lines changed

8 files changed

+206
-52
lines changed

‎app/Commands/Dev/PlainMarkdown/Format.hs

+2-3
Original file line numberDiff line numberDiff line change
@@ -2,7 +2,7 @@ module Commands.Dev.PlainMarkdown.Format where
22

33
import Commands.Base
44
import Commands.Dev.PlainMarkdown.Format.Options
5-
import Markdown.FromSource
5+
import Markdown.FromSource qualified as Markdown
66
import Markdown.Print
77

88
runCommand ::
@@ -12,6 +12,5 @@ runCommand ::
1212
Sem r ()
1313
runCommand opts = do
1414
afile <- fromAppPathFile (opts ^. formatFile)
15-
mdBlock <- runAppError @SimpleError (fromFile afile)
16-
print mdBlock
15+
mdBlock <- runAppError @SimpleError (Markdown.parseFile afile)
1716
renderStdOutLn (ppOut mdBlock)

‎src/Juvix/Prelude/Trace.hs

+1-2
Original file line numberDiff line numberDiff line change
@@ -27,8 +27,7 @@ traceWith f a = trace (f a) a
2727

2828
trace :: Text -> a -> a
2929
trace = traceLabel ""
30-
31-
-- {-# WARNING trace "Using trace" #-}
30+
{-# WARNING trace "Using trace" #-}
3231

3332
traceM :: (Applicative f) => Text -> f ()
3433
traceM t = traceLabel "" t (pure ())

‎src/Markdown/FromSource.hs

+7-14
Original file line numberDiff line numberDiff line change
@@ -1,22 +1,15 @@
11
-- | Import this module qualified
2-
module Markdown.FromSource where
2+
module Markdown.FromSource (parseText, parseFile) where
33

44
import Commonmark.Parser
55
import Juvix.Prelude
66
import Markdown.Language
7-
import Text.Show.Pretty
87

9-
fromFile :: (Members '[Files, Error SimpleError] r) => Path Abs File -> Sem r Blocks
10-
fromFile inputFile = do
11-
txt <- readFile' inputFile
8+
parseFile :: (Members '[Files, Error SimpleError] r) => Path Abs File -> Sem r Blocks
9+
parseFile inputFile = readFile' inputFile >>= parseText inputFile
10+
11+
parseText :: (Members '[Error SimpleError] r) => Path Abs File -> Text -> Sem r Blocks
12+
parseText inputFile txt = do
1213
case commonmark (toFilePath inputFile) txt of
13-
Left _err -> error "parse error"
14+
Left err -> throw (SimpleError ("markdown parse error: " <> show err))
1415
Right block -> return block
15-
16-
testFile :: Path Abs File -> IO ()
17-
testFile f = runM . runFilesIO . runSimpleErrorIO $ do
18-
b <- fromFile f
19-
print (ppShow (b ^. blocks))
20-
putStrLn "================"
21-
putStrLn "================\n"
22-
print b

‎src/Markdown/Language.hs

+64-28
Original file line numberDiff line numberDiff line change
@@ -51,17 +51,37 @@ newtype EscapedChar = EscapedChar
5151
}
5252
deriving stock (Show, Eq, Generic)
5353

54+
newtype Strong = Strong
55+
{ _strong :: Inlines
56+
}
57+
deriving stock (Show, Eq, Generic)
58+
59+
newtype Emph = Emph
60+
{ _emph :: Inlines
61+
}
62+
deriving stock (Show, Eq, Generic)
63+
64+
newtype Code = Code
65+
{ _code :: Text
66+
}
67+
deriving stock (Show, Eq, Generic)
68+
69+
newtype Entity = Entity
70+
{ _entity :: Text
71+
}
72+
deriving stock (Show, Eq, Generic)
73+
5474
data Inline
5575
= InlineHardBreak (Meta HardBreak)
5676
| InlineSoftBreak (Meta SoftBreak)
5777
| InlineString (Meta Text)
58-
| InlineEntity (Meta Text)
78+
| InlineEntity (Meta Entity)
5979
| InlineEscapedChar (Meta EscapedChar)
60-
| InlineEmph Inlines
61-
| InlineStrong Inlines
80+
| InlineEmph (Meta Emph)
81+
| InlineStrong (Meta Strong)
6282
| InlineLink (Meta Link)
6383
| InlineImage (Meta Image)
64-
| InlineCode (Meta Text)
84+
| InlineCode (Meta Code)
6585
| InlineRaw (Meta RawInline)
6686
deriving stock (Show, Eq, Generic)
6787

@@ -155,9 +175,20 @@ instance Rangeable (Meta a) where
155175
ranged = set (metaLoc . unIrrelevant)
156176

157177
instance HasAttributes Inline where
158-
addAttributes _attr = trace "todo"
178+
addAttributes attr =
179+
\case
180+
InlineHardBreak a -> InlineHardBreak (addAttributes attr a)
181+
InlineSoftBreak a -> InlineSoftBreak (addAttributes attr a)
182+
InlineString a -> InlineString (addAttributes attr a)
183+
InlineEntity a -> InlineEntity (addAttributes attr a)
184+
InlineEscapedChar a -> InlineEscapedChar (addAttributes attr a)
185+
InlineEmph a -> InlineEmph (addAttributes attr a)
186+
InlineStrong a -> InlineStrong (addAttributes attr a)
187+
InlineLink a -> InlineLink (addAttributes attr a)
188+
InlineImage a -> InlineImage (addAttributes attr a)
189+
InlineCode a -> InlineCode (addAttributes attr a)
190+
InlineRaw a -> InlineRaw (addAttributes attr a)
159191

160-
-- TODO
161192
instance Rangeable Inline where
162193
ranged d =
163194
\case
@@ -180,10 +211,10 @@ instance HasAttributes Inlines where
180211
addAttributes attr = over inlines (map (addAttributes attr))
181212

182213
instance Rangeable Blocks where
183-
ranged d bs = trace ("rangeable blocks " <> show (length (bs ^. blocks)) <> " " <> show d) (over blocks (map (ranged d)) bs)
214+
ranged d bs = over blocks (map (ranged d)) bs
184215

185216
instance Rangeable Inlines where
186-
ranged d = trace ("rangeable inlines " <> show d) . over inlines (map (ranged d))
217+
ranged d = over inlines (map (ranged d))
187218

188219
class IsInlines a where
189220
toInlines :: a -> Inlines
@@ -208,35 +239,40 @@ iniRange :: SourceRange
208239
iniRange = mempty
209240

210241
instance Rangeable Block where
211-
ranged r b =
212-
trace
213-
("rangeable block: " <> show b)
214-
( case b of
215-
BlockParagraph a -> BlockParagraph (ranged r a)
216-
BlockPlain a -> BlockPlain (ranged r a)
217-
BlockCodeBlock a -> BlockCodeBlock (ranged r a)
218-
BlockHeading a -> BlockHeading (ranged r a)
219-
BlockThematicBreak a -> BlockThematicBreak (ranged r a)
220-
BlockQuote a -> BlockQuote (ranged r a)
221-
BlockList a -> BlockList (ranged r a)
222-
BlockRawBlock a -> BlockRawBlock (ranged r a)
223-
BlockReferenceLinkDefinition a -> BlockReferenceLinkDefinition (ranged r a)
224-
)
242+
ranged r = \case
243+
BlockParagraph a -> BlockParagraph (ranged r a)
244+
BlockPlain a -> BlockPlain (ranged r a)
245+
BlockCodeBlock a -> BlockCodeBlock (ranged r a)
246+
BlockHeading a -> BlockHeading (ranged r a)
247+
BlockThematicBreak a -> BlockThematicBreak (ranged r a)
248+
BlockQuote a -> BlockQuote (ranged r a)
249+
BlockList a -> BlockList (ranged r a)
250+
BlockRawBlock a -> BlockRawBlock (ranged r a)
251+
BlockReferenceLinkDefinition a -> BlockReferenceLinkDefinition (ranged r a)
225252

226253
instance HasAttributes Block where
227-
addAttributes _ = trace "attributes block"
254+
addAttributes attr = \case
255+
BlockParagraph a -> BlockParagraph (addAttributes attr a)
256+
BlockPlain a -> BlockPlain (addAttributes attr a)
257+
BlockCodeBlock a -> BlockCodeBlock (addAttributes attr a)
258+
BlockHeading a -> BlockHeading (addAttributes attr a)
259+
BlockThematicBreak a -> BlockThematicBreak (addAttributes attr a)
260+
BlockQuote a -> BlockQuote (addAttributes attr a)
261+
BlockList a -> BlockList (addAttributes attr a)
262+
BlockRawBlock a -> BlockRawBlock (addAttributes attr a)
263+
BlockReferenceLinkDefinition a -> BlockReferenceLinkDefinition (addAttributes attr a)
228264

229265
instance IsInline Inlines where
230266
lineBreak = toInlines (InlineHardBreak (mkMeta HardBreak))
231267
softBreak = toInlines (InlineSoftBreak (mkMeta SoftBreak))
232268
str a = toInlines (InlineString (mkMeta a))
233-
entity a = toInlines (InlineEntity (mkMeta a))
269+
entity a = toInlines (InlineEntity (mkMeta (Entity a)))
234270
escapedChar _escapedChar = toInlines (InlineEscapedChar (mkMeta (EscapedChar {..})))
235-
emph a = toInlines (InlineEmph a)
236-
strong a = toInlines (InlineStrong a)
271+
emph a = toInlines (InlineEmph (mkMeta (Emph a)))
272+
strong a = toInlines (InlineStrong (mkMeta (Strong a)))
237273
link _linkDestination _linkTitle _linkDescription = toInlines (InlineLink (mkMeta Link {..}))
238274
image _imageSource _imageTitle _imageDescription = toInlines (InlineImage (mkMeta Image {..}))
239-
code a = toInlines (InlineCode (mkMeta a))
275+
code a = toInlines (InlineCode (mkMeta (Code a)))
240276
rawInline _rawInlineFormat _rawInlineText = toInlines (InlineRaw (mkMeta RawInline {..}))
241277

242278
instance IsBlock Inlines Blocks where
@@ -246,7 +282,7 @@ instance IsBlock Inlines Blocks where
246282
blockQuote _quoteBlock = mkBlocks (BlockQuote (mkMeta QuoteBlock {..}))
247283
codeBlock _codeBlockLanguage _codeBlock = mkBlocks (BlockCodeBlock (mkMeta (CodeBlock {..})))
248284
heading _headingLevel _headingText = mkBlocks (BlockHeading (mkMeta Heading {..}))
249-
rawBlock = error "todo"
285+
rawBlock _rawBlockFormat _rawBlockText = mkBlocks (BlockRawBlock (mkMeta RawBlock {..}))
250286
referenceLinkDefinition _referenceLinkDefinitionLabel (_referenceLinkDefinitionDestination, _referenceLinkDefinitionTitle) = mkBlocks (BlockReferenceLinkDefinition (mkMeta ReferenceLinkDefinition {..}))
251287
list _listType _listSpacing lstBlocks = mkBlocks (BlockList (mkMeta List {_listBlocks = nonEmpty' lstBlocks, ..}))
252288

‎src/Markdown/Print.hs

+66-4
Original file line numberDiff line numberDiff line change
@@ -38,12 +38,68 @@ instance PrettyPrint EscapedChar where
3838
ppCode (EscapedChar c) =
3939
ppCode (showEscapedChar c)
4040

41+
instance PrettyPrint Strong where
42+
ppCode (Strong i) = do
43+
ppCode @Text "**"
44+
ppCode i
45+
ppCode @Text "**"
46+
47+
instance PrettyPrint Emph where
48+
ppCode (Emph i) = do
49+
ppCode @Text "_"
50+
ppCode i
51+
ppCode @Text "_"
52+
53+
-- [link](/uri "title")
54+
instance PrettyPrint Link where
55+
ppCode Link {..} = do
56+
ppCode @Text "["
57+
<> ppCode _linkDescription
58+
<> ppCode @Text "]("
59+
<> ppCode _linkDestination
60+
<+?> ppLinkTitle _linkTitle
61+
<> ppCode @Text ")"
62+
63+
instance PrettyPrint Image where
64+
ppCode Image {..} = do
65+
ppCode @Text "!"
66+
ppCode
67+
Link
68+
{ _linkDescription = _imageDescription,
69+
_linkTitle = _imageTitle,
70+
_linkDestination = _imageSource
71+
}
72+
73+
instance PrettyPrint Code where
74+
ppCode (Code c) = do
75+
ppCode @Text "`"
76+
ppCode c
77+
ppCode @Text "`"
78+
79+
instance PrettyPrint Entity where
80+
ppCode (Entity e) = ppCode e
81+
4182
instance PrettyPrint Inline where
4283
ppCode = \case
4384
InlineString txt -> noLoc (pretty txt)
4485
InlineSoftBreak b -> ppCode b
4586
InlineHardBreak b -> ppCode b
4687
InlineEscapedChar b -> ppCode b
88+
InlineEntity b -> ppCode b
89+
InlineEmph b -> ppCode b
90+
InlineStrong b -> ppCode b
91+
InlineLink b -> ppCode b
92+
InlineImage b -> ppCode b
93+
InlineCode b -> ppCode b
94+
InlineRaw b -> ppCode b
95+
96+
instance PrettyPrint RawBlock where
97+
ppCode RawBlock {..} =
98+
ppCode _rawBlockText
99+
100+
instance PrettyPrint RawInline where
101+
ppCode RawInline {..} =
102+
ppCode _rawInlineText
47103

48104
instance PrettyPrint Inlines where
49105
ppCode = mapM_ ppCode . (^. inlines)
@@ -108,11 +164,17 @@ instance PrettyPrint QuoteBlock where
108164
$ Text.lines q
109165
noLoc (pretty withQuotes)
110166

167+
ppLinkTitle ::
168+
(Member (Reader Options) r, Member ExactPrint r) =>
169+
Text ->
170+
Maybe (Sem r ())
171+
ppLinkTitle title
172+
| Text.null title = Nothing
173+
| otherwise = Just (ppCode (show @Text title))
174+
111175
instance PrettyPrint ReferenceLinkDefinition where
112176
ppCode ReferenceLinkDefinition {..} = do
113-
let title
114-
| Text.null _referenceLinkDefinitionTitle = Nothing
115-
| otherwise = Just (ppCode (show @Text _referenceLinkDefinitionTitle))
177+
let title = ppLinkTitle _referenceLinkDefinitionTitle
116178
ppCode ("[" <> _referenceLinkDefinitionLabel <> "]:")
117179
<+> ppCode _referenceLinkDefinitionDestination
118180
<+?> title
@@ -125,6 +187,6 @@ instance PrettyPrint Block where
125187
BlockHeading p -> ppCode p
126188
BlockThematicBreak p -> ppCode p
127189
BlockQuote p -> ppCode p
128-
BlockRawBlock {} -> error "raw block"
190+
BlockRawBlock p -> ppCode p
129191
BlockList l -> ppCode l
130192
BlockReferenceLinkDefinition d -> ppCode d

‎test/Main.hs

+2-1
Original file line numberDiff line numberDiff line change
@@ -16,6 +16,7 @@ import Juvix.Config qualified as Config
1616
import Nockma qualified
1717
import Package qualified
1818
import Parsing qualified
19+
import PlainMarkdown qualified
1920
import Reg qualified
2021
import Repl qualified
2122
import Resolver qualified
@@ -67,4 +68,4 @@ fastTests =
6768
main :: IO ()
6869
main = do
6970
tests <- sequence [fastTests, slowTests]
70-
defaultMain (testGroup "Juvix tests" tests)
71+
defaultMain (testGroup "Juvix tests" [PlainMarkdown.allTests])

‎test/PlainMarkdown.hs

+48
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,48 @@
1+
module PlainMarkdown (allTests) where
2+
3+
import Base
4+
import Juvix.Prelude.Pretty
5+
import Markdown.FromSource qualified as Markdown
6+
import Markdown.Language
7+
import Markdown.Print
8+
9+
data PosTest = PosTest
10+
{ _name :: String,
11+
_file :: Path Rel File
12+
}
13+
14+
allTests :: TestTree
15+
allTests =
16+
testGroup
17+
"PlainMarkdown"
18+
(map (mkTest . testDescr) tests)
19+
20+
root :: Path Abs Dir
21+
root = relToProject $(mkRelDir "tests/PlainMarkdown")
22+
23+
renderMd :: (PrettyPrint c) => c -> Text
24+
renderMd = toPlainText . ppOut
25+
26+
testDescr :: PosTest -> TestDescr
27+
testDescr PosTest {..} =
28+
let tRoot = root
29+
file' = tRoot <//> _file
30+
in TestDescr
31+
{ _testName = _name,
32+
_testRoot = tRoot,
33+
_testAssertion = Steps $ \step -> runM . runSimpleErrorIO . runFilesIO $ do
34+
liftIO (step "Parsing")
35+
s :: Blocks <- Markdown.parseFile file'
36+
let rendered :: Text = renderMd s
37+
38+
liftIO (step "Parsing pretty parsed")
39+
parsedPretty <- Markdown.parseText file' rendered
40+
41+
liftIO (step "Checks")
42+
liftIO (assertEqDiffShow "parsed . pretty . parsed = parsed" s parsedPretty)
43+
}
44+
45+
tests :: [PosTest]
46+
tests =
47+
[ PosTest "benchmark" $(mkRelFile "benchmark.md")
48+
]

‎tests/PlainMarkdown/benchmark.md

+16
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,16 @@
1+
Markdown: Syntax
2+
================
3+
4+
<ul id="ProjectSubmenu">
5+
<li><a href="/projects/markdown/" title="Markdown Project Page">Main</a></li>
6+
<li><a href="/projects/markdown/basics" title="Markdown Basics">Basics</a></li>
7+
<li><a class="selected" title="Markdown Syntax Documentation">Syntax</a></li>
8+
<li><a href="/projects/markdown/license" title="Pricing and License Information">License</a></li>
9+
<li><a href="/projects/markdown/dingus" title="Online Markdown Web Form">Dingus</a></li>
10+
</ul>
11+
12+
13+
* [Overview](#overview)
14+
* [Philosophy](#philosophy)
15+
* [Inline HTML](#html)
16+
* [Automatic Escaping for Special Characters](#autoescape)

0 commit comments

Comments
 (0)