diff options
Diffstat (limited to 'indexing/hsindex/src/HsIndex/Sorting.hs')
-rw-r--r-- | indexing/hsindex/src/HsIndex/Sorting.hs | 246 |
1 files changed, 246 insertions, 0 deletions
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 + + + + + + + + + |