{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Text.BlogLiterately.Highlight
( HsHighlight(..)
, _HsColourInline
, colourIt
, litify
, StylePrefs
, defaultStylePrefs
, getStylePrefs
, bakeStyles
, replaceBreaks
, colouriseCodeBlock
, colourisePandoc
) where
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)
type StylePrefs = [(String,String)]
data HsHighlight =
HsColourInline StylePrefs
| HsColourCSS
| HsKate
| HsNoHighlight
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
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
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"
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
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
"")
]
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)
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
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 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
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]))
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
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")
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
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
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)
-> Attr
-> Text
-> Maybe a
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)