{-# LANGUAGE CPP               #-}
{-# LANGUAGE OverloadedStrings #-}

module Skylighting.Format.HTML.Lucid
  ( formatHtmlInline
  , formatHtmlBlock
  ) where

import           Data.Foldable (traverse_)
import qualified Data.List as L
import qualified Data.Text as T
import           Lucid
import           Skylighting.Types

#if !MIN_VERSION_base(4,11,0)
import           Data.Semigroup
#endif

-- | Format tokens using HTML spans inside @code@ tags. For example,
-- A @KeywordTok@ is rendered as a span with class @kw@.
-- Short class names correspond to 'TokenType's as follows:
-- 'KeywordTok'        = @kw@,
-- 'DataTypeTok'       = @dt@,
-- 'DecValTok'         = @dv@,
-- 'BaseNTok'          = @bn@,
-- 'FloatTok'          = @fl@,
-- 'CharTok'           = @ch@,
-- 'StringTok'         = @st@,
-- 'CommentTok'        = @co@,
-- 'OtherTok'          = @ot@,
-- 'AlertTok'          = @al@,
-- 'FunctionTok'       = @fu@,
-- 'RegionMarkerTok'   = @re@,
-- 'ErrorTok'          = @er@,
-- 'ConstantTok'       = @cn@,
-- 'SpecialCharTok'    = @sc@,
-- 'VerbatimStringTok' = @vs@,
-- 'SpecialStringTok'  = @ss@,
-- 'ImportTok'         = @im@,
-- 'DocumentationTok'  = @do@,
-- 'AnnotationTok'     = @an@,
-- 'CommentVarTok'     = @cv@,
-- 'VariableTok'       = @va@,
-- 'ControlFlowTok'    = @cf@,
-- 'OperatorTok'       = @op@,
-- 'BuiltInTok'        = @bu@,
-- 'ExtensionTok'      = @ex@,
-- 'PreprocessorTok'   = @pp@,
-- 'AttributeTok'      = @at@,
-- 'InformationTok'    = @in@,
-- 'WarningTok'        = @wa@.
-- A 'NormalTok' is not marked up at all.
formatHtmlInline :: FormatOptions -> [SourceLine] -> Html ()
formatHtmlInline :: FormatOptions -> [SourceLine] -> HtmlT Identity ()
formatHtmlInline FormatOptions
opts =
  -- wrapCode opts . mconcat . L.intersperse (toHtml "\n") . map (traverse_ (tokenToHtml opts))
  FormatOptions -> HtmlT Identity () -> HtmlT Identity ()
wrapCode FormatOptions
opts (HtmlT Identity () -> HtmlT Identity ())
-> ([SourceLine] -> HtmlT Identity ())
-> [SourceLine]
-> HtmlT Identity ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [HtmlT Identity ()] -> HtmlT Identity ()
forall a. Monoid a => [a] -> a
mconcat ([HtmlT Identity ()] -> HtmlT Identity ())
-> ([SourceLine] -> [HtmlT Identity ()])
-> [SourceLine]
-> HtmlT Identity ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SourceLine -> HtmlT Identity ())
-> [SourceLine] -> [HtmlT Identity ()]
forall a b. (a -> b) -> [a] -> [b]
map ((Token -> HtmlT Identity ()) -> SourceLine -> HtmlT Identity ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (FormatOptions -> Token -> HtmlT Identity ()
tokenToHtml FormatOptions
opts))

-- | Format tokens as an HTML @pre@ block. Each line is wrapped in an a element
-- with the class ‘source-line’. If line numbering is selected, the surrounding
-- pre is given the class ‘numberSource’, and the resulting html will display
-- line numbers thanks to the included CSS. See the documentation for
-- 'formatHtmlInline' for information about how tokens are encoded.
formatHtmlBlock :: FormatOptions -> [SourceLine] -> Html ()
formatHtmlBlock :: FormatOptions -> [SourceLine] -> HtmlT Identity ()
formatHtmlBlock FormatOptions
opts [SourceLine]
ls =
  [Attribute] -> HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
div_ [Text -> Attribute
class_ Text
"sourceCode"]
  (HtmlT Identity () -> HtmlT Identity ())
-> HtmlT Identity () -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ [Attribute] -> HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
pre_ [[Text] -> Attribute
classes_ [Text]
classes]
    (HtmlT Identity () -> HtmlT Identity ())
-> HtmlT Identity () -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ FormatOptions -> HtmlT Identity () -> HtmlT Identity ()
wrapCode FormatOptions
opts
    (HtmlT Identity () -> HtmlT Identity ())
-> HtmlT Identity () -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ [HtmlT Identity ()] -> HtmlT Identity ()
forall a. Monoid a => [a] -> a
mconcat
    ([HtmlT Identity ()] -> HtmlT Identity ())
-> [HtmlT Identity ()] -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ HtmlT Identity () -> [HtmlT Identity ()] -> [HtmlT Identity ()]
forall a. a -> [a] -> [a]
L.intersperse HtmlT Identity ()
"\n"
    ([HtmlT Identity ()] -> [HtmlT Identity ()])
-> [HtmlT Identity ()] -> [HtmlT Identity ()]
forall a b. (a -> b) -> a -> b
$ (LineNo -> SourceLine -> HtmlT Identity ())
-> [LineNo] -> [SourceLine] -> [HtmlT Identity ()]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (FormatOptions -> LineNo -> SourceLine -> HtmlT Identity ()
sourceLineToHtml FormatOptions
opts) [LineNo
startNum..] [SourceLine]
ls
  where
    classes :: [T.Text]
    classes :: [Text]
classes = Text
"sourceCode"
      Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:  [Text
"numberSource" | FormatOptions -> Bool
numberLines FormatOptions
opts]
      [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text
x | Text
x <- FormatOptions -> [Text]
containerClasses FormatOptions
opts, Text
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"sourceCode"]

    startNum :: LineNo
    startNum :: LineNo
startNum = Int -> LineNo
LineNo (Int -> LineNo) -> Int -> LineNo
forall a b. (a -> b) -> a -> b
$ FormatOptions -> Int
startNumber FormatOptions
opts

wrapCode :: FormatOptions -> Html () -> Html ()
wrapCode :: FormatOptions -> HtmlT Identity () -> HtmlT Identity ()
wrapCode FormatOptions
opts HtmlT Identity ()
h =
  [Attribute] -> HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
code_ [[Text] -> Attribute
classes_ ([Text] -> Attribute) -> [Text] -> Attribute
forall a b. (a -> b) -> a -> b
$ Text
"sourceCode" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: FormatOptions -> [Text]
codeClasses FormatOptions
opts] HtmlT Identity ()
h
                         -- !? (startZero /= 0, A.style (toValue counterOverride))
                         -- $ h
  -- where
  --   counterOverride :: String
  --   counterOverride = "counter-reset: source-line " <> show startZero <> ";"

  --   startZero :: Int
    -- startZero = startNumber opts - 1

-- | Each line of source is wrapped in an (inline-block) anchor that makes
-- subsequent per-line processing (e.g. adding line numnbers) possible.
sourceLineToHtml :: FormatOptions -> LineNo -> SourceLine -> Html ()
sourceLineToHtml :: FormatOptions -> LineNo -> SourceLine -> HtmlT Identity ()
sourceLineToHtml FormatOptions
opts LineNo
lno SourceLine
cont = [Attribute] -> HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
span_ [Text -> Attribute
id_ Text
prefixedLineNo] (HtmlT Identity () -> HtmlT Identity ())
-> HtmlT Identity () -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ do
  [Attribute] -> HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
a_ [Text -> Attribute
href_ Text
lineRef] HtmlT Identity ()
""
  (Token -> HtmlT Identity ()) -> SourceLine -> HtmlT Identity ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (FormatOptions -> Token -> HtmlT Identity ()
tokenToHtml FormatOptions
opts) SourceLine
cont
  where
    lineRef :: T.Text
    lineRef :: Text
lineRef = Char -> Text -> Text
T.cons Char
'#' Text
prefixedLineNo

    prefixedLineNo :: T.Text
    prefixedLineNo :: Text
prefixedLineNo = FormatOptions -> Text
lineIdPrefix FormatOptions
opts Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ LineNo -> Int
lineNo LineNo
lno)

tokenToHtml :: FormatOptions -> Token -> Html ()
tokenToHtml :: FormatOptions -> Token -> HtmlT Identity ()
tokenToHtml FormatOptions
_ (TokenType
NormalTok, Text
txt) = Text -> HtmlT Identity ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
forall (m :: * -> *). Monad m => Text -> HtmlT m ()
toHtml Text
txt
tokenToHtml FormatOptions
opts (TokenType
toktype, Text
txt)
  | FormatOptions -> Bool
titleAttributes FormatOptions
opts = HtmlT Identity ()
sp -- ! A.title (toValue $ show toktype)
  | Bool
otherwise = HtmlT Identity ()
sp
  where
    sp :: Html ()
    sp :: HtmlT Identity ()
sp = [Attribute] -> HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
span_ [Text -> Attribute
class_ (Text -> Attribute) -> Text -> Attribute
forall a b. (a -> b) -> a -> b
$ TokenType -> Text
short TokenType
toktype] (HtmlT Identity () -> HtmlT Identity ())
-> HtmlT Identity () -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ Text -> HtmlT Identity ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
forall (m :: * -> *). Monad m => Text -> HtmlT m ()
toHtml Text
txt

short :: TokenType -> T.Text
short :: TokenType -> Text
short TokenType
KeywordTok        = Text
"kw"
short TokenType
DataTypeTok       = Text
"dt"
short TokenType
DecValTok         = Text
"dv"
short TokenType
BaseNTok          = Text
"bn"
short TokenType
FloatTok          = Text
"fl"
short TokenType
CharTok           = Text
"ch"
short TokenType
StringTok         = Text
"st"
short TokenType
CommentTok        = Text
"co"
short TokenType
OtherTok          = Text
"ot"
short TokenType
AlertTok          = Text
"al"
short TokenType
FunctionTok       = Text
"fu"
short TokenType
RegionMarkerTok   = Text
"re"
short TokenType
ErrorTok          = Text
"er"
short TokenType
ConstantTok       = Text
"cn"
short TokenType
SpecialCharTok    = Text
"sc"
short TokenType
VerbatimStringTok = Text
"vs"
short TokenType
SpecialStringTok  = Text
"ss"
short TokenType
ImportTok         = Text
"im"
short TokenType
DocumentationTok  = Text
"do"
short TokenType
AnnotationTok     = Text
"an"
short TokenType
CommentVarTok     = Text
"cv"
short TokenType
VariableTok       = Text
"va"
short TokenType
ControlFlowTok    = Text
"cf"
short TokenType
OperatorTok       = Text
"op"
short TokenType
BuiltInTok        = Text
"bu"
short TokenType
ExtensionTok      = Text
"ex"
short TokenType
PreprocessorTok   = Text
"pp"
short TokenType
AttributeTok      = Text
"at"
short TokenType
InformationTok    = Text
"in"
short TokenType
WarningTok        = Text
"wa"
short TokenType
NormalTok         = Text
""