{-# LANGUAGE OverloadedStrings #-}

module IHaskell.Eval.Evaluate.HTML (htmlify) where

import           Data.Function ((&))
import qualified Data.List as L
import           Data.Maybe
import           Data.Text as T hiding (concat)
import           GHC.SyntaxHighlighter (tokenizeHaskell)
import qualified GHC.SyntaxHighlighter as SH
import           IHaskell.Display (html')
import           IHaskell.IPython.Types (DisplayData)


htmlify :: Maybe Text -> Text -> String -> DisplayData
htmlify :: Maybe Text -> Text -> String -> DisplayData
htmlify Maybe Text
wrapClass Text
classPrefix String
str1 = Maybe Text -> String -> DisplayData
html' Maybe Text
forall a. Maybe a
Nothing String
outerDiv
  where
    outerDiv :: String
outerDiv = Text -> String
T.unpack (Text
"<div class=\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
" " [Text]
classNames Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\">" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
spans Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"</div>")

    classNames :: [Text]
classNames = Text
"code" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Maybe Text] -> [Text]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Text
wrapClass]

    spans :: Text
    spans :: Text
spans = Text -> [Text] -> Text
T.intercalate Text
"\n" (([(Token, Text)] -> Text) -> [[(Token, Text)]] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(Token, Text)] -> Text
renderLine ([(Token, Text)] -> [[(Token, Text)]]
getLines [(Token, Text)]
tokensAndTexts))

    renderLine :: [(Token, Text)] -> Text
renderLine [(Token, Text)]
xs = [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat [Text
"<span class=\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
classPrefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Token -> Text
tokenToClassName Token
token Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\">" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
escapeHtml Text
text Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"</span>"
                            | (Token
token, Text
text) <- [(Token, Text)]
xs]

    tokensAndTexts :: [(Token, Text)]
tokensAndTexts = [(Token, Text)] -> Maybe [(Token, Text)] -> [(Token, Text)]
forall a. a -> Maybe a -> a
fromMaybe [] (Text -> Maybe [(Token, Text)]
tokenizeHaskell (String -> Text
T.pack String
str1))

    escapeHtml :: Text -> Text
escapeHtml Text
text = Text
text
                    Text -> (Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
& HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"\n" Text
"<br />"

    getLines :: [(SH.Token, Text)] -> [[(SH.Token, Text)]]
    getLines :: [(Token, Text)] -> [[(Token, Text)]]
getLines [] = []
    getLines [(Token, Text)]
xs = ([(Token, Text)]
curLine [(Token, Text)] -> [(Token, Text)] -> [(Token, Text)]
forall a. Semigroup a => a -> a -> a
<> [(Token, Text)
spaceBoundary]) [(Token, Text)] -> [[(Token, Text)]] -> [[(Token, Text)]]
forall a. a -> [a] -> [a]
: [(Token, Text)] -> [[(Token, Text)]]
getLines ([(Token, Text)] -> [(Token, Text)]
forall a. HasCallStack => [a] -> [a]
L.tail [(Token, Text)]
rest)
      where ([(Token, Text)]
curLine, [(Token, Text)]
rest) = ((Token, Text) -> Bool)
-> [(Token, Text)] -> ([(Token, Text)], [(Token, Text)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.span ((Token, Text) -> (Token, Text) -> Bool
forall a. Eq a => a -> a -> Bool
/= (Token, Text)
spaceBoundary) [(Token, Text)]
xs

    spaceBoundary :: (Token, Text)
spaceBoundary = (Token
SH.SpaceTok, Text
"\n")

tokenToClassName :: SH.Token -> Text
tokenToClassName :: Token -> Text
tokenToClassName Token
SH.KeywordTok     = Text
"keyword"
tokenToClassName Token
SH.PragmaTok      = Text
"meta"
tokenToClassName Token
SH.SymbolTok      = Text
"atom"
tokenToClassName Token
SH.VariableTok    = Text
"variable"
tokenToClassName Token
SH.ConstructorTok = Text
"variable-2"
tokenToClassName Token
SH.OperatorTok    = Text
"operator"
tokenToClassName Token
SH.CharTok        = Text
"char"
tokenToClassName Token
SH.StringTok      = Text
"string"
tokenToClassName Token
SH.IntegerTok     = Text
"number"
tokenToClassName Token
SH.RationalTok    = Text
"number"
tokenToClassName Token
SH.CommentTok     = Text
"comment"
tokenToClassName Token
SH.SpaceTok       = Text
"space"
tokenToClassName Token
SH.OtherTok       = Text
"builtin"