108 lines
4.7 KiB
Haskell
108 lines
4.7 KiB
Haskell
module Handler.Utils.I18n
|
||
( i18nWidgetFile
|
||
, i18nWidgetFiles
|
||
, i18nMessage
|
||
, authorizedI18n, authenticationRequiredI18n, unauthorizedI18n
|
||
, _AuthorizedI18n, _AuthenticationRequiredI18n, _UnauthorizedI18n
|
||
, pattern UnauthorizedI18n, pattern AuthorizedI18n, pattern AuthenticationRequiredI18n
|
||
, module Utils.I18n
|
||
) where
|
||
|
||
import Import.NoFoundation
|
||
import Foundation.Type
|
||
|
||
import Utils.I18n
|
||
|
||
import Language.Haskell.TH
|
||
import Language.Haskell.TH.Syntax (qRunIO)
|
||
|
||
import qualified Data.List as List
|
||
import qualified Data.List.NonEmpty as NonEmpty
|
||
|
||
import qualified Data.Map as Map
|
||
|
||
import System.Directory (listDirectory)
|
||
|
||
|
||
-- | Add language dependent template files
|
||
--
|
||
-- For large files which are translated as a whole.
|
||
--
|
||
-- Argument musst be a directory under @/templates@,
|
||
-- which contains a file for each language,
|
||
-- eg. @imprint@ for choosing between
|
||
-- @/templates/imprint/de.hamlet@, @/templates/imprint/de-at.hamlet@,
|
||
-- and @/templates/imprint/en.hamlet@
|
||
--
|
||
-- Dependency detection cannot work properly (no `addDependentFile`-equivalent
|
||
-- for directories)
|
||
-- @$ stack clean@ is required so new translations show up
|
||
i18nWidgetFile :: FilePath -> Q Exp
|
||
i18nWidgetFile basename = do
|
||
-- Construct list of available translations (@de@, @en@, ...) at compile time
|
||
let i18nDirectory = "templates" </> "i18n" </> basename
|
||
availableFiles <- qRunIO $ listDirectory i18nDirectory
|
||
let availableTranslations = sortWith (NTop . flip List.elemIndex (NonEmpty.toList appLanguages)) . List.nub $ pack . takeBaseName <$> availableFiles
|
||
availableTranslations' <- maybe (fail $ "‘" <> i18nDirectory <> "’ is empty") return $ NonEmpty.nonEmpty availableTranslations
|
||
|
||
-- Dispatch to correct language (depending on user settings via `selectLanguage`) at run time
|
||
ws <- newName "ws" -- Name for dispatch function
|
||
letE
|
||
[ funD ws $ [ clause [litP $ stringL l] (normalB . widgetFile $ "i18n" </> basename </> l) []
|
||
| l <- unpack <$> NonEmpty.toList availableTranslations' -- One function definition for every available language
|
||
] ++ [ clause [wildP] (normalB [e| error "selectLanguage returned an invalid translation" |]) [] ] -- Fallback mostly there so compiler does not complain about non-exhaustive pattern match
|
||
] [e|selectLanguage availableTranslations' >>= $(varE ws)|]
|
||
|
||
i18nWidgetFiles :: FilePath -> Q Exp
|
||
i18nWidgetFiles basename = do
|
||
availableTranslations' <- i18nWidgetFilesAvailable' basename
|
||
|
||
-- Dispatch to correct language (depending on user settings via `selectLanguage`) at run time
|
||
ws <- newName "ws" -- Name for dispatch function
|
||
letE
|
||
[ funD ws $ [ clause [litP $ stringL kind, litP $ stringL l] (normalB [e|$(widgetFile $ "i18n" </> basename </> kind <.> l) :: WidgetFor UniWorX ()|]) []
|
||
| (unpack -> kind, ls) <- Map.toList availableTranslations'
|
||
, l <- unpack <$> NonEmpty.toList ls
|
||
] ++ [ clause [wildP, wildP] (normalB [e| error "selectLanguage returned an invalid translation" |]) [] ] -- Fallback mostly there so compiler does not complain about non-exhaustive pattern match
|
||
] [e|imap (\kind ls -> selectLanguage ls >>= $(varE ws) kind) availableTranslations'|]
|
||
|
||
|
||
i18nMessage :: ( MonadHandler m
|
||
, HandlerSite m ~ UniWorX
|
||
, RenderMessage UniWorX msg
|
||
)
|
||
=> msg -> m I18nText
|
||
i18nMessage = i18nMessageFor $ toList appLanguages
|
||
|
||
unauthorizedI18n :: ( MonadHandler m
|
||
, HandlerSite m ~ UniWorX
|
||
, RenderMessage UniWorX msg
|
||
)
|
||
=> msg -> m I18nAuthResult
|
||
unauthorizedI18n = fmap (fmap Unauthorized) . i18nMessage
|
||
|
||
_UnauthorizedI18n :: Prism' I18nAuthResult I18nText
|
||
_UnauthorizedI18n = prism' (fmap Unauthorized) . traverse $ preview _Unauthorized
|
||
|
||
_AuthorizedI18n :: Prism' I18nAuthResult ()
|
||
_AuthorizedI18n = prism' (\() -> authorizedI18n) . traverse_ $ preview _Authorized
|
||
|
||
_AuthenticationRequiredI18n :: Prism' I18nAuthResult ()
|
||
_AuthenticationRequiredI18n = prism' (\() -> authenticationRequiredI18n) . traverse_ $ preview _AuthenticationRequired
|
||
|
||
authorizedI18n, authenticationRequiredI18n :: I18nAuthResult
|
||
authorizedI18n = opoint Authorized
|
||
authenticationRequiredI18n = opoint Authorized
|
||
|
||
pattern UnauthorizedI18n :: I18nText -> I18nAuthResult
|
||
pattern UnauthorizedI18n x <- (preview _UnauthorizedI18n -> Just x) where
|
||
UnauthorizedI18n = review _UnauthorizedI18n
|
||
|
||
pattern AuthorizedI18n :: I18nAuthResult
|
||
pattern AuthorizedI18n <- (preview _AuthorizedI18n -> Just ()) where
|
||
AuthorizedI18n = authorizedI18n
|
||
|
||
pattern AuthenticationRequiredI18n :: I18nAuthResult
|
||
pattern AuthenticationRequiredI18n <- (preview _AuthenticationRequiredI18n -> Just ()) where
|
||
AuthenticationRequiredI18n = authenticationRequiredI18n
|