space_latex_width = normal_width " "
{- functions for calculating an interger value according to a given
Units per mm found in: Karsten G�nther, "Einf�hrung in LaTeX2e" (p.376)
calc_line_length :: String -> Int
(\(x,y) -> (reverse x,reverse y)) $ span isAlpha $ reverse s
u -> error ( "unknown or unsupported LaTeX unit: " ++ u )
len = read $ map (\c -> case c of ',' -> '.';_ -> c) r_number
in truncate (len * unit * 1000)
pt_length :: Int -> String
pt_length i = showFFloat (Just 3) pt "pt"
pt = fromRational (toRational i /351)
-- a hack to have some debug prints
condTrace :: String -> a -> a
condTrace s v = v -- trace s v
{- functions to calculate a word-width in integer with a given word
data Word_type = Keyword | StructId | Normal
| Comment | Annotation | AnnotationBold
calc_word_width :: Word_type -> String -> Int
Nothing -> sum_char_width_deb ( showString "In map \""
. showString "\" \'") wFM k_wFM s
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,
Axiom -> (axiom_map,key_axiom_map)
Normal -> (normal_map,key_normal_map)
itCorrection :: String -> Int
| 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
(r + lookupCorrection (y1:y2:[]))
itCorrection' _ _ = error ("itCorrection' doesn't work with " ++ s)
lookupCorrection str = findWithDefault def_cor str italiccorrection_map
-- lookupWithDefaultFM correction_map def_cor pc
-- TODO: Build a nice correction map
sum_char_width_deb :: (String -> String) -- only used for an hackie debug thing
-> 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
| c == ' ' = r + lookupWithDefault_cFM "~"
| otherwise = r + 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
sum_char_width' cs (r + lookupWithDefault_cFM "~")
sum_char_width' rest (r + lookupWithDefault_cFM "~")
| otherwise = case prefixIsKey full key_cFM of
Just key -> sum_char_width'
Nothing -> sum_char_width' rest nl
where nl = r + lookupWithDefault_cFM (c1:[])
lookupWithDefault_cFM s' = case
Map.lookup s' cFM of
prefixIsKey :: String -> Map Char [String] -> Maybe String
prefixIsKey [] _ = Nothing
prefixIsKey ls@(c:_) key_cFM = case
Map.lookup c key_cFM of
Just ws -> firstJust $ map testPrefix ws
where testPrefix s = if ((flip isPrefixOf) ls) s
firstJust (ms:mss) = if isJust ms then ms else firstJust mss
isLigature :: String -> Bool
| (length s) /= 2 = False
| otherwise = findWithDefault False s ligatures
keyword_width, structid_width, axiom_width, annotationbf_width,
annotation_width, comment_width, normal_width
annotation_width = calc_word_width Annotation
annotationbf_width = calc_word_width AnnotationBold
keyword_width = calc_word_width Keyword
structid_width = calc_word_width StructId
axiom_width = calc_word_width Axiom
comment_width = calc_word_width Comment
normal_width = calc_word_width Normal
-- LaTeX version of <+> with enough space counted. It's choosen the
-- space between keywords which is nearly the average width of a
(<\+>) :: Doc -> Doc -> Doc
-- TODO: did not work correctly !!!
d1 <\+> d2 = if isEmpty d1
d1 <> casl_normal_latex " " <> d2)
(<~>) :: Doc -> Doc -> Doc
d1 <~> d2 = d1 <> casl_normal_latex "~" <> d2
-- 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. latex_macro :: String -> Doc
{- an alternative implementation of
latex_text with bad counts for letters etc. :
case sp_length s 0 of {sl -> sp_text sl s}
sp_length :: String -> Int -> Int
| x == '\\' = let (c,rest) = spanLaMacro xs
| x == '{' = sp_length xs a
| x == '}' = sp_length xs a
| otherwise = sp_length xs (a+1)
where spanLaMacro :: String -> (Int, String)
spanLaMacro "" = (1,"") -- lambda
| x == ' ' = (1,xs) -- an explicit space
| isAlpha x = let (makro,rest) =
-- error $ "spanLaMacro: strange " ++
comma_latex, semi_latex, space_latex,equals_latex,colon_latex :: Doc
comma_latex = let s = "," in sp_text (normal_width s) s
semi_latex = let s = ";" in sp_text (normal_width s) s
colon_latex = let s = ":" in sp_text (normal_width s) s
space_latex = let s = " " in sp_text (normal_width s) s
equals_latex = hc_sty_axiom "="
braces_latex, parens_latex, brackets_latex, quotes_latex :: Doc -> Doc
braces_latex d = casl_normal_latex "\\{"<>d<>casl_normal_latex "\\}"
parens_latex d = casl_normal_latex "("<>d<>casl_normal_latex ")"
brackets_latex d = casl_normal_latex "["<>d<>casl_normal_latex "]"
quotes_latex d = q <> d <> q
where q = casl_normal_latex "{\\tt{}\\textquotedblright}"
-- nest and hang that do the obvious thing except that they use
-- multiple spaces for indentation and set tabs with spaces
nest_latex :: Int -> Doc -> Doc
nest_latex k = nest (k * space_latex_width)
hang_latex :: Doc -> Int -> Doc -> Doc
hang_latex d1 n d2 = sep_latex [d1, nest_latex n d2]
sep_latex :: [Doc] -> Doc
sep_latex = cat . (cond_punctuate (casl_normal_latex " "))
fsep_latex :: [Doc] -> Doc
fsep_latex = fcat . (cond_punctuate (casl_normal_latex " "))
initial_keyword_latex :: String -> String -> Doc
initial_keyword_latex fs kw =
let fs_w = keyword_width fs
casl_keyword_latex, casl_annotation_latex, casl_annotationbf_latex,
casl_comment_latex, casl_structid_latex,
casl_normal_latex :: String -> Doc
casl_keyword_latex s = sp_text (keyword_width s) s
casl_annotation_latex s = sp_text (annotation_width s) s
casl_annotationbf_latex s = sp_text (annotationbf_width s) s
casl_comment_latex s = sp_text (comment_width s) s
casl_structid_latex s = sp_text (structid_width s) s
casl_axiom_latex s = sp_text (axiom_width s) s
casl_normal_latex s = sp_text (normal_width s) s
hc_sty_keyword :: Maybe String -> String -> Doc
latex_macro "\\KW"<>fkw_doc<>latex_macro "{"<>kw_doc<> latex_macro "}"
Just fkw -> (latex_macro "["<>latex_macro fkw<>latex_macro "]",
initial_keyword_latex fkw kw)
Nothing -> (empty,casl_keyword_latex kw)
hc_sty_plain_keyword :: String -> Doc
hc_sty_plain_keyword = hc_sty_keyword Nothing
hc_sty_hetcasl_keyword :: String -> Doc
hc_sty_hetcasl_keyword str =
str' -> hc_sty_keyword (Just "view") str'
where sp_t s = sp_text (keyword_width str) s
hc_sty_small_keyword :: String -> Doc
hc_sty_small_keyword kw =
latex_macro "\\KW{" <> casl_annotationbf_latex kw <> latex_macro "}"
hc_sty_comment, hc_sty_annotation :: Doc -> Doc
hc_sty_comment cm = latex_macro startAnno <> cm <> latex_macro endAnno
hc_sty_annotation = hc_sty_comment
hc_sty_axiom, hc_sty_structid, hc_sty_id,hc_sty_structid_indexed
hc_sty_structid sid = latex_macro "\\SId{"<>sid_doc<>latex_macro "}"
where sid_doc = casl_structid_latex (escape_latex sid)
hc_sty_structid_indexed sid =
latex_macro "\\SIdIndex{"<>sid_doc<>latex_macro "}"
where sid_doc = casl_structid_latex (escape_latex 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
cond_punctuate :: Doc -> [Doc] -> [Doc]
cond_punctuate _p [] = []
cond_punctuate p (doc:docs) = go doc docs
go d (e:es) = cond_predicate : go e es
where cond_predicate = if isEmpty d then d else d<>p
-- a constant String for the start of annotations
-- a constant string ending an annotation
-- moved from PPUtils (used for String instance of PrettyPrint and
-- various other functions that print Strings with special stuff
escape_latex :: String -> String
| x == '\\' = "\\textbackslash" ++ '{':'}':escape_latex xs
| x == '"' = -- something to prevent
german.sty from interpreting '"'
y:ys | isAlphaNum y -> '`':'`':y:escape_latex ys
| isSpace y -> default_quotes (y:escape_latex ys)
| otherwise -> default_quotes (escape_latex xs)
| x `elem` "_%$&{}#" = '\\':x:escape_latex xs
| x `elem` "~^" = '\\':x:("{}"++escape_latex xs)
| otherwise = x:escape_latex xs
where default_quotes = ('\'':) . ('\'':)
escape_comment_latex :: String -> String
| or $ map (`elem` s) "<>" = ecl s'
where s' = escape_latex s
|| x == '>' = "\\Ax{"++x:"}"++ecl xs