Heading support

src/SSG/Djot/Block.idr

@@ -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"]]

src/SSG/Djot/Lines.idr

@@ -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   *
 --************************

src/SSG/Djot/Render.idr

@@ -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
 

test/djotToHtml/002-headings/Main.idr

@@ -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

test/djotToHtml/002-headings/expected

@@ -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>

test/djotToHtml/002-headings/pack.toml

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

test/djotToHtml/002-headings/run

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

test/djotToHtml/002-headings/test.dj

@@ -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)

test/djotToHtml/002-headings/test.ipkg

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

todo.org

@@ -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