markup-preview 0.2 → 0.2.0.1
raw patch · 4 files changed
+200/−2 lines, 4 files
Files
- Application/CommandLine.hs +64/−0
- Application/FileHandling.hs +46/−0
- Application/GUI.hs +85/−0
- markup-preview.cabal +5/−2
+ Application/CommandLine.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE ImplicitParams, RankNTypes #-}+module Application.CommandLine (withCommandLine, StartupOptions(..)) where++ import Application.FileHandling++ import System.Console.CmdArgs.Explicit++ import Data.Maybe+ import Data.List+ import Control.Monad+++ type SkipExecution = Bool+ type ArgumentKey = String+ type Arguments = [(ArgumentKey, String)]++ data StartupOptions = StartupOptions+ { file :: Maybe FilePath+ , filetype :: Maybe String+ , canLoad :: Bool }+++ arguments :: Mode Arguments+ arguments = mode "markup-preview" [] "" (flagArg (upd "file") "file")+ [ flagHelpSimple (("help",""):)+ , flagVersion (("version",""):)+ , flagNone ["markdown"] (setKey "force-type" "Markdown") "Treat file as Markdown" + , flagNone ["textile"] (setKey "force-type" "Textile") "Treat file as Textile" + , flagNone ["rst"] (setKey "force-type" "reStructuredText") "Treat file as reStructuredText" + ]+ where upd msg x v = Right $ (msg,x):v+ setKey key v xs = case findIndex (\(k,_) -> k == key) xs of+ Just _ -> map (\x@(k,_) -> if key == k then (k,v) else x) xs+ Nothing -> (key,v):xs+++ hasFlag :: ArgumentKey -> Arguments -> Bool+ hasFlag flag = isJust . findIndex (\(k,_) -> k == flag)+++ getFlag :: ArgumentKey -> Arguments -> Maybe String+ getFlag flag = listToMaybe . map snd . filter (\(k,_) -> k == flag)+++ handleInformationRequest :: Arguments -> IO SkipExecution+ handleInformationRequest args + | hasFlag "version" args = putStrLn "markup-preview 0.2.0.1" >> return True+ | hasFlag "help" args = print (helpText [] HelpFormatDefault arguments) >> return True+ | otherwise = return False+++ buildOptions :: Arguments -> StartupOptions+ buildOptions args = StartupOptions { file=file_option, filetype=filetype_option, canLoad=can_load_option } where+ file_option = getFlag "file" args+ can_load_option = isJust filetype_option+ filetype_option | hasFlag "force-type" args = getFlag "force-type" args+ | otherwise = file_option >>= detectFiletype+++ withCommandLine :: ((?startupOptions :: StartupOptions) => IO ()) -> IO ()+ withCommandLine f = do+ args <- processArgs arguments+ skip <- handleInformationRequest args+ unless skip $ let ?startupOptions = buildOptions args in f
+ Application/FileHandling.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE CPP #-}+module Application.FileHandling (detectFiletype, renderHtml) where++ import Text.Pandoc+ import GHC.IO.Handle+ import System.Directory+ import System.IO.Temp++#ifdef CABAL+ import Paths_markup_preview+#endif++ import Control.Applicative+ import Data.List+ import Data.Maybe+++ detectFiletype :: FilePath -> Maybe String+ detectFiletype filepath = fst <$> find (any (`isSuffixOf` filepath) . snd)+ [ ("Markdown", [".markdown", ".md"])+ , ("Textile", [".textile"])+ , ("reStructuredText", [".rst", ".rest", ".restx"]) ]+++ readResource :: FilePath -> IO String+ readResource filepath =+#ifdef CABAL+ getDataFileName filepath >>= \filepath' -> readFile filepath'+#endif+#ifndef CABAL+ readFile filepath+#endif+++ renderHtml :: (String, FilePath) -> IO String+ renderHtml (format, filepath) = readFile filepath >>= writeHtmlFile where+ readerF = fromJust $ lookup format [("Markdown", readMarkdown), ("reStructuredText", readRST), ("Textile", readTextile)]+ writer = writeHtmlString def+ reader = readerF (def { readerStandalone = True })+ writeHtmlFile content = do+ tempDirectory <- getTemporaryDirectory+ layout <- readResource "Resources/layout.html"+ let htmlContent = renderTemplate [("htmlContent", writer $ reader content)] layout+ (tempFilePath, tempHandle) <- openTempFile tempDirectory "markup-preview.html"+ hPutStr tempHandle htmlContent >> hFlush tempHandle+ return ("file://" ++ tempFilePath)
+ Application/GUI.hs view
@@ -0,0 +1,85 @@+module Application.GUI (withGUI, createInterface, webViewLoadUri) where++ import Graphics.UI.Gtk+ import Graphics.UI.Gtk.WebKit.WebView++ import Control.Monad+ import Control.Monad.Trans+ import Control.Monad.Trans.Maybe+ import Data.Maybe+ import Control.Concurrent.MVar+++ createFilter :: String -> [String] -> IO FileFilter+ createFilter name filepatterns = do+ fileFilter <- fileFilterNew+ mapM_ (fileFilterAddPattern fileFilter) filepatterns+ fileFilterSetName fileFilter name+ return fileFilter+++ createOpenDialog :: IO FileChooserDialog+ createOpenDialog = do+ dialog <- fileChooserDialogNew + (Just "Choose a markup file")+ Nothing+ FileChooserActionOpen+ [("Ok", ResponseAccept), ("Cancel", ResponseCancel)]+ createFilter "Markdown" ["*.md", "*.markdown"] >>= fileChooserAddFilter dialog+ createFilter "reStructuredText" ["*.rst", "*.rest", "*.restx"] >>= fileChooserAddFilter dialog + createFilter "Textile" ["*.textile"] >>= fileChooserAddFilter dialog ++ return dialog+++ createToolbar :: MVar (String, FilePath) -> IO Toolbar+ createToolbar loadNotifier = do+ toolbar <- toolbarNew+ toolbarSetStyle toolbar ToolbarIcons+ openButton <- toolButtonNewFromStock "gtk-open"+ void $ onToolButtonClicked openButton $ do+ openDialog <- createOpenDialog+ dialogResponse' <- dialogRun openDialog+ when (dialogResponse' == ResponseAccept) $ do+ response' <- runMaybeT $ do+ filepath <- MaybeT $ fileChooserGetFilename openDialog+ fileFilter <- MaybeT $ fileChooserGetFilter openDialog+ format <- lift $ fileFilterGetName fileFilter + return (format, filepath)+ when (isJust response') $ putMVar loadNotifier (fromJust response')+ widgetDestroy openDialog++ toolbarInsert toolbar openButton 0++ return toolbar+++ createInterface :: MVar (String, FilePath) -> IO (Window, WebView)+ createInterface loadNotifier = do+ window <- windowNew+ scrolledWindow <- scrolledWindowNew Nothing Nothing+ webView <- webViewNew+ set scrolledWindow [ containerChild := webView ]+ statusBar <- statusbarNew+ toolBar <- createToolbar loadNotifier++ singleColumn <- vBoxNew False 1+ boxPackStart singleColumn toolBar PackNatural 0+ boxPackStart singleColumn scrolledWindow PackGrow 0+ boxPackEnd singleColumn statusBar PackNatural 0++ set window [ containerChild := singleColumn+ , windowDefaultWidth := 600+ , windowDefaultHeight := 600+ , containerBorderWidth := 1+ ]+ return (window, webView)+++ withGUI :: WidgetClass self => IO self -> IO ()+ withGUI f = do+ void initGUI+ window <- f+ void $ onDestroy window mainQuit+ widgetShowAll window+ mainGUI
markup-preview.cabal view
@@ -1,5 +1,5 @@ name: markup-preview-version: 0.2+version: 0.2.0.1 synopsis: A simple markup document preview (markdown, textile, reStructuredText) description: A GUI application that renders the markup documents (markdown, textile, reStructuredText) into@@ -28,5 +28,8 @@ main-is: Main.hs ghc-options: -threaded -Wall cpp-options: -DCABAL- other-modules: Paths_markup_preview+ other-modules: Paths_markup_preview,+ Application.FileHandling,+ Application.CommandLine,+ Application.GUI build-depends: base == 4.*, gtk, webkit, pandoc, directory, temporary, transformers, mtl, cmdargs