185 lines
6.5 KiB
Haskell
185 lines
6.5 KiB
Haskell
-- 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'
|