diff options
Diffstat (limited to 'indexing/hsindex/src')
-rw-r--r-- | indexing/hsindex/src/HsIndex/CharLists/English.hs | 34 | ||||
-rw-r--r-- | indexing/hsindex/src/HsIndex/CharLists/French.hs | 108 | ||||
-rw-r--r-- | indexing/hsindex/src/HsIndex/CharLists/German.hs | 76 | ||||
-rw-r--r-- | indexing/hsindex/src/HsIndex/CharLists/Russian.hs | 73 | ||||
-rw-r--r-- | indexing/hsindex/src/HsIndex/CharLists/SubsIEC.hs | 128 | ||||
-rw-r--r-- | indexing/hsindex/src/HsIndex/CharLists/Symbols.hs | 30 | ||||
-rw-r--r-- | indexing/hsindex/src/HsIndex/Files.hs | 156 | ||||
-rw-r--r-- | indexing/hsindex/src/HsIndex/Functions.hs | 206 | ||||
-rw-r--r-- | indexing/hsindex/src/HsIndex/Parser.hs | 542 | ||||
-rw-r--r-- | indexing/hsindex/src/HsIndex/Show.hs | 324 | ||||
-rw-r--r-- | indexing/hsindex/src/HsIndex/Sorting.hs | 246 | ||||
-rw-r--r-- | indexing/hsindex/src/HsIndex/Types.hs | 205 | ||||
-rw-r--r-- | indexing/hsindex/src/hsindex.hs | 395 |
13 files changed, 2523 insertions, 0 deletions
diff --git a/indexing/hsindex/src/HsIndex/CharLists/English.hs b/indexing/hsindex/src/HsIndex/CharLists/English.hs new file mode 100644 index 0000000000..27adf8186e --- /dev/null +++ b/indexing/hsindex/src/HsIndex/CharLists/English.hs @@ -0,0 +1,34 @@ +-- | +-- Module : HsIndex.CharLists.English +-- Copyright : Jean-Luc JOULIN 2018-2019 +-- License : General Public Licence (GPLv3) +-- Maintainer : Jean-Luc JOULIN <jean-luc-joulin@orange.fr> +-- Stability : alpha +-- Portability : portable +-- The letters, numbers and symbol definition for the english language. + + +module HsIndex.CharLists.English where + +import HsIndex.Types +import HsIndex.Functions +import HsIndex.CharLists.Symbols +import HsIndex.CharLists.French + + + +ordEnglish = lstLatinLetter + +ordEnglishUpperLower = upperLower lstLatinLetter + + +-- | +langDefEnglish :: LangDef +langDefEnglish = LangDef + { lstLetters = lstSpace ++ ordEnglishUpperLower + , lstNumbers = lstDigit + , lstSymbols = Nothing + , lstSubs = subsFrenchUpperLower++subsSymb + , lstSecOrder = [Symbols, Numbers, Letters] + } + diff --git a/indexing/hsindex/src/HsIndex/CharLists/French.hs b/indexing/hsindex/src/HsIndex/CharLists/French.hs new file mode 100644 index 0000000000..a2b54e0a54 --- /dev/null +++ b/indexing/hsindex/src/HsIndex/CharLists/French.hs @@ -0,0 +1,108 @@ +-- | +-- Module : HsIndex.CharLists.French +-- Copyright : Jean-Luc JOULIN 2018-2019 +-- License : General Public Licence (GPLv3) +-- Maintainer : Jean-Luc JOULIN <jean-luc-joulin@orange.fr> +-- Stability : alpha +-- Portability : portable +-- The letters, numbers and symbol definition for the french language. + + +module HsIndex.CharLists.French where + +import HsIndex.Functions +import HsIndex.CharLists.Symbols +import HsIndex.Types + +lstSubsLatin = take 1 + + +ordFrench = lstLatinLetter + +ordFrenchUpperLower = upperLower lstLatinLetter + + + + +lstLatinLetter = + [ 'a' + , 'b' + , 'c' + , 'd' + , 'e' + , 'f' + , 'g' + , 'h' + , 'i' + , 'j' + , 'k' + , 'l' + , 'm' + , 'n' + , 'o' + , 'p' + , 'q' + , 'r' + , 's' + , 't' + , 'u' + , 'v' + , 'w' + , 'x' + , 'y' + , 'z' + ] + + +subsFrenchUpperLower = replaUpperLower subsFrench + + + + +subsFrench = + [ ('à', "a") + , ('â', "a") + , ('å', "a") + , ('ä', "a") + + , ('ç', "c") + + , ('é', "e") + , ('è', "e") + , ('ê', "e") + , ('ë', "e") + + , ('î', "i") + , ('ï', "i") + + , ('ô', "o") + , ('ö', "o") + + , ('ù', "u") + , ('û', "u") + , ('ü', "u") + + + , ('æ', "ae") + , ('œ', "oe") + ] + + +subsSymb = + [ ('-', " ") + , ('_', " ") + , ('\\', " ") + ] + + + +langDefFrench = LangDef + { lstLetters = lstSpace ++ ordFrenchUpperLower -- ++ (map substituted subsFrenchUpperLower) + , lstNumbers = lstDigit + , lstSymbols = Nothing + , lstSubs = subsFrenchUpperLower++subsSymb + , lstSecOrder = [Symbols, Numbers, Letters] + } + + + diff --git a/indexing/hsindex/src/HsIndex/CharLists/German.hs b/indexing/hsindex/src/HsIndex/CharLists/German.hs new file mode 100644 index 0000000000..cb7df65686 --- /dev/null +++ b/indexing/hsindex/src/HsIndex/CharLists/German.hs @@ -0,0 +1,76 @@ +-- | +-- Module : HsIndex.CharLists.German +-- Copyright : Jean-Luc JOULIN 2018-2019 +-- License : General Public Licence (GPLv3) +-- Maintainer : Jean-Luc JOULIN <jean-luc-joulin@orange.fr> +-- Stability : alpha +-- Portability : portable +-- The letters, numbers and symbol definition for the german language. + + +module HsIndex.CharLists.German where + + +import HsIndex.Functions +import HsIndex.Types +import HsIndex.CharLists.Symbols +import HsIndex.CharLists.French ( lstLatinLetter ) + + + +ordGerman = lstLatinLetter + +ordGermanLowerUpper = lowerUpper lstLatinLetter + +lstGermanLetter = + [ 'a' + , 'b' + , 'c' + , 'd' + , 'e' + , 'f' + , 'g' + , 'h' + , 'i' + , 'j' + , 'k' + , 'l' + , 'm' + , 'n' + , 'o' + , 'p' + , 'q' + , 'r' + , 's' + , 'ß' + , 't' + , 'u' + , 'v' + , 'w' + , 'x' + , 'y' + , 'z' + ] + + +charSubsGerman = + [ ('æ', "ae") + , ('ä', "a") + , ('ö', "o") + , ('ß', "ss") + , ('ü', "u") + ] + + + + +langDefGerman = LangDef + { lstLetters = lstSpace ++ ordGermanLowerUpper -- ++ map substituted charSubsGerman + , lstNumbers = lstDigit + , lstSymbols = Nothing + , lstSubs = charSubsGerman + , lstSecOrder = [Symbols, Letters, Numbers] + } + + + diff --git a/indexing/hsindex/src/HsIndex/CharLists/Russian.hs b/indexing/hsindex/src/HsIndex/CharLists/Russian.hs new file mode 100644 index 0000000000..1e9c3c96dc --- /dev/null +++ b/indexing/hsindex/src/HsIndex/CharLists/Russian.hs @@ -0,0 +1,73 @@ +-- | +-- Module : HsIndex.CharLists.Russian +-- Copyright : Jean-Luc JOULIN 2018-2019 +-- License : General Public Licence (GPLv3) +-- Maintainer : Jean-Luc JOULIN <jean-luc-joulin@orange.fr> +-- Stability : alpha +-- Portability : portable +-- The letters, numbers and symbol definition for the russian language. + + +module HsIndex.CharLists.Russian where + +import HsIndex.Functions +import HsIndex.Types +import HsIndex.CharLists.Symbols + +ordRussian = lstCyrillic + +ordRussianUpperLower = upperLower lstCyrillic + +-- | List of cyrillic characters. +lstCyrillic = + [ 'а' + , 'б' + , 'в' + , 'г' + , 'д' + , 'е' + , 'ё' + , 'ж' + , 'з' + , 'и' + , 'й' + , 'к' + , 'л' + , 'м' + , 'н' + , 'о' + , 'п' + , 'р' + , 'с' + , 'т' + , 'у' + , 'ф' + , 'х' + , 'ц' + , 'ч' + , 'ш' + , 'щ' + , 'ъ' + , 'ы' + , 'ь' + , 'э' + , 'ю' + , 'я' + ] + + + + + +lettersRussian = lstCyrillic + +langDefRussian = LangDef + { lstLetters = lstSpace ++ ordRussianUpperLower + , lstNumbers = lstDigit + , lstSymbols = Nothing + , lstSubs = [] + , lstSecOrder = [Symbols, Numbers, Letters] + } + + + diff --git a/indexing/hsindex/src/HsIndex/CharLists/SubsIEC.hs b/indexing/hsindex/src/HsIndex/CharLists/SubsIEC.hs new file mode 100644 index 0000000000..33813a6ce8 --- /dev/null +++ b/indexing/hsindex/src/HsIndex/CharLists/SubsIEC.hs @@ -0,0 +1,128 @@ +-- | +-- Module : HsIndex.CharLists.SubsIEC +-- Copyright : Jean-Luc JOULIN 2018-2019 +-- License : General Public Licence (GPLv3) +-- Maintainer : Jean-Luc JOULIN <jean-luc-joulin@orange.fr> +-- Stability : alpha +-- Portability : portable +-- The list of imakeidx IEC substitution hard-coded for all languages. + + +module HsIndex.CharLists.SubsIEC where + + +-- | List of characters substitutions for parsing the 'imakeindex' output file. +lstLaTeXSubs = + [ ("'e" , 'é') + , ("`e" , 'è') + , ("^e" , 'ê') + , ("\"e" , 'ë') + , ("`a" , 'à') + , ("^a" , 'â') + , ("\"a" , 'ä') + , ("\"\\i" , 'ï') + , ("^\\i " , 'î') + , ("^u" , 'û') + , ("\"u" , 'ü') + , ("^o" , 'ô') + , ("\"o" , 'ö') + , ("'E" , 'É') + , ("`E" , 'È') + , ("^E" , 'Ê') + , ("\"E" , 'Ë') + , ("`A" , 'À') + , ("^A" , 'Â') + , ("\"A" , 'Ä') + , ("\"\\I" , 'Ï') + , ("^\\I " , 'Î') + , ("^U" , 'Û') + , ("\"U" , 'Ü') + , ("^O" , 'Ô') + , ("\"O" , 'Ö') + , ("r a" , 'å') + , ("ae" , 'æ') + , ("oe" , 'œ') + , ("c c" , 'ç') + , ("ss" , 'ß') + , ("r A" , 'Å') + , ("AE" , 'Æ') + , ("OE" , 'Œ') + , ("cyra" , 'а') + , ("cyrb" , 'б') + , ("cyrv" , 'в') + , ("cyrg" , 'г') + , ("cyrd" , 'д') + , ("cyre" , 'е') + , ("cyryo" , 'ё') + , ("cyrzh" , 'ж') + , ("cyrz" , 'з') + , ("cyri" , 'и') + , ("cyrishrt", 'й') + , ("cyrk" , 'к') + , ("cyrl" , 'л') + , ("cyrm" , 'м') + , ("cyrn" , 'н') + , ("cyro" , 'о') + , ("cyrp" , 'п') + , ("cyrr" , 'р') + , ("cyrs" , 'с') + , ("cyrt" , 'т') + , ("cyru" , 'у') + , ("cyrf" , 'ф') + , ("cyrh" , 'х') + , ("cyrc" , 'ц') + , ("cyrch" , 'ч') + , ("cyrsh" , 'ш') + , ("cyrshch" , 'щ') + , ("cyrhrdsn", 'ъ') + , ("cyrery" , 'ы') + , ("cyrsftsn", 'ь') + , ("cyrerev" , 'э') + , ("cyryu" , 'ю') + , ("cyrya" , 'я') + , ("CYRA" , 'А') + , ("CYRB" , 'Б') + , ("CYRV" , 'В') + , ("CYRG" , 'Г') + , ("CYRD" , 'Д') + , ("CYRE" , 'Е') + , ("CYRYO" , 'Ё') + , ("CYRZH" , 'Ж') + , ("CYRZ" , 'З') + , ("CYRI" , 'И') + , ("CYRISHRT", 'Й') + , ("CYRK" , 'К') + , ("CYRL" , 'Л') + , ("CYRM" , 'М') + , ("CYRN" , 'Н') + , ("CYRO" , 'О') + , ("CYRP" , 'П') + , ("CYRR" , 'Р') + , ("CYRS" , 'С') + , ("CYRT" , 'Т') + , ("CYRU" , 'У') + , ("CYRF" , 'Ф') + , ("CYRH" , 'Х') + , ("CYRC" , 'Ц') + , ("CYRCH" , 'Ч') + , ("CYRSH" , 'Ш') + , ("CYRSHCH" , 'Щ') + , ("CYRHRDSN", 'Ъ') + , ("CYRERY" , 'Ы') + , ("CYRSFTSN", 'Ь') + , ("CYREREV" , 'Э') + , ("CYRYU" , 'Ю') + , ("CYRYA" , 'Я') + + + , ("textquoteleft" , '‘') + , ("textquoteright" , '’') + , ("nobreakspace" , ' ') + + + ] + + + + + diff --git a/indexing/hsindex/src/HsIndex/CharLists/Symbols.hs b/indexing/hsindex/src/HsIndex/CharLists/Symbols.hs new file mode 100644 index 0000000000..813bacfbde --- /dev/null +++ b/indexing/hsindex/src/HsIndex/CharLists/Symbols.hs @@ -0,0 +1,30 @@ +-- | +-- Module : HsIndex.CharLists.Symbols +-- Copyright : Jean-Luc JOULIN 2018-2019 +-- License : General Public Licence (GPLv3) +-- Maintainer : Jean-Luc JOULIN <jean-luc-joulin@orange.fr> +-- Stability : alpha +-- Portability : portable +-- The list of symbols for all languages. + + +module HsIndex.CharLists.Symbols where + + +-- | Allowed symbols. +allowedSymb = " &~\"'()[]{}<>*+/`^#@°=$£µ%§:;.,?" + +-- | Forbidden symbols. +-- +-- These symbols +forbiddenSymb = "!|\n\r" -- "!|{}\n\r" + +-- | The hyphens symbols. +lstHyph = "-_" + +-- | List of digits. +lstDigit = "0123456789" + +lstSpace = " " + + diff --git a/indexing/hsindex/src/HsIndex/Files.hs b/indexing/hsindex/src/HsIndex/Files.hs new file mode 100644 index 0000000000..5f1d15c3ea --- /dev/null +++ b/indexing/hsindex/src/HsIndex/Files.hs @@ -0,0 +1,156 @@ +-- +-- GNU General Public License (GPLv3) +-- +-- THIS SOFTWARE IS PROVIDED BY THE AUTHOR(S) “AS IS” AND ANY EXPRESS OR +-- IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES +-- OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. +-- IN NO EVENT SHALL THE AUTHOR(S) BE LIABLE FOR ANY DIRECT, INDIRECT, +-- INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, +-- BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF +-- USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON +-- ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +-- (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF +-- THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +-- | +-- Module : HsIndex.Files +-- Copyright : Jean-Luc JOULIN 2018-2019 +-- License : General Public Licence (GPLv3) +-- Maintainer : Jean-Luc JOULIN <jean-luc-joulin@orange.fr> +-- Stability : alpha +-- Portability : portable +-- Module for reading input and style files. +-- +-- This module also provide the function to write output file. +-- + + + + +module HsIndex.Files + ( + -- * Read functions + readIndexFile + , readStyleFile + , readDefinitionFile + , readAllFile + + -- * Writing function + , writeIndex + ) + where + +import Data.Char +import HsIndex.Functions +import HsIndex.Show +import HsIndex.Parser +import HsIndex.Types +import Text.Parsec +import Text.Parsec.String +import System.Directory ( doesFileExist ) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Data.Functor.Identity + + +-- | Read an index input file. +readIndexFile :: FilePath -- ^ The path to the index file. + -> ParsecT String () Identity t -- ^ The parser to apply on the file to extract datas. + -> (t -> IO ()) -- ^ List of operations to perform on parsed datas. + -> IO () +readIndexFile fidx parsfun fun = do + e <- doesFileExist fidx + if e + then do + f <- readFile fidx + case parse parsfun "(stdin)" f of + Left err -> do + putStrLn $ "/!\\ ERROR reading Index file : " ++ fidx + print err + Right resu -> fun resu + else + putStrLn + $ "/!\\ ERROR the Index file : " + ++ fidx + ++ " does not exist !\n" + + +-- | Read a style input file +-- +-- If no path is provided for the style file, the standard style 'styleBasic' is applied. +-- +readStyleFile :: IndexType -- ^ The type of style. + -> (IndexStyle -> IO ()) -- ^ Operations to apply with the parsed style. + -> IO () +readStyleFile StyleBasic fun = do + putStrLn "Using the default basic style" + fun styleBasic + +readStyleFile StyleDouble fun = do + putStrLn "Using the default double letters style" + fun styleDoubleHeading + + + +readStyleFile (Stylecustom fsty) fun = do + e <- doesFileExist fsty + if e + then do + f <- readFile fsty + case parse (parseStyleFile styleBasic) "(stdin)" f of + Left err -> do + putStrLn $ "/!\\ ERROR reading Style file : " ++ fsty + print err + Right resu -> fun resu + else + putStrLn + $ "/!\\ ERROR the Style file : " + ++ fsty + ++ " does not exist !\n" + + +-- | Read a language definition input file. +readDefinitionFile :: FilePath -- ^ The path to the definition file. + -> (LangDef -> IO ()) -- ^ Operations to apply with the parsed style. + -> IO () +readDefinitionFile fdef fun = do + e <- doesFileExist fdef + if e + then do + f <- readFile fdef + case runParser (parseLanguageFile) emptyPermState "(stdin)" f of + Left err -> do + putStrLn $ "/!\\ ERROR reading Definition file : " ++ fdef + print err + Right resu -> fun resu + else + putStrLn + $ "/!\\ ERROR the Definition file : " + ++ fdef + ++ " does not exist !\n" + + +-- | Read both an index input file and style file. +-- +-- If no path is provided for the style file, the standard style 'styleBasic' is applied. +-- +readAllFile :: FilePath -- ^ The path to the index file. + -> IndexType -- ^ The type of index. + -> ParsecT String () Identity t -- ^ The parser to apply on the index file. + -> (t -> IndexStyle -> IO ()) -- ^ Operations to apply with the parsed index data and style. + -> IO () +readAllFile fidx mbfsty parsfun fun = + readIndexFile fidx parsfun (readStyleFile mbfsty . fun) + + +-- | Write the sorted entries in a output file with the format provided in the `IndexStyle`. +writeIndex :: FilePath -- ^ The path to the output file + -> IndexStyle -- ^ The style file. + -> Bool -- ^ Automatic conversion to pages ranges + -> Index -- ^ The index. + -> IO () +writeIndex file style rng sec = do + putStrLn $ "Writing index to File : " ++ file + T.writeFile file $ showIndex style rng sec + + diff --git a/indexing/hsindex/src/HsIndex/Functions.hs b/indexing/hsindex/src/HsIndex/Functions.hs new file mode 100644 index 0000000000..344a1c515e --- /dev/null +++ b/indexing/hsindex/src/HsIndex/Functions.hs @@ -0,0 +1,206 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | +-- Module : HsIndex.Files +-- Copyright : Jean-Luc JOULIN 2018-2020 +-- License : General Public Licence (GPLv3) +-- Maintainer : Jean-Luc JOULIN <jean-luc-joulin@orange.fr> +-- Stability : alpha +-- Portability : portable +-- This module provide miscellaneous functions for comparing +-- and cutting list of IndexItem + + + + +module HsIndex.Functions ( + splitIndex + , concatPagesItems + , substituteCharInString + -- ~ , upperLower + , upperLower + , lowerUpper + , replaUpper + , substituted + , literalNewLine + , replaUpperLower + , sepArobase + ) where + + +import HsIndex.Types +import Data.List +import Data.Char +import HsIndex.Show +import qualified Data.Text as T + + +-- | Convert a list of 'IndexItem's into an 'Index' by splitting the liste +-- according to the first letter of the equivalent name and section (layer 1). +-- +-- The input list of 'IndexItem' must be sorted with 'sortItems' before +-- using this function. +-- +splitIndex :: IndexStyle -- ^ The style of the 'Index'. + -> [IndexItem] -- ^ List of 'IndexItem's to sort in a 'Index'. + -> Index -- ^ The final index. +splitIndex style [] = [] +splitIndex style lst@(x : xs) = if null d + then splitIndex style f + else IndexSection tit (splitIndex' style d) : splitIndex style f + where + -- ~ (d, f) = span (\c -> areItemsEqual False (itemEqui c) (itemEqui x)) lst + (d, f) = partition (\c -> areItemsEqual False (itemEqui c) (itemEqui x)) lst + tit = showHeading1 style (itemEqui (head d)) + + +-- | Test if layer 1 equivalent names of two items are equals. +areItemsEqual :: Bool -- ^ Test is Case sensitive + -> (Section, T.Text) -- ^ First equivalent name to compare. + -> (Section, T.Text) -- ^ Second equivalent name to compare. + -> Bool +areItemsEqual True (Letters, a) (Letters, b) = T.take 1 a == T.take 1 b -- Test if the first letters are the same (Case sensitive) +areItemsEqual False (Letters, a) (Letters, b) = T.toUpper (T.take 1 a) == T.toUpper (T.take 1 b) -- Test if the first letters are the same (Case sensitive) +areItemsEqual _ (Numbers, a) (Numbers, b) = True -- Numbers are always number in L1 +areItemsEqual _ (Symbols, a) (Symbols, b) = True -- Symbols are always symbols in L1 +areItemsEqual _ _ _ = False + + +-- | Convert a list of 'IndexItem's into an 'Index' by splitting the liste +-- according to the first two letters of the equivalent name and section (layer 2). +-- +-- The input list of 'IndexItem' must be sorted with 'sortItems' before +-- using this function. +-- +splitIndex' :: IndexStyle -- ^ The style of the 'Index'. + -> [IndexItem] -- ^ List of 'IndexItem's to sort in a 'Index'. + -> [IndexSubSection] +splitIndex' style [] = [] +splitIndex' style lst@(x : xs) = if null d + then splitIndex' style f + else IndexSubSection tit d : splitIndex' style f + where + -- ~ (d, f) = span (\c -> areItemsEqual' False (itemEqui c) (itemEqui x)) lst + (d, f) = partition (\c -> areItemsEqual' False (itemEqui c) (itemEqui x)) lst + tit = showHeading2 style (itemEqui (head d)) + + +-- | Test if layer 2 equivalent names of two items are equals. +areItemsEqual' True (Letters, a) (Letters, b) = T.take 2 a == T.take 2 b -- Test if the two first letters are the same (Case sensitive) +areItemsEqual' True (Numbers, a) (Numbers, b) = T.take 1 a == T.take 1 b -- Test if the first numbers are the same (Case sensitive) +areItemsEqual' True (Symbols, a) (Symbols, b) = T.take 1 a == T.take 1 b -- Test if the first symbols are the same (Case sensitive) +areItemsEqual' False (Letters, a) (Letters, b) = T.toUpper (T.take 2 a) == T.toUpper (T.take 2 b) -- Test if the two first letters are the same (Case insensitive) +areItemsEqual' False (Numbers, a) (Numbers, b) = T.toUpper (T.take 1 a) == T.toUpper (T.take 1 b) -- Test if the first numbers are the same (Case insensitive) +areItemsEqual' False (Symbols, a) (Symbols, b) = T.toUpper (T.take 1 a) == T.toUpper (T.take 1 b) -- Test if the first symbols are the same (Case insensitive) +areItemsEqual' _ _ _ = False + + +-- | Extract the first letters of a string after letters substitutions. +firstLetters :: Int + -> T.Text + -> T.Text +firstLetters n "" = error "no letters" +firstLetters n str = T.take n str + + +-- | Substitute the string "\\n" into a String by a '\n' newline character. +literalNewLine :: T.Text -> T.Text +literalNewLine str = T.replace (T.pack "\\\\n") (T.pack "\n") str + + + +-- | Concatenate pages numbers of entries. +-- +-- Pages numbers are sorted and filtered to get each page number once. +concatPagesItems :: [IndexItem] + -> [IndexItem] +concatPagesItems [] = [] +concatPagesItems lst@(IndexItem nam equ com pag sub : xs) = IndexItem nam equ com pages subentries : concatPagesItems a + where + (p, a) = partition (\e -> itemName e == nam) xs + pages = nub $ sort $ concat $ pag : map itemPages p + subentries = concatPagesSubItems $ concat $ sub : map itemContent p + + +-- | Concatenate pages numbers of subentries. +-- +-- Pages numbers are sorted and filtered to get each page number once. +concatPagesSubItems :: [IndexSubItem] + -> [IndexSubItem] +concatPagesSubItems [] = [] +concatPagesSubItems lst@(IndexSubItem nam equ com pag subsub : xs) = IndexSubItem nam equ com pages subsubentries + : concatPagesSubItems a + where + (p, a) = partition (\e -> subItemName e == nam) xs + pages = nub $ sort $ concat $ pag : map subItemPages p + subsubentries = concatPagesSubSubItems $ concat $ subsub : map subItemContent p + + +-- | Concatenate pages numbers of subsubentries. +-- +-- Pages numbers are sorted and filtered to get each page number once. +concatPagesSubSubItems :: [IndexSubSubItem] + -> [IndexSubSubItem] +concatPagesSubSubItems [] = [] +concatPagesSubSubItems lst@(IndexSubSubItem nam equ com pag : xs) = IndexSubSubItem nam equ com pages + : concatPagesSubSubItems a + where + (p, a) = partition (\e -> subSubItemName e == nam) xs + pages = nub $ sort $ concat $ pag : map subSubItemPages p + + +-- | Substitute 'Char's listed in the 'CharSubs' list in a String +-- +-- >>> substituteCharInString [CharSubs 'œ' "oe"] "oeil" +-- +substituteCharInString :: [(Char,String)] -- ^ The list of substitutions + -> T.Text -- ^ The string where to perform substitutions + -> T.Text +substituteCharInString repl text = replaces repl text + + +-- | Set the substitutions to uppercase. +replaUpper :: [(Char, String)] -> [(Char, String)] +replaUpper = map (\(a, b) -> (toUpper a, map toUpper b)) + +-- | Set the substitutions to lowercase. +replaLower :: [(Char, String)] -> [(Char, String)] +replaLower = map (\(a, b) -> (toLower a, map toLower b)) + + + + + +upperLower [] = [] +upperLower (x : xs) = toUpper x : toLower x : upperLower xs + + +lowerUpper [] = [] +lowerUpper (x : xs) = toLower x : toUpper x : lowerUpper xs + + +replaUpperLower lst = replaUpper lst ++ replaLower lst + + +substituted (a, b) = a -- TODO A supprimer + + +replaces repl text = foldl (\t (r, s) -> T.replace (T.pack [r]) (T.pack s) t) text repl + + +sepArobase str | null item = (str, "") + | otherwise = (tail item, equ) + where + equ = takeWhile (/= '@') str + item = dropWhile (/= '@') str + + + + + + + + + + + + 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 [] [] + + diff --git a/indexing/hsindex/src/HsIndex/Show.hs b/indexing/hsindex/src/HsIndex/Show.hs new file mode 100644 index 0000000000..6bab73245c --- /dev/null +++ b/indexing/hsindex/src/HsIndex/Show.hs @@ -0,0 +1,324 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | +-- Module : HsIndex.Show +-- Copyright : Jean-Luc JOULIN 2018-2019 +-- License : General Public Licence (GPLv3) +-- Maintainer : Jean-Luc JOULIN <jean-luc-joulin@orange.fr> +-- Stability : alpha +-- Portability : portable +-- The functions to display data types. + +-- This module provide functions to + +module HsIndex.Show + ( + -- * Function to show the whole index. + showIndex + , showHeading1 + , showHeading2 + + -- * Function to show a style. + , showStyle + , showLangDef + ) where + + +import HsIndex.Types +import Data.List +import Data.Char +import qualified Data.Text as T + + + + + +-- | Convert a 'IndexStyle' into String +-- +-- This string is readable by hsindex. +-- +showStyle style = unlines + [ "preamble " ++ show (idxPreamble style) + , "postamble " ++ show (idxPostamble style) + , "headings_flag " ++ showStyleHeading (idxHeadingFlag0 style) + , "heading_prefix " ++ show (idxHeadingPreL0 style) + , "heading_suffix " ++ show (idxHeadingSufL0 style) + , "headings_flag1 " ++ showStyleHeading (idxHeadingFlag1 style) + , "heading_prefix1 " ++ show (idxHeadingPreL1 style) + , "heading_suffix1 " ++ show (idxHeadingSufL1 style) + , "symhead_positive " ++ show (idxSymhead style) + , "numhead_positive " ++ show (idxNumhead style) + , "group_skip " ++ show (idxGroupSkip0 style) + , "group_skip1 " ++ show (idxGroupSkip1 style) + , "item_0 " ++ show (idxItem0 style) + , "item_1 " ++ show (idxItem1 style) + , "item_2 " ++ show (idxItem2 style) + , "item_01 " ++ show (idxItem01 style) + , "item_12 " ++ show (idxItem12 style) + , "delim_0 " ++ show (idxDelim0 style) + , "delim_1 " ++ show (idxDelim1 style) + , "delim_2 " ++ show (idxDelim2 style) + , "delim_n " ++ show (idxDelimn style) + , "delim_r " ++ show (idxDelimr style) + , "encap_infix " ++ show (idxEncapPre style) + , "encap_suffix " ++ show (idxEncapSuf style) + ] + + +-- | Convert 'Heading' into 'String'. +showStyleHeading None = "None" +showStyleHeading UpperCase = "UpperCase" +showStyleHeading LowerCase = "LowerCase" + + +showLangDef def = unlines $ ["LETTERS", lstLetters def] ++ if null (lstNumbers def) + then [] + else + ["NUMBERS", lstNumbers def] + + ++ case lstSymbols def of + Nothing -> [] + Just sym -> ["SYMBOLS", sym] + ++ if null (lstSubs def) then [] else ["SUBSTITUTIONS"] ++ subS (lstSubs def) + + where + subS [] = [] + subS ((a, b) : xs) = (a : "->" ++ b) : subS xs + + +-- | convert an index into a 'Text' +showIndex :: IndexStyle -- ^ The index style. + -> Bool -- ^ Automatic conversion to pages ranges + -> [IndexSection] -- ^ The list of section of the index. + -> T.Text -- ^ The output string in the LaTeX format. +showIndex style rng lst = T.concat [idxPreamble style, showIndexSections style rng lst, idxPostamble style] + + +-- | convert list of 'IndexSection' into a 'Text' readable with LaTeX. +showIndexSections :: IndexStyle -- ^ The index style. + -> Bool -- ^ Automatic conversion to pages ranges + -> [IndexSection] -- ^ The list of section of the index. + -> T.Text -- ^ The output string in the LaTeX format. +showIndexSections style _ [] = T.empty +showIndexSections style rng lst = T.intercalate (idxGroupSkip0 style) (map (showIndexSection style rng) lstf) + where lstf = filter (\(IndexSection tit sub) -> not (null sub)) lst + + +showIndexSection :: IndexStyle -> Bool -> IndexSection -> T.Text +showIndexSection style rng (IndexSection "" sub) = + showIndexSubSections style rng sub +showIndexSection style rng (IndexSection tit []) = + T.concat [idxHeadingPreL0 style, tit, idxHeadingSufL0 style] +showIndexSection style rng (IndexSection tit sub) = T.concat + [ idxHeadingPreL0 style + , tit + , idxHeadingSufL0 style + , showIndexSubSections style rng sub + ] + + +-- | convert list of 'IndexSubSection' into a 'Text' readable with LaTeX. +showIndexSubSections :: IndexStyle -- ^ The index style. + -> Bool -- ^ Automatic conversion to pages ranges + -> [IndexSubSection] -- ^ The list of subsection of the index. + -> T.Text -- ^ The output string in the LaTeX format. +showIndexSubSections style _ [] = "" +showIndexSubSections style rng lst = T.intercalate + (idxGroupSkip1 style) + (map (showIndexSubSection style rng) lstf) + where lstf = filter (\(IndexSubSection tit ent) -> not (null ent)) lst + + +showIndexSubSection :: IndexStyle -> Bool -> IndexSubSection -> T.Text +showIndexSubSection style rng (IndexSubSection "" ent) = + showIndexItems style rng ent +showIndexSubSection style _ (IndexSubSection tit []) = + T.concat [idxHeadingPreL1 style, tit, idxHeadingSufL1 style] +showIndexSubSection style rng (IndexSubSection tit ent) = T.concat + [ idxHeadingPreL1 style + , tit + , idxHeadingSufL1 style + , showIndexItems style rng ent + ] + + +-- | Convert a list of 'IndexItem' into a 'Text' readable with LaTeX. +showIndexItems :: IndexStyle -- ^ The index style. + -> Bool -- ^ Automatic conversion to pages ranges + -> [IndexItem] -- ^ The list of items of the index. + -> T.Text -- ^ The output string in the LaTeX format. +showIndexItems style _ [] = "" +showIndexItems style rng (IndexItem n _ com p [] : xs) = T.concat + [ idxItem0 style + , n + , idxDelim0 style + , showPageRange style com (if rng then 3 else 1000) p + , showIndexItems style rng xs + ] +showIndexItems style rng (IndexItem n _ _ [] sub : xs) = T.concat + [ idxItem0 style + , n + , showIndexSubItems style rng sub + , showIndexItems style rng xs + ] +showIndexItems style rng (IndexItem n _ com p sub : xs) = T.concat + [ idxItem0 style + , n + , idxDelim0 style + , showPageRange style com (if rng then 3 else 1000) p + , showIndexSubItems style rng sub + , showIndexItems style rng xs + ] + + +-- | Convert an 'IndexSubItem' into a 'Text' readable with LaTeX. +-- +-- This function is a transition between entry and its subentries. +showIndexSubItems :: IndexStyle -- ^ The index style. + -> Bool -- ^ Automatic conversion to pages ranges + -> [IndexSubItem] -- ^ The list of subitems of the index. + -> T.Text -- ^ The output string in the LaTeX format. +showIndexSubItems style _ [] = "" +showIndexSubItems style rng (IndexSubItem n _ com p [] : xs) = T.concat + [ idxItem01 style + , n + , idxDelim1 style + , showPageRange style com (if rng then 3 else 1000) p + , showIndexSubItems' style rng xs + ] +showIndexSubItems style rng (IndexSubItem n _ _ [] subsub : xs) = T.concat + [ idxItem01 style + , n + , showIndexSubSubItems style rng subsub + , showIndexSubItems' style rng xs + ] +showIndexSubItems style rng (IndexSubItem n _ com p subsub : xs) = T.concat + [ idxItem01 style + , n + , idxDelim1 style + , showPageRange style com (if rng then 3 else 1000) p + , showIndexSubSubItems style rng subsub + , showIndexSubItems' style rng xs + ] + + +-- | Convert an 'IndexItem' into a 'Text' readable with LaTeX. +showIndexSubItems' :: IndexStyle -> Bool -> [IndexSubItem] -> T.Text +showIndexSubItems' style _ [] = "" +showIndexSubItems' style rng (IndexSubItem n _ com p [] : xs) = T.concat + [ idxItem1 style + , n + , idxDelim1 style + , showPageRange style com (if rng then 3 else 1000) p + , showIndexSubItems' style rng xs + ] +showIndexSubItems' style rng (IndexSubItem n _ _ [] subsub : xs) = T.concat + [ idxItem1 style + , n + , showIndexSubSubItems style rng subsub + , showIndexSubItems' style rng xs + ] +showIndexSubItems' style rng (IndexSubItem n _ com p subsub : xs) = T.concat + [ idxItem1 style + , n + , idxDelim1 style + , showPageRange style com (if rng then 3 else 1000) p + , showIndexSubSubItems style rng subsub + , showIndexSubItems' style rng xs + ] + + +-- | Convert an 'IndexSubSubItem' into a 'Text' readable with LaTeX. +-- +-- This function is a transition between subentries and its subsubentries. + +showIndexSubSubItems :: IndexStyle -- ^ The index style. + -> Bool -- ^ Automatic conversion to pages ranges + -> [IndexSubSubItem] -- ^ The list of subsubitems of the index. + -> T.Text -- ^ The output string in the LaTeX format. +showIndexSubSubItems style _ [] = "" +showIndexSubSubItems style rng (IndexSubSubItem n _ com p : xs) = T.concat + [ idxItem12 style + , n + , idxDelim2 style + , showPageRange style com (if rng then 3 else 1000) p + , showIndexSubSubItems' style rng xs + ] + + +-- | Convert an 'IndexSubSubItem' into a 'Text' usable with LaTeX. +showIndexSubSubItems' :: IndexStyle -> Bool -> [IndexSubSubItem] -> T.Text +showIndexSubSubItems' style _ [] = "" +showIndexSubSubItems' style rng (IndexSubSubItem n _ com p : xs) = T.concat + [ idxItem2 style + , n + , idxDelim2 style + , showPageRange style com (if rng then 3 else 1000) p + , showIndexSubSubItems' style rng xs + ] + + + + + + + + + +-- | Return the string of the heading (Layer 1) according to the style and +-- the equivalent name of an item. +showHeading1 :: IndexStyle -- ^ The index style. + -> (Section, T.Text) -- ^ The equivalent name. + -> T.Text +showHeading1 sty (Letters, a) | idxHeadingFlag0 sty == UpperCase = T.toUpper (T.take 1 a) + | idxHeadingFlag0 sty == LowerCase = T.toLower (T.take 1 a) + | otherwise = T.empty + +showHeading1 sty (Numbers, a) | idxHeadingFlag0 sty == UpperCase = idxNumhead sty + | idxHeadingFlag0 sty == LowerCase = idxNumhead sty + | otherwise = T.empty + +showHeading1 sty (Symbols, a) | idxHeadingFlag0 sty == UpperCase = idxSymhead sty + | idxHeadingFlag0 sty == LowerCase = idxSymhead sty + | otherwise = T.empty + + +-- | Return the string of the heading (Layer 1) according to the style and +-- the equivalent name of an item. +showHeading2 :: IndexStyle -- ^ The index style. + -> (Section, T.Text) -- ^ The equivalent name. + -> T.Text +showHeading2 sty (Letters, a) | idxHeadingFlag1 sty == UpperCase = T.toUpper (T.take 2 a) + | idxHeadingFlag1 sty == LowerCase = T.toLower (T.take 2 a) + | otherwise = T.empty + +showHeading2 sty (Numbers, a) | idxHeadingFlag1 sty == UpperCase = T.take 1 a + | idxHeadingFlag1 sty == LowerCase = T.take 1 a + | otherwise = T.empty + +showHeading2 sty (Symbols, a) | idxHeadingFlag1 sty == UpperCase = T.take 1 a + | idxHeadingFlag1 sty == LowerCase = T.take 1 a + | otherwise = T.empty + + +groupedBySuccessors [] = [] +groupedBySuccessors lst@(x : xs) = map fst ok : groupedBySuccessors (map fst nok) + where + lstC = [x ..] + (ok, nok) = span (\(a, b) -> a == b) $ zip lst lstC + + +showPageRange style com n nums = if com == T.empty + then T.intercalate (idxDelimn style) (map showRange grps) + else T.intercalate (idxDelimn style) (map showRangeCom grps) + where + showRangeCom gr = if length gr >= n + then T.concat ["\\", com, idxEncapPre style, T.pack $ show (head gr), idxDelimr style, T.pack $ show (last gr), idxEncapSuf style] + else T.intercalate (idxDelimn style) (map (\v -> T.concat ["\\", com, idxEncapPre style, T.pack $ show v, idxEncapSuf style]) gr) + + showRange gr = if length gr >= n + then T.concat [T.pack $ show (head gr), idxDelimr style, T.pack $ show (last gr)] + else T.intercalate (idxDelimn style) (map (\v -> T.concat [T.pack $ show v]) gr) + + grps = groupedBySuccessors nums + + diff --git a/indexing/hsindex/src/HsIndex/Sorting.hs b/indexing/hsindex/src/HsIndex/Sorting.hs new file mode 100644 index 0000000000..4a33259947 --- /dev/null +++ b/indexing/hsindex/src/HsIndex/Sorting.hs @@ -0,0 +1,246 @@ +-- | +-- Module : HsIndex.Sorting +-- Copyright : Jean-Luc JOULIN 2018-2019 +-- License : General Public Licence (GPLv3) +-- Maintainer : Jean-Luc JOULIN <jean-luc-joulin@orange.fr> +-- Stability : alpha +-- Portability : portable +-- The functions to sort data types. + + + +module HsIndex.Sorting where + + +import Data.List +import Data.Char +import HsIndex.Types + +import HsIndex.Functions +import qualified Data.Text as T + + + +-- | Generate the equivalent name of 'IndexItem's. +-- +-- +equivItems :: Bool -- ^ Case sensitivity. + -> LangDef -- ^ Lists of chars in each sections. + -> [IndexItem] + -> [IndexItem] +equivItems _ _ [] = [] +equivItems False cha (x : xs) + | T.head equi `elem` map toUpper (lstLetters cha) = x { itemEqui = (Letters, equi),itemContent = equivSubItems False cha (itemContent x) } : equivItems False cha xs + | T.head equi `elem` map toUpper (lstNumbers cha) = x { itemEqui = (Numbers, equi),itemContent = equivSubItems False cha (itemContent x) } : equivItems False cha xs + | otherwise = case lstSymbols cha of + Nothing -> x { itemEqui = (Symbols, equi) } : equivItems False cha xs + Just ch -> if T.head equi `elem` map toUpper ch + then x { itemEqui = (Symbols, equi) } : equivItems False cha xs + else equivItems False cha xs + where + equi = + T.toUpper $ if snd (itemEqui x) == T.empty + then substituteCharInString (lstSubs cha) (itemName x) + else snd (itemEqui x) + +equivItems True cha (x : xs) + | T.head equi `elem` lstLetters cha = x { itemEqui = (Letters, equi),itemContent = equivSubItems True cha (itemContent x) } : equivItems True cha xs + | T.head equi `elem` lstNumbers cha = x { itemEqui = (Numbers, equi),itemContent = equivSubItems True cha (itemContent x) } : equivItems True cha xs + | otherwise = case lstSymbols cha of + Nothing -> x { itemEqui = (Symbols, equi) } : equivItems True cha xs + Just ch -> if T.head equi `elem` ch + then x { itemEqui = (Symbols, equi) } : equivItems True cha xs + else equivItems True cha xs + where + equi = + if snd (itemEqui x) == T.empty + then substituteCharInString (lstSubs cha) (itemName x) + else snd (itemEqui x) + + + +equivSubItems :: Bool -- ^ Case sensitivity. + -> LangDef -- ^ Lists of chars in each sections. + -> [IndexSubItem] + -> [IndexSubItem] +equivSubItems _ _ [] = [] +equivSubItems False cha (x : xs) + | T.head equi `elem` map toUpper (lstLetters cha) = x { subItemEqui = (Letters, equi),subItemContent = equivSubSubItems False cha (subItemContent x) } : equivSubItems False cha xs + | T.head equi `elem` map toUpper (lstNumbers cha) = x { subItemEqui = (Numbers, equi),subItemContent = equivSubSubItems False cha (subItemContent x) } : equivSubItems False cha xs + | otherwise = case lstSymbols cha of + Nothing -> x { subItemEqui = (Symbols, equi) } : equivSubItems False cha xs + Just ch -> if T.head equi `elem` map toUpper ch + then x { subItemEqui = (Symbols, equi) } : equivSubItems False cha xs + else equivSubItems False cha xs + where + equi = T.toUpper $ if snd (subItemEqui x) == T.empty + then substituteCharInString (lstSubs cha) (subItemName x) + else snd (subItemEqui x) + +equivSubItems True cha (x : xs) + | T.head equi `elem` lstLetters cha = x { subItemEqui = (Letters, equi),subItemContent = equivSubSubItems True cha (subItemContent x) } : equivSubItems True cha xs + | T.head equi `elem` lstNumbers cha = x { subItemEqui = (Numbers, equi),subItemContent = equivSubSubItems True cha (subItemContent x) } : equivSubItems True cha xs + | otherwise = case lstSymbols cha of + Nothing -> x { subItemEqui = (Symbols, equi) } : equivSubItems True cha xs + Just ch -> if T.head equi `elem` ch + then x { subItemEqui = (Symbols, equi) } : equivSubItems True cha xs + else equivSubItems True cha xs + where + equi = if snd (subItemEqui x) == T.empty + then substituteCharInString (lstSubs cha) (subItemName x) + else snd (subItemEqui x) + + +equivSubSubItems :: Bool -- ^ Case sensitivity. + -> LangDef -- ^ Lists of chars in each sections. + -> [IndexSubSubItem] + -> [IndexSubSubItem] +equivSubSubItems _ _ [] = [] +equivSubSubItems False cha (x : xs) + | T.head equi `elem` map toUpper (lstLetters cha) + = x { subSubItemEqui = (Letters, equi) } : equivSubSubItems False cha xs + | T.head equi `elem` map toUpper (lstNumbers cha) + = x { subSubItemEqui = (Numbers, equi) } : equivSubSubItems False cha xs + | otherwise + = case lstSymbols cha of + Nothing -> x { subSubItemEqui = (Symbols, equi) } : equivSubSubItems False cha xs + Just ch -> if T.head equi `elem` map toUpper ch + then x { subSubItemEqui = (Symbols, equi) } : equivSubSubItems False cha xs + else equivSubSubItems False cha xs + where + equi = T.toUpper $ if snd (subSubItemEqui x) == T.empty + then substituteCharInString (lstSubs cha) (subSubItemName x) + else snd (subSubItemEqui x) + + +equivSubSubItems True cha (x : xs) + | T.head equi `elem` lstLetters cha = x { subSubItemEqui = (Letters, equi) } : equivSubSubItems True cha xs + | T.head equi `elem` lstNumbers cha = x { subSubItemEqui = (Numbers, equi) } : equivSubSubItems True cha xs + | otherwise = case lstSymbols cha of + Nothing -> x { subSubItemEqui = (Symbols, equi) } : equivSubSubItems True cha xs + Just ch -> if T.head equi `elem` ch + then x { subSubItemEqui = (Symbols, equi) } : equivSubSubItems True cha xs + else equivSubSubItems True cha xs + where + equi = if snd (subSubItemEqui x) == T.empty + then substituteCharInString (lstSubs cha) (subSubItemName x) + else snd (subSubItemEqui x) + + +sortItems :: Bool + -> LangDef -- ^ The list of 'Char's for each section. + -> [IndexItem] + -> [IndexItem] +sortItems True cha lst = sortBy (\a b -> compareBySection True cha (itemEqui a) (itemEqui b)) nlst + where nlst = map (\itm -> itm { itemContent = sortSubItems True cha (itemContent itm) }) lst + + +sortItems False cha lst = sortBy (\a b -> compareBySection False cha ( itemEqui a) ( itemEqui b)) nlst + where nlst = map (\itm -> itm { itemContent = sortSubItems False cha (itemContent itm) }) lst + + + + +sortSubItems :: Bool + -> LangDef -- ^ The list of 'Char's for each section. + -> [IndexSubItem] + -> [IndexSubItem] +sortSubItems True cha lst = sortBy (\a b -> compareBySection True cha (subItemEqui a) (subItemEqui b)) nlst + where nlst = map (\itm -> itm { subItemContent = sortSubSubItems True cha (subItemContent itm) }) lst + + +sortSubItems False cha lst = sortBy (\a b -> compareBySection False cha (subItemEqui a) (subItemEqui b)) nlst + where nlst = map (\itm -> itm { subItemContent = sortSubSubItems False cha (subItemContent itm) }) lst + + +sortSubSubItems :: Bool + -> LangDef -- ^ The list of 'Char's for each section. + -> [IndexSubSubItem] + -> [IndexSubSubItem] +sortSubSubItems True cha lst = sortBy (\a b -> compareBySection True cha (subSubItemEqui a) (subSubItemEqui b)) lst + +sortSubSubItems False cha lst = sortBy (\a b -> compareBySection False cha (subSubItemEqui a) (subSubItemEqui b)) lst + + + +-- | compareBySection two items according to : +-- +-- 1. The 'Section' they belongs to. The section order is given in argument. +-- +-- 2. Their alphabetical order given by a list of 'Char's. +-- +compareBySection :: Bool + -> LangDef -- ^ The list of 'Char's for each section. + -> (Section, T.Text) -- ^ The first item to compareBySection. + -> (Section, T.Text) -- ^ The second index to compareBySection. + -> Ordering -- ^ The 'Ordering'. +compareBySection cas cha (seca, stra) (secb, strb) = case (ind_a, ind_b) of + (Just ia, Just ib) | ia == ib -> if cas + then compareByString (genListChar cha) (T.unpack stra) (T.unpack strb) + else compareByString' (genListChar cha) (T.unpack stra) (T.unpack strb) + | ia < ib -> LT + | otherwise -> GT + where + recu + | seca == Letters = if cas + then compareByString (lstLetters cha) (T.unpack stra) (T.unpack strb) + else compareByString' (lstLetters cha) (T.unpack stra) (T.unpack strb) + | seca == Numbers = if cas + then compareByString (lstNumbers cha) (T.unpack stra) (T.unpack strb) + else compareByString' (lstNumbers cha) (T.unpack stra) (T.unpack strb) + | seca == Symbols = case lstSymbols cha of + Nothing -> EQ -- error "No list of symbols defined" + Just ch -> if cas + then compareByString ch (T.unpack stra) (T.unpack strb) + else compareByString' ch (T.unpack stra) (T.unpack strb) + (Nothing, _ ) -> error "" + (_ , Nothing) -> error "" + where + ind_a = elemIndex seca (lstSecOrder cha) + ind_b = elemIndex secb (lstSecOrder cha) + + +compareByString' ord stra strb = compareByString (map toUpper ord) (map toUpper stra) (map toUpper strb) + + +-- | Compare two 'String's according to a list of 'Char'. +compareByString :: String -- ^ The list of Char's giving the order. + -> String -- ^ The first 'String' to compare. + -> String -- ^ The second 'String' to compare. + -> Ordering -- ^ The 'Ordering' result. +compareByString ordlst [] [] = EQ +compareByString ordlst [] (b : bx) = LT -- GT +compareByString ordlst (a : ax) [] = GT -- LT +compareByString ordlst (a : ax) (b : bx) = case (ind_a, ind_b) of + -- If both char are presents in the ordering list, we compare their indexes + (Just ia, Just ib) | ia == ib -> compareByString ordlst ax bx -- Same indexes, we compare the next chars + | ia < ib -> LT + | otherwise -> GT + (Nothing, Nothing) -> compareByString ordlst ax bx -- compare a b + (Nothing, _ ) -> LT + (_ , Nothing) -> GT + where + ind_a = elemIndex a ordlst -- Seek the char index of the first string in the ordering list + ind_b = elemIndex b ordlst -- Seek the char index of the second string in the ordering list + + + +-- | Generate the concatenated list of Char of all Sections in +-- the sorting order. +genListChar cha = genListChar' cha (lstSecOrder cha) + where + genListChar' _ [] = "" + genListChar' cha (Letters : xs) = lstLetters cha ++ genListChar' cha xs + genListChar' cha (Numbers : xs) = lstNumbers cha ++ genListChar' cha xs + genListChar' cha (Symbols : xs) = case lstSymbols cha of + Nothing -> genListChar' cha xs + Just str -> str ++ genListChar' cha xs + + + + + + + + + diff --git a/indexing/hsindex/src/HsIndex/Types.hs b/indexing/hsindex/src/HsIndex/Types.hs new file mode 100644 index 0000000000..cc7340d7d2 --- /dev/null +++ b/indexing/hsindex/src/HsIndex/Types.hs @@ -0,0 +1,205 @@ +-- | +-- Module : HsIndex.Types +-- 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 definition of main types for HsIndex. + + + + +module HsIndex.Types where + + +import Text.Parsec +import Text.Parsec.String + +import Data.Char +import qualified Data.Text as T + +-- +-- The main data structure of an index is made like this +-- +-- * Section "" +-- +-- * Subsection "" +-- +-- * Entry "" [4] +-- +-- * Entry "" [17,12] +-- +-- * SubEntry "" [21] +-- +-- * SubSubEntry "" [22] +-- +-- * SubEntry "" [29] +-- +-- * Subsection "" +-- +-- +-- * Section B" +-- +-- * .... +-- +-- * .... +-- +-- +-- Sections are made to store SubSections starting with the same first letter. +-- +-- SubSections are made to store Entries starting with the same two letters. +-- +-- Entry is made to store a word, it's pages numbers and a list of SubEntries. It's equivalent to "imakeidx" items. +-- +-- SubEntry is made to store a word, it's pages numbers and a list of SubSubEntries. It's equivalent to "imakeidx" subitems. +-- +-- SubSubEntry is made to store a word and it's pages numbers. It's equivalent to "imakeidx" subsubitems. +-- +-- +-- This data structure is deep enough to comply with "imakeidx" LaTeX package. +-- + + + + + + + + + + + +-- | The type to describe the style of the Index +-- +-- preamble +-- +-- prefix heading layer1 suffix +-- +-- name1 delimiters 1, 3, 4 +-- +-- name2 delimiters 4, 9 +-- +-- name3 delimiters 9, 12 +-- +-- postamble +-- +data IndexStyle = + IndexStyle { idxPreamble :: T.Text -- ^ The preamble + , idxPostamble :: T.Text -- ^ The postamble + , idxHeadingFlag0 :: Heading -- ^ The flag for the layer 0 heading, in connection with 'IndexSection's + , idxHeadingFlag1 :: Heading -- ^ The flag for the layer 1 heading, in connection with 'IndexSubSection's + , idxHeadingPreL0 :: T.Text -- ^ The prefix for the Layer 0 heading, in connection with 'IndexSection's + , idxHeadingSufL0 :: T.Text -- ^ The suffix for the Layer 0 heading, in connection with 'IndexSection's + , idxHeadingPreL1 :: T.Text -- ^ The prefix for the Layer 1 heading, in connection with 'IndexSubSection's + , idxHeadingSufL1 :: T.Text -- ^ The suffix for the Layer 1 heading, in connection with 'IndexSubSection's + , idxSymhead :: T.Text -- ^ The title for the "symbols" section + , idxNumhead :: T.Text -- ^ The title for the "numbers" section + , idxGroupSkip0 :: T.Text -- ^ The skip command after a layer 0 group ('IndexSection') + , idxGroupSkip1 :: T.Text -- ^ The skip command after a layer 1 group ('IndexSubSection') + , idxItem0 :: T.Text -- ^ The command to place before the index "items" + , idxItem1 :: T.Text -- ^ The command to place before the index "subitems" + , idxItem2 :: T.Text -- ^ The command to place before the index "subsubitems" + , idxItem01 :: T.Text -- ^ The command to place between an index "items" and an index "subitems" + , idxItem12 :: T.Text -- ^ The command to place between an index "subitems" and an index "subsubitems" + , idxDelim0 :: T.Text -- ^ The delimiter between the name and the pages numbers for "items" + , idxDelim1 :: T.Text -- ^ The delimiter between the name and the pages numbers for "subitems" + , idxDelim2 :: T.Text -- ^ The delimiter between the name and the pages numbers for "subsubitems" + , idxDelimn :: T.Text -- ^ The delimiter between pages numbers. + , idxDelimr :: T.Text -- ^ The delimiter between pages range. + , idxEncapPre :: T.Text + , idxEncapSuf :: T.Text + } + + +-- | The list of chars to define a language. +data LangDef = LangDef { lstLetters :: [Char] -- ^ Chars considered as letters. + , lstNumbers :: [Char] -- ^ Chars considered as numbers. + , lstSymbols :: Maybe [Char] -- ^ Chars considered as symbols. + , lstSubs :: [(Char,String)] -- ^ List of substitutions to perform. + , lstSecOrder :: [Section] + } + + +-- | The style of a heading. +data Heading = None -- ^ No heading + | UpperCase -- ^ Upper case heading + | LowerCase -- ^ Lower case heading + deriving (Eq) + + +-- | The category of a section. +-- +-- A section can be one of these three categories : +-- +-- * Letters +-- +-- * Numbers +-- +-- * Symbols +-- +data Section = Letters + | Numbers + | Symbols + deriving (Eq, Show) + +-- | An alias for a list of 'IndexSection's +type Index = [IndexSection] + + +-- | The type for a section. +data IndexSection = + IndexSection { secTitle :: T.Text -- ^ The section title. + , secSubSections :: [IndexSubSection] -- ^ The subsections. + } + deriving (Show) + +-- | The type for a subsection. +data IndexSubSection = + IndexSubSection { subSecTitle :: T.Text -- ^ The subsection title. + , subSecEntries :: [IndexItem] -- ^ The entries. + } + deriving (Show) + +-- | The type for an item. +data IndexItem = + IndexItem { itemName :: T.Text -- ^ The name of the index item. + , itemEqui :: (Section, T.Text) -- ^ The equivalent name and the section of the item. + , itemPageCommand :: T.Text -- ^ The command to insert before page number + , itemPages :: [Int] -- ^ The pages numbers it refers to. + , itemContent :: [IndexSubItem] -- ^ The subitems. + } + deriving (Show) + +-- | The type for a subitem. +data IndexSubItem = + IndexSubItem { subItemName :: T.Text -- ^ The name of the index subitem. + , subItemEqui :: (Section, T.Text) -- ^ The equivalent name and the section of the subitem. + , subItemPageCommand :: T.Text -- ^ The command to insert before page number + , subItemPages :: [Int] -- ^ The pages numbers it refers to. + , subItemContent :: [IndexSubSubItem] -- ^ The subsubitems. + } + deriving (Show) + +-- | The type for a subsubitem. +data IndexSubSubItem = + IndexSubSubItem { subSubItemName :: T.Text -- ^ The name of the index subsubitem. + , subSubItemEqui :: (Section, T.Text) -- ^ The equivalent name and the section of the subsubitem. + , subSubItemPageCommand :: T.Text -- ^ The command to insert before page number + , subSubItemPages :: [Int] -- ^ The pages numbers it refers to. + } + deriving (Show) + + +-- | The type of index to use +data IndexType = StyleBasic -- ^ The default basic style + | StyleDouble -- ^ The default double header style + | Stylecustom FilePath -- ^ A custom style (path to the style file). + + +-- | A state to accumulate the 'Section' order. +data PermState = PermState{ order::[Section]} + +-- | The empty state +emptyPermState = PermState [] + diff --git a/indexing/hsindex/src/hsindex.hs b/indexing/hsindex/src/hsindex.hs new file mode 100644 index 0000000000..bee37119cf --- /dev/null +++ b/indexing/hsindex/src/hsindex.hs @@ -0,0 +1,395 @@ +-- | +-- Module : HsIndex.Files +-- 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 Main program for the index generator +-- + + +import Prelude hiding (getContents, putStrLn) + + + +import Control.Monad + +import Data.Char +import Data.Function +import Data.List +import Data.Maybe +import Data.Ord +import Debug.Trace +import GHC.IO.Encoding -- solve bug commitBuffer: invalid argument (invalid character) +import HsIndex.CharLists.English +import HsIndex.CharLists.French +import HsIndex.CharLists.German +import HsIndex.CharLists.Russian +import HsIndex.Files +import HsIndex.Functions +import HsIndex.Parser +import HsIndex.Show +import HsIndex.Sorting +import HsIndex.Types +import qualified Prelude (getContents, putStrLn) +import System.Console.CmdArgs.Explicit +import System.Console.CmdArgs.Text +import System.Environment +import System.Exit +import System.IO +import Text.Parsec +import Text.Printf + +import System.Directory +import System.FilePath + + +-- | The ASCII art for the CLI title. +logo = + [ + " _ _ _____ _____ __ __ " + , " | | | | |_ _| | __ \\ \\ \\ / / " + , " | |__| |___ | | _ __ | | | | ___ \\ V / " + , " | __ / __| | | | '_ \\| | | |/ _ \\ > < " + , " | | | \\__ \\_| |_| | | | |__| | __// . \\ " + , " |_| |_|___/_____|_| |_|_____/ \\___/_/ \\_\\ " + ] + + +-- | Available options for the CLI. +data MyModes = + + IndexRussian { fileIn :: FilePath -- ^ The input file + , fileOut :: FilePath -- ^ The output file + , fileStyle :: IndexType -- ^ The style type + , autoRange :: Bool + , caseSens :: Bool + } + | IndexFrench { fileIn :: FilePath + , fileOut :: FilePath + , fileStyle :: IndexType -- ^ The style type + , autoRange :: Bool + , caseSens :: Bool + } + | IndexGerman { fileIn :: FilePath + , fileOut :: FilePath + , fileStyle :: IndexType -- ^ The style type + , autoRange :: Bool + , caseSens :: Bool + } + | IndexEnglish { fileIn :: FilePath + , fileOut :: FilePath + , fileStyle :: IndexType -- ^ The style type + , autoRange :: Bool + , caseSens :: Bool + } + | IndexCustom { fileIn :: FilePath + , fileOut :: FilePath + , fileStyle :: IndexType -- ^ The style type + , autoRange :: Bool + , caseSens :: Bool + , fileDef :: FilePath + } + | IndexCheck { checkInternalStyle :: Bool + , checkLanguageDef :: Maybe String + } + + | ArgHelp + | ArgVersion + + +-- | The basic options for English language. +initialOptsIndexEnglish = IndexEnglish "" "" StyleBasic False True + +-- | The basic options for French language. +initialOptsIndexFrench = IndexFrench "" "" StyleBasic False True + +-- | The basic options for German language. +initialOptsIndexGerman = IndexGerman "" "" StyleBasic False True + +-- | The basic options for Russian language. +initialOptsIndexRussian = IndexRussian "" "" StyleBasic False True + +-- | The basic options for custom language. +initialOptsIndexCustom = IndexCustom "" "" StyleBasic False True "" + +-- | The basic options for cheking the program. +initialOptsCheck = IndexCheck False Nothing + + +-- | The cli mode for English language. +modeGenIndexEnglish :: Mode MyModes +modeGenIndexEnglish = mode "english" initialOptsIndexEnglish description unnamedArg convertFlags + where + description = "Generate a English index" + unnamedArg = Arg { argValue = updateUnnamed, argType = "", argRequire = False } + where updateUnnamed str opts = Left ("Error unknown argument : " ++ str) + + convertFlags = + [ flagReq ["input", "i"] setInputFile "<File>" "Input file" + , flagReq ["output", "o"] setOutpuFile "<File>" "Output file" + , flagReq ["style", "s"] setStyleFile "<File>" "Style file" + , flagNone ["range"] setRange "Convert sequences of page into range" + , flagNone ["nocase"] setNoCase "Case insensitive ordering" + , flagNone ["dbl"] setDblHeader "Two letters headers" + ] + +-- | The cli mode for French language. +modeGenIndexFrench :: Mode MyModes +modeGenIndexFrench = mode "french" initialOptsIndexFrench description unnamedArg convertFlags + where + description = "Generate a French index" + unnamedArg = Arg { argValue = updateUnnamed, argType = "", argRequire = False } + where updateUnnamed str opts = Left ("Error unknown argument : " ++ str) + convertFlags = + [ flagReq ["input", "i"] setInputFile "<File>" "Input file" + , flagReq ["output", "o"] setOutpuFile "<File>" "Output file" + , flagReq ["style", "s"] setStyleFile "<File>" "Style file" + , flagNone ["range"] setRange "Convert sequences of page into range" + , flagNone ["nocase"] setNoCase "Case insensitive ordering" + , flagNone ["dbl"] setDblHeader "Two letters headers" + ] + +-- | The cli mode for German language. +modeGenIndexGerman :: Mode MyModes +modeGenIndexGerman = mode "german" initialOptsIndexGerman description unnamedArg convertFlags + where + description = "Generate a German index" + unnamedArg = Arg { argValue = updateUnnamed, argType = "", argRequire = False } + where updateUnnamed str opts = Left ("Error unknown argument : " ++ str) + convertFlags = + [ flagReq ["input", "i"] setInputFile "<File>" "Input file" + , flagReq ["output", "o"] setOutpuFile "<File>" "Output file" + , flagReq ["style", "s"] setStyleFile "<File>" "Style file" + , flagNone ["range"] setRange "Convert sequences of page into range" + , flagNone ["nocase"] setNoCase "Case insensitive ordering" + , flagNone ["dbl"] setDblHeader "Two letters headers" + ] + +-- | The cli mode for Russian language. +modeGenIndexRussian :: Mode MyModes +modeGenIndexRussian = mode "russian" initialOptsIndexRussian description unnamedArg convertFlags + where + description = "Generate a Russian index" + unnamedArg = Arg { argValue = updateUnnamed, argType = "", argRequire = False } + where updateUnnamed str opts = Left ("Error unknown argument : " ++ str) + convertFlags = + [ flagReq ["input", "i"] setInputFile "<File>" "Input file" + , flagReq ["output", "o"] setOutpuFile "<File>" "Output file" + , flagReq ["style", "s"] setStyleFile "<File>" "Style file" + , flagNone ["range"] setRange "Convert sequences of page into range" + , flagNone ["nocase"] setNoCase "Case insensitive ordering" + , flagNone ["dbl"] setDblHeader "Two letters headers" + ] + +-- | The cli mode for a custom language. +modeGenIndexCustom :: Mode MyModes +modeGenIndexCustom = mode "custom" initialOptsIndexCustom description unnamedArg convertFlags + where + description = "Generate a index with a custom language" + unnamedArg = Arg { argValue = updateUnnamed, argType = "", argRequire = False } + where updateUnnamed str opts = Left ("Error unknown argument : " ++ str) + + convertFlags = + [ flagReq ["input", "i"] setInputFile "<File>" "Input file" + , flagReq ["output", "o"] setOutpuFile "<File>" "Output file" + , flagReq ["style", "s"] setStyleFile "<File>" "Style file" + , flagReq ["def", "d"] setDefFile "<File>" "Definition file" + , flagNone ["range"] setRange "Convert sequences of page into range" + , flagNone ["nocase"] setNoCase "Case insensitive ordering" + , flagNone ["dbl"] setDblHeader "Two letters headers" + ] + +-- | The cli mode for a checking the program. +modeGenCheck :: Mode MyModes +modeGenCheck = mode "check" initialOptsCheck description unnamedArg convertFlags + where + description = "Check the internal parameter of the program" + unnamedArg = Arg { argValue = updateUnnamed, argType = "", argRequire = False } + where updateUnnamed str opts = Left ("Error unknown argument : " ++ str) + + convertFlags = + [ flagNone ["style"] setCheckStyle "Check built-in default style" + , flagReq ["language", "l"] setCheckLanguage "<Lang>" "Check built-in language definition" + ] + + + + +-- | Set the input file. +setInputFile str opts = Right $ opts { fileIn = str } + +-- | Set the output file. +setOutpuFile str opts = Right $ opts { fileOut = str } + +-- | Set the style file. +setStyleFile str opts = Right $ opts { fileStyle = Stylecustom str } + +-- | Set the definition file. +setDefFile str opts = Right $ opts { fileDef = str } + +-- | Enable automatic conversion of pages sequences into ranges. +setRange opts = opts { autoRange = True } + +-- | Enable the checking of the internal default style. +setCheckStyle opts = opts { checkInternalStyle = True } + +-- | Disable case sensitivity in ordering. +setNoCase opts = opts { caseSens = False } + +-- | Enable the two letters defaults header +setDblHeader opts = opts { fileStyle = StyleDouble } + + +-- | Set the language definition to check +setCheckLanguage "english" opts = Right $ opts { checkLanguageDef = Just "english" } +setCheckLanguage "french" opts = Right $ opts { checkLanguageDef = Just "french" } +setCheckLanguage "german" opts = Right $ opts { checkLanguageDef = Just "german" } +setCheckLanguage "russian" opts = Right $ opts { checkLanguageDef = Just "russian" } +setCheckLanguage str opts = Left $ "/!\\ ERROR The language " ++ str ++ " is not recognized" + + +-- | List of all possibles cli modes. +lstModes :: [Mode MyModes] +lstModes = + [ modeGenIndexEnglish + , modeGenIndexFrench + , modeGenIndexGerman + , modeGenIndexRussian + , modeGenIndexCustom + , modeGenCheck + ] + + + +-- | The main cli mode. +-- +-- Contain all the languages modes with the help and version flags. +modesCLI mods = (modes _ProgName ArgHelp "" mods) { modeGroupFlags = toGroup [helpFlag, versionFlag] } + where + helpFlag = flagNone ["help", "h", "?"] (const ArgHelp) "Help message" + versionFlag = flagNone ["version", "V"] (const ArgVersion) "Version informations" + + + +_ProgName = "hsindex" +_ProgDetails = "A program to create indexes for LaTeX and XeTeX" +_Auteur = "(c) Jean-Luc JOULIN 2018-2020" +_Version = "0.12.0" + + +-- | The main function. +main :: IO () +main = do + setLocaleEncoding utf8 -- solve bug commitBuffer: invalid argument (invalid character) + opts <- processArgs $ modesCLI lstModes + outputScreen opts + + +-- | Main function to output result to screen. +outputScreen opts@(IndexEnglish fin fou fsty rng cas ) = do + let fout = if null fou then ((dropExtension fin) ++ ".ind") else fou + readAllFile + fin + fsty + parseIndexFile + (\ent idx -> do + let entc = concatPagesItems ent + ents = sortItems cas langDefEnglish (equivItems True langDefEnglish entc) + entd = splitIndex idx ents + writeIndex fout idx rng entd + ) + +outputScreen opts@(IndexFrench fin fou fsty rng cas ) = do + let fout = if null fou then ((dropExtension fin) ++ ".ind") else fou + readAllFile + fin + fsty + parseIndexFile + (\ent idx -> do + let entc = concatPagesItems ent + ents = sortItems cas langDefFrench (equivItems True langDefFrench entc) + entd = splitIndex idx ents + writeIndex fout idx rng entd + ) + +outputScreen opts@(IndexGerman fin fou fsty rng cas ) = do + let fout = if null fou then ((dropExtension fin) ++ ".ind") else fou + readAllFile + fin + fsty + parseIndexFile + (\ent idx -> do + let entc = concatPagesItems ent + ents = sortItems cas langDefGerman (equivItems True langDefGerman entc) + entd = splitIndex idx ents + writeIndex fout idx rng entd + ) + +outputScreen opts@(IndexRussian fin fou fsty rng cas ) = do + let fout = if null fou then ((dropExtension fin) ++ ".ind") else fou + readAllFile + fin + fsty + parseIndexFile + (\ent idx -> do + let entc = concatPagesItems ent + ents = sortItems cas langDefRussian (equivItems True langDefRussian entc) + entd = splitIndex idx ents + writeIndex fout idx rng entd + ) + +outputScreen opts@(IndexCustom fin fou fsty rng cas fdef) = do + let fout = if null fou then ((dropExtension fin) ++ ".ind") else fou + readDefinitionFile + fdef + (\def -> readAllFile + fin + fsty + parseIndexFile + (\ent idx -> do + let entc = concatPagesItems ent + ents = sortItems cas def { lstLetters = (lstLetters def) } (equivItems True def entc) + entd = splitIndex idx ents + putStrLn $ "Building index with custom language definition" + putStrLn $ showLangDef def + writeIndex fout idx rng entd + ) + ) + +outputScreen opts@(IndexCheck sty mblang ) = do + if sty + then do + putStrLn $ showStyle styleBasic + else putStrLn "" + case mblang of + Nothing -> do + putStrLn "" + Just "english" -> putStrLn $ showLangDef langDefEnglish + Just "french" -> putStrLn $ showLangDef langDefFrench + Just "german" -> putStrLn $ showLangDef langDefGerman + Just "russian" -> putStrLn $ showLangDef langDefRussian + +outputScreen opts@ArgHelp = do + putStrLn $ unlines logo + putStrLn $ " " ++ _ProgDetails + putStrLn $ " " ++ _Auteur + putStrLn $ " Version : " ++ _Version + print $ helpText [] HelpFormatAll (modesCLI lstModes) + exitSuccess + +outputScreen opts@ArgVersion = do + putStrLn $ unlines logo + putStrLn $ " " ++ _ProgDetails + putStrLn $ " " ++ _Auteur + putStrLn $ " Version : " ++ _Version + exitSuccess + + + + + + + + |