-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later

module Utils.Lang where

import ClassyPrelude.Yesod

import Model.Types.Languages
import Utils.Cookies.Registered
import Utils.Parameters
import Utils.Session

import qualified Data.List.NonEmpty as NonEmpty
import Data.List.NonEmpty (NonEmpty(..), nonEmpty)

import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import qualified Data.List as List

import qualified Data.CaseInsensitive as CI

import Yesod.Core.Types (HandlerData(handlerRequest))
import qualified Network.Wai.Parse as NWP

import Control.Monad.Trans.Maybe (MaybeT(..))
import Control.Monad.Reader.Class (local)

import qualified Data.HashMap.Strict as HashMap

import Data.Containers.ListUtils

isDe :: Lang -> Bool
isDe = isPrefixOf "de"

isEn :: Lang -> Bool
isEn = isPrefixOf "en"

selectDeEn :: Maybe Languages -> Lang
selectDeEn = selectLanguage' availableLanguages . concatMap getLanguages
  where 
    availableLanguages = "de" :| ["en"] -- for now, we only have german and english, with german being the default language

selectEnDe :: Maybe Languages -> Lang
selectEnDe = selectLanguage' availableLanguages . concatMap getLanguages
  where 
    availableLanguages = "en" :| ["de"]

selectLanguage :: MonadHandler m
               => NonEmpty Lang -- ^ Available translations, first is default
               -> m Lang
selectLanguage avL = selectLanguage' avL <$> languages

selectLanguage' :: NonEmpty Lang -- ^ Available translations, first is default
                -> [Lang] -- ^ Languages in preference order
                -> Lang
selectLanguage' avL ls = NonEmpty.head $ selectLanguages avL ls

selectLanguages :: NonEmpty Lang -> [Lang] -> NonEmpty Lang
selectLanguages (defL :| _) [] = defL :| []
selectLanguages avL (l:ls)
  | not $ null l
  , Just lParts <- nonEmpty $ matchesFor l
  , found <- nubOrd
      [ l'' | lParts' <- NonEmpty.toList lParts
            , l' <- NonEmpty.toList avL
            , l'' <- matchesFor l'
            , langMatches lParts' l''
            ]
  = let now = nonEmpty $ sortOn (Down . length) found
        others = selectLanguages avL ls
     in maybe id (\now' others' -> NonEmpty.fromList $ toList now' ++ filter (`notElem` toList now') (toList others')) now others
  | otherwise = selectLanguages avL ls

langMatches :: Lang -- ^ Needle
            -> Lang -- ^ Haystack
            -> Bool
langMatches (CI.foldCase -> needle) (CI.foldCase -> haystack) = needle `elem` matchesFor haystack

matchesFor :: Lang -> [Lang]
matchesFor = mapMaybe (\frags -> Text.intercalate "-" frags <$ guard (not $ null frags)) . reverse . List.inits . Text.splitOn "-"


highPrioRequestedLangs, lowPrioRequestedLangs :: forall m. MonadHandler m => m [Lang]
highPrioRequestedLangs = fmap (concatMap $ fromMaybe []) . mapM runMaybeT $
  [ lookupGlobalGetParams GetLang
  , lookupRegisteredCookies pure CookieLang
  , fmap pure . MaybeT $ lookupSessionKey SessionLang
  ]
lowPrioRequestedLangs = maybe [] (mapMaybe (either (const Nothing) Just . Text.decodeUtf8') . NWP.parseHttpAccept) <$> lookupHeader hAcceptLanguage

languagesMiddleware :: forall site a. NonEmpty Lang -> HandlerFor site a -> HandlerFor site a
languagesMiddleware avL act = do
  pLangs <- fmap nubOrd $ (<>) <$> highPrioRequestedLangs <*> lowPrioRequestedLangs
  let langs = toList $ selectLanguages avL pLangs
      setLangs hData = hData{ handlerRequest = (handlerRequest hData){ reqLangs = langs } }
  local setLangs $ ($logDebugS "languages" . tshow . (pLangs,langs,) =<< languages) *> act


renderMessageDispatch :: forall msg site.
                         Lang -- ^ Default language
                      -> (site -> [Lang] -> msg -> Text) -- ^ Default renderer
                      -> HashMap Lang (Either (site -> [Lang] -> msg -> Maybe Text) (site -> [Lang] -> msg -> Text)) -- ^ All renderers
                      -> site -> [Lang] -> msg -> Text
renderMessageDispatch defLang defRender extraRenders app langs msg = go $ selectLanguages avLangs langs
  where
    avLangs = defLang :| HashMap.keys extraRenders

    go (l :| []) = case HashMap.lookup l extraRenders of
      Nothing -> defRender app langs msg
      Just (Left pRender) -> fromMaybe (defRender app langs msg) $ pRender app langs msg
      Just (Right tRender) -> tRender app langs msg
    go (l1 :| l2 : ls) = case HashMap.lookup l1 extraRenders of
      Nothing -> go (l2 :| ls)
      Just (Left pRender) -> fromMaybe (go $ l2 :| ls) $ pRender app langs msg
      Just (Right tRender) -> tRender app langs msg
{-# INLINE renderMessageDispatch #-}