More progress

src/Text/Pandoc/Readers/Djot.hs

@@ -2,8 +2,6 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
 {- |
@@ -27,14 +25,19 @@ import Text.Pandoc.Sources
 import Text.Parsec.Pos (sourceName)  -- TODO export from T.P.Sources?
 import Text.Pandoc.Options
 import Text.Pandoc.Definition
+import Text.Pandoc.Shared (addPandocAttributes)
 import qualified Text.Pandoc.UTF8 as UTF8
 import Djot.Options (ParseOptions(..))
 import Djot.Blocks (parseDoc)
 import qualified Djot.AST as D
 import Text.Pandoc.Error (PandocError(..))
 import Control.Monad.Except (throwError)
 import qualified Data.Text as T
-
+import Text.Pandoc.Builder
+import Text.Pandoc.Emoji (emojiToInline)
+import Control.Monad.Reader
+import qualified Data.Foldable as F
+import qualified Data.Sequence as Seq
 -- import Debug.Trace
 
 -- | Read Djot from an input string and return a Pandoc document.
@@ -47,5 +50,79 @@ readDjot _opts inp = do
   case parseDoc ParseOptions{ optSourcePositions = False }
          (UTF8.fromText $ sourcesToText sources) of
     Left e -> throwError $ PandocParseError $ T.pack $ show e
-    Right doc -> do
-      pure $ Pandoc mempty mempty -- TODO
+    Right d ->
+      runReaderT (doc <$> convertBlocks (D.docBlocks d))
+        Env{ references = D.docReferences d
+           , footnotes = D.docFootnotes d }
+
+data Env =
+  Env{ references :: D.ReferenceMap
+     , footnotes :: D.NoteMap }
+  deriving (Show, Ord, Eq)
+
+convertBlocks :: PandocMonad m => D.Blocks -> ReaderT Env m Blocks
+convertBlocks = fmap mconcat . mapM convertBlock . F.toList . D.unBlocks
+
+convertBlock :: PandocMonad m => D.Node D.Block -> ReaderT Env m Blocks
+convertBlock (D.Node attr bl) = addAttrToBlock attr <$>
+  case bl of
+    D.Para ils -> para <$> convertInlines ils
+    D.Section bls -> divWith ("",["section"],[]) <$> convertBlocks bls
+    D.Heading lev ils -> header lev <$> convertInlines ils
+    D.BlockQuote bls -> blockQuote <$> convertBlocks bls
+    D.CodeBlock lang bs -> pure $
+      codeBlockWith ("", [UTF8.toText lang], []) $ UTF8.toText bs
+    D.Div bls -> divWith nullAttr <$> convertBlocks bls
+    D.OrderedList listAttr listSpacing items -> pure mempty -- TODO
+    D.BulletList listSpacing items -> pure mempty -- TODO
+    D.TaskList listSpacing items -> pure mempty -- TODO -- [(TaskStatus, Blocks)]
+    D.DefinitionList listSpacing items -> pure mempty -- TODO -- [(Inlines, Blocks)]
+    D.ThematicBreak -> pure horizontalRule
+    D.Table mbCaption rows -> pure mempty -- TODO -- [[Cell]]
+    D.RawBlock (D.Format fmt) bs -> pure $
+      rawBlock (UTF8.toText fmt) (UTF8.toText bs)
+
+addAttrToBlock :: D.Attr -> Blocks -> Blocks
+addAttrToBlock attr =
+  case attr of
+       D.Attr [] -> id
+       D.Attr as -> addPandocAttributes
+                      (map (\(k,v) -> (UTF8.toText k, UTF8.toText v)) as)
+
+convertInlines :: PandocMonad m => D.Inlines -> ReaderT Env m Inlines
+convertInlines = fmap mconcat . mapM convertInline . F.toList . D.unInlines
+
+convertInline :: PandocMonad m => D.Node D.Inline -> ReaderT Env m Inlines
+convertInline (D.Node attr il) = addAttrToInline attr <$>
+  case il of
+    D.Str bs -> pure $ str (UTF8.toText bs)
+    D.Emph ils -> emph <$> convertInlines ils
+    D.Strong ils -> strong <$> convertInlines ils
+    D.Highlight ils -> spanWith ("",["highlighted"],[]) <$> convertInlines ils
+    D.Insert ils -> spanWith ("",["inserted"],[]) <$> convertInlines ils
+    D.Delete ils -> spanWith ("",["deleted"],[]) <$> convertInlines ils
+    D.Subscript ils -> subscript <$> convertInlines ils
+    D.Superscript ils -> superscript <$> convertInlines ils
+    D.Span ils -> spanWith nullAttr <$> convertInlines ils
+    D.Verbatim bs -> pure $ code (UTF8.toText bs)
+    D.Symbol bs -> pure $
+      let s = UTF8.toText bs
+       in maybe (spanWith ("",["symbol"],[]) (str s)) singleton $ emojiToInline s
+    D.Math sty bs -> pure mempty -- TODO
+    D.Link ils tgt -> pure mempty -- TODO
+    D.Image ils tgt -> pure mempty -- TODO
+    D.FootnoteReference bs -> pure mempty -- TODO
+    D.UrlLink bs -> pure mempty -- TODO
+    D.EmailLink bs -> pure mempty -- TODO
+    D.RawInline (D.Format fbs) bs -> pure $
+      rawInline (UTF8.toText fbs) (UTF8.toText bs)
+    D.NonBreakingSpace -> pure $ str "\160"
+    D.SoftBreak -> pure softbreak
+    D.HardBreak -> pure linebreak
+
+addAttrToInline :: D.Attr -> Inlines -> Inlines
+addAttrToInline attr =
+  case attr of
+       D.Attr [] -> id
+       D.Attr as -> addPandocAttributes
+                      (map (\(k,v) -> (UTF8.toText k, UTF8.toText v)) as)