{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE TemplateHaskell    #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Text.BlogLiterately.Highlight
-- Copyright   :  (c) 2008-2010 Robert Greayer, 2012 Brent Yorgey
-- License     :  GPL (see LICENSE)
-- Maintainer  :  Brent Yorgey <byorgey@gmail.com>
--
-- Syntax highlighting.
--
-----------------------------------------------------------------------------

module Text.BlogLiterately.Highlight
    ( HsHighlight(..)
    , _HsColourInline
    , colourIt
    , litify
    , StylePrefs
    , defaultStylePrefs
    , getStylePrefs
    , bakeStyles
    , replaceBreaks
    , colouriseCodeBlock
    , colourisePandoc
    ) where

-- xmlParse (from HaXmL) uses String
-- hscolour uses String

import           Data.Text                           (Text)
import qualified Data.Text                           as T

import           Control.Lens                        (makePrisms)
import           Control.Monad                       (liftM)
import           Data.Char                           (toLower)
import           Data.List                           (find)
import           Data.Maybe                          (fromMaybe)

import           Language.Haskell.HsColour           (Output (..), hscolour)
import           Language.Haskell.HsColour.Colourise (defaultColourPrefs)
import           System.Console.CmdArgs              (Data, Typeable)
import           Text.Blaze.Html.Renderer.String     (renderHtml)
import           Text.Highlighting.Kate
import           Text.Pandoc.Definition
import           Text.Pandoc.Shared                  (safeRead)
import           Text.XML.HaXml                      hiding (attr, find, html)
import           Text.XML.HaXml.Posn                 (noPos)

import           Text.BlogLiterately.Block           (unTag)

-- | Style preferences are specified as a list of mappings from class
--   attributes to CSS style attributes.
type StylePrefs = [(String,String)]

-- | Four modes for highlighting Haskell.
data HsHighlight =
      HsColourInline StylePrefs   -- ^ Use hscolour and inline the styles.
    | HsColourCSS                 -- ^ Use hscolour in conjunction with
                                  --   an external CSS style sheet.
    | HsKate                      -- ^ Use highlighting-kate.
    | HsNoHighlight               -- ^ Do not highlight Haskell.
  deriving (Typeable HsHighlight
HsHighlight -> DataType
HsHighlight -> Constr
(forall b. Data b => b -> b) -> HsHighlight -> HsHighlight
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> HsHighlight -> u
forall u. (forall d. Data d => d -> u) -> HsHighlight -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> HsHighlight -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> HsHighlight -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> HsHighlight -> m HsHighlight
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> HsHighlight -> m HsHighlight
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c HsHighlight
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> HsHighlight -> c HsHighlight
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c HsHighlight)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c HsHighlight)
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> HsHighlight -> m HsHighlight
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> HsHighlight -> m HsHighlight
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> HsHighlight -> m HsHighlight
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> HsHighlight -> m HsHighlight
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> HsHighlight -> m HsHighlight
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> HsHighlight -> m HsHighlight
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> HsHighlight -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> HsHighlight -> u
gmapQ :: forall u. (forall d. Data d => d -> u) -> HsHighlight -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> HsHighlight -> [u]
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> HsHighlight -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> HsHighlight -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> HsHighlight -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> HsHighlight -> r
gmapT :: (forall b. Data b => b -> b) -> HsHighlight -> HsHighlight
$cgmapT :: (forall b. Data b => b -> b) -> HsHighlight -> HsHighlight
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c HsHighlight)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c HsHighlight)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c HsHighlight)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c HsHighlight)
dataTypeOf :: HsHighlight -> DataType
$cdataTypeOf :: HsHighlight -> DataType
toConstr :: HsHighlight -> Constr
$ctoConstr :: HsHighlight -> Constr
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c HsHighlight
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c HsHighlight
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> HsHighlight -> c HsHighlight
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> HsHighlight -> c HsHighlight
Data,Typeable,Int -> HsHighlight -> ShowS
[HsHighlight] -> ShowS
HsHighlight -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HsHighlight] -> ShowS
$cshowList :: [HsHighlight] -> ShowS
show :: HsHighlight -> String
$cshow :: HsHighlight -> String
showsPrec :: Int -> HsHighlight -> ShowS
$cshowsPrec :: Int -> HsHighlight -> ShowS
Show,HsHighlight -> HsHighlight -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HsHighlight -> HsHighlight -> Bool
$c/= :: HsHighlight -> HsHighlight -> Bool
== :: HsHighlight -> HsHighlight -> Bool
$c== :: HsHighlight -> HsHighlight -> Bool
Eq)

makePrisms ''HsHighlight

{-

The literate Haskell that Pandoc finds in a file ends up in various
`CodeBlock` elements of the `Pandoc` document.  Other code can also
wind up in `CodeBlock` elements -- normal markdown formatted code.
The `Attr` component has metadata about what's in the code block:

    [haskell]
    type Attr = ( Text,           -- code block identifier
                , [Text]          -- list of code classes
                , [(Text, Text)]  -- name/value pairs
                )

Thanks to some feedback from the Pandoc author, John MacFarlane, I
learned that the CodeBlock *may* contain markers about the kind of
code contained within the block.  LHS (bird-style or LaTex style) will
always have an `Attr` of the form `("",["sourceCode","haskell"],[])`,
and other `CodeBlock` elements are the markdown code blocks *may* have
an identifier, classes, or key/value pairs.  Pandoc captures this info
when the file contains code blocks in the delimited (rather than
indented) format, which allows an optional meta-data specification,
e.g.

~~~~~~~~~~~
~~~~~~~ { .bash }
x=$1
echo $x
~~~~~~~
~~~~~~~~~~~

Although Pandoc supports the above format for marking code blocks (and
annotating the kind of code within the block) I'll also keep my
notation as another option for use with indented blocks, i.e. if you
write:

<pre><code>
    [haskell]
    foo :: String -> String
</code></pre>

it is a Haskell block.  You can also use other annotations, *e.g.*

<pre><code>
    [cpp]
    cout << "Hello World!";
</code></pre>

If highlighting-kate is specified for highlighting Haskell blocks, the
distinction between the literate blocks and the delimited blocks is
lost (this is simply how the Pandoc highlighting module currently
works).

I'll adopt the rule that if you specify a class or classes using
Pandoc's delimited code block syntax, I'll assume that there is no
additional tag within the block in Blog Literately syntax.  I still
need my `unTag` function to parse the code block.


To highlight the syntax using hscolour (which produces HTML), I'm
going to need to transform the `String` from a `CodeBlock` element to
a `String` suitable for the `RawHtml` element (because the hscolour
library transforms Haskell text to HTML). Pandoc strips off the
prepended &gt; characters from the literate Haskell, so I need to put
them back, and also tell hscolour whether the source it is colouring
is literate or not.  The hscolour function looks like:

    [haskell]
    hscolour :: Output      -- ^ Output format.
             -> ColourPrefs -- ^ Colour preferences...
             -> Bool        -- ^ Whether to include anchors.
             -> Bool        -- ^ Whether output document is partial or complete.
             -> String      -- ^ Title for output.
             -> Bool        -- ^ Whether input document is literate haskell
             -> String      -- ^ Haskell source code.
             -> String      -- ^ Coloured Haskell source code.

Since I still don't like the `ICSS` output from hscolour, I'm going to
provide two options for hscolouring to users: one that simply uses
hscolour's `CSS` format, so the user can provide definitions in their
blog's stylesheet to control the rendering, and a post-processing
option to transform the `CSS` class-based rendering into a inline
style based rendering (for people who can't update their stylesheet).
`colourIt` performs the initial transformation:

-}

-- | Use hscolour to syntax highlight some Haskell code.  The first
-- argument indicates whether the code is literate Haskell.
colourIt :: Bool -> Text -> String
colourIt :: Bool -> Text -> String
colourIt Bool
literate Text
srcTxt =
    ShowS
wrapCode forall a b. (a -> b) -> a -> b
$ Output -> ColourPrefs -> Bool -> Bool -> String -> Bool -> ShowS
hscolour Output
CSS ColourPrefs
defaultColourPrefs Bool
False Bool
True String
"" Bool
literate (Text -> String
T.unpack Text
srcTxt')
    where srcTxt' :: Text
srcTxt' | Bool
literate  = Text -> Text
litify Text
srcTxt
                  | Bool
otherwise = Text
srcTxt
          -- wrap the result in a <pre><code> tag, similar to
          -- highlighting-kate results
          wrapCode :: ShowS
wrapCode String
s = forall a. Verbatim a => a -> String
verbatim forall a b. (a -> b) -> a -> b
$
              (\(Document Prolog
_ SymTab EntityDef
_ Element Posn
e [Misc]
_) -> forall i. CFilter i -> CFilter i
foldXml forall {i}. CFilter i
filt (forall i. Element i -> i -> Content i
CElem Element Posn
e Posn
noPos))
                             (String -> String -> Document Posn
xmlParse String
"colourIt" String
s)

          attrs :: [(String, Content i -> [Content i])]
attrs = [(String
"class", ((String
"sourceCode haskell")forall i. String -> CFilter i
!))]

          filt :: CFilter i
filt = forall i.
String -> [(String, CFilter i)] -> [CFilter i] -> CFilter i
mkElemAttr String
"pre" forall {i}. [(String, Content i -> [Content i])]
attrs [forall i.
String -> [(String, CFilter i)] -> [CFilter i] -> CFilter i
mkElemAttr String
"code" forall {i}. [(String, Content i -> [Content i])]
attrs [forall {i}. CFilter i
children]]
                    forall i. CFilter i -> CFilter i -> CFilter i
`when` forall i. String -> CFilter i
tag String
"pre"

-- | Prepend literate Haskell markers to some source code.
litify :: Text -> Text
litify :: Text -> Text
litify = [Text] -> Text
T.unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (Text -> Text -> Text
T.append Text
"> ") forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.lines

{-
Hscolour uses HTML `span` elements and CSS classes like 'hs-keyword'
or `hs-keyglyph` to markup Haskell code.  What I want to do is take
each marked `span` element and replace the `class` attribute with an
inline `style` element that has the markup I want for that kind of
source.  Style preferences are specified as a list of name/value
pairs:
-}

-- | A default style that produces something that looks like the
--   source listings on Hackage.
defaultStylePrefs :: StylePrefs
defaultStylePrefs :: StylePrefs
defaultStylePrefs =
  [ (String
"hs-keyword",String
"color: blue; font-weight: bold;")
  , (String
"hs-keyglyph",String
"color: red;")
  , (String
"hs-layout",String
"color: red;")
  , (String
"hs-comment",String
"color: green;")
  , (String
"hs-conid", String
"")
  , (String
"hs-varid", String
"")
  , (String
"hs-conop", String
"")
  , (String
"hs-varop", String
"")
  , (String
"hs-str", String
"color: teal;")
  , (String
"hs-chr", String
"color: teal;")
  , (String
"hs-number", String
"")
  , (String
"hs-cpp", String
"")
  , (String
"hs-selection", String
"")
  , (String
"hs-variantselection", String
"")
  , (String
"hs-definition", String
"")
  ]

-- | Read style preferences in from a file using the @Read@ instance
--   for @StylePrefs@, or return the default style if the file name is
--   empty.
getStylePrefs :: Maybe FilePath -> IO StylePrefs
getStylePrefs :: Maybe String -> IO StylePrefs
getStylePrefs Maybe String
Nothing      = forall (m :: * -> *) a. Monad m => a -> m a
return StylePrefs
defaultStylePrefs
getStylePrefs (Just String
fname) = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a. Read a => String -> a
read (String -> IO String
readFile String
fname)

-- | Take a @String@ of HTML produced by hscolour, and \"bake\" styles
--   into it by replacing class attributes with appropriate style
--   attributes.
bakeStyles :: StylePrefs -> String -> String
bakeStyles :: StylePrefs -> ShowS
bakeStyles StylePrefs
prefs String
s = forall a. Verbatim a => a -> String
verbatim forall a b. (a -> b) -> a -> b
$ Document Posn -> Content Posn
filtDoc (String -> String -> Document Posn
xmlParse String
"bake-input" String
s)
  where

    -- filter the document (an Hscoloured fragment of Haskell source)
    filtDoc :: Document Posn -> Content Posn
filtDoc (Document Prolog
_ SymTab EntityDef
_ Element Posn
e [Misc]
_) =  Content Posn
c where
        [Content Posn
c] = forall {i}. CFilter i
filts (forall i. Element i -> i -> Content i
CElem Element Posn
e Posn
noPos)

    -- the filter is a fold of individual filters for each CSS class
    filts :: CFilter i
filts = forall i. CFilter i -> CFilter i
foldXml forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall i. CFilter i -> CFilter i -> CFilter i
o forall a. a -> [a]
keep forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {i}. (String, String) -> CFilter i
filt StylePrefs
prefs

    -- an individual filter replaces the attributes of a tag with
    -- a style attribute when it has a specific 'class' attribute.
    filt :: (String, String) -> CFilter i
filt (String
cls,String
style) =
        forall i. StylePrefs -> CFilter i
replaceAttrs [(String
"style",String
style)] forall i. CFilter i -> CFilter i -> CFilter i
`when`
            (forall i. Attribute -> CFilter i
attrval forall a b. (a -> b) -> a -> b
$ (String -> QName
N String
"class", [Either String Reference] -> AttValue
AttValue [forall a b. a -> Either a b
Left String
cls]))

{- Highlighting-Kate uses @\<br/>@ in code blocks to indicate
   newlines.  WordPress (and possibly others) chooses to strip them
   away when found in @\<pre>@ sections of uploaded HTML.  So we
   need to turn them back to newlines.
-}

-- | Replace @\<br/>@ tags with newlines.
replaceBreaks :: String -> String
replaceBreaks :: ShowS
replaceBreaks String
s = forall a. Verbatim a => a -> String
verbatim forall a b. (a -> b) -> a -> b
$ Document Posn -> Content Posn
filtDoc (String -> String -> Document Posn
xmlParse String
"input" String
s)
  where
    -- filter the document (a highlighting-kate highlighted fragment of
    -- haskell source)
    filtDoc :: Document Posn -> Content Posn
filtDoc (Document Prolog
_ SymTab EntityDef
_ Element Posn
e [Misc]
_) = Content Posn
c where
        [Content Posn
c] = forall {i}. CFilter i
filts (forall i. Element i -> i -> Content i
CElem Element Posn
e Posn
noPos)
    filts :: CFilter i
filts = forall i. CFilter i -> CFilter i
foldXml (forall i. String -> CFilter i
literal String
"\n" forall i. CFilter i -> CFilter i -> CFilter i
`when` forall i. String -> CFilter i
tag String
"br")

{-
Note/todo: the above is a function that could be made better in a
few ways and then factored out into a library.  A way to handle the
above would be to allow the preferences to be specified as an actual
CSS style sheet, which then would be baked into the HTML.  Such a
function could be separately useful, and could be used to 'bake' in
the highlighting-kate styles.
-}

-- | Transform a @CodeBlock@ into a @RawHtml@ block, where
--   the content contains marked up Haskell (possibly with literate
--   markers), or marked up non-Haskell, if highlighting of non-Haskell has
--   been selected.
colouriseCodeBlock :: HsHighlight -> Bool -> Block -> Block
colouriseCodeBlock :: HsHighlight -> Bool -> Block -> Block
colouriseCodeBlock HsHighlight
hsHighlight Bool
otherHighlight (CodeBlock attr :: Attr
attr@(Text
_,[Text]
classes,[(Text, Text)]
_) Text
s)

  | Maybe Text
ctag forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Text
"haskell" Bool -> Bool -> Bool
|| Bool
haskell
  = case HsHighlight
hsHighlight of
        HsColourInline StylePrefs
style ->
            String -> Block
rawHtmlT forall b c a. (b -> c) -> (a -> b) -> a -> c
. StylePrefs -> ShowS
bakeStyles StylePrefs
style forall a b. (a -> b) -> a -> b
$ Bool -> Text -> String
colourIt Bool
lit Text
src
        HsHighlight
HsColourCSS   -> String -> Block
rawHtmlT forall a b. (a -> b) -> a -> b
$ Bool -> Text -> String
colourIt Bool
lit Text
src
        HsHighlight
HsNoHighlight -> Text -> Block
rawHtml forall a b. (a -> b) -> a -> b
$ Text -> Text
simpleHTML Text
hsrc
        HsHighlight
HsKate        -> case Maybe Text
ctag of
            Maybe Text
Nothing -> Attr -> Text -> Block
myHighlightK Attr
attr Text
hsrc
            Just Text
t  -> Attr -> Text -> Block
myHighlightK (Text
"", Text
tforall a. a -> [a] -> [a]
:[Text]
classes,[]) Text
hsrc

  | Bool
otherHighlight
  = case Maybe Text
ctag of
        Maybe Text
Nothing -> Attr -> Text -> Block
myHighlightK Attr
attr Text
src
        Just Text
t  -> Attr -> Text -> Block
myHighlightK (Text
"",[Text
t],[]) Text
src

  | Bool
otherwise
  = Text -> Block
rawHtml forall a b. (a -> b) -> a -> b
$ Text -> Text
simpleHTML Text
src

  where
    (Maybe Text
ctag,Text
src)
        | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
classes = Text -> (Maybe Text, Text)
unTag Text
s
        | Bool
otherwise    = (forall a. Maybe a
Nothing, Text
s)
    hsrc :: Text
hsrc
        | Bool
lit          = Text -> Text
litify Text
src
        | Bool
otherwise    = Text
src
    lit :: Bool
lit          = Text
"sourceCode" forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
classes
    haskell :: Bool
haskell      = Text
"haskell" forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
classes
    simpleHTML :: Text -> Text
simpleHTML Text
h = Text -> Text -> Text
T.append Text
"<pre><code>" (Text -> Text -> Text
T.append Text
h Text
"</code></pre>")
    myHighlightK :: Attr -> Text -> Block
myHighlightK Attr
attrs Text
h = case forall a.
(FormatOptions -> [SourceLine] -> a) -> Attr -> Text -> Maybe a
highlight FormatOptions -> [SourceLine] -> Html
formatHtmlBlock Attr
attrs Text
h of
        Maybe Html
Nothing   -> Text -> Block
rawHtml  forall a b. (a -> b) -> a -> b
$ Text -> Text
simpleHTML Text
s
        Just Html
html -> String -> Block
rawHtmlT forall a b. (a -> b) -> a -> b
$ ShowS
replaceBreaks forall a b. (a -> b) -> a -> b
$ Html -> String
renderHtml Html
html
    rawHtmlT :: String -> Block
rawHtmlT = Text -> Block
rawHtml forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack
    rawHtml :: Text -> Block
rawHtml  = Format -> Text -> Block
RawBlock (Text -> Format
Format Text
"html")

colouriseCodeBlock HsHighlight
_ Bool
_ Block
b = Block
b

-- | Perform syntax highlighting on an entire Pandoc document.
colourisePandoc :: HsHighlight -> Bool -> Pandoc -> Pandoc
colourisePandoc :: HsHighlight -> Bool -> Pandoc -> Pandoc
colourisePandoc HsHighlight
hsHighlight Bool
otherHighlight (Pandoc Meta
m [Block]
blocks) =
    Meta -> [Block] -> Pandoc
Pandoc Meta
m forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (HsHighlight -> Bool -> Block -> Block
colouriseCodeBlock HsHighlight
hsHighlight Bool
otherHighlight) [Block]
blocks

--------------------------------------------------
-- highlight function
--------------------------------------------------

-- Copied here from
--
--   https://github.com/jgm/pandoc/blob/8b3a81e4dd8bf46a822980781e28d9777a076c6a/src/Text/Pandoc/Highlighting.hs#L63
--
-- Pandoc 1.11 hid the Text.Pandoc.Highlighting module so we can't
-- import it from there anymore (at least not for the moment).

lcLanguages :: [String]
lcLanguages :: [String]
lcLanguages = forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower) [String]
languages

highlight :: (FormatOptions -> [SourceLine] -> a) -- ^ Formatter
          -> Attr    -- ^ Attributes of the CodeBlock
          -> Text    -- ^ Raw contents of the CodeBlock
          -> Maybe a -- ^ Maybe the formatted result
highlight :: forall a.
(FormatOptions -> [SourceLine] -> a) -> Attr -> Text -> Maybe a
highlight FormatOptions -> [SourceLine] -> a
formatter (Text
_, [Text]
classes, [(Text, Text)]
keyvals) Text
rawCode =
  let firstNum :: Int
firstNum = case forall (m :: * -> *) a. (MonadPlus m, Read a) => Text -> m a
safeRead (forall a. a -> Maybe a -> a
fromMaybe Text
"1" forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"startFrom" [(Text, Text)]
keyvals) of
                      Just Int
n  -> Int
n
                      Maybe Int
Nothing -> Int
1
      fmtOpts :: FormatOptions
fmtOpts = FormatOptions
defaultFormatOpts{
                  startNumber :: Int
startNumber = Int
firstNum,
                  numberLines :: Bool
numberLines = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`
                        [Text
"number",Text
"numberLines", Text
"number-lines"]) [Text]
classes }
      lcclasses :: [String]
lcclasses = forall a b. (a -> b) -> [a] -> [b]
map (Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.toLower) [Text]
classes
  in case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
lcLanguages) [String]
lcclasses of
            Maybe String
Nothing -> forall a. Maybe a
Nothing
            Just String
language -> forall a. a -> Maybe a
Just
                              forall a b. (a -> b) -> a -> b
$ FormatOptions -> [SourceLine] -> a
formatter FormatOptions
fmtOpts{ codeClasses :: [String]
codeClasses = [String
language],
                                                   containerClasses :: [String]
containerClasses = forall a b. (a -> b) -> [a] -> [b]
map Text -> String
T.unpack [Text]
classes }
                              forall a b. (a -> b) -> a -> b
$ String -> String -> [SourceLine]
highlightAs String
language (Text -> String
T.unpack Text
rawCode)