diff --git a/src/Foundation/I18n.hs b/src/Foundation/I18n.hs index 71543f2d9..90bcc6232 100644 --- a/src/Foundation/I18n.hs +++ b/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 diff --git a/src/Foundation/SiteLayout.hs b/src/Foundation/SiteLayout.hs index 765c1b70f..8ca6c3b29 100644 --- a/src/Foundation/SiteLayout.hs +++ b/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) diff --git a/src/Foundation/Yesod/Middleware.hs b/src/Foundation/Yesod/Middleware.hs index 6ba2b61ca..1a7183602 100644 --- a/src/Foundation/Yesod/Middleware.hs +++ b/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 diff --git a/src/Handler/Info.hs b/src/Handler/Info.hs index f62a9db0e..7f4749bb6 100644 --- a/src/Handler/Info.hs +++ b/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 diff --git a/src/Handler/Info/TH.hs b/src/Handler/Info/TH.hs index a36694c5c..25c55bdb6 100644 --- a/src/Handler/Info/TH.hs +++ b/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" diff --git a/src/Handler/News.hs b/src/Handler/News.hs index 04ee47d74..f21875ab3 100644 --- a/src/Handler/News.hs +++ b/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) diff --git a/src/Handler/SystemMessage.hs b/src/Handler/SystemMessage.hs index 79ee42ae6..83d6aa46b 100644 --- a/src/Handler/SystemMessage.hs +++ b/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) , .. diff --git a/src/Handler/Utils/I18n.hs b/src/Handler/Utils/I18n.hs index aaf7132f4..7a8ca8c0f 100644 --- a/src/Handler/Utils/I18n.hs +++ b/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 diff --git a/src/Settings.hs b/src/Settings.hs index b1b37557b..4e40ba9a4 100644 --- a/src/Settings.hs +++ b/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") diff --git a/src/Settings/Locale.hs b/src/Settings/Locale.hs new file mode 100644 index 000000000..f3d0f7a40 --- /dev/null +++ b/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"] diff --git a/src/Utils.hs b/src/Utils.hs index 4e0a169a5..f4aacc548 100644 --- a/src/Utils.hs +++ b/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 - -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 +-- `NTop` moved to `Utils.NTop` exceptTMaybe :: Monad m => ExceptT e m a -> MaybeT m a exceptTMaybe = MaybeT . fmap (either (const Nothing) Just) . runExceptT diff --git a/src/Utils/DateTime.hs b/src/Utils/DateTime.hs index 27b30c9bf..dc2ce4677 100644 --- a/src/Utils/DateTime.hs +++ b/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 diff --git a/src/Utils/I18n.hs b/src/Utils/I18n.hs new file mode 100644 index 000000000..2645230e2 --- /dev/null +++ b/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' + diff --git a/src/Utils/NTop.hs b/src/Utils/NTop.hs new file mode 100644 index 000000000..1199f26c3 --- /dev/null +++ b/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 + diff --git a/src/Utils/SystemMessage.hs b/src/Utils/SystemMessage.hs index 214cf5b65..9d78b2690 100644 --- a/src/Utils/SystemMessage.hs +++ b/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 diff --git a/src/Utils/TH.hs b/src/Utils/TH.hs index b233aaa73..b218011d1 100644 --- a/src/Utils/TH.hs +++ b/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