File: Macros.hs

package info (click to toggle)
haskell-texmath 0.6.6.1-1
  • links: PTS, VCS
  • area: main
  • in suites: jessie, jessie-kfreebsd
  • size: 780 kB
  • ctags: 2
  • sloc: haskell: 1,726; sh: 32; makefile: 4
file content (223 lines) | stat: -rw-r--r-- 7,221 bytes parent folder | download
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
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
{-# LANGUAGE RankNTypes #-}
{-
Copyright (C) 2010 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
-}

{- | Functions for parsing LaTeX macro definitions and applying macros
 to LateX expressions.
-}

module Text.TeXMath.Macros ( Macro
                           , parseMacroDefinitions
                           , applyMacros
                           )
where

import Data.Char (isDigit, isLetter)
import Control.Monad
import Text.ParserCombinators.Parsec

data Macro = Macro { macroDefinition :: String
                   , macroParser     :: forall st . GenParser Char st String }

instance Show Macro where
  show m = "Macro " ++ show (macroDefinition m)

-- | Parses a string for a list of macro definitions, optionally
-- separated and ended by spaces and TeX comments.  Returns
-- the list of macros (which may be empty) and the unparsed
-- portion of the input string.
parseMacroDefinitions :: String -> ([Macro], String)
parseMacroDefinitions s =
  case parse pMacroDefinitions "input" s of
       Left _       -> ([], s)
       Right res    -> res

-- | Parses one or more macro definitions separated by comments & space.
-- Return list of macros parsed + remainder of string.
pMacroDefinitions :: GenParser Char st ([Macro], String)
pMacroDefinitions = do
  defs <- sepEndBy pMacroDefinition pSkipSpaceComments
  rest <- getInput
  return (reverse defs, rest)  -- reversed so later macros shadow earlier

-- | Parses a @\\newcommand@ or @\\renewcommand@ macro definition and
-- returns a 'Macro'.
pMacroDefinition :: GenParser Char st Macro
pMacroDefinition = newcommand <|> declareMathOperator

-- | Skip whitespace and comments.
pSkipSpaceComments :: GenParser Char st ()
pSkipSpaceComments = spaces >> skipMany (comment >> spaces)

-- | Applies a list of macros to a string recursively until a fixed
-- point is reached.  If there are several macros in the list with the
-- same name, earlier ones will shadow later ones.
applyMacros :: [Macro] -> String -> String
applyMacros [] = id
applyMacros ms = iterateToFixedPoint ((2 * length ms) + 1) $ applyMacrosOnce ms

------------------------------------------------------------------------------

iterateToFixedPoint :: Eq a => Int -> (a -> a) -> a -> a
iterateToFixedPoint 0     _ _ = error $
  "Macro application did not terminate in a reasonable time.\n" ++
  "Check your macros for loops."
iterateToFixedPoint limit f x =
  if x' == x
     then x'
     else iterateToFixedPoint (limit - 1) f x'
    where x' = f x

applyMacrosOnce :: [Macro] -> String -> String
applyMacrosOnce ms s =
  case parse (many tok) "input" s of
       Right r -> concat r
       Left _  -> s  -- just return original on error
    where tok = try $ do
                  skipComment
                  choice [ choice (map macroParser ms)
                         , ctrlseq
                         , count 1 anyChar ]

ctrlseq :: GenParser Char st String
ctrlseq = do
          char '\\'
          res <- many1 letter <|> count 1 anyChar
          return $ '\\' : res

newcommand :: GenParser Char st Macro
newcommand = try $ do
  char '\\'
  -- we ignore differences between these so far:
  try (string "newcommand")
    <|> try (string "renewcommand")
    <|> string "providecommand"
  pSkipSpaceComments
  name <- inbraces <|> ctrlseq
  guard (take 1 name == "\\")
  let name' = drop 1 name
  pSkipSpaceComments
  numargs <- numArgs
  pSkipSpaceComments
  optarg <- if numargs > 0
               then optArg
               else return Nothing
  let numargs' = case optarg of
                   Just _  -> numargs - 1
                   Nothing -> numargs
  pSkipSpaceComments
  body <- inbraces <|> ctrlseq
  let defn = "\\newcommand{" ++ name ++ "}" ++
             (if numargs > 0 then ("[" ++ show numargs ++ "]") else "") ++
             case optarg of { Nothing -> ""; Just x -> "[" ++ x ++ "]"} ++
             "{" ++ body ++ "}"
  return $ Macro defn $ try $ do
    char '\\'
    string name'
    when (all isLetter name') $
      notFollowedBy letter
    pSkipSpaceComments
    opt <- case optarg of
                Nothing  -> return Nothing
                Just _   -> liftM (`mplus` optarg) optArg
    args <- count numargs' (pSkipSpaceComments >>
                  (inbraces <|> ctrlseq <|> count 1 anyChar))
    let args' = case opt of
                     Just x  -> x : args
                     Nothing -> args
    return $ apply args' $ "{" ++ body ++ "}"

-- | Parser for \DeclareMathOperator(*) command.
declareMathOperator :: GenParser Char st Macro
declareMathOperator = try $ do
  string "\\DeclareMathOperator"
  pSkipSpaceComments
  star <- option "" (string "*")
  pSkipSpaceComments
  name <- inbraces <|> ctrlseq
  guard (take 1 name == "\\")
  let name' = drop 1 name
  pSkipSpaceComments
  body <- inbraces <|> ctrlseq
  let defn = "\\DeclareMathOperator" ++ star ++ "{" ++ name ++ "}" ++
             "{" ++ body ++ "}"
  return $ Macro defn $ try $ do
    char '\\'
    string name'
    when (all isLetter name') $
      notFollowedBy letter
    pSkipSpaceComments
    return $ "\\operatorname" ++ star ++ "{" ++ body ++ "}"


apply :: [String] -> String -> String
apply args ('#':d:xs) | isDigit d =
  let argnum = read [d]
  in  if length args >= argnum
         then args !! (argnum - 1) ++ apply args xs
         else '#' : d : apply args xs
apply args ('\\':'#':xs) = '\\':'#' : apply args xs
apply args (x:xs) = x : apply args xs
apply _ "" = ""

skipComment :: GenParser Char st ()
skipComment = skipMany comment

comment :: GenParser Char st ()
comment = do
  char '%'
  skipMany (notFollowedBy newline >> anyChar)
  newline
  return ()

numArgs :: GenParser Char st Int
numArgs = option 0 $ do
  pSkipSpaceComments
  char '['
  pSkipSpaceComments
  n <- digit
  pSkipSpaceComments
  char ']'
  return $ read [n]

optArg :: GenParser Char st (Maybe String)
optArg = option Nothing $ (liftM Just $ inBrackets)

escaped :: String -> GenParser Char st String
escaped xs = try $ char '\\' >> oneOf xs >>= \x -> return ['\\',x]

inBrackets :: GenParser Char st String
inBrackets = try $ do
  char '['
  pSkipSpaceComments
  res <- manyTill (skipComment >> (escaped "[]" <|> count 1 anyChar))
          (try $ pSkipSpaceComments >> char ']')
  return $ concat res

inbraces :: GenParser Char st String
inbraces = try $ do
  char '{'
  res <- manyTill (skipComment >> (inbraces' <|> count 1 anyChar <|> escaped "{}"))
    (try $ skipComment >> char '}')
  return $ concat res

inbraces' :: GenParser Char st String
inbraces' = do
  res <- inbraces
  return $ '{' : (res ++ "}")