{-# 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')
                       forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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{" forall a. Semigroup a => a -> a -> a
<> [SourceLine] -> Text
formatConTeXt [SourceLine]
ls forall a. Semigroup a => a -> a -> a
<> Text
"}"

sourceLineToConTeXt :: SourceLine -> Text
sourceLineToConTeXt :: SourceLine -> Text
sourceLineToConTeXt =
  Text -> Text -> Text -> Text
Text.replace Text
"/ETEX/BTEX" Text
"" forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Text -> Text -> Text -> Text
Text.replace Text
"/ETEX /BTEX" Text
" " forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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\\" forall a. Semigroup a => a -> a -> a
<>
  (String -> Text
Text.pack (forall a. Show a => a -> String
show TokenType
toktype) forall a. Semigroup a => a -> a -> a
<> Text
"{" forall a. Semigroup a => a -> a -> a
<> Text -> Text
fixSpaces (Text -> Text
escapeConTeXt Text
txt) 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 = 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" 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 forall a b. (a -> b) -> a -> b
$
  ( case Style -> Maybe Color
backgroundColor Style
f of
         Maybe Color
Nothing          -> forall a. a -> a
id
         Just (RGB Word8
r Word8
g Word8
b) -> (:)
           (String -> Text
Text.pack forall a b. (a -> b) -> a -> b
$ forall r. PrintfType r => String -> r
printf String
"\\definecolor[shadecolor][x=%x%x%x]" Word8
r Word8
g Word8
b)
  ) 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]"
  ] forall a. [a] -> [a] -> [a]
++

  forall a. Ord a => [a] -> [a]
sort (forall a b. (a -> b) -> [a] -> [b]
map (Maybe Color -> [(TokenType, TokenStyle)] -> TokenType -> Text
macrodef (Style -> Maybe Color
defaultColor Style
f) (forall k a. Map k a -> [(k, a)]
Map.toList (Style -> Map TokenType TokenStyle
tokenStyles Style
f)))
            (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]\\"
  forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (forall a. Show a => a -> String
show TokenType
tokt)
  forall a. Semigroup a => a -> a -> a
<> Text
"{"
  forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (forall {t}. (PrintfArg t, PrintfType t) => t -> t
co forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. (Semigroup a, IsString a) => a -> a
ul forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. (Semigroup a, IsString a) => a -> a
bf forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. (Semigroup a, IsString a) => a -> a
it forall a b. (a -> b) -> a -> b
$ String
"#1")
  forall a. Semigroup a => a -> a -> a
<> Text
"}"
  where tokf :: TokenStyle
tokf = forall a. a -> Maybe a -> a
fromMaybe TokenStyle
defStyle forall a b. (a -> b) -> a -> b
$ 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{" forall a. Semigroup a => a -> a -> a
<> a
x 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 " 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 " forall a. Semigroup a => a -> a -> a
<> a
x
                  else a
x
        col :: Maybe (Double, Double, Double)
col  = forall a. FromColor a => Color -> a
fromColor forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (TokenStyle -> Maybe Color
tokenColor TokenStyle
tokf 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) ->
                   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