{-# 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