1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
|
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Main where
import Text.TeXMath
import Data.Char (isSpace)
import Text.XML.Light
import System.IO
import System.Environment
import System.Console.GetOpt
import System.Exit
import Data.Maybe
import Text.Pandoc.Definition
import Network.URI (unEscapeString)
import Data.Aeson (encode, (.=), object)
import qualified Data.ByteString.Lazy as B
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Data.Version ( showVersion )
import Text.Show.Pretty (ppShow)
import Paths_texmath (version)
tshow :: Show a => a -> T.Text
tshow = T.pack . ppShow
inHtml :: Element -> Element
inHtml e =
add_attr (Attr (unqual "xmlns") "http://www.w3.org/1999/xhtml") $
unode "html"
[ unode "head" $
add_attr (Attr (unqual "content") "application/xhtml+xml; charset=UTF-8") $
add_attr (Attr (unqual "http-equiv") "Content-Type") $
unode "meta" ()
, unode "body" e ]
type Reader = T.Text -> Either T.Text [Exp]
data Writer = XMLWriter (DisplayType -> [Exp] -> Element)
| StringWriter (DisplayType -> [Exp] -> T.Text)
| PandocWriter (DisplayType -> [Exp] -> Maybe [Inline])
readers :: [(T.Text, Reader)]
readers = [
("tex", readTeX)
, ("mathml", readMathML)
, ("omml", readOMML)
, ("native", readNative)]
readNative :: T.Text -> Either T.Text [Exp]
readNative s =
case reads (T.unpack s) of
((exps, ws):_) | all isSpace ws -> Right exps
((_, (_:_)):_) -> Left "Could not read whole input as native Exp"
_ -> Left "Could not read input as native Exp"
writers :: [(T.Text, Writer)]
writers = [
("native", StringWriter (\_ es -> tshow es) )
, ("tex", StringWriter (\_ -> writeTeX))
, ("eqn", StringWriter writeEqn)
, ("typst", StringWriter writeTypst)
, ("omml", XMLWriter writeOMML)
, ("xhtml", XMLWriter (\dt e -> inHtml (writeMathML dt e)))
, ("mathml", XMLWriter writeMathML)
, ("pandoc", PandocWriter writePandoc)]
data Options = Options {
optDisplay :: DisplayType
, optIn :: T.Text
, optOut :: T.Text }
def :: Options
def = Options DisplayBlock "tex" "mathml"
options :: [OptDescr (Options -> IO Options)]
options =
[ Option [] ["inline"]
(NoArg (\opts -> return opts {optDisplay = DisplayInline}))
"Use the inline display style"
, Option "f" ["from"]
(ReqArg (\s opts -> return opts {optIn = T.pack s}) "FORMAT")
("Input format: " <> T.unpack (T.intercalate ", " (map fst readers)))
, Option "t" ["to"]
(ReqArg (\s opts -> return opts {optOut = T.pack s}) "FORMAT")
("Output format: " <> T.unpack (T.intercalate ", " (map fst writers)))
, Option "v" ["version"]
(NoArg (\_ -> do
hPutStrLn stderr $ "Version " <> showVersion version
exitWith ExitSuccess))
"Print version"
, Option "h" ["help"]
(NoArg (\_ -> do
prg <- getProgName
hPutStrLn stderr (usageInfo (prg <> " [OPTIONS] [FILE*]") options)
exitWith ExitSuccess))
"Show help"
]
output :: DisplayType -> Writer -> [Exp] -> T.Text
output dt (XMLWriter w) es = output dt (StringWriter (\dt' -> T.pack . ppElement . w dt' )) es
output dt (StringWriter w) es = w dt es
output dt (PandocWriter w) es = tshow (fromMaybe fallback (w dt es))
where fallback = [Math mt $ writeTeX es]
mt = case dt of
DisplayBlock -> DisplayMath
DisplayInline -> InlineMath
err :: Bool -> Int -> T.Text -> IO a
err cgi code msg = do
if cgi
then B.putStr $ encode $ object ["error" .= msg]
else T.hPutStrLn stderr msg
exitWith $ ExitFailure code
ensureFinalNewline :: T.Text -> T.Text
ensureFinalNewline xs = case T.unsnoc xs of
Nothing -> xs
Just (_, '\n') -> xs
_ -> xs <> "\n"
urlUnencode :: T.Text -> T.Text
urlUnencode = T.pack . unEscapeString . plusToSpace . T.unpack
where plusToSpace ('+':xs) = "%20" <> plusToSpace xs
plusToSpace (x:xs) = x : plusToSpace xs
plusToSpace [] = []
main :: IO ()
main = do
progname <- getProgName
let cgi = progname == "texmath-cgi"
if cgi
then runCGI
else runCommandLine
runCommandLine :: IO ()
runCommandLine = do
args <- getArgs
let (actions, files, _) = getOpt RequireOrder options args
opts <- foldl (>>=) (return def) actions
inp <- case files of
[] -> T.getContents
_ -> T.concat <$> mapM T.readFile files
reader <- case lookup (optIn opts) readers of
Just r -> return r
Nothing -> err False 3 "Unrecognised reader"
writer <- case lookup (optOut opts) writers of
Just w -> return w
Nothing -> err False 5 "Unrecognised writer"
case reader inp of
Left msg -> err False 1 msg
Right v -> T.putStr $ ensureFinalNewline
$ output (optDisplay opts) writer v
exitWith ExitSuccess
runCGI :: IO ()
runCGI = do
query <- T.getContents
let topairs xs = case T.break (=='=') xs of
(ys, zs) -> case T.uncons zs of
Just ('=', zs') -> (urlUnencode ys, urlUnencode zs')
_ -> (urlUnencode ys, "")
let pairs = map topairs $ T.split (== '&') query
inp <- case lookup "input" pairs of
Just x -> return x
Nothing -> err True 3 "Query missing 'input'"
reader <- case lookup "from" pairs of
Just x -> case lookup x readers of
Just y -> return y
Nothing -> err True 5 "Unsupported value of 'from'"
Nothing -> err True 3 "Query missing 'from'"
writer <- case lookup "to" pairs of
Just x -> case lookup x writers of
Just y -> return y
Nothing -> err True 7 "Unsupported value of 'to'"
Nothing -> err True 3 "Query missing 'to'"
let inline = isJust $ lookup "inline" pairs
putStr "Content-type: text/json; charset=UTF-8\n\n"
case reader inp of
Left msg -> err True 1 msg
Right v -> B.putStr $ encode $ object
[ "success" .=
ensureFinalNewline (output
(if inline
then DisplayInline
else DisplayBlock) writer v) ]
exitWith ExitSuccess
|
