{-# 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
DataType
Constr
Typeable HsHighlight
-> (forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> HsHighlight -> c HsHighlight)
-> (forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c HsHighlight)
-> (HsHighlight -> Constr)
-> (HsHighlight -> DataType)
-> (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))
-> ((forall b. Data b => b -> b) -> HsHighlight -> HsHighlight)
-> (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 u. (forall d. Data d => d -> u) -> HsHighlight -> [u])
-> (forall u.
Int -> (forall d. Data d => d -> u) -> HsHighlight -> u)
-> (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 (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> HsHighlight -> m HsHighlight)
-> Data HsHighlight
HsHighlight -> DataType
HsHighlight -> Constr
(forall b. Data b => b -> b) -> HsHighlight -> HsHighlight
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> HsHighlight -> c HsHighlight
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c 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)
$cHsNoHighlight :: Constr
$cHsKate :: Constr
$cHsColourCSS :: Constr
$cHsColourInline :: Constr
$tHsHighlight :: DataType
gmapMo :: (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 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 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 :: Int -> (forall d. Data d => d -> u) -> HsHighlight -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> HsHighlight -> u
gmapQ :: (forall d. Data d => d -> u) -> HsHighlight -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> HsHighlight -> [u]
gmapQr :: (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 :: (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 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 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 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 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
$cp1Data :: Typeable HsHighlight
Data,Typeable,Int -> HsHighlight -> ShowS
[HsHighlight] -> ShowS
HsHighlight -> String
(Int -> HsHighlight -> ShowS)
-> (HsHighlight -> String)
-> ([HsHighlight] -> ShowS)
-> Show HsHighlight
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
(HsHighlight -> HsHighlight -> Bool)
-> (HsHighlight -> HsHighlight -> Bool) -> Eq HsHighlight
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 ShowS -> ShowS
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 = [Content Posn] -> String
forall a. Verbatim a => a -> String
verbatim ([Content Posn] -> String) -> [Content Posn] -> String
forall a b. (a -> b) -> a -> b
$
(\(Document Prolog
_ SymTab EntityDef
_ Element Posn
e [Misc]
_) -> CFilter Posn -> CFilter Posn
forall i. CFilter i -> CFilter i
foldXml CFilter Posn
forall i. CFilter i
filt (Element Posn -> Posn -> Content Posn
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")String -> Content i -> [Content i]
forall i. String -> CFilter i
!))]
filt :: CFilter i
filt = String -> [(String, CFilter i)] -> [CFilter i] -> CFilter i
forall i.
String -> [(String, CFilter i)] -> [CFilter i] -> CFilter i
mkElemAttr String
"pre" [(String, CFilter i)]
forall i. [(String, Content i -> [Content i])]
attrs [String -> [(String, CFilter i)] -> [CFilter i] -> CFilter i
forall i.
String -> [(String, CFilter i)] -> [CFilter i] -> CFilter i
mkElemAttr String
"code" [(String, CFilter i)]
forall i. [(String, Content i -> [Content i])]
attrs [CFilter i
forall i. CFilter i
children]]
CFilter i -> CFilter i -> CFilter i
forall i. CFilter i -> CFilter i -> CFilter i
`when` String -> CFilter i
forall i. String -> CFilter i
tag String
"pre"
litify :: Text -> Text
litify :: Text -> Text
litify = [Text] -> Text
T.unlines ([Text] -> Text) -> (Text -> [Text]) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Text -> Text
T.append Text
"> ") ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [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 = StylePrefs -> IO StylePrefs
forall (m :: * -> *) a. Monad m => a -> m a
return StylePrefs
defaultStylePrefs
getStylePrefs (Just String
fname) = (String -> StylePrefs) -> IO String -> IO StylePrefs
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM String -> StylePrefs
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 = Content Posn -> String
forall a. Verbatim a => a -> String
verbatim (Content Posn -> String) -> Content Posn -> String
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] = CFilter Posn
forall i. CFilter i
filts (Element Posn -> Posn -> Content Posn
forall i. Element i -> i -> Content i
CElem Element Posn
e Posn
noPos)
filts :: CFilter i
filts = CFilter i -> CFilter i
forall i. CFilter i -> CFilter i
foldXml (CFilter i -> CFilter i) -> CFilter i -> CFilter i
forall a b. (a -> b) -> a -> b
$ (CFilter i -> CFilter i -> CFilter i)
-> CFilter i -> [CFilter i] -> CFilter i
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl CFilter i -> CFilter i -> CFilter i
forall i. CFilter i -> CFilter i -> CFilter i
o CFilter i
forall a. a -> [a]
keep ([CFilter i] -> CFilter i) -> [CFilter i] -> CFilter i
forall a b. (a -> b) -> a -> b
$ ((String, String) -> CFilter i) -> StylePrefs -> [CFilter i]
forall a b. (a -> b) -> [a] -> [b]
map (String, String) -> CFilter i
forall i. (String, String) -> CFilter i
filt StylePrefs
prefs
filt :: (String, String) -> CFilter i
filt (String
cls,String
style) =
StylePrefs -> CFilter i
forall i. StylePrefs -> CFilter i
replaceAttrs [(String
"style",String
style)] CFilter i -> CFilter i -> CFilter i
forall i. CFilter i -> CFilter i -> CFilter i
`when`
(Attribute -> CFilter i
forall i. Attribute -> CFilter i
attrval (Attribute -> CFilter i) -> Attribute -> CFilter i
forall a b. (a -> b) -> a -> b
$ (String -> QName
N String
"class", [Either String Reference] -> AttValue
AttValue [String -> Either String Reference
forall a b. a -> Either a b
Left String
cls]))
replaceBreaks :: String -> String
replaceBreaks :: ShowS
replaceBreaks String
s = Content Posn -> String
forall a. Verbatim a => a -> String
verbatim (Content Posn -> String) -> Content Posn -> String
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] = CFilter Posn
forall i. CFilter i
filts (Element Posn -> Posn -> Content Posn
forall i. Element i -> i -> Content i
CElem Element Posn
e Posn
noPos)
filts :: CFilter i
filts = CFilter i -> CFilter i
forall i. CFilter i -> CFilter i
foldXml (String -> CFilter i
forall i. String -> CFilter i
literal String
"\n" CFilter i -> CFilter i -> CFilter i
forall i. CFilter i -> CFilter i -> CFilter i
`when` String -> CFilter i
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 Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"haskell" Bool -> Bool -> Bool
|| Bool
haskell
= case HsHighlight
hsHighlight of
HsColourInline StylePrefs
style ->
String -> Block
rawHtmlT (String -> Block) -> ShowS -> String -> Block
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StylePrefs -> ShowS
bakeStyles StylePrefs
style (String -> Block) -> String -> Block
forall a b. (a -> b) -> a -> b
$ Bool -> Text -> String
colourIt Bool
lit Text
src
HsHighlight
HsColourCSS -> String -> Block
rawHtmlT (String -> Block) -> String -> Block
forall a b. (a -> b) -> a -> b
$ Bool -> Text -> String
colourIt Bool
lit Text
src
HsHighlight
HsNoHighlight -> Text -> Block
rawHtml (Text -> Block) -> Text -> Block
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
tText -> [Text] -> [Text]
forall 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 (Text -> Block) -> Text -> Block
forall a b. (a -> b) -> a -> b
$ Text -> Text
simpleHTML Text
src
where
(Maybe Text
ctag,Text
src)
| [Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
classes = Text -> (Maybe Text, Text)
unTag Text
s
| Bool
otherwise = (Maybe Text
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" Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
classes
haskell :: Bool
haskell = Text
"haskell" Text -> [Text] -> Bool
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 (FormatOptions -> [SourceLine] -> Html)
-> Attr -> Text -> Maybe Html
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 (Text -> Block) -> Text -> Block
forall a b. (a -> b) -> a -> b
$ Text -> Text
simpleHTML Text
s
Just Html
html -> String -> Block
rawHtmlT (String -> Block) -> String -> Block
forall a b. (a -> b) -> a -> b
$ ShowS
replaceBreaks ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Html -> String
renderHtml Html
html
rawHtmlT :: String -> Block
rawHtmlT = Text -> Block
rawHtml (Text -> Block) -> (String -> Text) -> String -> Block
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 ([Block] -> Pandoc) -> [Block] -> Pandoc
forall a b. (a -> b) -> a -> b
$ (Block -> Block) -> [Block] -> [Block]
forall a b. (a -> b) -> [a] -> [b]
map (HsHighlight -> Bool -> Block -> Block
colouriseCodeBlock HsHighlight
hsHighlight Bool
otherHighlight) [Block]
blocks
lcLanguages :: [String]
lcLanguages :: [String]
lcLanguages = ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower) [String]
languages
highlight :: (FormatOptions -> [SourceLine] -> a)
-> Attr
-> Text
-> Maybe a
highlight :: (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 Text -> Maybe Int
forall (m :: * -> *) a. (MonadPlus m, Read a) => Text -> m a
safeRead (Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"1" (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> [(Text, Text)] -> Maybe Text
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 = (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`
[Text
"number",Text
"numberLines", Text
"number-lines"]) [Text]
classes }
lcclasses :: [String]
lcclasses = (Text -> String) -> [Text] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> String
T.unpack (Text -> String) -> (Text -> Text) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.toLower) [Text]
classes
in case (String -> Bool) -> [String] -> Maybe String
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
lcLanguages) [String]
lcclasses of
Maybe String
Nothing -> Maybe a
forall a. Maybe a
Nothing
Just String
language -> a -> Maybe a
forall a. a -> Maybe a
Just
(a -> Maybe a) -> a -> Maybe a
forall a b. (a -> b) -> a -> b
$ FormatOptions -> [SourceLine] -> a
formatter FormatOptions
fmtOpts{ codeClasses :: [String]
codeClasses = [String
language],
containerClasses :: [String]
containerClasses = (Text -> String) -> [Text] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Text -> String
T.unpack [Text]
classes }
([SourceLine] -> a) -> [SourceLine] -> a
forall a b. (a -> b) -> a -> b
$ String -> String -> [SourceLine]
highlightAs String
language (Text -> String
T.unpack Text
rawCode)