summaryrefslogtreecommitdiff
path: root/indexing/hsindex/src/HsIndex/Parser.hs
blob: 35063ab43b5d6ad9d7988d4af7a9fc760ac386b7 (plain)
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
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
-- |
-- Module      :  HsIndex.Parser
-- Copyright   :  Jean-Luc JOULIN 2018-2020
-- License     :  General Public Licence (GPLv3)
-- Maintainer  :  Jean-Luc JOULIN  <jean-luc-joulin@orange.fr>
-- Stability   :  alpha
-- Portability :  portable
-- The parsing functions for the hsindex program.



module HsIndex.Parser
  (
  -- * Parsing the index file


  -- * Parsing the style file


  -- * Parsing the custom language definition file
  --
  -- ** Description of a custom file
  --
  -- A custom language can be defined with a specific file.
  -- This file must respect the following format and contain in any order :
  --
  -- 1. A mandatory ordered list of letters describing the alphabet.
  --
  --        > LETTERS
  --        > abcdefghijkl
  --
  -- 2. An optional ordered list of numbers.
  --
  --        > NUMBERS
  --        > 0123456789
  --
  -- 3. An optional ordered list of symbols.
  --
  --        > SYMBOLS
  --        > 0123456789
  --
  -- 4. An optional substitution list. This list describe the character substitutions
  --    to perform before sorting the words.
  --
  --        > SUBSTITUTIONS
  --        > œ->oe
  --        > à->a
  --        > ê->e
  --
  -- ** example of custom file
  --
  --
    styleBasic
  , styleDoubleHeading
  , parseStyleFile
  , parseLanguageFile
  , parseIndexFile
  , emptyDef
  ) where


import           Data.Char
import           Data.Functor.Identity
import           Data.Functor
import           HsIndex.CharLists.French
import           HsIndex.CharLists.Russian
import           HsIndex.CharLists.SubsIEC
import           HsIndex.CharLists.Symbols
import           HsIndex.Functions
                            ( literalNewLine
                            -- ~ , upperLower
                            -- ~ , replaUpperLower
                            , sepArobase
                            )
import           HsIndex.Types
import qualified Data.Text                     as T
import           Text.Parsec
import           Text.Parsec.Perm
import           Text.Parsec.Text



-- | The default 'IndexStyle' applied to an index.
--
-- This default style have :
--
-- * Basic preamble and postamble
--
-- * Uppercase Layer 0 heading
--
-- * No Layer 1 heading
--
styleBasic = IndexStyle
  { idxPreamble     = T.pack "\\begin{theindex}\n"
  , idxPostamble    = T.pack "\n\n\\end{theindex}\n"
  , idxHeadingFlag0 = UpperCase
  , idxHeadingFlag1 = None
  , idxHeadingPreL0 = T.pack "{\\vspace{1.5cm}\\huge{\\textbf{"
  , idxHeadingSufL0 = T.pack "}}\\hfill}\\nopagebreak\n"
  , idxHeadingPreL1 = T.pack "" -- TODO Remplacer par empty
  , idxHeadingSufL1 = T.pack ""
  , idxSymhead      = T.pack "Symbols"
  , idxNumhead      = T.pack "Numbers"
  , idxGroupSkip0   = T.pack "\n \\indexspace\n" -- "\n\n \\indexspace\n"
  , idxGroupSkip1   = T.pack ""
  , idxItem0        = T.pack "\n \\item "
  , idxItem1        = T.pack "\n \\subitem "
  , idxItem2        = T.pack "\n \\subsubitem "
  , idxItem01       = T.pack "\n \\subitem "
  , idxItem12       = T.pack "\n \\subsubitem "
  , idxDelim0       = T.pack ", " -- \\hfill
  , idxDelim1       = T.pack ", "
  , idxDelim2       = T.pack ", "
  , idxDelimn       = T.pack ", "
  , idxDelimr       = T.pack "--"
  , idxEncapPre     = T.pack "{"
  , idxEncapSuf     = T.pack "}"
  }


-- | Another 'IndexStyle' applied to an index.
--
-- This default style have :
--
-- * Basic preamble and postamble
--
-- * Uppercase Layer 0 headings
--
-- * Uppercase Layer 1 headings
--
styleDoubleHeading = IndexStyle
  { idxPreamble     = T.pack "\\begin{theindex}\n"
  , idxPostamble    = T.pack "\n\n\\end{theindex}\n"
  , idxHeadingFlag0 = UpperCase
  , idxHeadingFlag1 = UpperCase
  , idxHeadingPreL0 = T.pack "{\\vspace{1.5cm}\\huge{\\textbf{"
  , idxHeadingSufL0 = T.pack "}}\\hfill}\\nopagebreak\n\n"
  , idxHeadingPreL1 = T.pack "\n{\\vspace{0.5cm}\\large{\\textbf{"
  , idxHeadingSufL1 = T.pack "}}\\hfill}\\nopagebreak"
  , idxSymhead      = T.pack "Symbols"
  , idxNumhead      = T.pack "Numbers"
  , idxGroupSkip0   = T.pack "\n\n \\indexspace\n"
  , idxGroupSkip1   = T.pack "\n\n \\indexspace\n"
  , idxItem0        = T.pack "\n \\item "
  , idxItem1        = T.pack "\n \\subitem "
  , idxItem2        = T.pack "\n \\subsubitem "
  , idxItem01       = T.pack "\n \\subitem "
  , idxItem12       = T.pack "\n \\subsubitem "
  , idxDelim0       = T.pack ", " -- \\hfill
  , idxDelim1       = T.pack ", "
  , idxDelim2       = T.pack ", "
  , idxDelimn       = T.pack ", "
  , idxDelimr       = T.pack "--"
  , idxEncapPre     = T.pack "{"
  , idxEncapSuf     = T.pack "}"
  }


-- | Parse a style file
--
-- A style file can contain several optional keywords definition to set the design
-- of an index.
-- 
--  Keywords can be :
--
-- [preamble] To set the beginning of the index.
--
--
-- [postamble] To set the end of the index.
--
parseStyleFile :: IndexStyle                            -- ^ The default 'Style' to use.
               -> ParsecT String () Identity IndexStyle -- ^ The new 'Style' parsed.
parseStyleFile sty = do
  emptyLines -- Possibles emptylines at the beginning of the file
  sty <- permute
    (    IndexStyle -- all possible permutations
    <$?> (idxPreamble sty    , try $ parseStyleDef "preamble") -- Parse the preamble
    <|?> (idxPostamble sty   , try $ parseStyleDef "postamble")
    <|?> (idxHeadingFlag0 sty, try $ parseStyleDefHead "headings_flag")
    <|?> (idxHeadingFlag1 sty, try $ parseStyleDefHead "headings_flag1")
    <|?> (idxHeadingPreL0 sty, try $ parseStyleDef "heading_prefix")
    <|?> (idxHeadingSufL0 sty, try $ parseStyleDef "heading_suffix")
    <|?> (idxHeadingPreL1 sty, try $ parseStyleDef "heading_prefix1")
    <|?> (idxHeadingSufL1 sty, try $ parseStyleDef "heading_suffix1")
    <|?> (idxSymhead sty     , try $ parseStyleDef "symhead_positive")
    <|?> (idxNumhead sty     , try $ parseStyleDef "numhead_positive")
    <|?> (idxGroupSkip0 sty  , try $ parseStyleDef "group_skip")
    <|?> (idxGroupSkip1 sty  , try $ parseStyleDef "group_skip1")
    <|?> (idxItem0 sty       , try $ parseStyleDef "item_0")
    <|?> (idxItem1 sty       , try $ parseStyleDef "item_1")
    <|?> (idxItem2 sty       , try $ parseStyleDef "item_2")
    <|?> (idxItem01 sty      , try $ parseStyleDef "item_01")
    <|?> (idxItem12 sty      , try $ parseStyleDef "item_12")
    <|?> (idxDelim0 sty      , try $ parseStyleDef "delim_0")
    <|?> (idxDelim1 sty      , try $ parseStyleDef "delim_1")
    <|?> (idxDelim2 sty      , try $ parseStyleDef "delim_2")
    <|?> (idxDelimn sty      , try $ parseStyleDef "delim_n")
    <|?> (idxDelimr sty      , try $ parseStyleDef "delim_r")
    <|?> (idxEncapPre sty    , try $ parseStyleDef "encap_infix")
    <|?> (idxEncapSuf sty    , try $ parseStyleDef "encap_suffix")

    )
  eof -- the end of file
  return sty


-- | Parse many empty lines.
emptyLines = many emptyLine


-- | Parse an empty line.
emptyLine = do
  many (oneOf " \t") -- possibly some spaces and tabulations.
  endOfLineP         -- The end of line


-- | Parse a style definition
--
-- > item_0 "my style definition"
--
parseStyleDef :: String                             -- ^ The name of the style
              -> ParsecT String () Identity  T.Text -- ^ The definition of the style.
parseStyleDef str = do
  string str
  many1 (char ' ')
  def <- between (char '"') (char '"') (many1 $ noneOf "\r\n\t\"")
  many (char ' ')
  endOfLineP
  emptyLines
  return (literalNewLine $ T.pack def)



parseStyleDefHead str = try (parseStyleDefHeadNum str) 
                    <|> try (parseStyleDefHeadNone str) 
                    <|> try (parseStyleDefHeadUpper str) 
                    <|>     (parseStyleDefHeadLower str)



parseStyleDefHeadNone :: String -> ParsecT String () Identity Heading
parseStyleDefHeadNone str = do
  string str
  many1 (char ' ')
  s <- string "None"
  many (char ' ')
  endOfLineP
  emptyLines
  return None


parseStyleDefHeadUpper :: String -> ParsecT String () Identity Heading
parseStyleDefHeadUpper str = do
  string str
  many1 (char ' ')
  s <- string "Upper"
  many (char ' ')
  endOfLineP
  emptyLines
  return UpperCase


parseStyleDefHeadLower :: String -> ParsecT String () Identity Heading
parseStyleDefHeadLower str = do
  string str
  many1 (char ' ')
  s <- string "Lower"
  many (char ' ')
  endOfLineP
  emptyLines
  return LowerCase


parseStyleDefHeadNum :: String -> ParsecT String () Identity Heading
parseStyleDefHeadNum str = do
  string str
  many1 (char ' ')
  s <- option ' ' (char '-')
  h <- many1 digit
  many (char ' ')
  endOfLineP
  emptyLines
  return (val2Heading (read (s : h)))



val2Heading 0 = None
val2Heading n = if n > 0 
  then UpperCase 
  else LowerCase


-- | Try to parse a IeC LaTeX substitution.
-- Return the associated character if succeed.
lstParseIeC lst = try $ do
  string "\\IeC"
  many (char ' ')
  choice $ map (\(s, r) ->
          (try $ do
             braces $ do
                many (char ' ')
                char '\\'
                string s
                many (char ' ')
                return r
          )) lst




-- | Parse a number
parseNumber :: ParsecT String () Identity Char
parseNumber = try digit

-- | Parse a symbol
parseSymbol :: ParsecT String () Identity Char
parseSymbol = try (oneOf allowedSymb)


-- | Parse an hyphen character
parseHyph :: ParsecT String () Identity Char
parseHyph = try (oneOf lstHyph)


parseAnything :: ParsecT String () Identity Char
parseAnything = try (noneOf forbiddenSymb)



braces = between (char '{') (char '}')

braces' = between (char '{') (try $ do char '}';lookAhead (char '{' ))


-- | Parse a single entry command from "imakeidx" LaTeX package.
parseIDX :: ParsecT String () Identity Char -> ParsecT String () Identity IndexItem
parseIDX pars = do
  string "\\indexentry"
  many (char ' ')
  ((itm,itmE),com) <- braces'
    (do
      itm <- sepArobase <$> many1 (notFollowedBy (do char '}';char '{') >> pars)
      com <- option "" $ try $do
                   char '|'
                   optional (char '(')
                   many (notFollowedBy (do char '}';char '{') >> parseAnything)
      return (itm,com)
    )
  many (char ' ')
  n <- braces (many1 digit)
  return (IndexItem (T.pack itm) (Letters, T.pack itmE) (T.pack com) [read n] [])


-- | Parse a entry command containing a subentry from "imakeidx" LaTeX package.
parseIDXSub :: ParsecT String () Identity Char -> ParsecT String () Identity IndexItem
parseIDXSub pars = do
  string "\\indexentry"
  many (char ' ')
  ((itm,itmE), (sub,subE),com) <- braces'
    (do
      itm <- sepArobase <$> many1 (notFollowedBy (do char '}';char '{') >> pars)
      char '!'
      sub <- sepArobase <$> many1 (notFollowedBy (do char '}';char '{') >> pars)
      -- ~ string "|hyperpage"
      com <- option "" $ try $do
                   char '|'
                   optional (char '(')
                   many (notFollowedBy (do char '}';char '{') >> parseAnything)
      return (itm, sub,com)
    )
  many (char ' ')
  n <- braces (many1 digit)
  return (IndexItem (T.pack itm) (Letters, T.pack itmE) T.empty [] [IndexSubItem (T.pack sub) (Letters, T.pack subE) (T.pack com) [read n] []])


-- | Parse a entry command containing a subsubentry from "imakeidx" LaTeX package.
parseIDXSubSub :: ParsecT String () Identity Char -> ParsecT String () Identity IndexItem
parseIDXSubSub pars = do
  string "\\indexentry"
  many (char ' ')
  ((itm,itmE), (sub,subE), (ssub,ssubE),com) <- braces'
    (do
      itm <- sepArobase <$> many1 (notFollowedBy (do char '}';char '{') >> pars)
      char '!'
      sub <- sepArobase <$> many1 (notFollowedBy (do char '}';char '{') >> pars)
      char '!'
      ssub <- sepArobase <$> many1 (notFollowedBy (do char '}';char '{') >> pars)
      -- ~ string "|hyperpage"
      com <- option "" $ try $ do
                   char '|'
                   optional (char '(')
                   many (notFollowedBy (do char '}';char '{') >> parseAnything)
      return (itm, sub, ssub,com)
    )
  many (char ' ')
  n <- braces (many1 digit)
  return (IndexItem (T.pack itm) (Letters, T.pack itmE) T.empty [] [IndexSubItem (T.pack sub) (Letters, T.pack subE) T.empty [] [IndexSubSubItem (T.pack ssub) (Letters, T.pack ssubE) (T.pack com)  [read n]]])


-- | Parse all possible forms of entry from "imakeidx" LaTeX package.
parseIndexItem pars = try (parseIDXSubSub pars) 
                  <|> try (parseIDXSub pars) 
                  <|>      parseIDX pars


parseIndexFile :: ParsecT String () Identity [IndexItem]
parseIndexFile = do
  emptyLines
  itms <- endBy (parseIndexItem parseCharL) endOfLineP
  emptyLines
  eof
  return itms




-- | Parse a end of line in both UNIX and WINDOWS format.
-- ~ endOfLineP :: ParsecT String () Identity String
endOfLineP = try (string "\n")    -- Fin de ligne Unix/Linux (LF : Line feed)
         <|> try (string "\r\n")  -- Fin de ligne Windows (CRLF : Carriage return Line feed)



-- | Standard parser for chars.
--
-- Try to parse :
--
-- 1. The specific char output from the "imakeidx" LaTeX package.
--
-- 2. Numbers
--
-- 3. 
parseCharL :: ParsecT String () Identity Char
parseCharL =  lstParseIeC lstLaTeXSubs
          <|>  parseAnything




-- | Parse a file containing the lists of chars defining a language.
--
parseLanguageFile ::  ParsecT String PermState Identity LangDef
parseLanguageFile = do
  emptyLines -- Possibles emptylines at the beginning of the file
  -- ~ putState emptyPermState
  def <- permute
    (    (\a b c d -> LangDef a b c d []) -- all possible permutations
    <$$> try (parseCharDefLetters ) -- <$$>
    <|?> ([], try $ parseCharDefNumbers )
    <|?> (Nothing, try $ parseCharDefSymbols )
    <|?> ([], try $ parseSubstitutions )
    )
  eof -- the end of file
  stat <- getState
  return def{lstSecOrder=order stat}


-- | Parse a char list definition.
--
-- A char list is defined by:
--
-- * A title
--
-- * A list of chars describing the sorting order of letters of this language.
--
parseCharDefLetters  = do
  string "LETTERS"
  endOfLineP
  chrs <- many (noneOf "\n\t")
  endOfLineP
  emptyLines
  modifyState (\st -> st{order=order st++[Letters]})
  return ( chrs)


parseCharDefNumbers  = do
  string "NUMBERS"
  endOfLineP
  chrs <- many (noneOf "\n\t")
  endOfLineP
  emptyLines
  modifyState (\st -> st{order=order st++[Numbers]})
  return ( chrs)


-- | Parse a char list definition.
--
-- A char list is defined by:
--
-- * A title
--
-- * A list of chars describing the sorting order of letters of this language.
--
parseCharDefSymbols  = do
  string "SYMBOLS"
  endOfLineP
  chrs <- many (noneOf "\n\t")
  endOfLineP
  emptyLines
  modifyState (\st -> st{order=order st++[Symbols]})
  return (Just ( chrs))


-- | Parse a list of substitutions
--
--  A substitution give an equivalent string to a char. A list of substitution is defined by :
--
-- * A title
--
-- * A list of substitutions :
--
--     > œ->oe
--     > à->a
--     > ê->e
--
-- note: The arrow -> musn't be preceded or followed by spaces.
--
-- A special char can be substituted by a space with the following substitution.
--
--     > _-> 
--     > --> 
--
parseSubstitutions  = do
  string "SUBSTITUTIONS"
  endOfLineP
  repl <- many1 parseSubstitution
  emptyLines
  return repl -- (replaUpperLower repl)

parseSubstitution = do
  cha <- noneOf "\r\n\t"
  string "->"
  str <- many1 (noneOf "\r\n\t")
  -- many (char ' ')
  endOfLineP
  return (cha, str)


-- | The empty list of chars.
emptyDef = LangDef [] [] Nothing [] []