Basic Html Rendering

src/SSG/Djot.idr

@@ -1,4 +1,17 @@
 module SSG.Djot
 
+import SSG.Parser.Util
+
+import Control.Eff
+
 import public SSG.Djot.Inline as SSG.Djot
 import public SSG.Djot.Block as SSG.Djot
+import public SSG.Djot.Render as SSG.Djot
+
+export
+||| Parse a djot document
+djot : String -> List Block
+djot str =
+  case runPS blocks str of
+    Left _ => []
+    Right x => x

src/SSG/Djot/Block.idr

@@ -97,6 +97,7 @@ heading = do
 -- Overall Block Parser --
 --------------------------
 
+export
 block : PS Block
 block = do
   -- eat up any blank lines
@@ -106,6 +107,7 @@ block = do
   , paragraph
   ]
 
+export
 blocks : PS (List Block)
 blocks = many block
 

src/SSG/Djot/Inline.idr

@@ -22,7 +22,7 @@ data Inline : Type where
   HardLineBreak : Inline
   SoftLineBreak : Inline
   NonBreakingSpace : Inline
-  Text : (c : Char) -> Inline
+  Text : (c : String) -> Inline
 
 %runElab derive "Inline" [Show, Eq]
 
@@ -69,13 +69,13 @@ softLineBreak = do
 escapedText : PS Inline
 escapedText = do
   c <- escapedChar
-  pure $ Text c
+  pure $ Text (singleton c)
 
 -- Any non-line-ending character can be part of regular text
 text : PS Inline
 text = do
   c <- nonTerminal
-  pure $ Text c
+  pure $ Text (singleton c)
 
 ---------------------------
 -- Overall Inline Parser --
@@ -113,7 +113,7 @@ inlineFromString : String -> List (Inline)
 inlineFromString str with (asList str)
   inlineFromString "" | [] = []
   inlineFromString (strCons c str) | (c :: x) =
-    Text c :: inlineFromString str | x
+    Text (singleton c) :: inlineFromString str | x
 
 export
 inlineFromString' : String -> List1 (Inline)
@@ -130,13 +130,13 @@ inlineFromString' str =
 inlineTextSmoke : IO Bool
 inlineTextSmoke =
   let input = "Hello World!" in
-  golden input (map Text . unpack $ input) (map forget inline)
+  golden input (map (Text . singleton) . unpack $ input) (map forget inline)
 
 -- @@test Escaped Text
 inlineEscapedSmoke : IO Bool
 inlineEscapedSmoke =
   let input = "Hello\\n\\*World"
-      ref = inlineFromString "Hello" ++ [Text '\n', Text '*'] ++ inlineFromString "World"
+      ref = inlineFromString "Hello" ++ [Text "\n", Text "*"] ++ inlineFromString "World"
   in golden input ref (map forget inline)
 
 -- @@test Hard Line Break

src/SSG/Djot/Render.idr

@@ -0,0 +1,70 @@
+module SSG.Djot.Render
+
+import SSG.HTML
+
+import SSG.Djot.Inline
+import SSG.Djot.Block
+
+import Data.String
+import Data.List1
+
+import Structures.Dependent.DList
+
+export
+renderInline : Inline -> (type : String ** Html type)
+renderInline HardLineBreak =
+  (_ ** Void "br" [])
+renderInline SoftLineBreak =
+  (_ ** Text "\n")
+renderInline NonBreakingSpace =
+  (_ ** Text " ")
+renderInline (Text c) =
+  (_ ** Text c)
+
+-- BUG: Coverage checker bug here?
+partial
+combineTexts : (types : List String ** DList _ Html types)
+  -> (types' : List String ** DList _ Html types')
+combineTexts (_ ** []) = (_ ** [])
+combineTexts xs@(_ ** (elem :: [])) = xs
+combineTexts (_ ** Text content :: (Text str :: rest)) =
+  combineTexts (_ ** Text (content ++ str) :: rest)
+combineTexts (_ ** Text content :: (next :: rest)) =
+  let (_ ** rest) = combineTexts (_ ** (next :: rest))
+  in (_ ** Text content :: rest)
+combineTexts (_ ** (x :: (next :: rest))) =
+  let (_ ** rest) = combineTexts (_ ** (next :: rest))
+  in (_ ** x :: rest)
+
+export
+renderInlines : List Inline -> (types : List String ** DList _ Html types)
+renderInlines xs = assert_total $
+  combineTexts . fromList . map renderInline $ xs
+
+headingLevel : HeaderLevel -> (h : String ** IsNormal h)
+headingLevel H1 = ("h1" ** IsH1)
+headingLevel H2 = ("h2" ** IsH2)
+headingLevel H3 = ("h3" ** IsH3)
+headingLevel H4 = ("h4" ** IsH4)
+headingLevel H5 = ("h5" ** IsH5)
+headingLevel H6 = ("h6" ** IsH6)
+
+export
+renderBlock : Block -> (type : String ** Html type)
+renderBlock (Paragraph contents) =
+  let (_ ** xs) = renderInlines $ forget contents
+  in (_ ** Normal "p" [] xs)
+renderBlock (Heading level contents) =
+  let (_ ** xs) = renderInlines $ forget contents
+      (level ** _ ) = headingLevel level
+  in (_ ** Normal level [] xs)
+
+export
+renderBlocks : List Block -> (types : List String ** DList _ Html types)
+renderBlocks xs = fromList $ map renderBlock xs
+
+export
+renderHtml : List Block -> Html "html"
+renderHtml xs =
+  let (_ ** xs) = renderBlocks xs
+  in Normal "html" ["lang" =$ "en"] xs