feat(messages): mkMessageAddition

messages/uniworx/misc/de-de-formal.msg

@@ -1,5 +1,3 @@
-PrintDebugForStupid name@Text: Debug message "#{name}"
-
 Logo: Uni2work
 
 BtnSubmit: Senden

messages/uniworx/misc/en-eu.msg

@@ -1,5 +1,3 @@
-PrintDebugForStupid name: Debug message "#{name}"
-
 Logo: Uni2work
 
 BtnSubmit: Submit

messages/uniworx/test/de-de-formal.msg

@@ -0,0 +1 @@
+PrintDebugForStupid name@Text: Debug message "#{name}"

messages/uniworx/test/en-eu.msg

@@ -0,0 +1 @@
+PrintDebugForStupid name: Debug message "#{name}"

src/Foundation/I18n.hs

@@ -3,7 +3,7 @@
 
 module Foundation.I18n
   ( appLanguages, appLanguagesOpts
-  , UniWorXMessage(..)
+  , UniWorXMessage(..), UniWorXTestMessage(..)
   , ShortTermIdentifier(..)
   , MsgLanguage(..)
   , ShortSex(..)
@@ -20,11 +20,11 @@ module Foundation.I18n
   , UniWorXMessages(..)
   , uniworxMessages
   , unRenderMessage, unRenderMessage', unRenderMessageLenient
+  , module Foundation.I18n.TH
   ) where
 
 import Foundation.Type
 
-
 import Import.NoFoundation
 
 import Auth.LDAP
@@ -131,12 +131,13 @@ maybeToMessage _      Nothing  _     = mempty
 maybeToMessage before (Just x) after = before <> toMessage x <> after
 
 -- Messages creates type UniWorXMessage and RenderMessage UniWorX instance
-mkMessage ''UniWorX "messages/uniworx" "de-de-formal"
-mkMessageVariant "UniWorX" "Campus" "messages/campus" "de"
-mkMessageVariant "UniWorX" "Dummy" "messages/dummy" "de"
-mkMessageVariant "UniWorX" "PWHash" "messages/pw-hash" "de"
-mkMessageVariant "UniWorX" "Button" "messages/button" "de"
-mkMessageVariant "UniWorX" "Frontend" "messages/frontend" "de-de-formal"
+mkMessage ''UniWorX "messages/uniworx/misc" "de-de-formal"
+mkMessageAddition ''UniWorX "Test" "messages/uniworx/test" "de-de-formal"
+mkMessageVariant ''UniWorX ''CampusMessage "messages/campus" "de"
+mkMessageVariant ''UniWorX ''DummyMessage "messages/dummy" "de"
+mkMessageVariant ''UniWorX ''PWHashMessage "messages/pw-hash" "de"
+mkMessageVariant ''UniWorX ''ButtonMessage "messages/button" "de"
+mkMessageVariant ''UniWorX ''FrontendMessage "messages/frontend" "de-de-formal"
 
 instance RenderMessage UniWorX TermIdentifier where
   renderMessage foundation ls TermIdentifier{..} = case season of

src/Foundation/I18n/TH.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE UndecidableInstances #-}
 
 module Foundation.I18n.TH
-  ( mkMessage
+  ( mkMessage, mkMessageFor, mkMessageVariant, mkMessageAddition
   ) where
 
 import Import.NoFoundation
@@ -113,17 +113,37 @@ mkMessage :: TH.Name  -- ^ Foundation type
           -> FilePath -- ^ Base directory of translation files
           -> Lang     -- ^ Default translation language
           -> TH.DecsQ
-mkMessage dt folder lang = mkMessageCommon True "Msg" "Message" dt (TH.nameBase dt) folder lang
+mkMessage dt folder lang = mkMessageCommon True "Msg" dt (TH.mkName $ TH.nameBase dt <> "Message") folder lang
+
+mkMessageFor :: TH.Name    -- ^ Foundation type
+             -> TH.Name    -- ^ Existing type to add translations for
+             -> FilePath   -- ^ Base directory of translation files
+             -> Lang       -- ^ Default translation language
+             -> TH.DecsQ
+mkMessageFor master dt folder lang = mkMessageCommon False "" master dt folder lang
+
+mkMessageVariant :: TH.Name  -- ^ Foundation type
+                 -> TH.Name  -- ^ Existing type to add translations for
+                 -> FilePath -- ^ Base directory of translation files
+                 -> Lang     -- ^ Default translation language
+                 -> TH.DecsQ
+mkMessageVariant master dt folder lang = mkMessageCommon False "Msg" master dt folder lang
+  
+mkMessageAddition :: TH.Name  -- ^ Foundation type
+                  -> String   -- ^ Qualifier to insert into name of message type
+                  -> FilePath -- ^ Base directory of translation files
+                  -> Lang     -- ^ Default translation language
+                  -> TH.DecsQ
+mkMessageAddition master dt folder lang = mkMessageCommon True "Msg" master (TH.mkName $ TH.nameBase master <> dt <> "Message") folder lang
 
 mkMessageCommon :: Bool     -- ^ Generate new datatype
                 -> String   -- ^ String to prepend to constructor names
-                -> String   -- ^ String to append to datatype name
                 -> TH.Name  -- ^ Name of master datatype
-                -> String   -- ^ Basename of translation datatype
+                -> TH.Name  -- ^ Name of translation datatype
                 -> FilePath -- ^ Base directory of translation files
                 -> Lang     -- ^ Default translation language
                 -> TH.DecsQ
-mkMessageCommon genType prefix postfix master dt folder defLang = do
+mkMessageCommon genType prefix master datName folder defLang = do
   files <- fmap DirTree.zipPaths . liftIO $ DirTree.readDirectoryWith (runExceptT . parseMsgFile) folder
   forMOf_ (folded . _1) files TH.addDependentFile
 
@@ -153,7 +173,6 @@ mkMessageCommon genType prefix postfix master dt folder defLang = do
   unless (null extraDefns) . fail $ "Extraneous message definitions:\n" <> indent 2 (unlines extraDefnsErrs)
 
   let defnName defn = TH.mkName $ prefix <> defn
-      datName = TH.mkName $ dt <> postfix
 
   execWriterT @_ @[TH.Dec] $ do
     when genType $ do

src/Handler/Admin/Test.hs

@@ -233,3 +233,5 @@ postAdminTestR = do
          <h2>_{MsgTestDownload}
          ^{testDownloadWidget}
     |]
+
+    i18n $ MsgPrintDebugForStupid "DebugForStupid"

src/Handler/Info.hs

@@ -104,7 +104,7 @@ getGlossaryR =
 
 
 mkI18nWidgetEnum "FAQ" "faq"
-mkMessageFor "UniWorX" "FAQItem" "messages/faq" "de-de-formal"
+mkMessageFor ''UniWorX ''FAQItem "messages/faq" "de-de-formal"
 
 faqsWidget :: ( MonadHandler m, HandlerSite m ~ UniWorX
               , MonadThrow m

src/Import/NoModel.hs

@@ -22,7 +22,7 @@ import ClassyPrelude.Yesod    as Import
          , sinkFile, sourceFile
          , defaultYesodMiddleware
          , authorizationCheck
-         , mkMessage
+         , mkMessage, mkMessageFor, mkMessageVariant
          )
 
 import UnliftIO.Async.Utils as Import