using Yesod to build a simple web interface to Pandoc

yespandoc_aform.hs

-- Using Yesod (AForm) to build a simple web interface to Pandoc
-- THIS is simply a demonstration, much can be done to improve it.
{-# LANGUAGE QuasiQuotes, TemplateHaskell, MultiParamTypeClasses,
    OverloadedStrings, TypeFamilies #-}
import Yesod
import Data.Text (Text, unpack, pack)
import Text.Pandoc
import Control.Applicative ((<$>), (<*>))

data Yespandoc = Yespandoc

mkYesod "Yespandoc" [parseRoutes|
/ RootR GET POST
|]

instance Yesod Yespandoc

instance RenderMessage Yespandoc FormMessage where
    renderMessage _ _ = defaultFormMessage

instance YesodJquery Yespandoc

data Panda = Panda
    { inText :: Textarea
    , inFormat :: PandaFormat
    , outFormat :: PandaFormat
    }
    deriving Show

data PandaFormat = Markdown | LaTeX
    deriving (Show, Eq, Enum, Bounded)

pandocForm :: Html -> MForm Yespandoc Yespandoc (FormResult Panda, Widget)
pandocForm = renderDivs $ Panda
    <$> areq textareaField "inText" Nothing
    <*> areq (selectFieldList formats) "inFormat" Nothing
    <*> areq (selectFieldList formats) "outFormat" Nothing
    where
        formats :: [(Text, PandaFormat)]
        formats = [("Markdown", Markdown), ("LaTeX", LaTeX)]

getRootR :: Handler RepHtml
getRootR = do
    (widget, enctype) <- generateFormPost pandocForm
    defaultLayout [whamlet|
<form method=post action=@{RootR} enctype=#{enctype}>
    ^{widget}
    <input type=submit>
|]

postRootR :: Handler RepHtml
postRootR = do
    ((result, widget), enctype) <- runFormPost pandocForm
    case result of 
        FormSuccess pandoc -> do
            let input = unTextarea $ inText pandoc
            let inputFormat = inFormat pandoc
            let outputFormat = outFormat pandoc
            let pd = case inputFormat of
                        Markdown -> readMarkdown defaultParserState $ unpack input
                        LaTeX -> readLaTeX defaultParserState $ unpack input
            let outHtml = writeHtml defaultWriterOptions pd
            let output = case outputFormat of
                            Markdown -> writeMarkdown defaultWriterOptions pd
                            LaTeX -> writeLaTeX defaultWriterOptions pd
            defaultLayout $ do
                toWidget outHtml
                [whamlet|
<form method=post action=@{RootR} enctype=#{enctype}>
            ^{widget}
            <p>#{output}
            <input type=submit>
            |]
        _ -> defaultLayout [whamlet|
<form method=post action=@{RootR} enctype=#{enctype}>
            ^{widget}
            <input type=submit>
            |]

main :: IO ()
main = warpDebug 3000 Yespandoc

yespandoc_mform.hs

-- Using Yesod (MForm) to build a simple web interface to Pandoc
-- THIS is simply a demonstration, much can be done to improve it.
{-# LANGUAGE QuasiQuotes, TemplateHaskell, MultiParamTypeClasses,
    OverloadedStrings, TypeFamilies #-}
import Yesod
import Data.Text (Text, unpack, pack)
import Text.Pandoc
import Text.Pandoc.Shared (tabFilter)
import Text.Blaze.Html (toHtml)
import Text.Html (stringToHtml, stringToHtmlString)
import Control.Applicative ((<$>), (<*>))
import Control.Arrow ((&&&))

data Yespandoc = Yespandoc

mkYesod "Yespandoc" [parseRoutes|
/ RootR GET POST
|]

instance Yesod Yespandoc

instance RenderMessage Yespandoc FormMessage where
    renderMessage _ _ = defaultFormMessage

data Panda = Panda
    { inText :: Textarea
    , inFormat :: PandaFormat
    , outFormat :: ToFormat
    }
    deriving Show

data PandaFormat = Markdown | LaTeX
    deriving (Show, Eq, Enum, Bounded)

data ToFormat = ToMarkdown | ToLaTeX | ToRST
    deriving (Show, Eq, Enum, Bounded)
pandocForm :: Html -> MForm Yespandoc Yespandoc (FormResult Panda, Widget)
pandocForm extra = do
    -- type signature can not be omitted
    --let formats = [("Markdown", Markdown), ("LaTeX", LaTeX)] :: [(Text, PandaFormat)]
    let formats = map (pack . show &&& id ) $ [minBound..maxBound]
    let toformats = map (pack . show &&& id ) $ [minBound..maxBound]
    (inRes, inView) <- mreq textareaField "inText" Nothing
    (fFormatRes, fFormatView) <- mreq (selectFieldList formats) "inFormat" Nothing
    (tFormatRes, tFormatView) <- mreq (selectFieldList toformats) "outFormat" Nothing

    let pandocRes = Panda <$> inRes <*> fFormatRes <*> tFormatRes
    let widget = do
        toWidget [lucius|
##{fvId inView} {
    width: 40%;
    height: 20em;
}
|]
        [whamlet|
#{extra}
<p>
    ^{fvInput inView}
    ^{fvInput fFormatView}
    ^{fvInput tFormatView}
    <input type=submit value="Convert">
|]
    return (pandocRes, widget)

getRootR :: Handler RepHtml
getRootR = do
    (widget, enctype) <- generateFormPost pandocForm
    defaultLayout [whamlet|
<form method=post action=@{RootR} enctype=#{enctype}>
    ^{widget}
|]

postRootR :: Handler RepHtml
postRootR = do
    ((result, widget), enctype) <- runFormPost pandocForm
    case result of 
        FormSuccess pandoc -> do
            let input = unTextarea $ inText pandoc
            let inputFormat = inFormat pandoc
            let outputFormat = outFormat pandoc
            -- filter out '\r', thus '\r\n' become '\n'
            let inputString = tabFilter 0 $ unpack input
            let pd = case inputFormat of
                        Markdown -> readMarkdown defaultParserState inputString
                        LaTeX -> readLaTeX defaultParserState inputString
            let outHtml = writeHtml defaultWriterOptions pd
            let output = case outputFormat of
                            ToMarkdown -> writeMarkdown defaultWriterOptions pd
                            ToLaTeX -> writeLaTeX defaultWriterOptions pd
            defaultLayout $ do
                toWidget outHtml
                [whamlet|
<form method=post action=@{RootR} enctype=#{enctype}>
            ^{widget}
            <pre>#{output}
            |]
        _ -> defaultLayout [whamlet|
<form method=post action=@{RootR} enctype=#{enctype}>
            ^{widget}
            |]

main :: IO ()
main = warpDebug 3000 Yespandoc