74 lines
2.4 KiB
Haskell
74 lines
2.4 KiB
Haskell
module Handler.Info.TH
|
|
( glossaryTerms
|
|
, mkFaqItems
|
|
) 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 "-"
|
|
|
|
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"
|