{-# 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 = Text.intercalate (Text.singleton '\n')
                       . map 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 _opts ls =
  "\\highlight{" <> formatConTeXt ls <> "}"

sourceLineToConTeXt :: SourceLine -> Text
sourceLineToConTeXt =
  Text.replace "/ETEX/BTEX" "" .
  Text.replace "/ETEX /BTEX" " " .
  mconcat . map tokenToConTeXt

tokenToConTeXt :: Token -> Text
tokenToConTeXt (NormalTok, txt)
  | Text.all isSpace txt = escapeConTeXt txt
tokenToConTeXt (toktype, txt)   = "/BTEX\\" <>
  (Text.pack (show toktype) <> "{" <> fixSpaces (escapeConTeXt txt) <> "}/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.replace "  " " { }"

escapeConTeXt :: Text -> Text
escapeConTeXt = Text.concatMap escapeConTeXtChar
  where escapeConTeXtChar c =
         case c of
           '\\' -> "\\letterbackslash{}"
           '{'  -> "\\letteropenbrace{}"
           '}'  -> "\\letterclosebrace{}"
           '|'  -> "\\letterbar{}"
           '$'  -> "\\letterdollar{}"
           '_'  -> "\\letterunderscore{}"
           '%'  -> "\\letterpercent{}"
           '#'  -> "\\letterhash{}"
           '/'  -> "\\letterslash{}"
           '~'  -> "\\lettertilde{}"
           _    -> Text.singleton 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 opts ls = Text.unlines
  [ "\\starthighlighting" <>
    (if numberLines opts
     then "[numbering=line]"
     else Text.empty)
  , formatConTeXt ls
  , "\\stophighlighting"
  ]

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

  sort (map (macrodef (defaultColor f) (Map.toList (tokenStyles f)))
            (enumFromTo KeywordTok NormalTok))

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