diff --git a/src/Handler/Info.hs b/src/Handler/Info.hs index c4a5fe7dc..69aa8437b 100644 --- a/src/Handler/Info.hs +++ b/src/Handler/Info.hs @@ -2,6 +2,7 @@ module Handler.Info where import Import import Handler.Utils +import Handler.Info.TH import qualified Data.Map as Map import qualified Data.CaseInsensitive as CI @@ -84,7 +85,4 @@ getGlossaryR = $(widgetFile "glossary") where entries = $(i18nWidgetFiles "glossary") - msgMap = Map.fromList - [ ("applicant" , MsgApplicant ) - , ("course-participant", MsgCourseParticipant) - ] + msgMap = $(glossaryTerms "glossary") diff --git a/src/Handler/Info/TH.hs b/src/Handler/Info/TH.hs new file mode 100644 index 000000000..25c55bdb6 --- /dev/null +++ b/src/Handler/Info/TH.hs @@ -0,0 +1,23 @@ +module Handler.Info.TH + ( glossaryTerms + ) where + +import Import +import Handler.Utils.I18n + +import Language.Haskell.TH + +import qualified Data.Char as Char + +import qualified Data.Map.Strict as Map +import qualified Data.Text as Text + + +glossaryTerms :: FilePath -> Q Exp +glossaryTerms basename = do + translationsAvailable <- i18nWidgetFilesAvailable' basename + let terms = Map.mapWithKey (\k _ -> "Msg" <> unPathPiece k) translationsAvailable + [e|Map.fromList $(listE . map (\(int, msg) -> tupE [litE . stringL $ repack int, conE $ mkName msg]) $ Map.toList terms)|] + where + unPathPiece :: Text -> String + unPathPiece = repack . mconcat . map (over _head Char.toUpper) . Text.splitOn "-" diff --git a/src/Handler/Utils/I18n.hs b/src/Handler/Utils/I18n.hs index f3b2e157a..a98067a49 100644 --- a/src/Handler/Utils/I18n.hs +++ b/src/Handler/Utils/I18n.hs @@ -1,10 +1,13 @@ module Handler.Utils.I18n - where + ( i18nWidgetFile + , i18nWidgetFilesAvailable, i18nWidgetFilesAvailable', i18nWidgetFiles + ) where import Import 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 @@ -47,8 +50,8 @@ i18nWidgetFile basename = do ] ++ [ 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 +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 @@ -58,6 +61,15 @@ i18nWidgetFiles basename = do availableTranslations' <- iforM fileKinds $ \kind -> maybe (fail $ "‘" <> i18nDirectory <> "’ has no translations for ‘" <> unpack kind <> "’") return . NonEmpty.nonEmpty + return availableTranslations' + +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