fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

refactor: generalize mkFaqItems

Browse Source
This commit is contained in:
Gregor Kleen 2020-09-28 12:23:38 +02:00
parent b359468593
commit 0e1035ddb0
16 changed files with 162 additions and 100 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
src/Foundation/I18n.hs
View File

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

2
src/Foundation/SiteLayout.hs
View File

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

1
src/Foundation/Yesod/Middleware.hs
View File

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

2
src/Handler/Info.hs
View File

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

50
src/Handler/Info/TH.hs
View File

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

2
src/Handler/News.hs
View File

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

4
src/Handler/SystemMessage.hs
View File

@ -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)
, ..

24
src/Handler/Utils/I18n.hs
View File

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

9
src/Settings.hs
View File

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

21
src/Settings/Locale.hs Normal file
View File

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

12
src/Utils.hs
View File

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

2
src/Utils/DateTime.hs
View File

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

44
src/Utils/I18n.hs Normal file
View File

@ -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'

17
src/Utils/NTop.hs Normal file
View File

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

5
src/Utils/SystemMessage.hs
View File

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

63
src/Utils/TH.hs
View File

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