Markdown.hs

module Frame.View.Markdown where

import Frame.View
import Text.Pandoc hiding (Block (Header), Inline (Code, Strong, Image, Link))
import qualified Text.Pandoc as P (Block (Header), Inline (Code, Strong, Image, Link)) 

markdownToViewPart :: String -> Data
markdownToViewPart m = pandocToViewPart $ readMarkdown defaultParserState $ filter (/='\r') m

pandocToViewPart :: Pandoc -> Data
pandocToViewPart (Pandoc _ bs) = ViewPart $ toContainers bs

toContainers :: [P.Block] -> [Container]
toContainers = map blockToContainer

blockToContainer :: P.Block -> Container
blockToContainer (Plain is)               = Paragraph (inlinesToElement is) []
blockToContainer (Para is)                = Paragraph (inlinesToElement is) [] 
blockToContainer (CodeBlock _ s)          = Code s
blockToContainer (RawHtml s)              = Code s
blockToContainer (BlockQuote bs)          = Quote $ toContainers bs
blockToContainer (OrderedList _ bss)      = NumList (map toContainers bss) [] 
blockToContainer (BulletList bss)         = List (map toContainers bss) []
blockToContainer (P.Header i is)          = Header i $ inlinesToElement is
blockToContainer HorizontalRule           = Line
blockToContainer _                        = Empty

inlinesToElement :: [P.Inline] -> [Element]
inlinesToElement = map inlineToElement

inlineToElement :: P.Inline -> Element
inlineToElement (P.Link is t) = Link (fst t) $ Text $ concatMap inlineToString is
inlineToElement (P.Image a t) = Element $ Image (fst t) $ concatMap inlineToString a
inlineToElement (P.Strong is) = Strong (map inlineToElement is)
inlineToElement (Emph is)     = Emphasis (map inlineToElement is)
inlineToElement LineBreak     = Break
inlineToElement i             = Element $ Text $ inlineToString i

inlineToString :: P.Inline -> String
inlineToString Space      = " "
inlineToString (P.Code s) = s
inlineToString Apostrophe = "'"
inlineToString (Str s)    = s
inlineToString Ellipses   = "..."
inlineToString _          = ""