summaryrefslogtreecommitdiff
path: root/indexing/hsindex/src/HsIndex/Parser.hs
diff options
context:
space:
mode:
Diffstat (limited to 'indexing/hsindex/src/HsIndex/Parser.hs')
-rw-r--r--indexing/hsindex/src/HsIndex/Parser.hs542
1 files changed, 542 insertions, 0 deletions
diff --git a/indexing/hsindex/src/HsIndex/Parser.hs b/indexing/hsindex/src/HsIndex/Parser.hs
new file mode 100644
index 0000000000..35063ab43b
--- /dev/null
+++ b/indexing/hsindex/src/HsIndex/Parser.hs
@@ -0,0 +1,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 [] []
+
+