Typst.hs

{-# LANGUAGE GeneralizedNewtypeDeriving, ViewPatterns, GADTs, OverloadedStrings #-}
{-
Copyright (C) 2023 John MacFarlane <jgm@berkeley.edu>

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

-}

module Text.TeXMath.Writers.Typst (writeTypst) where

import Data.List (transpose)
import qualified Data.Map as M
import qualified Data.Text as T
import Text.TeXMath.Types
import qualified Text.TeXMath.Shared as S
import Typst.Symbols (typstSymbols)
import Data.Generics (everywhere, mkT)
import Data.Text (Text)
import Data.Char (isDigit, isAlpha)

-- import Debug.Trace
-- tr' x = trace (show x) x

-- | Transforms an expression tree to equivalent Typst
writeTypst :: DisplayType -> [Exp] -> Text
writeTypst dt exprs =
  T.unwords $ map writeExp $ everywhere (mkT $ S.handleDownup dt) exprs

writeExps :: [Exp] -> Text
writeExps = T.intercalate " " . map writeExp

inParens :: Text -> Text
inParens s = "(" <> s <> ")"

inQuotes :: Text -> Text
inQuotes s = "\"" <> s <> "\""

esc :: Text -> Text
esc t =
  if T.any needsEscape t
     then T.concatMap escapeChar t
     else t
  where
    escapeChar c
      | needsEscape c = "\\" <> T.singleton c
      | otherwise = T.singleton c
    needsEscape '[' = True
    needsEscape ']' = True
    needsEscape '|' = True
    needsEscape '#' = True
    needsEscape '$' = True
    needsEscape '(' = True
    needsEscape ')' = True
    needsEscape '_' = True
    needsEscape _ = False

writeExpS :: Exp -> Text
writeExpS (EGrouped es) = "(" <> writeExps es <> ")"
writeExpS e =
  case writeExp e of
    t | T.all (\c -> isDigit c || c == '.') t -> t
      | T.all (\c -> isAlpha c || c == '.') t -> t
      | otherwise -> "(" <> t <> ")"

writeExpB :: Exp -> Text
writeExpB e =
  case writeExp e of
    "" -> "zws"
    t -> t

writeExp :: Exp -> Text
writeExp (ENumber s) = s
writeExp (ESymbol _t s) =
  maybe (esc s) id $ M.lookup s typstSymbolMap
writeExp (EIdentifier s) =
  if T.length s == 1
     then writeExp (ESymbol Ord s)
     else inQuotes s
writeExp (EMathOperator s)
  | s `elem` ["arccos", "arcsin", "arctan", "arg", "cos", "cosh",
              "cot", "ctg", "coth", "csc", "deg", "det", "dim", "exp",
              "gcd", "hom", "mod", "inf", "ker", "lg", "lim", "ln",
              "log", "max", "min", "Pr", "sec", "sin", "sinh", "sup",
              "tan", "tg", "tanh", "liminf", "and", "limsup"]
    = s
  | otherwise = "\"" <> s <> "\""
writeExp (EGrouped es) = writeExps es
writeExp (EFraction _fractype e1 e2) =
  case (e1, e2) of
    (EGrouped _, _) -> "frac(" <> writeExp e1 <> ", " <> writeExp e2 <> ")"
    (_, EGrouped _) -> "frac(" <> writeExp e1 <> ", " <> writeExp e2 <> ")"
    _ -> writeExp e1 <> " / " <> writeExp e2
writeExp (ESub b e1) = writeExpB b <> "_" <> writeExpS e1
writeExp (ESuper b e1) = writeExpB b <> "^" <> writeExpS e1
writeExp (ESubsup b e1 e2) = writeExpB b <> "_" <> writeExpS e1 <>
                                           "^" <> writeExpS e2
writeExp (EOver _ (EOver _ b (ESymbol TOver "\9182")) e1) =
  "overbrace(" <> writeExp b <> ", " <> writeExp e1 <> ")"
writeExp (EOver _ (EOver _ b (ESymbol TOver "\9140")) e1) =
  "overbracket(" <> writeExp b <> ", " <> writeExp e1 <> ")"
writeExp (EOver _convertible b e1) =
  case e1 of
    ESymbol Accent "`" -> "grave" <> inParens (writeExp b)
    ESymbol Accent "\768" -> "grave" <> inParens (writeExp b)
    ESymbol Accent "\xb4" -> "acute" <> inParens (writeExp b)
    ESymbol Accent "^" -> "hat" <> inParens (writeExp b)
    ESymbol Accent "\770" -> "hat" <> inParens (writeExp b)
    ESymbol Accent "~" -> "tilde" <> inParens (writeExp b)
    ESymbol Accent "\771" -> "tilde" <> inParens (writeExp b)
    ESymbol Accent "\xaf" -> "macron" <> inParens (writeExp b)
    ESymbol Accent "\x2d8" -> "breve" <> inParens (writeExp b)
    ESymbol Accent "." -> "dot" <> inParens (writeExp b)
    ESymbol Accent "\775" -> "dot" <> inParens (writeExp b)
    ESymbol Accent "\xa8" -> "diaer" <> inParens (writeExp b)
    ESymbol Accent "\x2218" -> "circle" <> inParens (writeExp b)
    ESymbol Accent "\x2dd" -> "acute.double" <> inParens (writeExp b)
    ESymbol Accent "\x2c7" -> "caron" <> inParens (writeExp b)
    ESymbol Accent "\x2192" -> "->" <> inParens (writeExp b)
    ESymbol Accent "\x2190" -> "<-" <> inParens (writeExp b)
    ESymbol TOver "\9182" -> "overbrace(" <> writeExp b <> ")"
    ESymbol TOver "\9140" -> "overbracket(" <> writeExp b <> ")"
    ESymbol TOver "\175" -> "overline(" <> writeExp b <> ")"
    _ -> writeExpB b <> "^" <> writeExpS e1
writeExp (EUnder _ (EUnder _ b (ESymbol TUnder "\9183")) e1) =
  "underbrace(" <> writeExp b <> ", " <> writeExp e1 <> ")"
writeExp (EUnder _ (EUnder _ b (ESymbol TUnder "\9140")) e1) =
  "underbrace(" <> writeExp b <> ", " <> writeExp e1 <> ")"
writeExp (EUnder _convertible b e1) =
  case e1 of
    ESymbol TUnder "_" -> "underline(" <> writeExp b <> ")"
    ESymbol TUnder "\9183" -> "underbrace(" <> writeExp b <> ")"
    ESymbol TUnder "\9140" -> "underbracket(" <> writeExp b <> ")"
    _ -> writeExpB b <> "_" <> writeExpS e1
writeExp (EUnderover convertible b e1 e2) =
  case (e1, e2) of
    (_, ESymbol Accent _) -> writeExp (EUnder convertible (EOver False b e2) e1)
    (_, ESymbol TOver _) -> writeExp (EUnder convertible (EOver False b e2) e1)
    (ESymbol TUnder _, _) -> writeExp (EOver convertible (EUnder False b e1) e2)
    _ -> writeExpB b <> "_" <> writeExpS e1 <> "^" <> writeExpS e2
writeExp (ESqrt e) = "sqrt(" <> writeExp e <> ")"
writeExp (ERoot i e) = "root(" <> writeExp i <> ", " <> writeExp e <> ")"
writeExp (ESpace width) =
  case (floor (width * 18) :: Int) of
    0 -> "zws"
    3 -> "thin"
    4 -> "med"
    6 -> "thick"
    18 -> "quad"
    n -> "#h(" <> tshow (n `div` 18) <> "em)"
writeExp (EText ttype s) =
  case ttype of
       TextNormal -> "upright" <> inParens (inQuotes s)
       TextItalic -> "italic" <> inParens (inQuotes s)
       TextBold   -> "bold" <> inParens (inQuotes s)
       TextBoldItalic -> "bold" <> inParens ("italic" <> inParens (inQuotes s))
       TextMonospace -> "mono" <> inParens (inQuotes s)
       TextSansSerif -> "sans" <> inParens (inQuotes s)
       TextDoubleStruck -> "bb" <> inParens (inQuotes s)
       TextScript -> "cal" <> inParens (inQuotes s)
       TextFraktur -> "frak" <> inParens (inQuotes s)
       TextSansSerifBold -> "bold" <> inParens ("sans" <> inParens (inQuotes s))
       TextSansSerifBoldItalic -> "bold" <>
         inParens ("italic" <> inParens ("sans" <> inParens (inQuotes s)))
       TextBoldScript -> "bold" <> inParens ("cal" <> inParens (inQuotes s))
       TextBoldFraktur -> "bold" <> inParens ("frak" <> inParens (inQuotes s))
       TextSansSerifItalic -> "italic" <>
          inParens ("sans" <> inParens (inQuotes s))
writeExp (EStyled ttype es) =
  let contents = writeExps es
  in case ttype of
       TextNormal -> "upright" <> inParens contents
       TextItalic -> "italic" <> inParens contents
       TextBold   -> "bold" <> inParens contents
       TextBoldItalic -> "bold" <> inParens ("italic" <> inParens contents)
       TextMonospace -> "mono" <> inParens contents
       TextSansSerif -> "sans" <> inParens contents
       TextDoubleStruck -> "bb" <> inParens contents
       TextScript -> "cal" <> inParens contents
       TextFraktur -> "frak" <> inParens contents
       TextSansSerifBold -> "bold" <> inParens ("sans" <> inParens contents)
       TextSansSerifBoldItalic -> "bold" <>
         inParens ("italic" <> inParens ("sans" <> inParens contents))
       TextBoldScript -> "bold" <> inParens ("cal" <> inParens contents)
       TextBoldFraktur -> "bold" <> inParens ("frak" <> inParens contents)
       TextSansSerifItalic -> "italic" <> inParens ("sans" <> inParens contents)
writeExp (EBoxed e) = "#box([" <> writeExp e <> "])"
writeExp (EPhantom e) = "#hide[" <> writeExp e <> "]"
writeExp (EScaled size e) =
  "#scale(x: " <> tshow (floor (100 * size) :: Int) <>
          "%, y: " <> tshow (floor (100 * size) :: Int) <>
          "%)[" <> writeExp e <> "]"
writeExp (EDelimited "(" ")" [Right (EArray _aligns rows)])
  | all (\row -> length row == 1) rows = -- vector
  "vec(" <> mkArray (transpose rows) <> ")"
writeExp (EDelimited "(" ")" [Right (EArray _aligns [[xs],[ys]])]) =
  "binom(" <> writeExps xs <> ", " <> writeExps ys <> ")"
writeExp (EDelimited "(" ")" [Right (EArray _aligns rows)]) =
  "mat(delim: \"(\", " <> mkArray rows <> ")"
writeExp (EDelimited "[" "]" [Right (EArray _aligns rows)]) =
  "mat(delim: \"[\", " <> mkArray rows <> ")"
writeExp (EDelimited "{" "}" [Right (EArray _aligns rows)]) =
  "mat(delim: \"{\", " <> mkArray rows <> ")"
writeExp (EDelimited "|" "|" [Right (EArray _aligns rows)]) =
  "mat(delim: \"|\", " <> mkArray rows <> ")"
writeExp (EDelimited "||" "||" [Right (EArray _aligns rows)]) =
  "mat(delim: \"||\", " <> mkArray rows <> ")"
writeExp (EDelimited "\x2223" "\x2223" [Right (EArray _aligns rows)]) =
  "mat(delim: \"||\", " <> mkArray rows <> ")"
writeExp (EDelimited "\x2225" "\x2225" [Right (EArray _aligns rows)]) =
  "mat(delim: \"||\", " <> mkArray rows <> ")"
writeExp (EDelimited op "" [Right (EArray [AlignLeft, AlignLeft] rows)]) =
  "cases" <> inParens("delim: " <> inQuotes op <> mconcat (map toCase rows))
   where toCase = (", " <>) . T.intercalate " & " . map writeExps
writeExp (EDelimited open close es) =
  if isDelim open && isDelim close
     then "lr" <> inParens (open <> body <> close)
     else esc open <> body <> esc close
  where fromDelimited (Left e)  = e
        fromDelimited (Right e) = writeExp e
        isDelim c = c `elem` ["(",")","[","]","{","}","|","||"]
        body = T.unwords (map fromDelimited es)
writeExp (EArray _aligns rows)
  = T.intercalate "\\\n" $ map mkRow rows
     where mkRow = T.intercalate " & " . map writeExps

mkArray :: [[[Exp]]] -> Text
mkArray rows =
  T.intercalate "; " $ map mkRow rows
 where
   mkRow = T.intercalate ", " . map mkCell
   mkCell = writeExps

tshow :: Show a => a -> Text
tshow = T.pack . show

typstSymbolMap :: M.Map Text Text
typstSymbolMap = M.fromList [(s,name) | (name, _, s) <- typstSymbols]