Make pandoc highlight style configurable in settings and in query parameter

This commit is contained in:
fr33domlover 2019-05-27 18:30:48 +00:00
parent 12ec77fb44
commit e02a0fa4db
5 changed files with 39 additions and 6 deletions

View file

@ -168,3 +168,12 @@ retry-delivery-every:
# List of (hosts of) other known federating instances. # List of (hosts of) other known federating instances.
#instances: [] #instances: []
###############################################################################
# User interface
###############################################################################
# Default color scheme for syntax highlighing of code blocks inside rendered
# documents. The available styles are listed in the "Text.Pandoc.Highlighting"
# module documentation.
highlight-style: zenburn

View file

@ -66,7 +66,7 @@ import System.Hourglass (dateCurrent)
import Text.Blaze.Html (Html) import Text.Blaze.Html (Html)
import Text.Pandoc.Highlighting import Text.Pandoc.Highlighting
import Yesod.Auth (requireAuthId) import Yesod.Auth (requireAuthId)
import Yesod.Core (defaultLayout, setMessage) import Yesod.Core
import Yesod.Core.Content import Yesod.Core.Content
import Yesod.Core.Handler (lookupPostParam, redirect, notFound) import Yesod.Core.Handler (lookupPostParam, redirect, notFound)
import Yesod.Form.Functions (runFormPost) import Yesod.Form.Functions (runFormPost)
@ -364,4 +364,13 @@ postRepoDevR shr rp dev = do
_ -> notFound _ -> notFound
getHighlightStyleR :: Handler TypedContent getHighlightStyleR :: Handler TypedContent
getHighlightStyleR = pure $ TypedContent typeCss $ toContent $ styleToCss tango getHighlightStyleR = do
styleName <- do
ms <- lookupGetParam "style"
case ms of
Nothing -> getsYesod $ appHighlightStyle . appSettings
Just s -> return $ unpack s
case lookup styleName highlightingStyles of
Nothing -> notFound
Just style ->
return $ TypedContent typeCss $ toContent $ styleToCss style

View file

@ -26,7 +26,7 @@ import Prelude
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import Data.List (inits) import Data.List (inits)
import Data.Maybe (fromMaybe) import Data.Maybe
import Data.Text (Text, unpack) import Data.Text (Text, unpack)
import Data.Text.Encoding (decodeUtf8With) import Data.Text.Encoding (decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode) import Data.Text.Encoding.Error (lenientDecode)
@ -84,7 +84,9 @@ getDarcsRepoSource repository user repo dir = do
let parent = if null dir then [] else init dir let parent = if null dir then [] else init dir
dirs = zip parent (tail $ inits parent) dirs = zip parent (tail $ inits parent)
defaultLayout $ do defaultLayout $ do
addStylesheet HighlightStyleR ms <- lookupGetParam "style"
let mparam = ("style",) <$> ms
addStylesheetAttrs HighlightStyleR $ maybeToList mparam
$(widgetFile "repo/source-darcs") $(widgetFile "repo/source-darcs")
getDarcsRepoHeadChanges :: ShrIdent -> RpIdent -> Handler TypedContent getDarcsRepoHeadChanges :: ShrIdent -> RpIdent -> Handler TypedContent

View file

@ -35,7 +35,7 @@ import Data.Git.Types (Blob (..), Commit (..), Person (..), entName)
import Data.Graph.Inductive.Graph (noNodes) import Data.Graph.Inductive.Graph (noNodes)
import Data.Graph.Inductive.Query.Topsort import Data.Graph.Inductive.Query.Topsort
import Data.List (inits) import Data.List (inits)
import Data.Maybe (fromMaybe) import Data.Maybe
import Data.Text (Text, unpack) import Data.Text (Text, unpack)
import Data.Text.Encoding (decodeUtf8With) import Data.Text.Encoding (decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode) import Data.Text.Encoding.Error (lenientDecode)
@ -94,7 +94,9 @@ getGitRepoSource repository user repo ref dir = do
let parent = if null dir then [] else init dir let parent = if null dir then [] else init dir
dirs = zip parent (tail $ inits parent) dirs = zip parent (tail $ inits parent)
defaultLayout $ do defaultLayout $ do
addStylesheet HighlightStyleR ms <- lookupGetParam "style"
let mparam = ("style",) <$> ms
addStylesheetAttrs HighlightStyleR $ maybeToList mparam
$(widgetFile "repo/source-git") $(widgetFile "repo/source-git")
getGitRepoHeadChanges :: Repo -> ShrIdent -> RpIdent -> Handler TypedContent getGitRepoHeadChanges :: Repo -> ShrIdent -> RpIdent -> Handler TypedContent

View file

@ -39,6 +39,7 @@ import Data.Yaml (decodeEither')
import Database.Persist.Postgresql (PostgresConf) import Database.Persist.Postgresql (PostgresConf)
import Language.Haskell.TH.Syntax (Exp, Name, Q) import Language.Haskell.TH.Syntax (Exp, Name, Q)
import Network.Wai.Handler.Warp (HostPreference) import Network.Wai.Handler.Warp (HostPreference)
import Text.Pandoc.Highlighting
import Yesod.Default.Config2 (applyEnvValue, configSettingsYml) import Yesod.Default.Config2 (applyEnvValue, configSettingsYml)
import Yesod.Default.Util (WidgetFileSettings, widgetFileNoReload, import Yesod.Default.Util (WidgetFileSettings, widgetFileNoReload,
widgetFileReload) widgetFileReload)
@ -154,6 +155,10 @@ data AppSettings = AppSettings
, appInboxDebugReportLength :: Maybe Int , appInboxDebugReportLength :: Maybe Int
-- | List of (hosts of) other known federating instances. -- | List of (hosts of) other known federating instances.
, appInstances :: [Text] , appInstances :: [Text]
-- | Default color scheme for syntax highlighting of code blocks inside
-- documentes rendered with pandoc.
, appHighlightStyle :: String
} }
instance FromJSON AppSettings where instance FromJSON AppSettings where
@ -205,6 +210,12 @@ instance FromJSON AppSettings where
appInboxDebugReportLength <- o .:? "activity-debug-reports" appInboxDebugReportLength <- o .:? "activity-debug-reports"
appInstances <- o .:? "instances" .!= [] appInstances <- o .:? "instances" .!= []
appHighlightStyle <- do
s <- o .:? "highlight-style" .!= "zenburn"
case lookup s highlightingStyles of
Nothing -> fail $ "Highlighting style " ++ s ++ " not found"
Just _ -> return s
return AppSettings {..} return AppSettings {..}
where where
toSeconds :: TimeInterval -> Second toSeconds :: TimeInterval -> Second