chore: names with non-ascii prefix get a ExamOccurrenceMappingSpecial
This commit is contained in:
Wolfgang Witt
Wolfgang Witt
parent
d60f93561f
commit
5480e2d7b7
@ -1,4 +1,5 @@
|
||||
{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
|
||||
{-# OPTIONS_GHC -Wwarn #-}
|
||||
|
||||
module Handler.Utils.Exam
|
||||
( fetchExamAux
|
||||
@ -540,60 +541,68 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
|
||||
rangeAlphabet :: [CI Char]
|
||||
rangeAlphabet = case rule of
|
||||
ExamRoomSurname -> map CI.mk ['A'..'Z']
|
||||
-- ExamRoomSurname -> map CI.mk [c | c <- universeF, isPrint c] -- all printable unicode characters
|
||||
ExamRoomMatriculation-> map CI.mk ['0'..'9']
|
||||
_rule -> []
|
||||
|
||||
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
|
||||
(Just alphabet) -> Map.fromList $ go (singleton $ head alphabet) 1 [] result
|
||||
where
|
||||
go :: NonNull [CI Char] -> [(ExamOccurrenceId, ExamOccurrenceMappingDescription)] -> [(ExamOccurrenceId, [[CI Char]])] -> [(ExamOccurrenceId, ExamOccurrenceMappingDescription)]
|
||||
go _start acc [] = acc
|
||||
go :: NonNull [CI Char]
|
||||
-> Int
|
||||
-> [(ExamOccurrenceId, Set ExamOccurrenceMappingDescription)]
|
||||
-> [(ExamOccurrenceId, [[CI Char]])]
|
||||
-> [(ExamOccurrenceId, Set ExamOccurrenceMappingDescription)]
|
||||
go _start _borderLength acc [] = acc
|
||||
-- special case necessary, so ranges always end on last alphabet
|
||||
go start acc [(_occurrenceId, [])] = case acc of
|
||||
go start _borderLength acc [(_occurrenceId, [])] = case acc of
|
||||
[] -> []
|
||||
((occurrenceId, mappingDescription):t) -> (occurrenceId, mappingDescription {eaomrEnd}) : t
|
||||
((occurrenceId, mappingDescription):t) -> (occurrenceId, Set.map extendEnd mappingDescription) : t
|
||||
where
|
||||
extendEnd :: ExamOccurrenceMappingDescription -> ExamOccurrenceMappingDescription
|
||||
extendEnd ExamOccurrenceMappingRange {eaomrStart} = ExamOccurrenceMappingRange {eaomrStart, eaomrEnd}
|
||||
extendEnd examOccurrenceMappingSpecial = examOccurrenceMappingSpecial
|
||||
eaomrEnd :: [CI Char]
|
||||
eaomrEnd = replicate (length start) $ last alphabet
|
||||
go start acc ((_occurrenceId, []):t) = go start acc t
|
||||
go start acc ((occurrenceId, userTags):t)
|
||||
go start borderLength acc ((_occurrenceId, []):t) = go start borderLength acc t
|
||||
go start borderLength acc ((occurrenceId, userTags):t)
|
||||
| matchMappingDescription mappingDescription userTags
|
||||
= go nextStart ((occurrenceId, mappingDescription) : acc) t
|
||||
| length start < maxTagLength
|
||||
= go (impureNonNull $ replicate (succ $ length start) $ head alphabet) [] result
|
||||
= go nextStart borderLength ((occurrenceId, mappingDescription) : acc) t
|
||||
| borderLength < maxTagLength
|
||||
= go (singleton $ head alphabet) (succ borderLength) [] result
|
||||
| otherwise
|
||||
= []
|
||||
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
|
||||
| length biggestTag < length start
|
||||
-- add padding, to keep equal length
|
||||
-> biggestTag ++ replicate (length start - length biggestTag) paddingChar
|
||||
| otherwise -> biggestTag
|
||||
where
|
||||
biggestTag :: [CI Char]
|
||||
biggestTag = maximum $ impureNonNull $ map (transformTag start) userTags
|
||||
paddingChar :: CI Char
|
||||
paddingChar = CI.mk ' '
|
||||
mappingDescription :: Set ExamOccurrenceMappingDescription
|
||||
mappingDescription = Set.fromList $ case maybeEnd of
|
||||
(Just end) -> ExamOccurrenceMappingRange (toNullable start) end : specialMapping
|
||||
Nothing -> specialMapping
|
||||
|
||||
specialMapping :: [ExamOccurrenceMappingDescription]
|
||||
specialMapping = [ExamOccurrenceMappingSpecial $ transformTag borderLength tag | tag <- specialTags]
|
||||
|
||||
alphabetTags, specialTags :: [[CI Char]]
|
||||
(alphabetTags, specialTags) = partition (all (`elem` alphabet) . take (length start)) userTags
|
||||
-- | pre/suffix of largest user tag
|
||||
maybeEnd :: Maybe [CI Char]
|
||||
maybeEnd = case t of
|
||||
[] -> Just $ replicate borderLength $ last alphabet
|
||||
_nonEmpty -> transformTag borderLength . maximum <$> fromNullable alphabetTags
|
||||
nextStart :: NonNull [CI Char]
|
||||
-- end is guaranteed nonNull, all empty tags are filtered out in users'
|
||||
nextStart = impureNonNull $ reverse $ increase $ reverse end
|
||||
nextStart
|
||||
| Nothing <- maybeEnd
|
||||
= start
|
||||
| length start < borderLength
|
||||
= start <> impureNonNull [head alphabet]
|
||||
| (Just end) <- maybeEnd
|
||||
= impureNonNull $ reverse $ increase $ reverse end
|
||||
alphabetCycle :: [CI Char]
|
||||
alphabetCycle = List.cycle $ toNullable alphabet
|
||||
increase :: [CI Char] -> [CI Char]
|
||||
increase [] = []
|
||||
increase (c:cs)
|
||||
| c < head alphabet
|
||||
= head alphabet : cs
|
||||
| nextChar == head alphabet
|
||||
= nextChar : increase cs
|
||||
| otherwise
|
||||
@ -603,25 +612,25 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
|
||||
nextChar
|
||||
| c `elem` alphabet
|
||||
= dropWhile (/= c) alphabetCycle List.!! 1
|
||||
| otherwise -- includes padding char
|
||||
= head alphabet
|
||||
-- TODO what if the border is between to non-ascii characters?
|
||||
| otherwise -- shouldn't happen, simply use head alphabet
|
||||
= error $ "uncaught non-alphabet char: " ++ show c --TODO head alphabet
|
||||
|
||||
transformTag :: (MonoFoldable f) => f -> [CI Char] -> [CI Char]
|
||||
transformTag (length -> l) tag = case rule of
|
||||
transformTag :: Int -> [CI Char] -> [CI Char]
|
||||
transformTag 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
|
||||
checkSpecial :: [CI Char] -> [CI Char] -> Bool
|
||||
checkSpecial = case rule of
|
||||
ExamRoomMatriculation -> isSuffixOf
|
||||
_rule -> isPrefixOf
|
||||
matchMappingDescription :: Set ExamOccurrenceMappingDescription -> [[CI Char]] -> Bool
|
||||
matchMappingDescription mappingDescription userTags = flip all userTags $ \tag -> flip any mappingDescription $ \case
|
||||
ExamOccurrenceMappingRange {eaomrStart, eaomrEnd}
|
||||
-- non-rangeAlphabet-chars get a special mapping, so <= is fine here
|
||||
-> (eaomrStart <= transformTag (length eaomrStart) tag) && (transformTag (length eaomrEnd) tag <= eaomrEnd)
|
||||
ExamOccurrenceMappingSpecial {eaomrSpecial} -> checkSpecial eaomrSpecial tag
|
||||
where
|
||||
checkSpecial :: [CI Char] -> [CI Char] -> Bool
|
||||
checkSpecial = case rule of
|
||||
ExamRoomMatriculation -> isSuffixOf
|
||||
_rule -> isPrefixOf
|
||||
|
||||
resultUsers :: Map UserId (Maybe ExamOccurrenceId)
|
||||
resultUsers = Map.fromList $ do
|
||||
|
||||
@ -1,4 +1,5 @@
|
||||
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
|
||||
{-# OPTIONS_GHC -Wwarn #-}
|
||||
|
||||
module Handler.Utils.ExamSpec (spec) where
|
||||
|
||||
@ -15,6 +16,8 @@ import qualified Data.Set as Set
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import qualified Data.RFC5051 as RFC5051
|
||||
|
||||
import Handler.Utils.Exam
|
||||
|
||||
|
||||
@ -244,15 +247,21 @@ spec = do
|
||||
| otherwise -> userMatrikelnummer
|
||||
_rule -> Nothing
|
||||
fitsInRange :: ExamOccurrenceMappingDescription -> Bool
|
||||
fitsInRange ExamOccurrenceMappingRange {eaomrStart, eaomrEnd} = case ciTag of
|
||||
Nothing -> True
|
||||
(Just tag) -> (eaomrStart <= transformTag eaomrStart tag) && (transformTag eaomrEnd tag <= eaomrEnd)
|
||||
fitsInRange ExamOccurrenceMappingSpecial {}
|
||||
= True -- FIXME what is the meaning of special?
|
||||
fitsInRange mappingDescription = case (ciTag, mappingDescription) of
|
||||
(Nothing, _mappingDescription) -> True
|
||||
(Just tag, ExamOccurrenceMappingRange {eaomrStart=(pack . map CI.foldedCase -> start), eaomrEnd=(pack . map CI.foldedCase-> end)})
|
||||
-> (RFC5051.compareUnicode start (pack $ map CI.foldedCase $ transformTag start tag) /= GT)
|
||||
&& (RFC5051.compareUnicode end (pack $ map CI.foldedCase $ transformTag end tag) /= LT)
|
||||
(Just tag, ExamOccurrenceMappingSpecial {eaomrSpecial})
|
||||
-> checkSpecial eaomrSpecial tag
|
||||
transformTag :: (MonoFoldable f) => f -> [CI Char] -> [CI Char]
|
||||
transformTag (length -> rangeLength) = case rule of
|
||||
ExamRoomMatriculation -> reverse . take rangeLength . reverse
|
||||
_rule -> take rangeLength
|
||||
checkSpecial :: [CI Char] -> [CI Char] -> Bool
|
||||
checkSpecial = case rule of
|
||||
ExamRoomMatriculation -> isSuffixOf
|
||||
_rule -> isPrefixOf
|
||||
_otherwise -> (rule /= ExamRoomSurname) && (rule /= ExamRoomMatriculation)
|
||||
{-
|
||||
-- | Is mapping impossible?
|
||||
|
||||
Loading…
Reference in New Issue
Block a user