{-# OPTIONS_GHC -Wno-redundant-constraints #-}

module Handler.Utils.ExamSpec (spec) where

import TestImport
import Data.Universe (Universe, Finite, universeF)

import ModelSpec ()     -- instance Arbitrary User

import Test.Hspec.QuickCheck (prop)
import Test.HUnit.Lang (HUnitFailure(..), FailureReason(..))

import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified Data.CaseInsensitive as CI
import qualified Data.Foldable as Foldable

import qualified Data.RFC5051 as RFC5051

import Handler.Utils.Exam


-- direct copy&paste from an (currently) unmerged pull request for hspec-expectations
-- https://github.com/hspec/hspec-expectations/blob/6b4a475e42b0d44008c150727dea25dd79f568f2/src/Test/Hspec/Expectations.hs
-- |
-- If you have a test case that has multiple assertions, you can use the
-- 'annotate' function to provide a string message that will be attached to
-- the 'Expectation'.
--
-- @
-- describe "annotate" $ do
--   it "adds the message" $ do
--     annotate "obvious falsehood" $ do
--       True `shouldBe` False
--
-- ========>
--
-- 1) annotate, adds the message
--       obvious falsehood
--       expected: False
--        but got: True
-- @
myAnnotate :: HasCallStack => String -> Expectation -> Expectation
myAnnotate msg = handle $ \(HUnitFailure loc exn) ->
  throwIO $ HUnitFailure loc $ case exn of
    Reason str ->
      Reason $ msg ++
          if null str then str else ": " <> str
    ExpectedButGot mmsg expected got ->
      let
        mmsg' =
          Just $ msg <> maybe "" (": " <>) mmsg
      in
        ExpectedButGot mmsg' expected got


instance Arbitrary ExamOccurrence where
    arbitrary = ExamOccurrence
        <$> arbitrary   -- examOccurrenceExam
        <*> arbitrary   -- examOccurrenceName
        <*> arbitrary   -- examOccurrenceRoom
        <*> arbitrary   -- examOccurrenceRoomHidden
        <*> (Just <$> frequency [(let d = fromIntegral i in ceiling $ 100 * exp(- d*d / 50), pure i) | i <- [10 ..1000]])   -- examOccurrenceCapacity
        <*> arbitrary   -- examOccurrenceStart
        <*> arbitrary   -- examOccurrenceEnd
        <*> arbitrary   -- examOccurrenceDescription


data Preselection = NoPreselection | SomePreselection
    deriving stock (Show, Bounded, Enum)
    deriving anyclass (Universe, Finite)

data Nudges = NoNudges | SmallNudges | LargeNudges
    deriving stock (Show, Bounded, Enum)
    deriving anyclass (Universe, Finite)

uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d
uncurry3 f (a, b, c) = f a b c

uncurry4 :: (a -> b -> c -> d -> e) -> (a, b, c, d) -> e
uncurry4 f (a, b, c, d) = f a b c d

-- | Kopie der User-Datenstruktur beschränkt auf interessante Felder (besser verständliche Show-Instanz)
newtype UserProperties = UserProperties {user :: User}

instance Show UserProperties where
    --show :: UserProperties -> String
    show UserProperties {user=User {userSurname, userMatrikelnummer}}
        = "User {userSurname=" ++ show userSurname
        ++ ", userMatrikelnummer=" ++ show userMatrikelnummer ++ "}"

-- function Handler.Utils.examAutoOccurrence
spec :: Spec
spec = do
    describe "examAutoOccurrence" $ do
        describe "Surname" $ testWithRule ExamRoomSurname
        describe "Matriculation" $ testWithRule ExamRoomMatriculation
        describe "Random" $ testWithRule ExamRoomRandom
    where
        testWithRule :: ExamOccurrenceRule -> Spec
        testWithRule rule =
            forM_ universeF $ \nudges -> describe (show nudges) $
                forM_ universeF $ \preselection ->
                    prop (show preselection) $ propertyTest rule nudges preselection
        seed :: ()
        seed = ()
        propertyTest :: ExamOccurrenceRule -> Nudges -> Preselection -> Gen Property
        propertyTest rule nudges preselection = do
            (users, occurrences) <- genUsersWithOccurrences preselection
            eaocNudge <- case nudges of
                NoNudges -> pure Map.empty
                SmallNudges -> let nudgeFrequency = [(10, 0), (5, 1), (5, -1), (3, 2), (3, -2), (1, 3), (1, -3)]
                                in foldM (genNudge nudgeFrequency) Map.empty $ Map.keys occurrences
                LargeNudges -> let nudgeFrequency = [(7, 0), (5, 3), (5, -3), (3, 6), (3, -6), (2, 9), (2, -9),
                                                    (2, 11), (2, -11), (1, 15), (1,-15), (1, 17), (1, -17)]
                                in foldM (genNudge nudgeFrequency) Map.empty $ Map.keys occurrences
            let config :: ExamAutoOccurrenceConfig
                config = def {eaocNudge}
                autoOccurrenceResult = examAutoOccurrence seed rule config occurrences users
            pure $ ioProperty $ do
                let userProperties :: Map UserId (UserProperties, Maybe ExamOccurrenceId)
                    userProperties = Map.map (first UserProperties) users
                case autoOccurrenceResult of
                    (Right (occurrenceMapping, userMap)) -> do
                        -- user count stays constant
                        myAnnotate "number of users changed" $ shouldBe (length userMap) (length users)
                        -- no room is overfull
                        myAnnotate "room capacity exceeded" $ shouldSatisfy (userProperties, occurrences, userMap) $ uncurry3 fitsInRooms
                        -- mapping is a valid description
                        myAnnotate "invalid mapping description" $ shouldSatisfy (rule, occurrenceMapping) $ uncurry validRangeDescription
                        -- every (relevant) user got assigned a room
                        let foldFn :: (UserId, Maybe ExamOccurrenceId) -> Bool -> Bool
                            foldFn _userMapping False = False
                            foldFn (_userId, Just _occurrenceId) True = True
                            foldFn (userId, Nothing) True
                                = (rule == ExamRoomMatriculation)
                                -- every user with a userMatrikelnummer got a room
                                -- fail on unknown user
                                || maybe False (isNothing . userMatrikelnummer . fst) (Map.lookup userId users)
                        myAnnotate "user didn't get a room" $ shouldSatisfy userMap $ foldr foldFn True . Map.toList
                        -- all users match the shown ranges
                        myAnnotate "shown ranges don't match userMap"
                            $ shouldSatisfy (rule, userProperties, occurrenceMapping, userMap) $ uncurry4 showsCorrectRanges
                    -- is a nullResult justified?
                    (Left autoOccurrenceException) -> 
                        -- disabled for now, probably not correct with the current implementation
                        myAnnotate "unjustified nullResult"
                            $ shouldSatisfy (autoOccurrenceException, rule, userProperties, occurrences) $ uncurry4 isNullResultJustified
        -- | generate users without any pre-assigned rooms
        genUsersWithOccurrences :: Preselection -> Gen (Map UserId (User, Maybe ExamOccurrenceId), Map ExamOccurrenceId ExamOccurrenceCapacity)
        genUsersWithOccurrences preselection = do
            rawUsers <- listOf $ Entity <$> arbitrary <*> arbitrary -- consider applying `scale (50 *)` to uncover additional issues
            occurrences <- genOccurrences $ length rawUsers
            -- user surnames anpassen, sodass interessante instanz
            users <- fmap Map.fromList $ forM rawUsers $ \Entity {entityKey, entityVal} -> do
                userSurname <- elements surnames
                assignedRoom <- case preselection of
                    NoPreselection -> pure Nothing
                    SomePreselection -> frequency [(97, pure Nothing), (3, elements $ map Just $ Map.keys occurrences)]
                pure (entityKey, (entityVal {userSurname}, assignedRoom))
            pure (users, occurrences)
        genOccurrences :: Int -> Gen (Map ExamOccurrenceId ExamOccurrenceCapacity)
        genOccurrences numUsers = do
            -- extra space to allow nice borders
            extraSpace <- elements [numUsers `div` 5 .. numUsers `div` 2]
            let totalSpaceRequirement = fromIntegral $ numUsers + extraSpace
                createOccurrences acc
                    |  fold (map snd acc) < Restricted totalSpaceRequirement = do
                        Entity {entityKey, entityVal} <- Entity <$> arbitrary <*> arbitrary
                        createOccurrences $ (entityKey, view (from _examOccurrenceCapacityIso) $ fromIntegral <$> examOccurrenceCapacity entityVal) : acc
                    | otherwise = pure acc
            Map.fromList <$> createOccurrences []
        genNudge :: [(Int, Integer)] -> Map ExamOccurrenceId Integer -> ExamOccurrenceId -> Gen (Map ExamOccurrenceId Integer)
        genNudge nudgesList acc occurrenceId
            = fmap appendNonZero $ frequency $ map (second pure) nudgesList
            where
                appendNonZero :: Integer -> Map ExamOccurrenceId Integer
                appendNonZero 0 = acc
                appendNonZero nudge = Map.insert occurrenceId nudge acc
        -- name list copied from test/Database/Fill.hs
        surnames :: [Text]
        surnames =   [ "Smith", "Johnson", "Williams", "Brown"
                    , "Jones", "Miller", "Davis", "Garcia"
                    , "Rodriguez", "Wilson", "Martinez", "Anderson"
                    , "Taylor", "Thomas", "Hernandez", "Moore"
                    , "Martin", "Jackson", "Thompson", "White"
                    , "Lopez", "Lee", "Gonzalez", "Harris"
                    , "Clark", "Lewis", "Robinson", "Walker"
                    , "Perez", "Hall", "Young", "zu Allen", "Fu"
                    , "Meier", "Meyer", "Maier", "Mayer"
                    , "Meir", "Müller", "Schulze", "Schmitt"
                    , "FTB Modul", "Mártinèz", "zu Walker", "Schmidt"
                    , "Únîcòdé", "Ähm-Ümlaüte", "von Leerzeichen"
                    ]
        occurrenceMap :: Map UserId (Maybe ExamOccurrenceId) -> Map ExamOccurrenceId [UserId]
        occurrenceMap userMap = foldl' (\acc (userId, maybeOccurrenceId) -> appendJust maybeOccurrenceId userId acc)
            Map.empty $ Map.toAscList userMap
            where
                appendJust :: Maybe ExamOccurrenceId -> UserId -> Map ExamOccurrenceId [UserId] -> Map ExamOccurrenceId [UserId]
                appendJust Nothing _userId = id
                appendJust (Just occurrenceId) userId = Map.insertWith (++) occurrenceId [userId]
        -- | Are all rooms large enough to hold all assigned Users?
        fitsInRooms :: Map UserId (UserProperties, Maybe ExamOccurrenceId)
                    -> Map ExamOccurrenceId ExamOccurrenceCapacity
                    -> Map UserId (Maybe ExamOccurrenceId)
                    -> Bool
        fitsInRooms userProperties occurrences userMap
            = all roomIsBigEnough $ Map.toAscList $ occurrenceMap userMap
            where
                roomIsBigEnough :: (ExamOccurrenceId, [UserId]) -> Bool
                roomIsBigEnough (roomId, userIds) = case lookup roomId occurrences of
                    Nothing -> False
                    (Just capacity) -> Restricted (fromIntegral $ length userIds) <=  capacity
                                    || all (isJust . snd) (Map.restrictKeys userProperties $ Set.fromList userIds)
        -- | No range overlap for different rooms + end is always the greater value
        validRangeDescription :: ExamOccurrenceRule -> ExamOccurrenceMapping ExamOccurrenceId -> Bool
        validRangeDescription rule ExamOccurrenceMapping {examOccurrenceMappingMapping}
            = all (\(roomId, ranges) -> all (descriptionValid roomId) ranges) $ Map.toAscList examOccurrenceMappingMapping
            where
                descriptionValid:: ExamOccurrenceId -> ExamOccurrenceMappingDescription -> Bool
                descriptionValid roomId description
                    = endAfterStart description
                    && all (all $ noDirectOverlap description) (Map.delete roomId examOccurrenceMappingMapping)
                endAfterStart :: ExamOccurrenceMappingDescription -> Bool
                endAfterStart
                    ExamOccurrenceMappingRange {eaomrStart=(pack . map CI.foldedCase -> start), eaomrEnd=(pack . map CI.foldedCase -> end)}
                    = RFC5051.compareUnicode start end /= GT
                endAfterStart _mappingDescription = True
                -- also check for equal length with ExamRoomMatriculation
                noDirectOverlap :: ExamOccurrenceMappingDescription -> ExamOccurrenceMappingDescription -> Bool
                noDirectOverlap ExamOccurrenceMappingRandom other = other == ExamOccurrenceMappingRandom
                noDirectOverlap other ExamOccurrenceMappingRandom = other == ExamOccurrenceMappingRandom
                noDirectOverlap
                    ExamOccurrenceMappingRange {eaomrStart=cs0@(pack . map CI.foldedCase -> s0), eaomrEnd=ce0@(pack . map CI.foldedCase -> e0)} 
                    ExamOccurrenceMappingRange {eaomrStart=cs1@(pack . map CI.foldedCase -> s1), eaomrEnd=ce1@(pack . map CI.foldedCase -> e1)}
                    = equalLengthForMatriculation [cs0, ce0, cs1, ce1]
                    && ((RFC5051.compareUnicode s0 s1 == LT && RFC5051.compareUnicode e0 s1 == LT)
                        || (RFC5051.compareUnicode s0 e1 == GT && RFC5051.compareUnicode e0 s1 == GT))
                noDirectOverlap
                    ExamOccurrenceMappingRange {eaomrStart, eaomrEnd}
                    ExamOccurrenceMappingSpecial {eaomrSpecial}
                    = equalLengthForMatriculation [eaomrStart, eaomrEnd, eaomrSpecial]
                    && noDirectOverlapRangeSpecial eaomrStart eaomrEnd eaomrSpecial
                noDirectOverlap
                    ExamOccurrenceMappingSpecial {eaomrSpecial}
                    ExamOccurrenceMappingRange {eaomrStart, eaomrEnd}
                    = equalLengthForMatriculation [eaomrStart, eaomrEnd, eaomrSpecial]
                    && noDirectOverlapRangeSpecial eaomrStart eaomrEnd eaomrSpecial
                noDirectOverlap ExamOccurrenceMappingSpecial {eaomrSpecial=s0} ExamOccurrenceMappingSpecial {eaomrSpecial=s1}
                    = equalLengthForMatriculation [s0, s1] && s0 /= s1
                equalLengthForMatriculation :: [[CI Char]] -> Bool
                equalLengthForMatriculation [] = True
                equalLengthForMatriculation (h:t) = (rule /= ExamRoomMatriculation) || all (== length h) (length <$> t)
                noDirectOverlapRangeSpecial :: [CI Char] -> [CI Char] -> [CI Char] -> Bool
                noDirectOverlapRangeSpecial
                    (pack . map CI.foldedCase -> start)
                    (pack . map CI.foldedCase -> end)
                    (pack . map CI.foldedCase -> special)
                    = RFC5051.compareUnicode special start == LT || RFC5051.compareUnicode special end == GT
                -- RFC5051.compareUnicode :: Text -> Text -> Ordering
        -- | Does the (currently surname) User fit to the displayed ranges?
        -- Users with a previously assigned room are checked if the assignment stays the same, regardless of the ranges.
        showsCorrectRanges :: ExamOccurrenceRule
                            -> Map UserId (UserProperties, Maybe ExamOccurrenceId)
                            -> ExamOccurrenceMapping ExamOccurrenceId
                            -> Map UserId (Maybe ExamOccurrenceId)
                            -> Bool
        showsCorrectRanges rule userProperties ExamOccurrenceMapping {examOccurrenceMappingMapping} userMap
            = all userFitsInRange $ Map.toAscList $ occurrenceMap userMap
            where
                userFitsInRange :: (ExamOccurrenceId, [UserId]) -> Bool
                userFitsInRange (roomId, userIds) = flip all userIds $ \userId ->
                    case (Map.lookup roomId examOccurrenceMappingMapping, Map.lookup userId userProperties) of
                        (_maybeRanges, Just (_userProperty, Just fixedRoomId))
                            -> roomId == fixedRoomId
                        (Just ranges, Just (UserProperties User {userSurname, userMatrikelnummer}, Nothing))
                            -> any fitsInRange ranges
                            where
                                ciTag :: Maybe [CI Char]
                                ciTag = map CI.mk . Text.unpack <$> case rule of
                                    ExamRoomSurname
                                        | Text.null userSurname -> Nothing
                                        | otherwise-> Just userSurname
                                    ExamRoomMatriculation
                                        | maybe True Text.null userMatrikelnummer -> Nothing
                                        | otherwise -> userMatrikelnummer
                                    _rule -> Nothing
                                fitsInRange :: ExamOccurrenceMappingDescription -> Bool
                                fitsInRange mappingDescription = case (ciTag, mappingDescription) of
                                    (_tag, ExamOccurrenceMappingRandom) -> True
                                    (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 due to the given reason?
        isNullResultJustified :: ExamAutoOccurrenceException
                                -> ExamOccurrenceRule
                                -> Map UserId (UserProperties, Maybe ExamOccurrenceId)
                                -> Map ExamOccurrenceId ExamOccurrenceCapacity
                                -> Bool
        isNullResultJustified ExamAutoOccurrenceExceptionRuleNoOp rule _userProperties _occurrences
            = not $ examOccurrenceRuleAutomatic rule
        isNullResultJustified ExamAutoOccurrenceExceptionNotEnoughSpace rule userProperties occurrences
            = Restricted (fromIntegral $ length $ relevantUsers rule userProperties) > fold occurrences
        isNullResultJustified ExamAutoOccurrenceExceptionNoUsers rule userProperties _occurrences
            = noRelevantUsers rule userProperties
        isNullResultJustified ExamAutoOccurrenceExceptionRoomTooSmall rule userProperties occurrences
            = mappingImpossiblePlausible rule userProperties occurrences
        noRelevantUsers :: ExamOccurrenceRule -> Map UserId (UserProperties, Maybe ExamOccurrenceId) -> Bool
        noRelevantUsers rule = null . relevantUsers rule
        relevantUsers  :: ExamOccurrenceRule
                        -> Map UserId (UserProperties, Maybe ExamOccurrenceId)
                        -> Map UserId (UserProperties, Maybe ExamOccurrenceId)
        relevantUsers rule = Map.filter $ isRelevantUser rule
        isRelevantUser :: ExamOccurrenceRule -> (UserProperties, Maybe ExamOccurrenceId) -> Bool
        isRelevantUser _rule (_user, Just _assignedRoom) = False
        isRelevantUser rule (UserProperties User {userSurname, userMatrikelnummer}, Nothing) = case rule of
            ExamRoomSurname -> not $ null userSurname
            ExamRoomMatriculation -> maybe False (not . null) userMatrikelnummer
            ExamRoomRandom -> True
            _rule -> False
        mappingImpossiblePlausible :: ExamOccurrenceRule
                                    -> Map UserId (UserProperties, Maybe ExamOccurrenceId)
                                    -> Map ExamOccurrenceId ExamOccurrenceCapacity
                                    -> Bool
        mappingImpossiblePlausible
            rule
            userProperties@(sortBy RFC5051.compareUnicode . mapRuleProperty rule . Map.elems . relevantUsers rule -> users')
            (map snd . Map.toList . adjustOccurrences userProperties -> occurrences') = go 0 users' occurrences'
            where
                smallestRoom :: ExamOccurrenceCapacity
                smallestRoom = maybe (Restricted 0) minimum $ fromNullable occurrences'
                -- If there exists a bucket with the same tag bigger than the smallest room a nullResult might be returned
                -- It may still work, but is not guaranteed (e.g. both the first bucket)
                go :: forall a. Eq a => Natural -> [a] -> [ExamOccurrenceCapacity] -> Bool
                go biggestUserBucket [] _occurrences = Restricted biggestUserBucket > smallestRoom
                go _biggestUserBucket _remainingUsers [] = True
                go biggestUserBucket remainingUsers (Restricted 0:t) = go biggestUserBucket remainingUsers t
                go biggestUserBucket remainingUsers@(h:_t) (firstOccurrence:laterOccurrences)
                    | Restricted nextUsers <= firstOccurrence
                    = go (max biggestUserBucket nextUsers) remainingUsers'
                        $ (under (from _examOccurrenceCapacityIso) (fmap (flip (-) nextUsers)) firstOccurrence)
                        : laterOccurrences
                    | otherwise
                    = go biggestUserBucket remainingUsers laterOccurrences
                    where
                        nextUsers :: Natural
                        remainingUsers' :: [a]
                        (fromIntegral . length -> nextUsers, remainingUsers') = span (== h) remainingUsers
        mapRuleProperty :: ExamOccurrenceRule -> [(UserProperties, b)] -> [Text]
        mapRuleProperty rule (map fst -> users') = map (ruleProperty rule minMatrLength) users'
            where
                minMatrLength :: Int
                minMatrLength = Foldable.minimum $ map (maybe 0 Text.length . userMatrikelnummer . user) users'
        ruleProperty :: ExamOccurrenceRule -> Int -> UserProperties -> Text
        ruleProperty rule n = case rule of
            ExamRoomSurname -> userSurname . user
            ExamRoomMatriculation -> maybe Text.empty (Text.takeEnd n) . userMatrikelnummer . user
            _rule -> const $ pack $ show rule
        -- copied and adjusted from Hander.Utils.Exam
        adjustOccurrences :: Map UserId (UserProperties, Maybe ExamOccurrenceId)
                            -> Map ExamOccurrenceId ExamOccurrenceCapacity
                            -> Map ExamOccurrenceId ExamOccurrenceCapacity
        -- ^ reduce room capacity for every pre-assigned user by 1
        adjustOccurrences userProperties occurrences
            = foldl' (flip $ Map.update predToPositive) (Map.filter (> Restricted 0) occurrences)
                $ Map.mapMaybe snd userProperties
        predToPositive :: ExamOccurrenceCapacity -> Maybe ExamOccurrenceCapacity
        predToPositive Unrestricted = Just Unrestricted
        predToPositive (Restricted 0) = Nothing
        predToPositive (Restricted 1) = Nothing
        predToPositive (Restricted n) = Just $ Restricted $ pred n
