markup-preview-0.1.0.0: Main.hs

module Main where

    import Graphics.UI.Gtk (AttrOp((:=)))
    import qualified Graphics.UI.Gtk as G
    import qualified Graphics.UI.Gtk.WebKit.WebView as GW

    import Control.Monad (void, forever, when)
    import Control.Concurrent (forkIO, threadDelay)
    import Control.Concurrent.MVar
    import Data.Maybe (isJust, fromJust)

    import Text.Pandoc
    import System.Directory (getTemporaryDirectory, getModificationTime)
    import System.IO.Temp (openTempFile)
    import GHC.IO.Handle (hPutStr, hFlush)
    import Control.Monad.Trans (lift)
    import Control.Monad.Trans.Maybe

    import Paths_markup_preview

    import Debug.Trace


    generateHtml format contents = writeHtmlString def intermediaryDocument where
        intermediaryDocument = 
            let reader = fromJust $ lookup format [("Markdown", readMarkdown), ("reStructuredText", readRST), ("Textile", readTextile)]
            in reader (def { readerStandalone = True }) contents


    createFilter name filepatterns = do
        fileFilter <- G.fileFilterNew
        mapM_ (G.fileFilterAddPattern fileFilter) filepatterns
        G.fileFilterSetName fileFilter name
        return fileFilter


    createOpenDialog = do
        dialog <- G.fileChooserDialogNew 
                    (Just "Choose a markup file")
                    Nothing
                    G.FileChooserActionOpen
                    [("Ok", G.ResponseAccept), ("Cancel", G.ResponseCancel)]
        createFilter "Markdown" ["*.md", "*.markdown"] >>= G.fileChooserAddFilter dialog
        createFilter "reStructuredText" ["*.rst", "*.rest", "*.restx"] >>= G.fileChooserAddFilter dialog 
        createFilter "Textile" ["*.textile"] >>= G.fileChooserAddFilter dialog 

        return dialog


    createToolbar loadNotifier = do
        toolbar <- G.toolbarNew
        G.toolbarSetStyle toolbar G.ToolbarIcons
        openButton <- G.toolButtonNewFromStock "gtk-open"
        void $ G.onToolButtonClicked openButton $ do
            openDialog <- createOpenDialog
            dialogResponse <- G.dialogRun openDialog
            when (dialogResponse == G.ResponseAccept) $ do
                response <- runMaybeT $ do
                    filepath <- MaybeT $ G.fileChooserGetFilename openDialog
                    fileFilter <- MaybeT $  G.fileChooserGetFilter openDialog
                    format <- lift $ G.fileFilterGetName fileFilter 
                    return (format, filepath)
                when (isJust response) $ putMVar loadNotifier (fromJust response)
            G.widgetDestroy openDialog

        G.toolbarInsert toolbar openButton 0

        return toolbar


    createInterface loadNotifier = do
        window <- G.windowNew
        scrolledWindow <- G.scrolledWindowNew Nothing Nothing
        webView <- GW.webViewNew
        G.set scrolledWindow [ G.containerChild := webView ]
        statusBar <- G.statusbarNew
        toolBar <- createToolbar loadNotifier

        singleColumn <- G.vBoxNew False 1
        G.boxPackStart singleColumn toolBar G.PackNatural 0
        G.boxPackStart singleColumn scrolledWindow G.PackGrow 0
        G.boxPackEnd singleColumn statusBar G.PackNatural 0

        G.set window [ G.containerChild := singleColumn
                     , G.windowDefaultWidth := 600
                     , G.windowDefaultHeight := 600
                     , G.containerBorderWidth := 1
                     ]
        return (window, webView)


    withGUI f = do
        void G.initGUI
        window <- f
        G.onDestroy window G.mainQuit
        G.widgetShowAll window
        G.mainGUI


    loadHtmlInView webView htmlContent = do
            tempDirectory <- getTemporaryDirectory
            layout <- getDataFileName "Resources/layout.html" >>= \filepath -> readFile filepath
            let htmlContent' = renderTemplate [("htmlContent", htmlContent)] layout
            (tempFilePath, tempHandle) <- openTempFile tempDirectory "markup-preview.html"
            hPutStr tempHandle htmlContent' >> hFlush tempHandle
            GW.webViewLoadUri webView ("file://" ++ tempFilePath)


    loaderReloader webView loadNotifier Nothing Nothing = do
        threadDelay 500
        (format, filepath) <- takeMVar loadNotifier
        modificationTime <- getModificationTime filepath
        contents <- readFile filepath
        loadHtmlInView webView $ generateHtml format contents
        loaderReloader webView loadNotifier (Just (format, filepath)) (Just modificationTime)

    loaderReloader webView loadNotifier (Just (format, filepath)) (Just modificationTime) = do
        threadDelay 500
        noNewFile <- isEmptyMVar loadNotifier
        if noNewFile
            then do modificationTime' <- getModificationTime filepath
                    when (modificationTime' /= modificationTime) $ do
                        contents <- readFile filepath
                        loadHtmlInView webView $ generateHtml format contents
                    loaderReloader webView loadNotifier (Just (format, filepath)) (Just modificationTime')
            else loaderReloader webView loadNotifier Nothing Nothing


    main :: IO ()
    main = withGUI $ do
        loadNotifier <- newEmptyMVar :: IO (MVar (String, String))
        (window, webView) <- createInterface loadNotifier
        forkIO $ loaderReloader webView loadNotifier Nothing Nothing
        return window