module Utils.Lang where

import ClassyPrelude.Yesod

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)


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 <- List.nub
      [ 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 $
  [ lookupGetParams "_LANG"
  , lookupCookies "_LANG"
  , fmap pure . MaybeT $ lookupSession "_LANG"
  ]
lowPrioRequestedLangs = maybe [] (mapMaybe (either (const Nothing) Just . Text.decodeUtf8') . NWP.parseHttpAccept) <$> lookupHeader "Accept-Language"

languagesMiddleware :: forall site a. NonEmpty Lang -> HandlerFor site a -> HandlerFor site a
languagesMiddleware avL act = do
  pLangs <- fmap List.nub $ (<>) <$> 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