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

{-# LANGUAGE UndecidableInstances #-}

module Utils.I18n
  ( I18n(..)
  , I18nText, I18nHtml, I18nAuthResult
  , renderMessageI18n
  , i18nMessageFor
  , LanguageSelectI18n(..), getLanguageSelectI18n
  , selectLanguageI18n
  , Element
  , i18nWidgetFilesAvailable, i18nWidgetFilesAvailable'
  ) where

import ClassyPrelude.Yesod hiding (derivePersistFieldJSON)
import Settings.Locale (appLanguages)

import qualified Data.Aeson as JSON
import qualified Data.HashMap.Lazy as HashMap

import qualified Data.Map as Map
import qualified Data.Set as Set

import Model.Types.TH.JSON

import Data.Data (Data)

import Language.Haskell.TH
import Language.Haskell.TH.Syntax (qRunIO)
import qualified Language.Haskell.TH.Syntax as TH

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

import qualified Data.Text as Text

import System.FilePath
import System.Directory (listDirectory)

import Utils.NTop

import Utils.Lang (selectLanguage')

import Control.Lens
import Control.Lens.Extras (is)

import Control.Monad.Fail (fail)

import Data.Binary (Binary)


{-# ANN module ("HLint: ignore Use newtype instead of data"::String) #-}


data I18n a = I18n
  { i18nFallback     :: a
  , i18nFallbackLang :: Maybe Lang
  , i18nTranslations :: Map Lang a
  } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable, Data, Generic)
    deriving anyclass (MonoFunctor, MonoFoldable, MonoTraversable, Binary, NFData)
type instance Element (I18n a) = a

type I18nText = I18n Text
type I18nHtml = I18n Html
type I18nAuthResult = I18n AuthResult


instance MonoPointed (I18n a) where
  opoint i18nFallback = I18n { i18nFallback, i18nFallbackLang = Nothing, i18nTranslations = Map.empty }
  
instance IsString a => IsString (I18n a) where
  fromString = opoint . fromString

instance ToJSON a => ToJSON (I18n a) where
  toJSON I18n{..}
    | Map.null i18nTranslations
    , is _Nothing i18nFallbackLang
    , fallbackUnambiguous
    = toJSON i18nFallback
    | otherwise
    = JSON.object $ catMaybes
        [ pure $ "fallback" JSON..= i18nFallback
        , ("fallback-lang" JSON..=) <$> i18nFallbackLang
        , ("translations" JSON..=) <$> (i18nTranslations <$ guard (not $ Map.null i18nTranslations))
        ]
    where
      fallbackUnambiguous = case toJSON i18nFallback of
        JSON.Object hm  ->    not (HashMap.member "fallback" hm)
                           && not (HashMap.member "fallback-lang" hm)
        _other          -> True

instance FromJSON a => FromJSON (I18n a) where
  parseJSON (JSON.Object o)
    | HashMap.member "fallback" o || HashMap.member "fallback-lang" o = do
        i18nFallback <- o JSON..: "fallback"
        i18nFallbackLang <- o JSON..:? "fallback-lang"
        i18nTranslations <- o JSON..:? "translations" JSON..!= Map.empty
        return I18n{..}
  parseJSON val = do
    i18nFallback <- JSON.parseJSON val
    let i18nTranslations = Map.empty
        i18nFallbackLang = Nothing
    return I18n{..}

derivePersistFieldJSON ''I18n


unI18n :: [Lang] -> I18n a -> a
unI18n langs I18n{..} = case i18nFallbackLang of
  Just fL -> let translations' = Map.insert fL i18nFallback i18nTranslations
                 avLangs = fL :| filter (/= fL) (Map.keys i18nTranslations)
              in Map.findWithDefault i18nFallback (selectLanguage' avLangs langs) translations'
  Nothing -> let fakeLang = go Nothing
                   where go  Nothing | fake `Map.member` i18nTranslations = go $ Just 1
                                     | otherwise = fake
                           where fake = "fake"
                         go (Just n) | fake `Map.member` i18nTranslations = go . Just $ succ n
                                     | otherwise = fake
                           where fake = "fake-" <> tshow n
              in Map.findWithDefault i18nFallback (selectLanguage' (fakeLang :| Map.keys i18nTranslations) langs) i18nTranslations


instance Applicative I18n where
  pure = opoint
  f <*> x = I18n
    { i18nFallback = i18nFallback f $ unI18n (maybeToList $ i18nFallbackLang f) x
    , i18nFallbackLang = if
        | i18nFallbackLang f == i18nFallbackLang x -> i18nFallbackLang f
        | otherwise -> Nothing
    , i18nTranslations = Map.fromList $ do
        let fLangs = Map.keysSet $ i18nTranslations f
            xLangs = Map.keysSet $ i18nTranslations x
        lang <- Set.toList $ fLangs <> xLangs
        return (lang, unI18n [lang] f $ unI18n [lang] x)
    }


renderMessageI18n :: RenderMessage site msg
                  => [Lang] -> site -> msg -> I18nText
renderMessageI18n ls app msg = I18n{..}
  where
    i18nFallback = renderMessage app [] msg
    i18nFallbackLang = listToMaybe $ do
      (lang, translation) <- Map.toList i18nTranslations
      guard $ translation == i18nFallback
      return lang
    i18nTranslations = Map.fromList . flip map ls $ \l -> (l, ) $ renderMessage app (l : filter (/= l) ls) msg
  
i18nMessageFor :: ( MonadHandler m
                  , RenderMessage (HandlerSite m) msg
                  )
               => [Lang] -> msg -> m I18nText
i18nMessageFor ls msg = getsYesod $ flip (renderMessageI18n ls) msg

data LanguageSelectI18n = LanguageSelectI18n { slI18n :: forall a. I18n a -> a }

getLanguageSelectI18n :: MonadHandler m
                      => m LanguageSelectI18n
getLanguageSelectI18n = languages <&> \langs -> LanguageSelectI18n (unI18n langs)

selectLanguageI18n :: MonadHandler m
                   => I18n a -> m a
selectLanguageI18n i18n = do
  LanguageSelectI18n{..} <- getLanguageSelectI18n
  return $ slI18n i18n


i18nWidgetFilesAvailable' :: FilePath -> Q (Map Text (NonEmpty Text))
i18nWidgetFilesAvailable' basename = do
  let i18nDirectory = "templates" </> "i18n" </> basename
  availableFiles <- qRunIO $ listDirectory i18nDirectory
  let fileKinds' = fmap (pack . dropExtension . takeBaseName &&& toTranslation . pack . takeBaseName) availableFiles
      fileKinds :: Map Text [Text]
      fileKinds = sortWith (NTop . flip List.elemIndex (NonEmpty.toList appLanguages)) . Set.toList <$> Map.fromListWith Set.union [ (kind, Set.singleton l) | (kind, Just l) <- fileKinds' ]
      toTranslation fName = (listToMaybe . sortOn length) (mapMaybe ((flip Text.stripPrefix fName . (<>".")) . fst) fileKinds')

  iforM fileKinds $ \kind -> maybe (fail $ "‘" <> i18nDirectory <> "’ has no translations for ‘" <> unpack kind <> "’") return . NonEmpty.nonEmpty

i18nWidgetFilesAvailable :: FilePath -> Q Exp
i18nWidgetFilesAvailable = TH.lift <=< i18nWidgetFilesAvailable'