{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Foundation.I18n
  ( appLanguages, appLanguagesOpts
  , UniWorXMessage(..)
  , ShortTermIdentifier(..)
  , MsgLanguage(..)
  , ShortSex(..)
  , ShortWeekDay(..)
  , SheetTypeHeader(..)
  , SheetArchiveFileTypeDirectory(..)
  , ShortStudyDegree(..)
  , ShortStudyTerms(..)
  , StudyDegreeTerm(..)
  , ShortStudyFieldType(..)
  , StudyDegreeTermType(..)
  , ErrorResponseTitle(..)
  , UniWorXMessages(..)
  , uniworxMessages
  , unRenderMessage, unRenderMessage', unRenderMessageLenient
  ) where

import Foundation.Type


import Import.NoFoundation

import Auth.LDAP
import Auth.PWHash
import Auth.Dummy

import Data.CaseInsensitive (original, mk)

import qualified Data.Text as Text

import Utils.Form

import qualified GHC.Exts (IsList(..))

import Yesod.Form.I18n.German
import Yesod.Form.I18n.English

import qualified Data.Char as Char
import Text.Unidecode (unidecode)
import Data.Text.Lens (packed)

import Data.List ((!!))


appLanguages :: NonEmpty Lang
appLanguages = "de-de-formal" :| ["en-eu"]


pluralDE :: (Eq a, Num a)
            =>    a -- ^ Count
            -> Text -- ^ Singular
            -> Text -- ^ Plural
            -> Text
pluralDE num singularForm pluralForm
  | num == 1  = singularForm
  | otherwise = pluralForm

noneOneMoreDE :: (Eq a, Num a)
            =>    a -- ^ Count
            -> Text -- ^ None
            -> Text -- ^ Singular
            -> Text -- ^ Plural
            -> Text
noneOneMoreDE num noneText singularForm pluralForm
  | num == 0  = noneText
  | num == 1  = singularForm
  | otherwise = pluralForm

-- noneMoreDE :: (Eq a, Num a)
--             =>    a -- ^ Count
--             -> Text -- ^ None
--             -> Text -- ^ Some
--             -> Text
-- noneMoreDE num noneText someText
--   | num == 0  = noneText
--   | otherwise = someText

pluralEN :: (Eq a, Num a)
            =>    a -- ^ Count
            -> Text -- ^ Singular
            -> Text -- ^ Plural
            -> Text
pluralEN num singularForm pluralForm
  | num == 1  = singularForm
  | otherwise = pluralForm

noneOneMoreEN :: (Eq a, Num a)
            =>    a -- ^ Count
            -> Text -- ^ None
            -> Text -- ^ Singular
            -> Text -- ^ Plural
            -> Text
noneOneMoreEN num noneText singularForm pluralForm
  | num == 0  = noneText
  | num == 1  = singularForm
  | otherwise = pluralForm

-- noneMoreEN :: (Eq a, Num a)
--             =>    a -- ^ Count
--             -> Text -- ^ None
--             -> Text -- ^ Some
--             -> Text
-- noneMoreEN num noneText someText
--   | num == 0  = noneText
--   | otherwise = someText

ordinalEN :: ToMessage a
          => a
          -> Text
ordinalEN (toMessage -> numStr) = case lastChar of
  Just '1' -> [st|#{numStr}st|]
  Just '2' -> [st|#{numStr}nd|]
  Just '3' -> [st|#{numStr}rd|]
  _other   -> [st|#{numStr}th|]
  where
    lastChar = last <$> fromNullable numStr


-- Convenience Type for Messages, since Yesod messages cannot deal with compound type identifiers
type IntMaybe  = Maybe Int

-- | Convenience function for i18n messages definitions
maybeToMessage :: ToMessage m => Text -> Maybe m -> Text -> Text
maybeToMessage _      Nothing  _     = mempty
maybeToMessage before (Just x) after = before <> toMessage x <> after

-- Messages creates type UniWorXMessage and RenderMessage UniWorX instance
mkMessage "UniWorX" "messages/uniworx" "de-de-formal"
mkMessageVariant "UniWorX" "Campus" "messages/campus" "de"
mkMessageVariant "UniWorX" "Dummy" "messages/dummy" "de"
mkMessageVariant "UniWorX" "PWHash" "messages/pw-hash" "de"
mkMessageVariant "UniWorX" "Button" "messages/button" "de"
mkMessageVariant "UniWorX" "Frontend" "messages/frontend" "de-de-formal"

instance RenderMessage UniWorX TermIdentifier where
  renderMessage foundation ls TermIdentifier{..} = case season of
    Summer -> renderMessage' $ MsgSummerTerm year
    Winter -> renderMessage' $ MsgWinterTerm year
    where renderMessage' = renderMessage foundation ls

newtype ShortTermIdentifier = ShortTermIdentifier TermIdentifier
  deriving stock (Eq, Ord, Read, Show)
instance RenderMessage UniWorX ShortTermIdentifier where
  renderMessage foundation ls (ShortTermIdentifier TermIdentifier{..}) = case season of
    Summer -> renderMessage' $ MsgSummerTermShort year
    Winter -> renderMessage' $ MsgWinterTermShort year
    where renderMessage' = renderMessage foundation ls

instance RenderMessage UniWorX String where
  renderMessage f ls str = renderMessage f ls $ Text.pack str

-- TODO: raw number representation; instead, display e.g. 1000 as 1.000 or 1,000 or ... (language-dependent!)
instance RenderMessage UniWorX Int where
  renderMessage f ls = renderMessage f ls . tshow
instance RenderMessage UniWorX Int64 where
  renderMessage f ls = renderMessage f ls . tshow
instance RenderMessage UniWorX Integer where
  renderMessage f ls = renderMessage f ls . tshow
instance RenderMessage UniWorX Natural where
  renderMessage f ls = renderMessage f ls . tshow

instance HasResolution a => RenderMessage UniWorX (Fixed a) where
  renderMessage f ls = renderMessage f ls . showFixed True

instance RenderMessage UniWorX Load where
  renderMessage foundation ls = renderMessage foundation ls . \case
    Load { byTutorial = Nothing   , byProportion = p } -> MsgCorByProportionOnly p
    Load { byTutorial = Just True , byProportion = p } -> MsgCorByProportionIncludingTutorial p
    Load { byTutorial = Just False, byProportion = p } -> MsgCorByProportionExcludingTutorial p

newtype MsgLanguage = MsgLanguage Lang
  deriving stock (Eq, Ord, Show, Read)
instance RenderMessage UniWorX MsgLanguage where
  renderMessage foundation ls (MsgLanguage lang@(map mk . Text.splitOn "-" -> lang'))
    | ("de" : "DE" : _) <- lang' = mr MsgGermanGermany
    | ("de" : _)        <- lang' = mr MsgGerman
    | ("en" : "EU" : _) <- lang' = mr MsgEnglishEurope
    | ("en" : _)        <- lang' = mr MsgEnglish
    | otherwise = lang
    where
      mr = renderMessage foundation $ lang : filter (/= lang) ls

appLanguagesOpts :: ( MonadHandler m
                    , RenderMessage (HandlerSite m) MsgLanguage
                    ) => m (OptionList Lang)
-- ^ Authoritive list of supported Languages
appLanguagesOpts = do
  MsgRenderer mr <- getMsgRenderer
  let mkOption l = Option
        { optionDisplay = mr $ MsgLanguage l
        , optionInternalValue = l
        , optionExternalValue = l
        }
      langOptions = map mkOption $ toList appLanguages
  return $ mkOptionList langOptions

embedRenderMessage ''UniWorX ''MessageStatus ("Message" <>)
embedRenderMessage ''UniWorX ''NotificationTrigger $ ("NotificationTrigger" <>) . concat . drop 1 . splitCamel
embedRenderMessage ''UniWorX ''StudyFieldType id
embedRenderMessage ''UniWorX ''SheetFileType id
embedRenderMessage ''UniWorX ''SubmissionFileType id
embedRenderMessage ''UniWorX ''CorrectorState id
embedRenderMessage ''UniWorX ''SubmissionSinkException ("SubmissionSinkException" <>)
embedRenderMessage ''UniWorX ''SheetGrading ("SheetGrading" <>)
embedRenderMessage ''UniWorX ''AuthTag $ ("AuthTag" <>) . concat . drop 1 . splitCamel
embedRenderMessage ''UniWorX ''EncodedSecretBoxException id
embedRenderMessage ''UniWorX ''LecturerType id
embedRenderMessage ''UniWorX ''SubmissionModeDescr
  $ let verbMap [_, _, "None"] = "NoSubmissions"
        verbMap [_, _, v] = v <> "Submissions"
        verbMap _ = error "Invalid number of verbs"
     in verbMap . splitCamel
embedRenderMessage ''UniWorX ''UploadModeDescr id
embedRenderMessage ''UniWorX ''SecretJSONFieldException id
embedRenderMessage ''UniWorX ''AFormMessage $ concat . drop 2 . splitCamel
embedRenderMessage ''UniWorX ''SchoolFunction id
embedRenderMessage ''UniWorX ''CsvPreset id
embedRenderMessage ''UniWorX ''Quoting ("Csv" <>)
embedRenderMessage ''UniWorX ''FavouriteReason id
embedRenderMessage ''UniWorX ''Sex id
embedRenderMessage ''UniWorX ''ExamGradingMode id

embedRenderMessage ''UniWorX ''AuthenticationMode id

embedRenderMessage ''UniWorX ''RatingValidityException id

newtype ShortSex = ShortSex Sex
embedRenderMessageVariant ''UniWorX ''ShortSex ("Short" <>)

newtype SheetTypeHeader = SheetTypeHeader SheetType
embedRenderMessageVariant ''UniWorX ''SheetTypeHeader ("SheetType" <>)

newtype SheetArchiveFileTypeDirectory = SheetArchiveFileTypeDirectory SheetFileType
  deriving (Eq, Ord, Read, Show, Generic, Typeable)
  deriving newtype (Enum, Bounded, Universe, Finite)
embedRenderMessageVariant ''UniWorX ''SheetArchiveFileTypeDirectory $ ("SheetArchiveFileTypeDirectory" <>) . concat . drop 1 . splitCamel

instance RenderMessage UniWorX SheetType where
  renderMessage foundation ls sheetType = case sheetType of
      NotGraded -> mr $ SheetTypeHeader NotGraded
      other -> mr (grading other) <> ", " <> mr (SheetTypeHeader other)
    where
      mr :: RenderMessage UniWorX msg => msg -> Text
      mr = renderMessage foundation ls

instance RenderMessage UniWorX StudyDegree where
  renderMessage _found _ls StudyDegree{..} = fromMaybe (tshow studyDegreeKey) (studyDegreeName <|> studyDegreeShorthand)

newtype ShortStudyDegree = ShortStudyDegree StudyDegree

instance RenderMessage UniWorX ShortStudyDegree where
  renderMessage _found _ls (ShortStudyDegree StudyDegree{..}) = fromMaybe (tshow studyDegreeKey) studyDegreeShorthand

instance RenderMessage UniWorX StudyTerms where
  renderMessage _found _ls StudyTerms{..} = fromMaybe (tshow studyTermsKey) (studyTermsName <|> studyTermsShorthand)

newtype ShortStudyTerms = ShortStudyTerms StudyTerms

instance RenderMessage UniWorX ShortStudyTerms where
  renderMessage _found _ls (ShortStudyTerms StudyTerms{..}) = fromMaybe (tshow studyTermsKey) studyTermsShorthand

data StudyDegreeTerm = StudyDegreeTerm StudyDegree StudyTerms

instance RenderMessage UniWorX StudyDegreeTerm where
  renderMessage foundation ls (StudyDegreeTerm deg trm) = mr trm <> " (" <> mr (ShortStudyDegree deg) <> ")"
    where
      mr :: RenderMessage UniWorX msg => msg -> Text
      mr = renderMessage foundation ls

newtype ShortStudyFieldType = ShortStudyFieldType StudyFieldType
embedRenderMessageVariant ''UniWorX ''ShortStudyFieldType ("Short" <>)

data StudyDegreeTermType = StudyDegreeTermType StudyDegree StudyTerms StudyFieldType

instance RenderMessage UniWorX StudyDegreeTermType where
  renderMessage foundation ls (StudyDegreeTermType deg trm typ) = mr trm <> " (" <> mr (ShortStudyDegree deg) <> ", " <> mr (ShortStudyFieldType typ) <> ")"
    where
      mr :: RenderMessage UniWorX msg => msg -> Text
      mr = renderMessage foundation ls

instance RenderMessage UniWorX ExamGrade where
  renderMessage _ _ = pack . (showFixed False :: Deci -> String) . fromRational . review numberGrade

instance RenderMessage UniWorX ExamPassed where
  renderMessage foundation ls = \case
    ExamPassed True  -> mr MsgExamPassed
    ExamPassed False -> mr MsgExamNotPassed
    where
      mr :: RenderMessage UniWorX msg => msg -> Text
      mr = renderMessage foundation ls

instance RenderMessage UniWorX a => RenderMessage UniWorX (ExamResult' a) where
  renderMessage foundation ls = \case
    ExamAttended{..} -> mr examResult
    ExamNoShow       -> mr MsgExamResultNoShow
    ExamVoided       -> mr MsgExamResultVoided
    where
      mr :: RenderMessage UniWorX msg => msg -> Text
      mr = renderMessage foundation ls

instance RenderMessage UniWorX (Either ExamPassed ExamGrade) where
  renderMessage foundation ls = either mr mr
    where
      mr :: RenderMessage UniWorX msg => msg -> Text
      mr = renderMessage foundation ls

instance RenderMessage UniWorX CourseParticipantState where
  renderMessage foundation ls = \case
    CourseParticipantActive         -> mr MsgCourseParticipantActive
    CourseParticipantInactive False -> mr MsgCourseParticipantInactive
    CourseParticipantInactive True  -> mr MsgCourseParticipantNoShow
    where
      mr :: RenderMessage UniWorX msg => msg -> Text
      mr = renderMessage foundation ls

-- ToMessage instances for converting raw numbers to Text (no internationalization)

instance ToMessage Int where
  toMessage = tshow
instance ToMessage Int64 where
  toMessage = tshow
instance ToMessage Integer where
  toMessage = tshow
instance ToMessage Natural where
  toMessage = tshow

instance HasResolution a => ToMessage (Fixed a) where
  toMessage = toMessage . showFixed True

-- Do not use toMessage on Rationals and round them automatically. Instead, use rationalToFixed3 (declared in src/Utils.hs) to convert a Rational to Fixed E3!
-- instance ToMessage Rational where
--   toMessage = toMessage . fromRational'
--     where fromRational' = fromRational :: Rational -> Fixed E3


newtype ErrorResponseTitle = ErrorResponseTitle ErrorResponse
embedRenderMessageVariant ''UniWorX ''ErrorResponseTitle ("ErrorResponseTitle" <>)

newtype UniWorXMessages = UniWorXMessages [SomeMessage UniWorX]
  deriving stock (Generic, Typeable)
  deriving newtype (Semigroup, Monoid)

instance IsList UniWorXMessages where
  type Item UniWorXMessages = SomeMessage UniWorX
  fromList = UniWorXMessages
  toList (UniWorXMessages msgs) = msgs

instance RenderMessage UniWorX UniWorXMessages where
  renderMessage foundation ls (UniWorXMessages msgs) =
    Text.unwords $ map (renderMessage foundation ls) msgs

uniworxMessages :: [UniWorXMessage] -> UniWorXMessages
uniworxMessages = UniWorXMessages . map SomeMessage


-- This instance is required to use forms. You can modify renderMessage to
-- achieve customized and internationalized form validation messages.
instance RenderMessage UniWorX FormMessage where
    renderMessage _ ls | lang == "en" = englishFormMessage
                       | otherwise    = germanFormMessage
      where lang = selectLanguage' ("de" :| ["en"]) ls

instance RenderMessage UniWorX (ValueRequired UniWorX) where
  renderMessage foundation ls (ValueRequired label')
    | [w] <- Text.words label
    , let w' = Text.strip w
    , not $ Text.null w'
    = mr $ MsgValueRequiredLabeledSimple w'
    | Text.null $ Text.strip label
    = mr   MsgValueRequired
    | otherwise
    = mr . MsgValueRequiredLabeledMultiWord $ Text.strip label
    where
      label = mr label'
      mr :: forall msg. RenderMessage UniWorX msg => msg -> Text
      mr = renderMessage foundation ls

instance RenderRoute UniWorX => RenderMessage UniWorX (UnsupportedAuthPredicate AuthTag (Route UniWorX)) where
  renderMessage f ls (UnsupportedAuthPredicate tag route) = mr . MsgUnsupportedAuthPredicate (mr tag) $ Text.intercalate "/" pieces
    where
      mr :: forall msg. RenderMessage UniWorX msg => msg -> Text
      mr = renderMessage f ls
      (pieces, _) = renderRoute route

instance RenderMessage UniWorX WeekDay where
  renderMessage _ ls wDay = pack . fst $ wDays (getTimeLocale' ls) !! (fromEnum wDay `mod` 7)

newtype ShortWeekDay = ShortWeekDay { longWeekDay :: WeekDay }

instance RenderMessage UniWorX ShortWeekDay where
  renderMessage _ ls (ShortWeekDay wDay) = pack . snd $ wDays (getTimeLocale' ls) !! (fromEnum wDay `mod` 7)

embedRenderMessage ''UniWorX ''ButtonSubmit id


unRenderMessage' :: (Eq a, Finite a, RenderMessage master a) => (Text -> Text -> Bool) -> master -> Text -> [a]
unRenderMessage' cmp foundation inp = nub $ do
  l <- appLanguages'
  x <- universeF
  guard $ renderMessage foundation (l : filter (/= l) appLanguages') x `cmp` inp
  return x
  where appLanguages' = toList appLanguages

unRenderMessage :: (Eq a, Finite a, RenderMessage master a) => master -> Text -> [a]
unRenderMessage = unRenderMessage' (==)

unRenderMessageLenient :: (Eq a, Finite a, RenderMessage master a) => master -> Text -> [a]
unRenderMessageLenient = unRenderMessage' cmp
  where cmp = (==) `on` mk . under packed (filter Char.isAlphaNum . concatMap unidecode)


instance Default DateTimeFormatter where
  def = mkDateTimeFormatter (getTimeLocale' []) def appTZ