--------------------------------------------------------------------------------
-- | Displaying code blocks, optionally with syntax highlighting.
{-# LANGUAGE BangPatterns      #-}
{-# LANGUAGE OverloadedStrings #-}
module Patat.Presentation.Display.CodeBlock
    ( prettyCodeBlock
    ) where


--------------------------------------------------------------------------------
import           Data.Char.WCWidth.Extended          (wcstrwidth, wcwidth)
import           Data.Maybe                          (mapMaybe)
import qualified Data.Text                           as T
import           Patat.Presentation.Display.Internal
import qualified Patat.PrettyPrint                   as PP
import           Patat.Theme
import           Prelude
import qualified Skylighting                         as Skylighting


--------------------------------------------------------------------------------
highlight
    :: Skylighting.SyntaxMap -> [T.Text] -> T.Text -> [Skylighting.SourceLine]
highlight :: SyntaxMap -> [Text] -> Text -> [SourceLine]
highlight SyntaxMap
extraSyntaxMap [Text]
classes Text
rawCodeBlock =
    case (Text -> Maybe Syntax) -> [Text] -> [Syntax]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Text -> Maybe Syntax
getSyntax [Text]
classes of
        []        -> Text -> [SourceLine]
zeroHighlight Text
rawCodeBlock
        (Syntax
syn : [Syntax]
_) ->
            case TokenizerConfig -> Syntax -> Text -> Either String [SourceLine]
Skylighting.tokenize TokenizerConfig
config Syntax
syn Text
rawCodeBlock of
                Left  String
_  -> Text -> [SourceLine]
zeroHighlight Text
rawCodeBlock
                Right [SourceLine]
sl -> [SourceLine]
sl
  where
    getSyntax :: T.Text -> Maybe Skylighting.Syntax
    getSyntax :: Text -> Maybe Syntax
getSyntax Text
c = Text -> SyntaxMap -> Maybe Syntax
Skylighting.lookupSyntax Text
c SyntaxMap
syntaxMap

    config :: Skylighting.TokenizerConfig
    config :: TokenizerConfig
config = Skylighting.TokenizerConfig
        { syntaxMap :: SyntaxMap
Skylighting.syntaxMap  = SyntaxMap
syntaxMap
        , traceOutput :: Bool
Skylighting.traceOutput = Bool
False
        }

    syntaxMap :: Skylighting.SyntaxMap
    syntaxMap :: SyntaxMap
syntaxMap = SyntaxMap
extraSyntaxMap SyntaxMap -> SyntaxMap -> SyntaxMap
forall a. Semigroup a => a -> a -> a
<> SyntaxMap
Skylighting.defaultSyntaxMap


--------------------------------------------------------------------------------
-- | This does fake highlighting, everything becomes a normal token.  That makes
-- things a bit easier, since we only need to deal with one cases in the
-- renderer.
zeroHighlight :: T.Text -> [Skylighting.SourceLine]
zeroHighlight :: Text -> [SourceLine]
zeroHighlight Text
txt =
    [[(TokenType
Skylighting.NormalTok, Text
line)] | Text
line <- Text -> [Text]
T.lines Text
txt]


--------------------------------------------------------------------------------
-- | Expands tabs in code lines.
expandTabs :: Int -> Skylighting.SourceLine -> Skylighting.SourceLine
expandTabs :: Int -> SourceLine -> SourceLine
expandTabs Int
tabStop = Int -> SourceLine -> SourceLine
forall {a}. Int -> [(a, Text)] -> [(a, Text)]
goTokens Int
0
  where
    goTokens :: Int -> [(a, Text)] -> [(a, Text)]
goTokens Int
_    []                        = []
    goTokens Int
col0 ((a
tokType, Text
txt) : [(a, Text)]
tokens) = Int
-> String
-> String
-> (Int -> String -> [(a, Text)])
-> [(a, Text)]
forall k. Int -> String -> String -> (Int -> String -> k) -> k
goString Int
col0 String
"" (Text -> String
T.unpack Text
txt) ((Int -> String -> [(a, Text)]) -> [(a, Text)])
-> (Int -> String -> [(a, Text)]) -> [(a, Text)]
forall a b. (a -> b) -> a -> b
$
        \Int
col1 String
str -> (a
tokType, String -> Text
T.pack String
str) (a, Text) -> [(a, Text)] -> [(a, Text)]
forall a. a -> [a] -> [a]
: Int -> [(a, Text)] -> [(a, Text)]
goTokens Int
col1 [(a, Text)]
tokens

    goString :: Int -> String -> String -> (Int -> String -> k) -> k
    goString :: forall k. Int -> String -> String -> (Int -> String -> k) -> k
goString !Int
col String
acc String
str Int -> String -> k
k = case String
str of
        []       -> Int -> String -> k
k Int
col (String -> String
forall a. [a] -> [a]
reverse String
acc)
        Char
'\t' : String
t -> Int -> String -> String -> (Int -> String -> k) -> k
forall k. Int -> String -> String -> (Int -> String -> k) -> k
goString (Int
col Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
spaces) (Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
spaces Char
' ' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
acc) String
t Int -> String -> k
k
        Char
c    : String
t -> Int -> String -> String -> (Int -> String -> k) -> k
forall k. Int -> String -> String -> (Int -> String -> k) -> k
goString (Int
col Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
wcwidth Char
c) (Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String
acc) String
t Int -> String -> k
k
      where
        spaces :: Int
spaces = Int
tabStop Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
col Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
tabStop


--------------------------------------------------------------------------------
prettyCodeBlock :: DisplaySettings -> [T.Text] -> T.Text -> PP.Doc
prettyCodeBlock :: DisplaySettings -> [Text] -> Text -> Doc
prettyCodeBlock DisplaySettings
ds [Text]
classes Text
rawCodeBlock =
    [Doc] -> Doc
PP.vcat ((SourceLine -> Doc) -> [SourceLine] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map SourceLine -> Doc
blockified [SourceLine]
sourceLines) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
PP.hardline
  where
    sourceLines :: [Skylighting.SourceLine]
    sourceLines :: [SourceLine]
sourceLines = (SourceLine -> SourceLine) -> [SourceLine] -> [SourceLine]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> SourceLine -> SourceLine
expandTabs (DisplaySettings -> Int
dsTabStop DisplaySettings
ds)) ([SourceLine] -> [SourceLine]) -> [SourceLine] -> [SourceLine]
forall a b. (a -> b) -> a -> b
$
        [[]] [SourceLine] -> [SourceLine] -> [SourceLine]
forall a. [a] -> [a] -> [a]
++ SyntaxMap -> [Text] -> Text -> [SourceLine]
highlight (DisplaySettings -> SyntaxMap
dsSyntaxMap DisplaySettings
ds) [Text]
classes Text
rawCodeBlock [SourceLine] -> [SourceLine] -> [SourceLine]
forall a. [a] -> [a] -> [a]
++ [[]]

    prettySourceLine :: Skylighting.SourceLine -> PP.Doc
    prettySourceLine :: SourceLine -> Doc
prettySourceLine = [Doc] -> Doc
forall a. Monoid a => [a] -> a
mconcat ([Doc] -> Doc) -> (SourceLine -> [Doc]) -> SourceLine -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Token -> Doc) -> SourceLine -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Token -> Doc
prettyToken

    prettyToken :: Skylighting.Token -> PP.Doc
    prettyToken :: Token -> Doc
prettyToken (TokenType
tokenType, Text
str) = DisplaySettings -> (Theme -> Maybe Style) -> Doc -> Doc
themed
        DisplaySettings
ds
        (\Theme
theme -> Theme -> TokenType -> Maybe Style
syntaxHighlight Theme
theme TokenType
tokenType)
        (Text -> Doc
PP.text Text
str)

    sourceLineLength :: Skylighting.SourceLine -> Int
    sourceLineLength :: SourceLine -> Int
sourceLineLength SourceLine
line =
        [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [String -> Int
wcstrwidth (Text -> String
T.unpack Text
str) | (TokenType
_, Text
str) <- SourceLine
line]

    blockWidth :: Int
    blockWidth :: Int
blockWidth = (Int -> Int -> Int) -> Int -> [Int] -> Int
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 ((SourceLine -> Int) -> [SourceLine] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map SourceLine -> Int
sourceLineLength [SourceLine]
sourceLines)

    blockified :: Skylighting.SourceLine -> PP.Doc
    blockified :: SourceLine -> Doc
blockified SourceLine
line =
        let len :: Int
len    = SourceLine -> Int
sourceLineLength SourceLine
line
            indent :: Indentation Doc
indent = Int -> Doc -> Indentation Doc
forall a. Int -> a -> Indentation a
PP.Indentation Int
3 Doc
forall a. Monoid a => a
mempty in
        Indentation Doc -> Indentation Doc -> Doc -> Doc
PP.indent Indentation Doc
indent Indentation Doc
indent (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
        DisplaySettings -> (Theme -> Maybe Style) -> Doc -> Doc
themed DisplaySettings
ds Theme -> Maybe Style
themeCodeBlock (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
            Doc
" " Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<>
            SourceLine -> Doc
prettySourceLine SourceLine
line Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<>
            String -> Doc
PP.string (Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
blockWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
len) Char
' ') Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
" "