Allow using any reader for PageType

src/Network/Gitit/Config.hs

@@ -30,6 +30,7 @@ import Network.Gitit.Server (mimeTypes)
 import Network.Gitit.Framework
 import Network.Gitit.Authentication (formAuthHandlers, rpxAuthHandlers, httpAuthHandlers, githubAuthHandlers)
 import Network.Gitit.Util (parsePageType, readFileUTF8)
+import System.Directory (doesFileExist)
 import System.Log.Logger (logM, Priority(..))
 import qualified Data.Map as M
 import Data.ConfigFile hiding (readfile)
@@ -133,13 +134,16 @@ extractConfig cp = do
       cfPandocUserData <- get cp "DEFAULT" "pandoc-user-data"
       cfXssSanitize <- get cp "DEFAULT" "xss-sanitize"
       cfRecentActivityDays <- get cp "DEFAULT" "recent-activity-days"
-      let (pt, lhs) = parsePageType cfDefaultPageType
-      let markupHelpFile = show pt ++ if lhs then "+LHS" else ""
+      let pt = parsePageType cfDefaultPageType
+      let markupHelpFile = show pt
       markupHelpPath <- liftIO $ getDataFileName $ "data" </> "markupHelp" </> markupHelpFile
-      markupHelp' <- liftIO $ readFileUTF8 markupHelpPath
-      markupHelpText <- liftIO $ handleError $ runPure $ do
-        helpDoc <- readMarkdown def{ readerExtensions = getDefaultExtensions "markdown" } markupHelp'
-        writeHtml5String def helpDoc
+      helpFileExists <- liftIO $ doesFileExist markupHelpPath
+      markupHelpText <- if helpFileExists then do
+        markupHelp' <- liftIO $ readFileUTF8 markupHelpPath
+        liftIO $ handleError $ runPure $ do
+          helpDoc <- readMarkdown def{ readerExtensions = getDefaultExtensions "markdown" } markupHelp'
+          writeHtml5String def helpDoc
+      else return T.empty
 
       mimeMap' <- liftIO $ readMimeTypesFile cfMimeTypesFile
       let authMethod = map toLower cfAuthenticationMethod
@@ -166,7 +170,6 @@ extractConfig cp = do
                                       "mathjax"  -> MathJax cfMathjaxScript
                                       "google"   -> WebTeX "http://chart.apis.google.com/chart?cht=tx&chl="
                                       _          -> RawTeX
-        , defaultLHS           = lhs
         , showLHSBirdTracks    = cfShowLHSBirdTracks
         , withUser             = case authMethod of
                                       "form"     -> withUserFromSession

src/Network/Gitit/ContentTransformer.hs

@@ -83,7 +83,6 @@ import Network.Gitit.Page (stringToPage)
 import Network.Gitit.Server
 import Network.Gitit.State
 import Network.Gitit.Types
-import Network.Gitit.Util (getPageTypeDefaultExtensions)
 import Network.HTTP (urlDecode)
 import Network.URI (isUnescapedInURI)
 import Network.URL (encString)
@@ -333,7 +332,7 @@ pageToPandoc page' = do
   modifyContext $ \ctx -> ctx{ ctxTOC = pageTOC page'
                              , ctxCategories = pageCategories page'
                              , ctxMeta = pageMeta page' }
-  either (liftIO . E.throwIO) return $ readerFor (pageFormat page') (pageLHS page') (pageText page')
+  either (liftIO . E.throwIO) return $ readerFor (pageFormat page') (pageText page')
 
 -- | Detects if the page is a redirect page and handles accordingly. The exact
 -- behaviour is as follows:
@@ -669,23 +668,16 @@ updateLayout f = do
 -- Pandoc and wiki content conversion support
 --
 
-readerFor :: PageType -> Bool -> String -> Either PandocError Pandoc
-readerFor pt lhs =
-  let defExts = getDefaultExtensions $ T.toLower $ T.pack $ show pt
-      defPS = def{ readerExtensions = defExts
+readerFor :: PageType -> String -> Either PandocError Pandoc
+readerFor (PageType {
+  pageTypeReader = TextReader reader,
+  pageTypeExtensions = ext
+}) =
+  let defPS = def{ readerExtensions = ext
                                       <> extensionsFromList [Ext_emoji]
-                                      <> getPageTypeDefaultExtensions pt lhs
                                       <> readerExtensions def }
-  in runPure . (case pt of
-       RST        -> readRST defPS
-       Markdown   -> readMarkdown defPS
-       CommonMark -> readCommonMark defPS
-       LaTeX      -> readLaTeX defPS
-       HTML       -> readHtml defPS
-       Textile    -> readTextile defPS
-       Org        -> readOrg defPS
-       DocBook    -> readDocBook defPS
-       MediaWiki  -> readMediaWiki defPS) . T.pack
+  in runPure . reader defPS . T.pack
+readerFor pt = const $ Left $ PandocAppError $ "Binary PageType unsupported: " <> T.pack (show pt)
 
 wikiLinksTransform :: Pandoc -> PluginM Pandoc
 wikiLinksTransform pandoc

src/Network/Gitit/Initialize.hs

@@ -27,7 +27,6 @@ module Network.Gitit.Initialize ( initializeGititState
                                 , createTemplateIfMissing )
 where
 import System.FilePath ((</>), (<.>))
-import Data.Semigroup ((<>))
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.FileStore
@@ -40,8 +39,9 @@ import Network.Gitit.Plugins
 import Network.Gitit.Layout (defaultRenderPage)
 import Paths_gitit (getDataFileName)
 import Control.Exception (throwIO, try)
+import Control.Monad.Except (throwError)
 import System.Directory (copyFile, createDirectoryIfMissing, doesDirectoryExist, doesFileExist)
-import Control.Monad ((<=<), unless, forM_, liftM)
+import Control.Monad (unless, forM_, liftM)
 import Text.Pandoc hiding (getDataFileName, WARNING)
 import System.Log.Logger (logM, Priority(..))
 import qualified Text.StringTemplate as ST
@@ -131,29 +131,28 @@ createDefaultPages conf = do
                                              else writerExtensions def
                      }
         -- note: we convert this (markdown) to the default page format
-        converter = handleError . runPure . case pt of
-                       Markdown   -> return
-                       LaTeX      -> writeLaTeX defOpts <=< toPandoc
-                       HTML       -> writeHtml5String defOpts <=< toPandoc
-                       RST        -> writeRST defOpts <=< toPandoc
-                       Textile    -> writeTextile defOpts <=< toPandoc
-                       Org        -> writeOrg defOpts <=< toPandoc
-                       DocBook    -> writeDocbook5 defOpts <=< toPandoc
-                       MediaWiki  -> writeMediaWiki defOpts <=< toPandoc
-                       CommonMark -> writeCommonMark defOpts <=< toPandoc
+        converter input = handleError $ runPure $ do
+          (writer, exts) <- getWriter (T.pack $ pageTypeSpec pt)
+          pandoc <- toPandoc input
+          case writer of
+            TextWriter w -> w (defOpts { writerExtensions = exts <> writerExtensions defOpts }) pandoc
+            _ -> throwError $ PandocAppError $ "Binary PageType unsupported: " <> T.pack (show pt)
 
     welcomepath <- getDataFileName $ "data" </> "FrontPage" <.> "page"
     welcomecontents <- converter =<< readFileUTF8 welcomepath
     helppath <- getDataFileName $ "data" </> "Help" <.> "page"
     helpcontentsInitial <- converter =<< readFileUTF8 helppath
     markuppath <- getDataFileName $ "data" </> "markup" <.> show pt
-    helpcontentsMarkup <- converter =<< readFileUTF8 markuppath
+    markupExists <- doesFileExist markuppath
+    helpcontentsMarkup <- if markupExists then
+      converter =<< readFileUTF8 markuppath
+    else return T.empty
     let helpcontents = helpcontentsInitial <> "\n\n" <> helpcontentsMarkup
     usersguidepath <- getDataFileName "README.markdown"
     usersguidecontents <- converter =<< readFileUTF8 usersguidepath
     -- include header in case user changes default format:
     let header = "---\nformat: " <>
-          T.pack (show pt) <> (if defaultLHS conf then "+lhs" else "") <>
+          T.pack (show pt) <>
           "\n...\n\n"
     -- add front page, help page, and user's guide
     let auth = Author "Gitit" ""

src/Network/Gitit/Page.hs

@@ -106,7 +106,6 @@ stringToPage conf pagename raw =
   let (ls, rest) = parseMetadata raw
       page' = Page { pageName        = pagename
                    , pageFormat      = defaultPageType conf
-                   , pageLHS         = defaultLHS conf
                    , pageTOC         = tableOfContents conf
                    , pageTitle       = pagename
                    , pageCategories  = []
@@ -116,8 +115,8 @@ stringToPage conf pagename raw =
 
 adjustPage :: (String, String) -> Page -> Page
 adjustPage ("title", val) page' = page' { pageTitle = val }
-adjustPage ("format", val) page' = page' { pageFormat = pt, pageLHS = lhs }
-    where (pt, lhs) = parsePageType val
+adjustPage ("format", val) page' = page' { pageFormat = pt }
+    where pt = parsePageType val
 adjustPage ("toc", val) page' = page' {
   pageTOC = map toLower val `elem` ["yes","true"] }
 adjustPage ("categories", val) page' =
@@ -131,7 +130,6 @@ pageToString conf page' =
   let pagename   = pageName page'
       pagetitle  = pageTitle page'
       pageformat = pageFormat page'
-      pagelhs    = pageLHS page'
       pagetoc    = pageTOC page'
       pagecats   = pageCategories page'
       metadata   = filter
@@ -141,11 +139,9 @@ pageToString conf page' =
       metadata'  = (if pagename /= pagetitle
                        then "title: " ++ pagetitle ++ "\n"
                        else "") ++
-                   (if pageformat /= defaultPageType conf ||
-                          pagelhs /= defaultLHS conf
+                   (if pageformat /= defaultPageType conf
                        then "format: " ++
-                            map toLower (show pageformat) ++
-                            if pagelhs then "+lhs\n" else "\n"
+                            map toLower (show pageformat)
                        else "") ++
                    (if pagetoc /= tableOfContents conf
                        then "toc: " ++

src/Network/Gitit/State.hs

@@ -139,6 +139,3 @@ getFileStore = liftM wikiFileStore ask
 
 getDefaultPageType :: GititServerPart PageType
 getDefaultPageType = liftM defaultPageType getConfig
-
-getDefaultLHS :: GititServerPart Bool
-getDefaultLHS = liftM defaultLHS getConfig

src/Network/Gitit/Types.hs

@@ -69,7 +69,7 @@ import Control.Monad.Reader (ReaderT, runReaderT, mplus)
 import Control.Monad.State (StateT, runStateT, get, modify)
 import Control.Monad (liftM)
 import System.Log.Logger (Priority(..))
-import Text.Pandoc.Definition (Pandoc)
+import Text.Pandoc (Pandoc, Reader, PandocPure, Extensions)
 import Text.XHtml (Html)
 import qualified Data.Map as M
 import Data.Text (Text)
@@ -86,16 +86,17 @@ import Text.HTML.TagSoup.Entity (lookupEntity)
 import Data.Char (isSpace)
 import Network.OAuth.OAuth2
 
-data PageType = Markdown
-              | CommonMark
-              | RST
-              | LaTeX
-              | HTML
-              | Textile
-              | Org
-              | DocBook
-              | MediaWiki
-                deriving (Read, Show, Eq)
+data PageType = PageType {
+  pageTypeSpec       :: String,
+  pageTypeReader     :: Reader PandocPure,
+  pageTypeExtensions :: Extensions
+}
+
+instance Show PageType where
+  show = pageTypeSpec
+
+instance Eq PageType where
+  (PageType spec1 _ _) == (PageType spec2 _ _) = spec1 == spec2
 
 data FileStoreType = Git | Darcs | Mercurial deriving Show
 
@@ -117,8 +118,6 @@ data Config = Config {
   defaultExtension     :: String,
   -- | How to handle LaTeX math in pages?
   mathMethod           :: MathMethod,
-  -- | Treat as literate haskell by default?
-  defaultLHS           :: Bool,
   -- | Show Haskell code with bird tracks
   showLHSBirdTracks    :: Bool,
   -- | Combinator to set @REMOTE_USER@ request header
@@ -219,13 +218,12 @@ data Config = Config {
 data Page = Page {
     pageName        :: String
   , pageFormat      :: PageType
-  , pageLHS         :: Bool
   , pageTOC         :: Bool
   , pageTitle       :: String
   , pageCategories  :: [String]
   , pageText        :: String
   , pageMeta        :: [(String, String)]
-} deriving (Read, Show)
+} deriving (Show, Eq)
 
 newtype SessionKey = SessionKey Integer
   deriving (Read, Show, Eq, Ord)

src/Network/Gitit/Util.hs

@@ -26,20 +26,19 @@ module Network.Gitit.Util ( readFileUTF8
                           , yesOrNo
                           , parsePageType
                           , encUrl
-                          , getPageTypeDefaultExtensions
                           )
 where
 import System.Directory
 import Control.Exception (bracket)
 import System.FilePath ((</>), (<.>))
 import System.IO.Error (isAlreadyExistsError)
 import Control.Monad.Trans (liftIO)
-import Data.Char (toLower, isAscii)
+import Data.Char (isAscii)
 import Data.Text (Text)
 import Network.Gitit.Types
 import qualified Control.Exception as E
 import qualified Text.Pandoc.UTF8 as UTF8
-import Text.Pandoc (Extension(..), Extensions, getDefaultExtensions, enableExtension)
+import Text.Pandoc (getReader, runPure)
 import Network.URL (encString)
 
 #if !MIN_VERSION_pandoc(2,12,0)
@@ -101,39 +100,12 @@ yesOrNo :: Bool -> String
 yesOrNo True  = "yes"
 yesOrNo False = "no"
 
-parsePageType :: String -> (PageType, Bool)
-parsePageType s =
-  case map toLower s of
-       "markdown"     -> (Markdown,False)
-       "markdown+lhs" -> (Markdown,True)
-       "commonmark"   -> (CommonMark,False)
-       "docbook"      -> (DocBook,False)
-       "rst"          -> (RST,False)
-       "rst+lhs"      -> (RST,True)
-       "html"         -> (HTML,False)
-       "textile"      -> (Textile,False)
-       "latex"        -> (LaTeX,False)
-       "latex+lhs"    -> (LaTeX,True)
-       "org"          -> (Org,False)
-       "mediawiki"    -> (MediaWiki,False)
-       x              -> error $ "Unknown page type: " ++ x
-
-getPageTypeDefaultExtensions :: PageType -> Bool -> Extensions
-getPageTypeDefaultExtensions pt lhs =
-  if lhs
-     then enableExtension Ext_literate_haskell defaults
-     else defaults
-  where defaults = getDefaultExtensions $
-          case pt of
-            CommonMark -> "commonmark"
-            DocBook    -> "docbook"
-            HTML       -> "html"
-            LaTeX      -> "latex"
-            Markdown   -> "markdown"
-            MediaWiki  -> "mediawiki"
-            Org        -> "org"
-            RST        -> "rst"
-            Textile    -> "textile"
+parsePageType :: String -> PageType
+parsePageType s = case runPure $ getReader spec of
+  Right (r, e) -> PageType (T.unpack spec) r e
+  Left err -> error $ "Bad page type: " ++ show err
+  where
+  spec = T.toLower $ T.pack s
 
 encUrl :: String -> String
 encUrl = encString True isAscii