refactor: generalize mkFaqItems

src/Foundation/I18n.hs

@@ -47,10 +47,6 @@ import Data.Text.Lens (packed)
 import Data.List ((!!))
 
 
-appLanguages :: NonEmpty Lang
-appLanguages = "de-de-formal" :| ["en-eu"]
-
-
 pluralDE :: (Eq a, Num a)
             =>    a -- ^ Count
             -> Text -- ^ Singular

src/Foundation/SiteLayout.hs

@@ -446,7 +446,7 @@ applySystemMessages = liftHandler . maybeT_ . catchMPlus (Proxy @CryptoIDError)
       guard $ userSystemMessageShown <= Just systemMessageLastChanged
       guard $ userSystemMessageHidden <= Just systemMessageLastUnhide
 
-      (_, smTrans) <- MaybeT $ getSystemMessage appLanguages smId
+      (_, smTrans) <- MaybeT $ getSystemMessage smId
       let
         (summary, content) = case smTrans of
           Nothing -> (systemMessageSummary, systemMessageContent)

src/Foundation/Yesod/Middleware.hs

@@ -7,7 +7,6 @@ import Import.NoFoundation hiding (yesodMiddleware)
 
 import Foundation.Type
 import Foundation.Routes
-import Foundation.I18n
 import Foundation.Authorization
 
 import Utils.Metrics

src/Handler/Info.hs

@@ -90,7 +90,7 @@ getGlossaryR =
     msgMap = $(glossaryTerms "glossary")
 
 
-mkFaqItems "faq"
+mkI18nWidgetEnum "FAQ" "faq"
 mkMessageFor "UniWorX" "FAQItem" "messages/faq" "de-de-formal"
 
 faqsWidget :: ( MonadHandler m, HandlerSite m ~ UniWorX

src/Handler/Info/TH.hs

@@ -1,6 +1,5 @@
 module Handler.Info.TH
   ( glossaryTerms
-  , mkFaqItems
   ) where
 
 import Import
@@ -22,52 +21,3 @@ glossaryTerms basename = do
   where
     unPathPiece :: Text -> String
     unPathPiece = repack . mconcat . map (over _head Char.toUpper) . Text.splitOn "-"
-
-mkFaqItems :: FilePath -> DecsQ
-mkFaqItems basename = do
-  itemsAvailable <- i18nWidgetFilesAvailable' basename
-  let items = Map.mapWithKey (\k _ -> "FAQ" <> unPathPiece k) itemsAvailable
-  sequence
-    [ dataD (cxt []) dataName [] Nothing
-        [ normalC (mkName conName) []
-        | (_, conName) <- Map.toAscList items
-        ]
-        [ derivClause (Just StockStrategy)
-            [ conT ''Eq
-            , conT ''Ord
-            , conT ''Read
-            , conT ''Show
-            , conT ''Enum
-            , conT ''Bounded
-            , conT ''Generic
-            , conT ''Typeable
-            ]
-        , derivClause (Just AnyclassStrategy)
-            [ conT ''Universe
-            , conT ''Finite
-            ]
-        ]
-    , instanceD (cxt []) (conT ''PathPiece `appT` conT dataName)
-      [ funD 'toPathPiece
-        [ clause [conP (mkName con) []] (normalB . litE . stringL $ repack int) []
-        | (int, con) <- Map.toList items
-        ]
-      , funD 'fromPathPiece
-        [ clause [varP $ mkName "t"]
-          ( guardedB
-            [ (,) <$> normalG [e|$(varE $ mkName "t") == int|] <*> [e|Just $(conE $ mkName con)|]
-            | (int, con) <- Map.toList items
-            ]) []
-        , clause [wildP] (normalB [e|Nothing|]) []
-        ]
-      ]
-    , sigD (mkName "faqItemMap") [t|Map Text $(conT dataName)|]
-    , funD (mkName "faqItemMap")
-        [ clause [] (normalB [e| Map.fromList $(listE . map (\(int, con) -> tupE [litE . stringL $ repack int, conE $ mkName con]) $ Map.toList items) |]) []
-        ]
-    ]
-  where
-    unPathPiece :: Text -> String
-    unPathPiece = repack . mconcat . map (over _head Char.toUpper) . Text.splitOn "-"
-
-    dataName = mkName "FAQItem"

src/Handler/News.hs

@@ -69,7 +69,7 @@ newsSystemMessages = do
   (messages', Any anyHidden) <- liftHandler . runDB . runConduit . C.runWriterLC $
        transPipe lift (selectKeys [] [])
     .| C.filterM (hasReadAccessTo . MessageR <=< encrypt)
-    .| transPipe lift (C.mapMaybeM $ \smId -> fmap (\args@(sm, _) -> (smId, sm, systemMessageToTranslation smId args)) <$> getSystemMessage appLanguages smId)
+    .| transPipe lift (C.mapMaybeM $ \smId -> fmap (\args@(sm, _) -> (smId, sm, systemMessageToTranslation smId args)) <$> getSystemMessage smId)
     .| C.filter (\(_, SystemMessage{..}, _) -> NTop systemMessageFrom <= NTop (Just now) && NTop (Just now) < NTop systemMessageTo)
     .| C.mapMaybeM checkHidden
     .| C.iterM (\(smId, _, _, _) -> tellShown smId)

src/Handler/SystemMessage.hs

@@ -25,7 +25,7 @@ getMessageR, postMessageR :: CryptoUUIDSystemMessage -> Handler Html
 getMessageR = postMessageR
 postMessageR cID = do
   smId <- decrypt cID
-  (SystemMessage{..}, translation) <- runDB $ maybe notFound return =<< getSystemMessage appLanguages smId
+  (SystemMessage{..}, translation) <- runDB $ maybe notFound return =<< getSystemMessage smId
   let (summary, content) = case translation of
         Nothing -> (systemMessageSummary, systemMessageContent)
         Just SystemMessageTranslation{..} -> (systemMessageTranslationSummary, systemMessageTranslationContent)
@@ -185,7 +185,7 @@ postMessageListR = do
             in cell . toWidget $ fromMaybe content summary
       ]
     dbtProj DBRow{ dbrOutput = smE@(Entity smId _), .. } = do
-      smT <- (>>= view _2) <$> getSystemMessage appLanguages smId
+      smT <- (>>= view _2) <$> getSystemMessage smId
       return DBRow
         { dbrOutput = (smE, smT)
         , ..

src/Handler/Utils/I18n.hs

@@ -1,24 +1,22 @@
 module Handler.Utils.I18n
   ( i18nWidgetFile
-  , i18nWidgetFilesAvailable, i18nWidgetFilesAvailable', i18nWidgetFiles
+  , i18nWidgetFiles
+  , module Utils.I18n
   ) where
 
 import Import.NoFoundation
 import Foundation.Type
-import Foundation.I18n
+
+import Utils.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)
 
 
@@ -51,20 +49,6 @@ 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)|]
 
-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 . (<>".")) . 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

src/Settings.hs

@@ -12,6 +12,7 @@ module Settings
   , module Settings.Mime
   , module Settings.Cookies
   , module Settings.Log
+  , module Settings.Locale
   ) where
 
 import           Import.NoModel
@@ -55,6 +56,7 @@ import Settings.Cluster
 import Settings.Mime
 import Settings.Cookies
 import Settings.Log
+import Settings.Locale
 
 import qualified System.FilePath as FilePath
 
@@ -605,10 +607,3 @@ compileTimeAppSettings =
     case fromJSON $ applyEnvValue False mempty configSettingsYmlValue of
         Aeson.Error e -> error e
         Aeson.Success settings -> settings
-
-
-getTimeLocale' :: [Lang] -> TimeLocale
-getTimeLocale' = $(timeLocaleMap [("de-de", "de_DE.utf8"), ("en-GB", "en_GB.utf8")])
-
-appTZ :: TZ
-appTZ = $(includeSystemTZ "Europe/Berlin")

src/Settings/Locale.hs

@@ -0,0 +1,21 @@
+module Settings.Locale
+  ( getTimeLocale'
+  , appTZ
+  , appLanguages
+  ) where
+
+import Utils.DateTime
+
+import Data.List.NonEmpty
+
+import Text.Shakespeare.I18N (Lang)
+  
+
+getTimeLocale' :: [Lang] -> TimeLocale
+getTimeLocale' = $(timeLocaleMap [("de-de", "de_DE.utf8"), ("en-GB", "en_GB.utf8")])
+
+appTZ :: TZ
+appTZ = $(includeSystemTZ "Europe/Berlin")
+
+appLanguages :: NonEmpty Lang
+appLanguages = "de-de-formal" :| ["en-eu"]

src/Utils.hs

@@ -31,6 +31,7 @@ import Utils.Cookies as Utils
 import Utils.Cookies.Registered as Utils
 import Utils.Session as Utils
 import Utils.Csv as Utils
+import Utils.NTop as Utils
 
 import Text.Blaze (Markup, ToMarkup)
 
@@ -654,16 +655,7 @@ ignoreNothing _ Nothing y = y
 ignoreNothing _ x Nothing = x
 ignoreNothing f (Just x) (Just y) = Just $ f x y
 
-newtype NTop a = NTop { nBot :: a } -- treat Nothing as Top for Ord (Maybe a); default implementation treats Nothing as bottom
+-- `NTop` moved to `Utils.NTop`
-
-instance Eq a  => Eq (NTop (Maybe a)) where
-  (NTop x) == (NTop y) = x == y
-
-instance Ord a => Ord (NTop (Maybe a)) where
-  compare (NTop Nothing)  (NTop Nothing) = EQ
-  compare (NTop Nothing)  _              = GT
-  compare _               (NTop Nothing) = LT
-  compare (NTop (Just x)) (NTop (Just y)) = compare x y
 
 exceptTMaybe :: Monad m => ExceptT e m a -> MaybeT m a
 exceptTMaybe = MaybeT . fmap (either (const Nothing) Just) . runExceptT

src/Utils/DateTime.hs

@@ -45,6 +45,8 @@ import Algebra.Lattice.Ordered
 
 import Control.Monad.Fail
 
+import Utils.Lang (selectLanguage')
+
 
 -- $(timeLocaleMap _) :: [Lang] -> TimeLocale
 timeLocaleMap :: [(Lang, String)] -- ^ Languages and matching locales, first is taken as default

src/Utils/I18n.hs

@@ -0,0 +1,44 @@
+module Utils.I18n
+  ( i18nWidgetFilesAvailable, i18nWidgetFilesAvailable'
+  ) where
+
+import ClassyPrelude
+import Settings.Locale (appLanguages)
+
+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 Data.List.NonEmpty (NonEmpty)
+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.FilePath
+import System.Directory (listDirectory)
+
+import Utils.NTop
+
+import Control.Lens (iforM)
+import Control.Monad.Fail (fail)
+
+
+
+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 . (<>".")) . 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'
+

src/Utils/NTop.hs

@@ -0,0 +1,17 @@
+module Utils.NTop
+  ( NTop(..)
+  ) where
+
+import ClassyPrelude
+
+-- | treat Nothing as Top for Ord (Maybe a); default implementation treats Nothing as bottom
+newtype NTop a = NTop { nBot :: a }
+  deriving (Read, Show, Generic, Typeable)
+  deriving newtype (Eq)
+
+instance Ord a => Ord (NTop (Maybe a)) where
+  compare (NTop Nothing)  (NTop Nothing) = EQ
+  compare (NTop Nothing)  _              = GT
+  compare _               (NTop Nothing) = LT
+  compare (NTop (Just x)) (NTop (Just y)) = compare x y
+

src/Utils/SystemMessage.hs

@@ -7,10 +7,9 @@ import Data.List (findIndex)
 
 
 getSystemMessage :: (MonadHandler m, BackendCompatible SqlReadBackend backend)
-                 => NonEmpty Lang -- ^ `appLanguages`
+                 => SystemMessageId
-                 -> SystemMessageId
                  -> ReaderT backend m (Maybe (SystemMessage, Maybe SystemMessageTranslation))
-getSystemMessage appLanguages smId = withReaderT (projectBackend @SqlReadBackend) . runMaybeT $ do
+getSystemMessage smId = withReaderT (projectBackend @SqlReadBackend) . runMaybeT $ do
   SystemMessage{..} <- MaybeT $ get smId
   translations <- lift $ selectList [SystemMessageTranslationMessage ==. smId] []
   let

src/Utils/TH.hs

@@ -13,8 +13,18 @@ import Language.Haskell.TH.Datatype
 
 import Data.List ((!!), foldl)
 
+import Control.Lens
 import Control.Monad.Fail
 
+import Utils.I18n
+
+import qualified Data.Char as Char
+import Data.Universe (Universe, Finite)
+import qualified Data.Map as Map
+import qualified Data.Text as Text
+
+import Utils.PathPiece
+
 ------------
 -- Tuples --
 ------------
@@ -188,3 +198,56 @@ dispatchTH dType = do
       let fName = mkName $ "dispatch" <> nameBase constructorName
       match (conP constructorName $ map varP pats) (normalB $ foldl (\e pat -> e `appE` varE pat) (varE fName) pats) []
   lamCaseE matches
+
+
+mkI18nWidgetEnum :: String -> FilePath -> DecsQ
+mkI18nWidgetEnum (splitCamel -> namebase) basename = do
+  itemsAvailable <- i18nWidgetFilesAvailable' basename
+  let items = Map.mapWithKey (\k _ -> typPrefix <> unPathPiece k) itemsAvailable
+  sequence
+    [ dataD (cxt []) dataName [] Nothing
+        [ normalC (mkName conName) []
+        | (_, conName) <- Map.toAscList items
+        ]
+        [ derivClause (Just StockStrategy)
+            [ conT ''Eq
+            , conT ''Ord
+            , conT ''Read
+            , conT ''Show
+            , conT ''Enum
+            , conT ''Bounded
+            , conT ''Generic
+            , conT ''Typeable
+            ]
+        , derivClause (Just AnyclassStrategy)
+            [ conT ''Universe
+            , conT ''Finite
+            ]
+        ]
+    , instanceD (cxt []) (conT ''PathPiece `appT` conT dataName)
+      [ funD 'toPathPiece
+        [ clause [conP (mkName con) []] (normalB . litE . stringL $ repack int) []
+        | (int, con) <- Map.toList items
+        ]
+      , funD 'fromPathPiece
+        [ clause [varP $ mkName "t"]
+          ( guardedB
+            [ (,) <$> normalG [e|$(varE $ mkName "t") == int|] <*> [e|Just $(conE $ mkName con)|]
+            | (int, con) <- Map.toList items
+            ]) []
+        , clause [wildP] (normalB [e|Nothing|]) []
+        ]
+      ]
+    , sigD (mkName $ valPrefix <> "ItemMap") [t|Map Text $(conT dataName)|]
+    , funD (mkName $ valPrefix <> "ItemMap")
+        [ clause [] (normalB [e| Map.fromList $(listE . map (\(int, con) -> tupE [litE . stringL $ repack int, conE $ mkName con]) $ Map.toList items) |]) []
+        ]
+    ]
+  where
+    unPathPiece :: Text -> String
+    unPathPiece = repack . mconcat . map (over _head Char.toUpper) . Text.splitOn "-"
+
+    dataName = mkName $ typPrefix <> "Item"
+
+    typPrefix = concat $ over (takingWhile Char.isLower $ _head . traverse) Char.toUpper namebase
+    valPrefix = concat $ over (takingWhile Char.isUpper $ _head . traverse) Char.toLower namebase