81 lines
4.0 KiB
Haskell
81 lines
4.0 KiB
Haskell
module Handler.Utils.I18n
|
||
( i18nWidgetFile
|
||
, i18nWidgetFilesAvailable, i18nWidgetFilesAvailable', i18nWidgetFiles
|
||
) where
|
||
|
||
import Import.NoFoundation
|
||
import Foundation.Type
|
||
import Foundation.I18n
|
||
|
||
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 qualified Data.List.NonEmpty as NonEmpty
|
||
|
||
import qualified Data.Set as Set
|
||
import qualified Data.Map as Map
|
||
|
||
import qualified Data.Text as Text
|
||
|
||
import System.Directory (listDirectory)
|
||
import System.FilePath.Posix (takeBaseName)
|
||
|
||
|
||
-- | 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)|]
|
||
|
||
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 . (<>".")) $ map 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'
|
||
|
||
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'|]
|