chore: rewrite resultAscList

src/Handler/Utils/Exam.hs

@@ -49,8 +49,6 @@ import qualified Data.List as List
 
 import Data.ExtendedReal
 
-import qualified Data.Char as Char
-
 import qualified Data.RFC5051 as RFC5051
 
 import Handler.Utils.I18n
@@ -534,65 +532,75 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
                 -> ( Map ExamOccurrenceId (Set ExamOccurrenceMappingDescription)
                    , Map UserId (Maybe ExamOccurrenceId)
                    )
-    postprocess result = (resultAscList, resultUsers)
+    postprocess result = seq resultAscList (resultAscList, resultUsers)
       where
-        resultAscList = pad . Map.fromListWith Set.union $ accRes (pure <$> Set.lookupMin rangeAlphabet) result
+        rangeAlphabet :: [CI Char]
+        rangeAlphabet
+          | ExamRoomSurname <- rule
+          = map CI.mk ['A'..'Z']
+          | ExamRoomMatriculation <- rule
+          = map CI.mk ['0'..'9']
+          | otherwise
+          = []
+
+        resultAscList :: Map ExamOccurrenceId (Set ExamOccurrenceMappingDescription)
+        resultAscList = case fromNullable rangeAlphabet of
+            Nothing -> Map.empty
+            (Just alphabet) -> Map.map Set.singleton $ Map.fromList $ go (singleton $ head alphabet) [] result
+              where
+                go :: NonNull [CI Char] -> [(ExamOccurrenceId, ExamOccurrenceMappingDescription)] -> [(ExamOccurrenceId, [[CI Char]])] -> [(ExamOccurrenceId, ExamOccurrenceMappingDescription)]
+                go _start acc [] = acc
+                -- special case necessary, so ranges always end on last alphabet
+                go start acc [(_occurrenceId, [])] = case acc of
+                  [] -> []
+                  ((occurrenceId, mappingDescription):t) -> (occurrenceId, mappingDescription {eaomrEnd}) : t
+                  where
+                    eaomrEnd :: [CI Char]
+                    eaomrEnd = replicate (length start) $ last alphabet
+                go start acc ((_occurrenceId, []):t) = go start acc t
+                go start acc ((occurrenceId, userTags):t)
+                  | matchMappingDescription mappingDescription userTags = go nextStart ((occurrenceId, mappingDescription) : acc) t
+                  | otherwise = go (impureNonNull $ replicate (succ $ length start) $ head alphabet) [] result
+                  where
+                    mappingDescription :: ExamOccurrenceMappingDescription
+                    mappingDescription = ExamOccurrenceMappingRange (toNullable start) end
+                    -- | pre/suffix of larges user tag
+                    end :: [CI Char]
+                    -- userTags is guaranteed nonNull
+                    end = case t of
+                      [] -> replicate (length start) $ last alphabet
+                      _nonEmpty -> maximum $ impureNonNull $ map (transformTag start) userTags
+                    nextStart :: NonNull [CI Char]
+                    -- end is guaranteed nonNull, all empty tags are filtered out in users'
+                    nextStart = impureNonNull $ reverse $ increase $ reverse end
+                    alphabetCycle :: [CI Char]
+                    alphabetCycle = List.cycle $ toNullable alphabet
+                    increase :: [CI Char] -> [CI Char]
+                    increase [] = []
+                    increase (c:cs)
+                      | nextChar == head alphabet = nextChar : increase cs
+                      | otherwise = nextChar : cs
+                      where
+                        nextChar :: CI Char
+                        nextChar = dropWhile (/= c) alphabetCycle List.!! 1
+        
+        transformTag :: (MonoFoldable f) => f -> [CI Char] -> [CI Char]
+        transformTag (length -> l) tag = case rule of
+          ExamRoomMatriculation -> drop (max 0 $ length tag - l) tag
+          _rule -> take l tag
+
+        matchMappingDescription :: ExamOccurrenceMappingDescription -> [[CI Char]] -> Bool
+        matchMappingDescription ExamOccurrenceMappingRange {eaomrStart, eaomrEnd} = all $ \tag ->
+          (eaomrStart <= transformTag eaomrStart tag) && (transformTag eaomrEnd tag <= eaomrEnd)
+
+        matchMappingDescription ExamOccurrenceMappingSpecial {eaomrSpecial} = all $ checkSpecial eaomrSpecial
           where
-            accRes _ [] = []
+            checkSpecial :: [CI Char] -> [CI Char] -> Bool
-            accRes prevEnd ((occA, nsA) : (occB, nsB) : xs)
+            checkSpecial = case rule of
-              | Just minA <- prevEnd <|> preview _head nsA
+              ExamRoomMatriculation -> isSuffixOf
-              , Just maxA <- nsA ^? _last
+              _rule -> isPrefixOf
-              , Just minB <- nsB ^? _head
+
-              = let common = maxA `lcp` minB
+        resultUsers :: Map UserId (Maybe ExamOccurrenceId)
-                 in if
-                  | Just rmaxA <- nsA ^? to (filter . mayRange . succ $ length common) . _last
-                  , Just rminA <- maybe id (:) prevEnd nsA ^? to (filter . mayRange . succ $ length common) . _head
-                  , Just rminB <- nsB ^? to (filter . mayRange . succ $ length common) . _head
-                  , firstA : _ <- CI.foldedCase <$> drop (length common) rmaxA
-                  , firstB : _ <- CI.foldedCase <$> drop (length common) rminB
-                    -> let break'
-                             | occSize occA > 0 || occSize occB > 0
-                             = (occSize occA * Char.ord firstA + occSize occB * Char.ord firstB) % (occSize occA + occSize occB)
-                                 & floor
-                                 & Char.chr
-                                 & Char.toUpper
-                                 & CI.mk
-                                 & pure
-                                 & (common ++)
-                             | otherwise = common ++ pure (CI.mk firstA)
-                           succBreak = fmap reverse . go $ reverse break'
-                             where
-                               go [] = Nothing
-                               go (c:cs)
-                                 | c' <- CI.map succ c
-                                 , c' `Set.member` rangeAlphabet
-                                 = Just $ c' : cs
-                                 | otherwise
-                                 = go cs
-                           commonLength = max 1 . succ . length $ minA `lcp` break'
-                           isBreakSpecialStart c = not (mayRange (length rminA ) c) && length (rminA  `lcp` c) >= pred (length rminA )
-                           isBreakSpecialEnd c = not (mayRange (length break') c) && length (break' `lcp` c) >= pred (length break')
-                           rangeSpecials = Set.map (ExamOccurrenceMappingSpecial . take commonLength) . Set.filter (not . mayRange commonLength) $ Set.fromList nsA
-                           breakSpecialsStart = Set.map (ExamOccurrenceMappingSpecial . take (length rminA)) . Set.filter isBreakSpecialStart $ Set.fromList nsA
-                           breakSpecialsEnd = Set.map (ExamOccurrenceMappingSpecial . take (length break')) . Set.filter isBreakSpecialEnd $ Set.fromList nsA
-                        in (occA, Set.insert (ExamOccurrenceMappingRange rminA break') $ breakSpecialsStart <> breakSpecialsEnd <> rangeSpecials) : accRes succBreak ((occB, nsB) : xs)
-                  | otherwise
-                    -> (occA, Set.map (ExamOccurrenceMappingSpecial . take (max 1 . max (succ $ length common) $ maybe 0 length prevEnd)) $ Set.fromList nsA) : accRes (Just $ take (succ $ length common) minB) ((occB, nsB) : xs)
-              | null nsA
-              = accRes prevEnd $ (occB, nsB) : xs
-              | otherwise -- null nsB
-              = accRes prevEnd $ (occA, nsA) : xs
-            accRes prevEnd [(occZ, nsZ)]
-              | Just minAlpha <- Set.lookupMin rangeAlphabet
-              , Just maxAlpha <- Set.lookupMax rangeAlphabet
-              , minZ <- fromMaybe (pure minAlpha) prevEnd
-              = let commonLength = max 1 . succ . length $ takeWhile (== maxAlpha) minZ
-                    isBreakSpecial c = not (mayRange (length minZ) c) && length (minZ `lcp` c) >= pred (length minZ)
-                    rangeSpecials = Set.map (ExamOccurrenceMappingSpecial . take commonLength) . Set.filter (not . mayRange commonLength) $ Set.fromList nsZ
-                    breakSpecials = Set.map (ExamOccurrenceMappingSpecial . take (length minZ)) . Set.filter isBreakSpecial $ Set.fromList nsZ
-                 in pure (occZ, Set.insert (ExamOccurrenceMappingRange minZ $ replicate commonLength maxAlpha) $ rangeSpecials <> breakSpecials)
-              | otherwise
-              = pure (occZ, Set.map (ExamOccurrenceMappingSpecial . take (max 1 $ maybe 0 length prevEnd)) $ Set.fromList nsZ)
         resultUsers = Map.fromList $ do
           (occId, buckets) <- result
           let matchWord b b' = case rule of
@@ -603,30 +611,6 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
           user <- Set.toList $ foldMap (\b -> foldMap snd . filter (\(b', _) -> matchWord b b') $ Map.toList users') buckets
           return (user, Just occId)
 
-        occSize :: Num a => ExamOccurrenceId -> a
-        occSize occId = fromIntegral . length $ Map.filter (== Just occId) resultUsers
-
-        rangeAlphabet :: Set (CI Char)
-        rangeAlphabet
-          | ExamRoomSurname <- rule
-          = Set.fromList $ map CI.mk ['A'..'Z']
-          | ExamRoomMatriculation <- rule
-          = Set.fromList $ map CI.mk ['0'..'9']
-          | otherwise
-          = mempty
-        mayRange :: Int -> [CI Char] -> Bool
-        mayRange l = all (`Set.member` rangeAlphabet) . take l
-
-        pad :: Map ExamOccurrenceId (Set ExamOccurrenceMappingDescription) -> Map ExamOccurrenceId (Set ExamOccurrenceMappingDescription)
-        pad res
-          | ExamRoomMatriculation <- rule
-          , Just minAlpha <- Set.lookupMin rangeAlphabet
-          = let maxLength' = maybe 0 maximum . fromNullable $ res ^.. folded . folded . (_eaomrStart <> _eaomrEnd <> _eaomrSpecial) . to length
-                padSuff cs = replicate (maxLength' - length cs) minAlpha ++ cs
-             in Set.map (appEndo $ foldMap Endo [ over l padSuff | l <- [_eaomrStart, _eaomrEnd, _eaomrSpecial]]) <$> res
-          | otherwise
-          = res
-
 
 deregisterExamUsersCount :: (MonadIO m, HandlerSite m ~ UniWorX, MonadHandler m, MonadCatch m) => ExamId -> [UserId] -> SqlPersistT m Int64
 deregisterExamUsersCount eId uids = do