{- |
Module      :  ./Common/LaTeX_funs.hs
Description :  auxiliary functions for LaTeX printing
Copyright   :  (c) Klaus Luettich, Uni Bremen 2002-2006
License     :  GPLv2 or higher, see LICENSE.txt

Maintainer  :  Christian.Maeder@dfki.de
Stability   :  provisional
Portability :  portable

Auxiliary functions for LaTeX printing

Functions to calculate the length of a given word as it would be
   printed with LaTeX according to one of four categories of words
   useful for CASL:

   * keywords -- all the things that were printed in boldface

   * structid -- all the names used in the structured context of CASL

   * annotation -- all the comments and annotations of CASL in a smaller font

   * axiom -- identifiers in math mode for CASL Basic specs
-}

module Common.LaTeX_funs
    ( calcLineLen
    , axiom_width
    , latex_macro
    , flushright
    , casl_comment_latex
    , casl_normal_latex

    , hc_sty_small_keyword
    , hc_sty_plain_keyword
    , hc_sty_casl_keyword

    , hc_sty_axiom
    , hc_sty_structid
    , hc_sty_structid_indexed
    , hc_sty_id

    , startTab, endTab, setTab
    , setTabWSp
    , startAnno
    , endAnno
    , escapeSpecial
    , escapeLatex
    ) where

import qualified Data.Map as Map
import Data.Char
import Data.List (isPrefixOf)

import Common.LaTeX_maps
import Common.Lib.Pretty as Pretty
import Common.Parsec
import Text.ParserCombinators.Parsec as Parsec

-- | a constant String for starting a LaTeX indentation with tab stop
startTab :: String
startTab = "\\@begT@"

-- | a constant String for releasing a LaTeX indentation with tab stop
endTab :: String
endTab = "\\@endT@"

-- | a constant String to set a tab stop and enable it
setTab :: String
setTab = "\\="

-- | a constant String indicating the start of a space based indentation
setTabWSp :: String
setTabWSp = "\\@setTS@{"

{- | functions for calculating an integer value according to a given
   length in LaTeX points.
-}
calcLineLen :: Int -> Int
calcLineLen len = scaleDown $ len * 351
-- Units per mm found in: Karsten Guenther, "Einfuehrung in LaTeX2e" (p.376)

scaleDown :: Int -> Int
scaleDown = (`div` 44) . (+ 15)

{- functions to calculate a word-width in integer with a given word
   type or purpose
-}

data Word_type =
    Keyword | StructId | Normal | Comment | Annotation | AnnotationBold | Axiom
    deriving (Show, Eq)

calc_word_width :: Word_type -> String -> Int
calc_word_width wt s = scaleDown $ calc_word_widthAux wt s

calc_word_widthAux :: Word_type -> String -> Int
calc_word_widthAux wt s = Map.findWithDefault
  (sum_char_width_deb (showString "In map \"" . shows wt . showString "\" \'")
   wFM k_wFM s - correction) s wFM
    where (wFM, k_wFM) = case wt of
                        Keyword -> (keyword_map, key_keyword_map)
                        StructId -> (structid_map, key_structid_map)
                        Comment -> (comment_map, key_comment_map)
                        Annotation -> (annotation_map, key_annotation_map)
                        AnnotationBold -> (annotationbf_map,
                                           key_annotationbf_map)
                        Axiom -> (axiom_map, key_axiom_map)
                        Normal -> (normal_map, key_normal_map)
          correction = case wt of
                       Axiom -> itCorrection s
                       _ -> 0

itCorrection :: String -> Int
itCorrection [] = 0
itCorrection s
    | length s < 2 || head s == '\\' = 0
    | otherwise = itCorrection' 0 s
    where itCorrection' :: Int -> String -> Int
          itCorrection' _ [] = error "itCorrection' applied to empty List"
          itCorrection' r ys@[y1, y2]
              | not (isAlphaNum y1) = r
              | not (isAlphaNum y2) = r
              | otherwise = r + lookupCorrection ys

          itCorrection' r (y1 : ys@(y2 : _))
              | not (isAlphaNum y1) = itCorrection' r ys
              | otherwise =
                  itCorrection'
                        (r + lookupCorrection [y1, y2])
                        ys
          itCorrection' _ _ = error ("itCorrection' doesn't work with " ++ s)
          lookupCorrection str = Map.findWithDefault def_cor str
                                 italiccorrection_map
          def_cor = 610

sum_char_width_deb :: (String -> String) -- only used for an hackie debug thing
                   -> Map.Map String Int
                   -> Map.Map Char [String] -> String -> Int
sum_char_width_deb _pref_fun cFM key_cFM s = sum_char_width' s 0
    where sum_char_width' [] r = r
          sum_char_width' [c] r = r + case c of
              '}' -> 0
              '{' -> 0
              ' ' -> lookupWithDefault_cFM "~"
              _ -> lookupWithDefault_cFM [c]
          sum_char_width' full@(c1 : rest@(c2 : cs)) r
              | isLigature [c1, c2] = case Map.lookup [c1, c2] cFM of
                                        Just l -> sum_char_width' cs (r + l)
                                        Nothing -> sum_char_width' rest nl
              | [c1, c2] == "\\ " =
                  sum_char_width' cs (r + lookupWithDefault_cFM "~")
              | c1 == ' ' =
                  sum_char_width' rest (r + lookupWithDefault_cFM "~")
              | otherwise = case prefixIsKey full key_cFM of
                            Just key -> sum_char_width'
                                        (drop (length key) full)
                                        $ r + (cFM Map.! key)
                            Nothing -> if c1 == '\\' then
                                        sum_char_width'
                                        (dropWhile isAlpha rest)
                                         $ r + lookupWithDefault_cFM "~"
                                        else sum_char_width' rest nl
              where nl = r + lookupWithDefault_cFM [c1]
          lookupWithDefault_cFM s' = Map.findWithDefault 2200 s' cFM
              -- 2200 may not be optimal


prefixIsKey :: String -> Map.Map Char [String] -> Maybe String
prefixIsKey [] _ = Nothing
prefixIsKey ls@(c : _) key_cFM = case filter (`isPrefixOf` ls)
        $ Map.findWithDefault [] c key_cFM of
    [] -> Nothing
    s : _ -> Just s

isLigature :: String -> Bool
isLigature s = case s of
  [_, _] -> Map.findWithDefault False s ligatures
  _ -> False

keyword_width, structid_width, axiom_width, annotationbf_width,
    comment_width, normal_width :: String -> Int
annotationbf_width = calc_word_width AnnotationBold
keyword_width = calc_word_width Keyword
structid_width = calc_word_width StructId
comment_width = calc_word_width Comment
normal_width = calc_word_width Normal
axiom_width = sum . map (calc_word_width Axiom) . parseAxiomString

{- |
latex_macro creates a document ('Doc') containing String
that has a zero width.
So it can be used for LaTeX-macros not needing any space, i.e.
@\textit{@ or @}@ -}
latex_macro :: String -> Doc
latex_macro = sizedText 0

casl_keyword_latex, casl_annotationbf_latex,
       casl_axiom_latex,
       casl_comment_latex, casl_structid_latex,
       casl_normal_latex :: String -> Doc
casl_annotationbf_latex s = sizedText (annotationbf_width s) s
casl_structid_latex s = sizedText (structid_width s) s
casl_comment_latex s = sizedText (comment_width s) s
casl_keyword_latex s = sizedText (keyword_width s) s
casl_normal_latex s = sizedText (normal_width s) s
casl_axiom_latex s = sizedText (axiom_width s) s

-- | sort, op, pred, type and its plurals
hc_sty_casl_keyword :: String -> Doc
hc_sty_casl_keyword str =
    sizedText (keyword_width "preds") $ '\\' : map toUpper str

hc_sty_plain_keyword :: String -> Doc
hc_sty_plain_keyword kw =
    latex_macro "\\KW{" <> casl_keyword_latex (escapeSpecial kw)
                    <> latex_macro "}"

hc_sty_small_keyword :: String -> Doc
hc_sty_small_keyword kw =
    latex_macro "\\KW{" <> casl_annotationbf_latex (escapeSpecial kw)
                    <> latex_macro "}"

hc_sty_axiom, hc_sty_structid, hc_sty_id, hc_sty_structid_indexed
    :: String -> Doc
hc_sty_structid sid = latex_macro "\\SId{" <> sid_doc <> latex_macro "}"
    where sid_doc = casl_structid_latex (escapeSpecial sid)
hc_sty_structid_indexed sid =
    latex_macro "\\SIdIndex{" <> sid_doc <> latex_macro "}"
    where sid_doc = casl_structid_latex (escapeSpecial sid)
hc_sty_id i = latex_macro "\\Id{" <> id_doc <> latex_macro "}"
    where id_doc = casl_axiom_latex i
hc_sty_axiom ax = latex_macro "\\Ax{" <> ax_doc <> latex_macro "}"
    where ax_doc = casl_axiom_latex ax

-- | flush argument doc to the right
flushright :: Doc -> Doc
flushright = (latex_macro "\\`" <>)

-- | a constant String for the start of annotations
startAnno :: String
startAnno = "{\\small{}"

-- | a constant string ending an annotation
endAnno :: String
endAnno = "%@%small@}"

escapeSpecial :: String -> String
escapeSpecial = concatMap $ \ c -> if elem c "_%$&{}#" then '\\' : [c] else
  Map.findWithDefault [c] c escapeMap

{- http://dhelta.net/hprojects/HaTeX/code/HaTeX-3.1.0/Text/LaTeX/Base/Syntax.hs
changes _ to \_{} -}

escapeLatex :: String -> String
escapeLatex = concatMap $ \ c -> case () of
  ()
    | elem c "_%$&{}#" -> "\\Ax{\\" ++ c : "}"
    | elem c "<|>=-!()[]?:;,./*+@" -> "\\Ax{" ++ c : "}"
    | otherwise -> Map.findWithDefault [c] c escapeMap

parseAxiomString :: String -> [String]
parseAxiomString s = case parse axiomString "" s of
    Left _ -> [s]
    Right l -> l

axiomString :: CharParser st [String]
axiomString = do
  l <- many parseAtom
  eof
  return $ concat l

parseAtom :: CharParser st [String]
parseAtom = fmap concat
    ((tryString "\\Ax{" <|> tryString "\\Id{" <|> string "{")
    >> many parseAtom << Parsec.char '}')
 <|> do
    b <- Parsec.char '\\'
    s <- fmap (: []) (satisfy (\ c -> isSpace c
                                      || elem c "_~^|\'\",;:.`\\{}[]%$&#()"))
         <|> many1 letter
    return [b : s]
 <|> do
    s <- many1 letter
    return [s]
 <|> do
    c <- satisfy (/= '}')
    return [[c]]

-- | a character map for special latex characters
escapeMap :: Map.Map Char String
escapeMap = Map.fromList
 [('\\', "\\Ax{\\setminus}"),
  ('^', "\\Ax{\\hat{\\ }}"),
  ('"', "''"),
  ('~', "\\Ax{\\sim}"),
  ('\160', "\\ "),
  ('\162', "\\Id{\\textcent}"),
  ('\164', "\\Id{\\textcurrency}"),
  ('\165', "\\Id{\\textyen}"),
  ('\166', "\\Id{\\textbrokenbar}"),
  ('\170', "\\Id{\\textordfeminine}"),
  ('\171', "\\Id{\\guillemotleft}"),
  ('\172', "\\Ax{\\neg}"),
  ('\173', "-"),
  ('\174', "\\Id{\\textregistered}"),
  ('\175', "\\Ax{\\bar{\\ }}"),
  ('\176', "\\Id{\\textdegree}"),
  ('\177', "\\Ax{\\pm}"),
  ('\178', "\\Ax{^2}"),
  ('\179', "\\Ax{^3}"),
  ('\180', "\\Ax{\\acute{\\ }}"),
  ('\181', "\\Ax{\\mu}"),
  ('\185', "\\Ax{^1}"),
  ('\186', "\\Id{\\textordmasculine}"),
  ('\187', "\\Id{\\guillemotright}"),
  ('\192', "\\Ax{\\grave{A}}"),
  ('\193', "\\Ax{\\acute{A}}"),
  ('\200', "\\Ax{\\grave{E}}"),
  ('\201', "\\Ax{\\acute{E}}"),
  ('\204', "\\Ax{\\grave{I}}"),
  ('\205', "\\Ax{\\acute{I}}"),
  ('\208', "\\Id{\\DH}"),
  ('\210', "\\Ax{\\grave{O}}"),
  ('\211', "\\Ax{\\acute{O}}"),
  ('\215', "\\Ax{\\times}"),
  ('\217', "\\Ax{\\grave{U}}"),
  ('\218', "\\Ax{\\acute{U}}"),
  ('\221', "\\Ax{\\acute{Y}}"),
  ('\222', "\\Id{\\TH}"),
  ('\224', "\\Ax{\\grave{a}}"),
  ('\225', "\\Ax{\\acute{a}}"),
  ('\232', "\\Ax{\\grave{e}}"),
  ('\233', "\\Ax{\\acute{e}}"),
  ('\236', "\\Ax{\\grave{\\Id{\\i}}}"),
  ('\237', "\\Ax{\\acute{\\Id{\\i}}}"),
  ('\240', "\\Id{\\dh}"),
  ('\242', "\\Ax{\\grave{o}}"),
  ('\243', "\\Ax{\\acute{o}}"),
  ('\247', "\\Ax{\\div}"),
  ('\249', "\\Ax{\\grave{u}}"),
  ('\250', "\\Ax{\\acute{u}}"),
  ('\253', "\\Ax{\\acute{y}}"),
  ('\254', "\\Id{\\th}")]

{- acute and grave characters don't work in a tabbing environment
   \textcent upto textbrokenbar requires \usepackage{textcomp}
    whereas \guillemot, eth, and thorn  \usepackage[T1]{fontenc}
-}
