{-# 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' forall a. Maybe a Nothing String outerDiv where outerDiv :: String outerDiv = Text -> String T.unpack (Text "<div class=\"" forall a. Semigroup a => a -> a -> a <> Text -> [Text] -> Text T.intercalate Text " " [Text] classNames forall a. Semigroup a => a -> a -> a <> Text "\">" forall a. Semigroup a => a -> a -> a <> Text spans forall a. Semigroup a => a -> a -> a <> Text "</div>") classNames :: [Text] classNames = Text "code" forall a. a -> [a] -> [a] : forall a. [Maybe a] -> [a] catMaybes [Maybe Text wrapClass] spans :: Text spans :: Text spans = Text -> [Text] -> Text T.intercalate Text "\n" (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 = forall a. Monoid a => [a] -> a mconcat [Text "<span class=\"" forall a. Semigroup a => a -> a -> a <> Text classPrefix forall a. Semigroup a => a -> a -> a <> Token -> Text tokenToClassName Token token forall a. Semigroup a => a -> a -> a <> Text "\">" forall a. Semigroup a => a -> a -> a <> Text -> Text escapeHtml Text text forall a. Semigroup a => a -> a -> a <> Text "</span>" | (Token token, Text text) <- [(Token, Text)] xs] tokensAndTexts :: [(Token, Text)] tokensAndTexts = 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 forall a b. a -> (a -> b) -> b & 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 forall a. Semigroup a => a -> a -> a <> [(Token, Text) spaceBoundary]) forall a. a -> [a] -> [a] : [(Token, Text)] -> [[(Token, Text)]] getLines (forall a. [a] -> [a] L.tail [(Token, Text)] rest) where ([(Token, Text)] curLine, [(Token, Text)] rest) = forall a. (a -> Bool) -> [a] -> ([a], [a]) L.span (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"