refactor(glossary): use more template haskell

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")

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 "-"

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