    {-# LANGUAGE CPP                 #-}
    {-# LANGUAGE OverloadedStrings   #-}
    {-# LANGUAGE ScopedTypeVariables #-}
    module Skylighting.Format.ConTeXt
      ( formatConTeXtInline
      , formatConTeXtBlock
      , styleToConTeXt
      ) where

    import Control.Monad (mplus)
    import Data.Char (isSpace)
    import Data.List (sort)
    import qualified Data.Map as Map
    import Data.Maybe (fromMaybe)
    import Data.Text (Text)
    import qualified Data.Text as Text
    import Skylighting.Types
    import Text.Printf
    #if !MIN_VERSION_base(4,11,0)
    import Data.Semigroup
    #endif

    formatConTeXt :: [SourceLine] -> Text
    formatConTeXt :: [SourceLine] -> Text
    formatConTeXt = Text -> [Text] -> Text
    Text.intercalate (Char -> Text
    Text.singleton Char
    '\n')
                           ([Text] -> Text)
    -> ([SourceLine] -> [Text]) -> [SourceLine] -> Text
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (SourceLine -> Text) -> [SourceLine] -> [Text]
    forall a b. (a -> b) -> [a] -> [b]
    map SourceLine -> Text
    sourceLineToConTeXt

    -- | Formats tokens as ConTeXt using custom commands inside a @\type{}@.
    -- A @KeywordTok@ is rendered using @\\KeywordTok{..}@, and so on.
    formatConTeXtInline :: FormatOptions -> [SourceLine] -> Text
    formatConTeXtInline :: FormatOptions -> [SourceLine] -> Text
    formatConTeXtInline FormatOptions
    _opts [SourceLine]
    ls =
      Text
    "\\highlight{" Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> [SourceLine] -> Text
    formatConTeXt [SourceLine]
    ls Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    "}"

    sourceLineToConTeXt :: SourceLine -> Text
    sourceLineToConTeXt :: SourceLine -> Text
    sourceLineToConTeXt =
      HasCallStack => Text -> Text -> Text -> Text
    Text -> Text -> Text -> Text
    Text.replace Text
    "/ETEX/BTEX" Text
    "" (Text -> Text) -> (SourceLine -> Text) -> SourceLine -> Text
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    .
      HasCallStack => Text -> Text -> Text -> Text
    Text -> Text -> Text -> Text
    Text.replace Text
    "/ETEX /BTEX" Text
    " " (Text -> Text) -> (SourceLine -> Text) -> SourceLine -> Text
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    .
      [Text] -> Text
    forall a. Monoid a => [a] -> a
    mconcat ([Text] -> Text) -> (SourceLine -> [Text]) -> SourceLine -> Text
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Token -> Text) -> SourceLine -> [Text]
    forall a b. (a -> b) -> [a] -> [b]
    map Token -> Text
    tokenToConTeXt

    tokenToConTeXt :: Token -> Text
    tokenToConTeXt :: Token -> Text
    tokenToConTeXt (TokenType
    NormalTok, Text
    txt)
      | (Char -> Bool) -> Text -> Bool
    Text.all Char -> Bool
    isSpace Text
    txt = Text -> Text
    escapeConTeXt Text
    txt
    tokenToConTeXt (TokenType
    toktype, Text
    txt)   = Text
    "/BTEX\\" Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <>
      (String -> Text
    Text.pack (TokenType -> String
    forall a. Show a => a -> String
    show TokenType
    toktype) Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    "{" Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text -> Text
    fixSpaces (Text -> Text
    escapeConTeXt Text
    txt) Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    "}/ETEX")
     where
      -- Always place the second of two consecutive spaces in a group. The
      -- ConTeXt parser would otherwise collapse all spaces into a single
      -- space.
      fixSpaces :: Text -> Text
    fixSpaces = HasCallStack => Text -> Text -> Text -> Text
    Text -> Text -> Text -> Text
    Text.replace Text
    "  " Text
    " { }"

    escapeConTeXt :: Text -> Text
    escapeConTeXt :: Text -> Text
    escapeConTeXt = (Char -> Text) -> Text -> Text
    Text.concatMap Char -> Text
    escapeConTeXtChar
      where escapeConTeXtChar :: Char -> Text
    escapeConTeXtChar Char
    c =
             case Char
    c of
               Char
    '\\' -> Text
    "\\letterbackslash{}"
               Char
    '{'  -> Text
    "\\letteropenbrace{}"
               Char
    '}'  -> Text
    "\\letterclosebrace{}"
               Char
    '|'  -> Text
    "\\letterbar{}"
               Char
    '$'  -> Text
    "\\letterdollar{}"
               Char
    '_'  -> Text
    "\\letterunderscore{}"
               Char
    '%'  -> Text
    "\\letterpercent{}"
               Char
    '#'  -> Text
    "\\letterhash{}"
               Char
    '/'  -> Text
    "\\letterslash{}"
               Char
    '~'  -> Text
    "\\lettertilde{}"
               Char
    _    -> Char -> Text
    Text.singleton Char
    c

    -- ConTeXt

    -- | Format tokens as a ConTeXt @highlighting@ typing environment. The
    -- @highlighting@ environemnt is defined by the macros produced by
    -- 'styleToConTeXt'; it is a @typing@ environment with default escaping
    -- enabled, i.e., @/@ is the escape character.
    formatConTeXtBlock :: FormatOptions -> [SourceLine] -> Text
    formatConTeXtBlock :: FormatOptions -> [SourceLine] -> Text
    formatConTeXtBlock FormatOptions
    opts [SourceLine]
    ls = [Text] -> Text
    Text.unlines
      [ Text
    "\\starthighlighting" Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <>
        (if FormatOptions -> Bool
    numberLines FormatOptions
    opts
         then Text
    "[numbering=line]"
         else Text
    Text.empty)
      , [SourceLine] -> Text
    formatConTeXt [SourceLine]
    ls
      , Text
    "\\stophighlighting"
      ]

    -- | Converts a 'Style' to a set of ConTeXt command definitions,
    -- which should be placed in the document's preamble.
    styleToConTeXt :: Style -> Text
    styleToConTeXt :: Style -> Text
    styleToConTeXt Style
    f = [Text] -> Text
    Text.unlines ([Text] -> Text) -> [Text] -> Text
    forall a b. (a -> b) -> a -> b
    $
      ( case Style -> Maybe Color
    backgroundColor Style
    f of
             Maybe Color
    Nothing          -> [Text] -> [Text]
    forall a. a -> a
    id
             Just (RGB Word8
    r Word8
    g Word8
    b) -> (:)
               (String -> Text
    Text.pack (String -> Text) -> String -> Text
    forall a b. (a -> b) -> a -> b
    $ String -> Word8 -> Word8 -> Word8 -> String
    forall r. PrintfType r => String -> r
    printf String
    "\\definecolor[shadecolor][x=%x%x%x]" Word8
    r Word8
    g Word8
    b)
      ) ([Text] -> [Text]) -> [Text] -> [Text]
    forall a b. (a -> b) -> a -> b
    $
      [ Text
    "\\defineframedtext [shaded]"
      , Text
    "  [backgroundcolor=shadecolor,"
      , Text
    "   background=color,"
      , Text
    "   frame=off,"
      , Text
    "   offset=0pt,"
      , Text
    "   width=local]"
      , Text
    "\\definetyping [highlighting]"
      , Text
    "  [escape=yes,"
      , Text
    "   before={\\startshaded},"
      , Text
    "   after={\\stopshaded}]"
      , Text
    "\\definetype [highlight]"
      , Text
    "  [escape=yes]"
      ] [Text] -> [Text] -> [Text]
    forall a. [a] -> [a] -> [a]
    ++

      [Text] -> [Text]
    forall a. Ord a => [a] -> [a]
    sort ((TokenType -> Text) -> [TokenType] -> [Text]
    forall a b. (a -> b) -> [a] -> [b]
    map (Maybe Color -> [(TokenType, TokenStyle)] -> TokenType -> Text
    macrodef (Style -> Maybe Color
    defaultColor Style
    f) (Map TokenType TokenStyle -> [(TokenType, TokenStyle)]
    forall k a. Map k a -> [(k, a)]
    Map.toList (Style -> Map TokenType TokenStyle
    tokenStyles Style
    f)))
                (TokenType -> TokenType -> [TokenType]
    forall a. Enum a => a -> a -> [a]
    enumFromTo TokenType
    KeywordTok TokenType
    NormalTok))

    macrodef :: Maybe Color -> [(TokenType, TokenStyle)] -> TokenType -> Text
    macrodef :: Maybe Color -> [(TokenType, TokenStyle)] -> TokenType -> Text
    macrodef Maybe Color
    defaultcol [(TokenType, TokenStyle)]
    tokstyles TokenType
    tokt = Text
    "\\define[1]\\"
      Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> String -> Text
    Text.pack (TokenType -> String
    forall a. Show a => a -> String
    show TokenType
    tokt)
      Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    "{"
      Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> String -> Text
    Text.pack (String -> String
    forall {t}. (PrintfArg t, PrintfType t) => t -> t
    co (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String
    forall {a}. (Semigroup a, IsString a) => a -> a
    ul (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String
    forall {a}. (Semigroup a, IsString a) => a -> a
    bf (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String
    forall {a}. (Semigroup a, IsString a) => a -> a
    it (String -> String) -> String -> String
    forall a b. (a -> b) -> a -> b
    $ String
    "#1")
      Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    "}"
      where tokf :: TokenStyle
    tokf = TokenStyle -> Maybe TokenStyle -> TokenStyle
    forall a. a -> Maybe a -> a
    fromMaybe TokenStyle
    defStyle (Maybe TokenStyle -> TokenStyle) -> Maybe TokenStyle -> TokenStyle
    forall a b. (a -> b) -> a -> b
    $ TokenType -> [(TokenType, TokenStyle)] -> Maybe TokenStyle
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
    lookup TokenType
    tokt [(TokenType, TokenStyle)]
    tokstyles
            ul :: a -> a
    ul a
    x = if TokenStyle -> Bool
    tokenUnderline TokenStyle
    tokf
                      then a
    "\\underbar{" a -> a -> a
    forall a. Semigroup a => a -> a -> a
    <> a
    x a -> a -> a
    forall a. Semigroup a => a -> a -> a
    <> a
    "}"
                      else a
    x
            it :: a -> a
    it a
    x = if TokenStyle -> Bool
    tokenItalic TokenStyle
    tokf
                      then a
    "\\em " a -> a -> a
    forall a. Semigroup a => a -> a -> a
    <> a
    x
                      else a
    x
            bf :: a -> a
    bf a
    x = if TokenStyle -> Bool
    tokenBold TokenStyle
    tokf
                      then a
    "\\bf " a -> a -> a
    forall a. Semigroup a => a -> a -> a
    <> a
    x
                      else a
    x
            col :: Maybe (Double, Double, Double)
    col  = Color -> (Double, Double, Double)
    forall a. FromColor a => Color -> a
    fromColor (Color -> (Double, Double, Double))
    -> Maybe Color -> Maybe (Double, Double, Double)
    forall a b. (a -> b) -> Maybe a -> Maybe b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    `fmap` (TokenStyle -> Maybe Color
    tokenColor TokenStyle
    tokf Maybe Color -> Maybe Color -> Maybe Color
    forall a. Maybe a -> Maybe a -> Maybe a
    forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
    `mplus` Maybe Color
    defaultcol)
                     :: Maybe (Double, Double, Double)
            co :: t -> t
    co t
    x = case Maybe (Double, Double, Double)
    col of
                     Maybe (Double, Double, Double)
    Nothing        -> t
    x
                     Just (Double
    r, Double
    g, Double
    b) ->
                       String -> Double -> Double -> Double -> t -> t
    forall r. PrintfType r => String -> r
    printf String
    "\\colored[r=%0.2f,g=%0.2f,b=%0.2f]{%s}" Double
    r Double
    g Double
    b t
    x