Heading support

This commit is contained in:
Nathan McCarty 2025-02-27 21:05:04 -05:00
parent 72c73ec99d
commit 6263a02f89
10 changed files with 251 additions and 10 deletions

View file

@ -5,6 +5,7 @@ import SSG.Djot.Inline
import SSG.Djot.Lines
import Control.Eff
import Data.Nat
import Data.Maybe
import Data.String
import Derive.Prelude
@ -20,23 +21,31 @@ import System
%hide Generics.Derive.Show
%hide Generics.Derive.Eq
--* Data Structures *
--******************************
--* Data Structures *
--******************************
||| Types of block level element
public export
data BlockType : Type where
TParagraph : BlockType
THeading : BlockType
%runElab derive "BlockType" [Generic, Show, Eq, DecEq]
||| A block element
public export
data Block : BlockType -> Type where
Paragraph : (content : List (Inline)) -> Block TParagraph
Paragraph : (content : List Inline) -> Block TParagraph
Heading : (level : Nat) -> (content : List Inline)
-> {auto non_zero : IsSucc level} -> {auto in_range : level `LTE` 6}
-> Block THeading
%runElab derive "Block" [Show, Eq]
--* Parsing Utilities *
--******************************
--* Parsing Utilities *
--******************************
||| Type alias for block parsing
BParser : Type -> Type
@ -79,19 +88,78 @@ runBParser : (input : String) -> BParser t -> Maybe t
runBParser input x =
map fst . extract . runFail . runLines input $ x
--* Syntax *
||| Returns true if a character is horizontal whitespace
isHoriz : Char -> Bool
isHoriz ' ' = True
isHoriz '\t' = True
isHoriz _ = False
--******************************
--* Syntax *
--******************************
-- Forward declare for mutual recursion
||| Top level block parser
pBlock : BParser (t : BlockType ** Block t)
-- Paragraph
paragraph : BParser (Block TParagraph)
paragraph = do
contents <- map (inline . joinBy "\n") $ slurp blankLine
pure $ Paragraph contents
-- Heading
record HeadingLevel where
constructor MkHL
level : Nat
{auto non_zero : IsSucc level}
{auto in_range : level `LTE` 6}
acceptHeadingPrefix : String -> Maybe (HeadingLevel, String)
acceptHeadingPrefix str =
let (level, str) = acceptHeadingPrefix' 0 str
in case isItSucc level of
Yes non_zero =>
case level `isLTE` 6 of
Yes in_range => Just $ (MkHL level, str)
No _ => Nothing
No _ => Nothing
where
acceptHeadingPrefix' : (acc : Nat) -> String -> (Nat, String)
acceptHeadingPrefix' acc str with (asList str)
acceptHeadingPrefix' acc "" | [] = (acc, "")
acceptHeadingPrefix' acc (strCons '#' str) | ('#' :: x) =
acceptHeadingPrefix' (S acc) str | x
acceptHeadingPrefix' acc (strCons c str) | (c :: x) =
if isHoriz c
then acceptHeadingPrefix' acc str | x
else (acc, strCons c str)
headingFirstLine : BParser (HeadingLevel, String)
headingFirstLine = do
first <- take >>= fromJust
fromJust $ acceptHeadingPrefix first
heading : BParser (Block THeading)
heading = do
(MkHL level {non_zero} {in_range}, first) <- headingFirstLine
rest <- slurp blankLine
let contents = joinBy "\n" $ first :: map (stripPrefix level) rest
pure $ Heading level (inline contents)
where
stripPrefix : (l : Nat) -> String -> String
stripPrefix l str with (asList str)
stripPrefix 0 str | _ = str
stripPrefix (S k) "" | [] = ""
stripPrefix (S k) (strCons '#' str) | ('#' :: x) = stripPrefix k str | x
stripPrefix (S k) (strCons c str) | (c :: x) = strCons c str
-- Definition for top level block parser
pBlock = selectParser paragraph []
pBlock = selectParser paragraph
[ (isJust . acceptHeadingPrefix, heading)
]
--******************************
@ -106,7 +174,9 @@ block input =
Nothing => (_ ** [])
Just x => fromList x
--* Unit Tests *
--******************************
--* Unit Tests *
--******************************
[myshow] Show (t : BlockType ** Block t) where
show (_ ** block) = show block
@ -138,3 +208,24 @@ smokeTwoParagraph =
golden
"Hello World!\n\nHello Alice!"
[Paragraph [Text "Hello World!"], Paragraph [Text "Hello Alice!"]]
-- @@test Heading Smoke
smokeHeading : IO Bool
smokeHeading =
golden
"# Level 1 Heading"
[Heading 1 [Text "Level 1 Heading"]]
-- @@test Multiline Prefixed Heading Smoke
smokeHeadingMultilinePrefixed : IO Bool
smokeHeadingMultilinePrefixed =
golden
"# Level 1\n# Heading"
[Heading 1 [Text "Level 1", SoftLineBreak, Text "Heading"]]
-- @@test Multiline Nonprefixed Heading Smoke
smokeHeadingMultilineNonprefixed : IO Bool
smokeHeadingMultilineNonprefixed =
golden
"# Level 1\nHeading"
[Heading 1 [Text "Level 1", SoftLineBreak, Text "Heading"]]

View file

@ -57,6 +57,13 @@ slurp predicate = do
| _ => pure []
map (x ::) (slurp predicate)
||| Pop the next line and ignore its value
export
drop : Has Lines fs => Eff fs ()
drop = do
_ <- take
pure ()
--************************
--* Effect Handlers *
--************************

View file

@ -6,6 +6,7 @@ import SSG.Djot.Inline
import SSG.Djot.Block
import Data.List
import Data.Nat
||| Render a single inline element as HTML
export
@ -30,6 +31,20 @@ renderBlocks : {types: _} -> DList _ Block types -> (types' ** DList _ Html type
renderBlock (Paragraph content) =
(_ ** Normal "p" [] (snd (renderInlines content)))
renderBlock (Heading 1 content {non_zero = ItIsSucc} {in_range}) =
(_ ** Normal "h1" [] (snd (renderInlines content)))
renderBlock (Heading 2 content {non_zero = ItIsSucc} {in_range}) =
(_ ** Normal "h2" [] (snd (renderInlines content)))
renderBlock (Heading 3 content {non_zero = ItIsSucc} {in_range}) =
(_ ** Normal "h3" [] (snd (renderInlines content)))
renderBlock (Heading 4 content {non_zero = ItIsSucc} {in_range}) =
(_ ** Normal "h4" [] (snd (renderInlines content)))
renderBlock (Heading 5 content {non_zero = ItIsSucc} {in_range}) =
(_ ** Normal "h5" [] (snd (renderInlines content)))
renderBlock (Heading 6 content {non_zero = ItIsSucc} {in_range}) =
(_ ** Normal "h6" [] (snd (renderInlines content)))
renderBlock (Heading (6 + (S n)) content {non_zero = ItIsSucc} {in_range}) =
absurd in_range
renderBlocks xs = dMap' (\_, x => renderBlock x) xs

View file

@ -0,0 +1,18 @@
module Main
import SSG.Djot
import SSG.HTML
import System
import System.File
main : IO ()
main = do
Right contents <- readFile "./test.dj"
| Left err => do
printLn err
exitFailure
let (_ ** blocks) = block contents
let html = renderDocument blocks
let output = render html
putStrLn output

View file

@ -0,0 +1,44 @@
<!DOCTYPE HTML>
<html lang=en>
<body>
<h1>Level 1 Heading</h1>
<h2>Level 2 Heading</h2>
<h3>Level 3 Heading</h3>
<h4>Level 4 Heading</h4>
<h5>Level 5 Heading</h5>
<h6>Level 6 Heading</h6>
<p>####### Level 7 Not a heading</p>
<h1>
Multiline heading
with prefix
</h1>
<h1>
Multiline heading
with prefix and some extra whitespace
</h1>
<h2>
Level 2 multiline heading
with prefix
</h2>
<h1>
Multiline heading
with no prefix
</h1>
<h2>
Level 2 multiline heading
with no prefix
</h2>
<h1>
Unprefixed multiline heading
with some indentation
</h1>
<h1>
Heading level 1
# With a level 2 right after it (this line shouldn't be a heading)
</h1>
<h2>
Heading level 2
With a level 1 right after it (this line shouldn't be a heading)
</h2>
</body>
</html>

View file

@ -0,0 +1,5 @@
[custom.all.SSG]
type = "local"
path = "../../.."
ipkg = "SSG.ipkg"
test = "test/test.ipkg"

View file

@ -0,0 +1,6 @@
rm -rf build/
flock "$1" pack -q install-deps test.ipkg
pack -q run test.ipkg
rm -rf build/

View file

@ -0,0 +1,38 @@
# Level 1 Heading
## Level 2 Heading
### Level 3 Heading
#### Level 4 Heading
##### Level 5 Heading
###### Level 6 Heading
####### Level 7 Not a heading
# Multiline heading
# with prefix
# Multiline heading
# with prefix and some extra whitespace
## Level 2 multiline heading
## with prefix
# Multiline heading
with no prefix
## Level 2 multiline heading
with no prefix
# Unprefixed multiline heading
with some indentation
# Heading level 1
## With a level 2 right after it (this line shouldn't be a heading)
## Heading level 2
# With a level 1 right after it (this line shouldn't be a heading)

View file

@ -0,0 +1,9 @@
package a-test
depends = SSG
, hedgehog
, eff
main = Main
executable = test

View file

@ -10,13 +10,12 @@ Decided to rename =Tag= to =Html=, and =Raw= to =Text=, which makes this make se
** TODO Refine =location= in =ParserLocation=
** TODO Error messages
** TODO Combinators for predictive parsing
* Djot [3/38]
* Djot [4/40]
:PROPERTIES:
:COOKIE_DATA: recursive
:END:
** Parsing [3/33]
** Parsing [4/34]
*** Block Level
**** TODO Heading
**** TODO Block Quote
**** TODO List Item
**** TODO List
@ -30,6 +29,7 @@ Decided to rename =Tag= to =Html=, and =Raw= to =Text=, which makes this make se
**** TODO Block Attributes
**** TODO Heading Links
**** DONE Paragraph
**** DONE Heading
*** Inline
**** TODO Escaped Text
**** TODO Link
@ -40,7 +40,7 @@ Decided to rename =Tag= to =Html=, and =Raw= to =Text=, which makes this make se
**** TODO Highlighted
**** TODO Super/subscript
**** TODO Insert/delete
**** TODO Smart Puncuation
**** TODO Smart Punctuation
**** TODO Math
**** TODO Footnote Reference
**** TODO Comment
@ -52,9 +52,17 @@ Decided to rename =Tag= to =Html=, and =Raw= to =Text=, which makes this make se
*** Lines effect
**** TODO =IO= Backed implementation
*** Known Inaccuracies
**** TODO Stripping of prefixes from multiline headings isn't entirely accurate
Currently, it strips at least =level= ~#~'s from the start of the line, but doesn't check to see if its the correct number of them.
I need to see how other implementations handle this
** Extensions
*** TODO GFM-style alerts
*** TODO Emoji extension
**** TODO Unicode Emoji
**** TODO Icon font emoji
**** TODO Autolink for source forges
** Misc
*** TODO Add =fromString= for =Inline=
* Features
** TODO Preview rendered post in terminal
Centered headings, text styling, and syntax highlighted code blocks