feat(messages): implement custom parser for message files
This commit is contained in:
Gregor Kleen
parent
f50665b08c
commit
bb877eb813
@ -17,7 +17,7 @@ BtnExamSwitchOccurrence: Zu Prüfungstermin/-raum wechseln
|
||||
BtnExamDeregister: Von der Prüfung abmelden
|
||||
BtnHijack: Sitzung übernehmen
|
||||
BtnSave: Speichern
|
||||
PressSaveToSave: Änderungen werden erst durch Drücken des Knopfes "Speichern" gespeichert.
|
||||
PressSaveToSave: Änderungen werden erst durch Drücken des Knopfes „_{MsgBtnSave}“ gespeichert.
|
||||
BtnHandIn: Abgeben
|
||||
BtnNameCandidatesInfer: Studienfach-Namens-Zuordnung automatisch lernen
|
||||
BtnNameCandidatesDeleteConflicts: Namenskonflikte löschen
|
||||
@ -151,7 +151,7 @@ CourseMemberOf: Teilnehmer von
|
||||
CourseAssociatedWith: assoziiert mit
|
||||
CourseMembersCount n@Int: #{n}
|
||||
CourseMembersCountLimited n@Int max@Int: #{n}/#{max}
|
||||
CourseMembersCountOf n@Int mbNum@IntMaybe: #{n} Kursanmeldungen #{maybeToMessage " von " mbNum " möglichen"}
|
||||
CourseMembersCountOf n@Int mbNum@(Maybe Int): #{n} Kursanmeldungen #{maybeToMessage " von " mbNum " möglichen"}
|
||||
CourseName: Kurstitel
|
||||
CourseDescription: Beschreibung
|
||||
CourseHomepageExternal: Externe Homepage
|
||||
@ -2146,8 +2146,8 @@ CsvImportExplanationLabel: Hinweise zum CSV-Import
|
||||
CsvExampleData: Beispiel-Datei
|
||||
CsvExportExample: Beispiel-CSV exportieren
|
||||
|
||||
Proportion c@Text of@Text prop@Rational: #{c}/#{of} (#{rationalToFixed2 (100 * prop)}%)
|
||||
ProportionNoRatio c@Text of@Text: #{c}/#{of}
|
||||
Proportion c@Text of'@Text prop@Rational: #{c}/#{of'} (#{rationalToFixed2 (100 * prop)}%)
|
||||
ProportionNoRatio c@Text of'@Text: #{c}/#{of'}
|
||||
|
||||
CourseUserCsvName tid@TermId ssh@SchoolId csh@CourseShorthand: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-teilnehmer
|
||||
ExamUserCsvName tid@TermId ssh@SchoolId csh@CourseShorthand examn@ExamName: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldedCase examn}-teilnehmer
|
||||
|
||||
@ -2145,8 +2145,8 @@ CsvImportExplanationLabel: Informating regarding CSV import
|
||||
CsvExampleData: Example data
|
||||
CsvExportExample: Export example CSV
|
||||
|
||||
Proportion c of prop: #{c}/#{of} (#{rationalToFixed2 (100 * prop)}%)
|
||||
ProportionNoRatio c of: #{c}/#{of}
|
||||
Proportion c of' prop: #{c}/#{of'} (#{rationalToFixed2 (100 * prop)}%)
|
||||
ProportionNoRatio c of': #{c}/#{of'}
|
||||
|
||||
CourseUserCsvName tid ssh csh: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-participants
|
||||
ExamUserCsvName tid ssh csh examn: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldedCase examn}-participants
|
||||
|
||||
@ -161,6 +161,7 @@ dependencies:
|
||||
- psqueues
|
||||
- nonce
|
||||
- IntervalMap
|
||||
- haskell-src-meta
|
||||
other-extensions:
|
||||
- GeneralizedNewtypeDeriving
|
||||
- IncoherentInstances
|
||||
|
||||
@ -52,6 +52,8 @@ import qualified Data.Scientific as Scientific
|
||||
|
||||
import Utils.Workflow (RouteWorkflowScope)
|
||||
|
||||
import Foundation.I18n.TH
|
||||
|
||||
|
||||
pluralDE :: (Eq a, Num a)
|
||||
=> a -- ^ Count
|
||||
@ -123,16 +125,13 @@ ordinalEN (toMessage -> numStr) = case lastChar of
|
||||
lastChar = last <$> fromNullable numStr
|
||||
|
||||
|
||||
-- Convenience Type for Messages, since Yesod messages cannot deal with compound type identifiers
|
||||
type IntMaybe = Maybe Int
|
||||
|
||||
-- | Convenience function for i18n messages definitions
|
||||
maybeToMessage :: ToMessage m => Text -> Maybe m -> Text -> Text
|
||||
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"
|
||||
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"
|
||||
|
||||
305
src/Foundation/I18n/TH.hs
Normal file
305
src/Foundation/I18n/TH.hs
Normal file
@ -0,0 +1,305 @@
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
module Foundation.I18n.TH
|
||||
( mkMessage
|
||||
) where
|
||||
|
||||
import Import.NoFoundation
|
||||
import qualified Language.Haskell.TH.Lib as TH
|
||||
import qualified Language.Haskell.TH.Syntax as TH
|
||||
|
||||
import qualified System.Directory.Tree as DirTree
|
||||
|
||||
import Data.HashMap.Strict.InsOrd (InsOrdHashMap)
|
||||
import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
|
||||
import Data.HashSet.InsOrd (InsOrdHashSet)
|
||||
import qualified Data.HashSet.InsOrd as InsOrdHashSet
|
||||
import qualified Data.Foldable as F
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import qualified Data.HashSet as HashSet
|
||||
import qualified Data.Map.Strict as Map
|
||||
|
||||
import qualified Text.Parsec as P
|
||||
import qualified Text.Parsec.Text.Lazy as P
|
||||
|
||||
import qualified Language.Haskell.Meta.Parse as Meta
|
||||
|
||||
import qualified Data.List.NonEmpty as NonEmpty
|
||||
|
||||
import qualified Data.Text as Text
|
||||
|
||||
import Utils.TH.AlphaConversion (alphaConvE)
|
||||
|
||||
|
||||
newtype MsgFile f g = MsgFile
|
||||
{ msgFileContent :: InsOrdHashMap String (f (MsgDef f g))
|
||||
} deriving (Generic, Typeable)
|
||||
|
||||
deriving stock instance Eq (f (MsgDef f g)) => Eq (MsgFile f g)
|
||||
deriving stock instance Show (f (MsgDef f g)) => Show (MsgFile f g)
|
||||
|
||||
instance Semigroup (f (MsgDef f g)) => Monoid (MsgFile f g) where
|
||||
mempty = MsgFile InsOrdHashMap.empty
|
||||
instance Semigroup (f (MsgDef f g)) => Semigroup (MsgFile f g) where
|
||||
MsgFile a <> MsgFile b = MsgFile $ InsOrdHashMap.unionWith (<>) a b
|
||||
|
||||
data MsgDef f g = MsgDef
|
||||
{ msgDefVars :: InsOrdHashMap String (f (g TH.Type))
|
||||
, msgDefContent :: [MsgDefContent]
|
||||
} deriving (Generic, Typeable)
|
||||
|
||||
deriving stock instance Eq (f (g TH.Type)) => Eq (MsgDef f g)
|
||||
deriving stock instance Show (f (g TH.Type)) => Show (MsgDef f g)
|
||||
|
||||
data MsgDefContent = MsgDefContentLiteral String
|
||||
| MsgDefContentSplice Bool {- Recurse? -} TH.Exp
|
||||
deriving (Eq, Ord, Show, Generic, Typeable)
|
||||
|
||||
|
||||
disambiguateMsgFile :: MsgFile NonEmpty Maybe -> Either (InsOrdHashSet String, InsOrdHashMap String (InsOrdHashSet String)) (MsgFile Identity Maybe)
|
||||
disambiguateMsgFile MsgFile{..}
|
||||
| not (InsOrdHashSet.null duplicateDefs) || not (InsOrdHashMap.null duplicateVars)
|
||||
= Left (duplicateDefs, duplicateVars)
|
||||
| otherwise
|
||||
= Right $ MsgFile{ msgFileContent = fmap msgDefToSingletons <$> toSingletons msgFileContent, .. }
|
||||
where
|
||||
toDuplicates :: forall k v. (Eq k, Hashable k) => InsOrdHashMap k (NonEmpty v) -> InsOrdHashSet k
|
||||
toDuplicates = InsOrdHashSet.fromList . InsOrdHashMap.keys . InsOrdHashMap.filter (minLength 2)
|
||||
duplicateDefs = toDuplicates msgFileContent
|
||||
duplicateVars = InsOrdHashMap.mapMaybe (assertM' (not . InsOrdHashSet.null) . toDuplicates . msgDefVars . NonEmpty.head) msgFileContent
|
||||
|
||||
toSingletons :: forall k v. InsOrdHashMap k (NonEmpty v) -> InsOrdHashMap k (Identity v)
|
||||
toSingletons = InsOrdHashMap.map $ \case
|
||||
x NonEmpty.:| [] -> Identity x
|
||||
xs -> error $ "toSingletons: Expected length 1, but got: " <> show (NonEmpty.length xs)
|
||||
msgDefToSingletons :: MsgDef NonEmpty Maybe -> MsgDef Identity Maybe
|
||||
msgDefToSingletons MsgDef{..} = MsgDef
|
||||
{ msgDefVars = toSingletons msgDefVars
|
||||
, ..
|
||||
}
|
||||
|
||||
ensureTypesMsgFile :: MsgFile Identity Maybe -> Either (InsOrdHashMap String (InsOrdHashSet String)) (MsgFile Identity Identity)
|
||||
ensureTypesMsgFile MsgFile{..}
|
||||
| not $ InsOrdHashMap.null untyped
|
||||
= Left untyped
|
||||
| otherwise
|
||||
= Right $ MsgFile{ msgFileContent = over _Wrapped msgDefToTyped <$> msgFileContent, .. }
|
||||
where
|
||||
untyped = InsOrdHashMap.mapMaybe (assertM' (not . InsOrdHashSet.null) . InsOrdHashSet.fromList . InsOrdHashMap.keys . InsOrdHashMap.filter (is _Nothing . runIdentity) . msgDefVars . runIdentity) msgFileContent
|
||||
|
||||
msgDefToTyped MsgDef{..} = MsgDef
|
||||
{ msgDefVars = flip InsOrdHashMap.map msgDefVars $ \case
|
||||
Identity (Just x) -> Identity $ Identity x
|
||||
_other -> error "msgDefToTyped got Nothing"
|
||||
, ..
|
||||
}
|
||||
|
||||
|
||||
accumInsOrdHashMap :: (Foldable f, Eq k, Hashable k)
|
||||
=> f (k, v)
|
||||
-> InsOrdHashMap k (NonEmpty v)
|
||||
accumInsOrdHashMap = F.foldl' (\acc (k, v) -> InsOrdHashMap.insertWith (<>) k (pure v) acc) InsOrdHashMap.empty
|
||||
|
||||
unionsInsOrdHashMap :: (Foldable f, Eq k, Hashable k)
|
||||
=> f (InsOrdHashMap k (NonEmpty v))
|
||||
-> InsOrdHashMap k (NonEmpty v)
|
||||
unionsInsOrdHashMap = F.foldl' (InsOrdHashMap.unionWith (<>)) InsOrdHashMap.empty
|
||||
|
||||
insOrdHashMapKeysSet :: InsOrdHashMap k v -> HashSet k
|
||||
insOrdHashMapKeysSet = HashMap.keysSet . InsOrdHashMap.toHashMap
|
||||
|
||||
|
||||
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
|
||||
|
||||
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
|
||||
-> FilePath -- ^ Base directory of translation files
|
||||
-> Lang -- ^ Default translation language
|
||||
-> TH.DecsQ
|
||||
mkMessageCommon genType prefix postfix master dt folder defLang = do
|
||||
files <- fmap DirTree.zipPaths . liftIO $ DirTree.readDirectoryWith (runExceptT . parseMsgFile) folder
|
||||
forMOf_ (folded . _1) files TH.addDependentFile
|
||||
|
||||
let (errors, successes) = flip (foldMapOf $ folded . _2) files $ \case
|
||||
Left err -> ([err], mempty)
|
||||
Right (lang, x) -> (mempty, MergeHashMap $ HashMap.singleton lang x)
|
||||
unless (null errors) . fail $ "Errors occurred while parsing message files:\n" <> indent 2 (unlines $ map show errors)
|
||||
|
||||
let (ambiguous, disambiguated) = flip ifoldMap successes $ \lang x -> case disambiguateMsgFile x of
|
||||
Left errs -> ([(lang, errs)], mempty)
|
||||
Right x' -> (mempty, HashMap.singleton lang x')
|
||||
ambiguousError (lang, (ambigDefs, ambigVars)) = "Language " <> unpack lang <> ":\n" <> unlines errs
|
||||
where
|
||||
errs = bool (pure $ "Duplicate message definitions:\n" <> indent 1 (unlines ambigDefsErrs)) [] (InsOrdHashSet.null ambigDefs)
|
||||
++ bool (pure $ "Duplicate variable names:\n" <> indent 1 (unlines ambigVarsErrs)) [] (InsOrdHashMap.null ambigVars)
|
||||
ambigDefsErrs = InsOrdHashSet.toList ambigDefs
|
||||
ambigVarsErrs = map (\(defn, InsOrdHashSet.toList -> vars) -> defn <> ": " <> intercalate ", " vars) $ InsOrdHashMap.toList ambigVars
|
||||
unless (null ambiguous) . fail . indent' 2 . unlines $ map ambiguousError ambiguous
|
||||
|
||||
defMsgFile <- case HashMap.lookup defLang disambiguated of
|
||||
Nothing -> fail $ "Default language (" <> unpack defLang <> ") not found; found instead: " <> intercalate ", " (unpack <$> HashMap.keys disambiguated)
|
||||
Just x -> return x
|
||||
|
||||
let allDefns = insOrdHashMapKeysSet $ msgFileContent defMsgFile
|
||||
extraDefns = flip HashMap.mapMaybe disambiguated $ \MsgFile{..} -> assertM' (not . HashSet.null) $ insOrdHashMapKeysSet msgFileContent `HashSet.difference` allDefns
|
||||
extraDefnsErrs = flip map (HashMap.toList extraDefns) $ \(lang, extra) -> "Language " <> unpack lang <> ":\n" <> indent 1 (intercalate ", " $ HashSet.toList extra)
|
||||
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
|
||||
typedDefMsgFile <- case ensureTypesMsgFile defMsgFile of
|
||||
Left untypedVars -> fail $ "Default language (" <> unpack defLang <> ") contains untyped variables:\n" <> indent 2 (unlines . flip map (InsOrdHashMap.toList $ InsOrdHashSet.toList <$> untypedVars) $ \(defn, vs) -> defn <> ": " <> intercalate ", " vs)
|
||||
Right x -> return x
|
||||
|
||||
let
|
||||
datCons :: [TH.ConQ]
|
||||
datCons = flip foldMap (InsOrdHashMap.toList $ msgFileContent typedDefMsgFile) $ \(defn, Identity MsgDef{ msgDefVars }) ->
|
||||
pure . TH.normalC (defnName defn) . flip foldMap (InsOrdHashMap.toList msgDefVars) $ \(_, Identity (Identity varT)) ->
|
||||
pure . TH.bangType (TH.bang TH.noSourceUnpackedness TH.sourceStrict) $ return varT
|
||||
|
||||
tellMPoint $ TH.dataD (TH.cxt []) datName [] Nothing datCons []
|
||||
|
||||
renderLangs <- iforM disambiguated $ \lang MsgFile{..} -> do
|
||||
let missing = allDefns `HashSet.difference` insOrdHashMapKeysSet msgFileContent
|
||||
complete = HashSet.null missing
|
||||
unless complete $
|
||||
lift . TH.reportWarning $ "Language " <> unpack lang <> " is not complete, missing:\n" <> indent 2 (unlines $ HashSet.toList missing)
|
||||
funName <- lift $ newUniqueName "renderLang"
|
||||
tellMPoint $ TH.sigD funName [t| $(TH.conT master) -> [Lang] -> $(TH.conT datName) -> $(bool [t|Maybe Text|] [t|Text|] complete) |]
|
||||
masterN <- lift $ TH.newName "_master"
|
||||
langsN <- lift $ TH.newName "_langs"
|
||||
let
|
||||
lamExp :: TH.ExpQ
|
||||
lamExp = TH.lamCaseE $ bool (++ [TH.match TH.wildP (TH.normalB [e|Nothing|]) []]) id complete matches
|
||||
where matches :: [TH.MatchQ]
|
||||
matches = flip map (InsOrdHashMap.toList msgFileContent) $ \(defn, Identity MsgDef{..}) -> do
|
||||
varns <- flip foldMapM (InsOrdHashMap.toList msgDefVars) $ \(varn, Identity mType) -> InsOrdHashMap.singleton varn . (, mType) <$> TH.newName ("_" <> varn)
|
||||
let transE :: TH.ExpQ
|
||||
transE
|
||||
| Just (x NonEmpty.:| xs) <- NonEmpty.nonEmpty msgDefContent = go x xs
|
||||
| otherwise = [e|Text.empty|]
|
||||
where
|
||||
go' (MsgDefContentLiteral (pack -> t)) = TH.lift (t :: Text)
|
||||
go' (MsgDefContentSplice isRec spliceE)
|
||||
| isRec = [e|renderMessage $(TH.varE masterN) $(TH.varE langsN) $(return $ alphaConv spliceE)|]
|
||||
| otherwise = [e|toMessage $(return $ alphaConv spliceE)|]
|
||||
|
||||
go c [] = go' c
|
||||
go (MsgDefContentLiteral t1) (MsgDefContentLiteral t2 : cs) = go (MsgDefContentLiteral $ t1 <> t2) cs
|
||||
go c1 (c2:cs) = [e|$(go' c1) `Text.append` $(go c2 cs)|]
|
||||
|
||||
alphaConv = alphaConvE . Map.fromList . map ((,) <$> views _1 TH.mkName <*> view (_2 . _1)) $ InsOrdHashMap.toList varns
|
||||
|
||||
defnP :: TH.PatQ
|
||||
defnP = TH.conP (defnName defn) . map varP $ F.toList varns
|
||||
where varP (varn, Nothing) = TH.varP varn
|
||||
varP (varn, Just typ) = TH.sigP (varP (varn, Nothing)) $ return typ
|
||||
TH.match defnP (TH.normalB $ bool [e|Just $(transE)|] transE complete) []
|
||||
tellMPoint . TH.funD funName . pure $ TH.clause [TH.varP masterN, TH.varP langsN] (TH.normalB lamExp) []
|
||||
tellMPoint $ TH.pragInlD funName TH.Inlinable TH.FunLike TH.AllPhases
|
||||
return (complete, funName)
|
||||
|
||||
allRenderers <- lift $ newUniqueName "langRendereres"
|
||||
tellMPoint $ TH.sigD allRenderers [t|HashMap Lang (Either ($(TH.conT master) -> [Lang] -> $(TH.conT datName) -> Maybe Text) ($(TH.conT master) -> [Lang] -> $(TH.conT datName) -> Text))|]
|
||||
let allRenderers' = TH.listE . flip map (HashMap.toList renderLangs) $ \(lang, (complete, funName)) -> [e|($(TH.lift lang), $(bool [e|Left|] [e|Right|] complete) $(TH.varE funName))|]
|
||||
in tellMPoint . TH.funD allRenderers . pure $ TH.clause [] (TH.normalB [e|HashMap.fromList $(allRenderers')|]) []
|
||||
tellMPoint $ TH.pragInlD allRenderers TH.NoInline TH.FunLike TH.AllPhases
|
||||
|
||||
let defRender = views _2 TH.varE $ HashMap.findWithDefault (error "could not find default language in renderLangs") defLang renderLangs
|
||||
in tellMPoint . TH.instanceD (TH.cxt []) [t|RenderMessage $(TH.conT master) $(TH.conT datName)|] . pure $
|
||||
TH.funD 'renderMessage . pure $
|
||||
TH.clause [] (TH.normalB [e|renderMessageDispatch $(TH.lift defLang) $(defRender) $(TH.varE allRenderers)|]) []
|
||||
where
|
||||
indent, indent' :: Int -> String -> String
|
||||
indent n = unlines . map (replicate (4 * n) ' ' <>) . lines
|
||||
indent' n = unlines . over (_tail . traverse) (replicate (4 * n) ' ' <>) . lines
|
||||
|
||||
parseMsgFile :: FilePath -> ExceptT P.ParseError IO (Lang, MsgFile NonEmpty Maybe)
|
||||
parseMsgFile fPath = do
|
||||
let msgFileLang = pack $ takeBaseName fPath
|
||||
msgFileContent <- either throwE return <=< liftIO $ P.parseFromFile (pMsgFile <* P.eof) fPath
|
||||
return (msgFileLang, MsgFile{..})
|
||||
|
||||
pMsgFile, pMsgLine :: P.Parser (InsOrdHashMap String (NonEmpty (MsgDef NonEmpty Maybe)))
|
||||
pMsgFile = flip P.label ".msg file" . fmap unionsInsOrdHashMap $ pMsgLine `P.sepEndBy` P.try (P.many1 P.endOfLine)
|
||||
pMsgLine = flip P.label ".msg line" $ do
|
||||
spaces
|
||||
P.choice
|
||||
[ flip P.label "comment line" $ InsOrdHashMap.empty <$ P.char '#' <* P.manyTill P.anyChar (P.lookAhead . P.try $ void P.endOfLine <|> P.eof)
|
||||
, flip P.label "empty line" $ InsOrdHashMap.empty <$ P.try P.endOfLine
|
||||
, flip P.label "message line" $ do
|
||||
constrBase <- (:) <$> P.upper <*> P.many (P.upper <|> P.lower <|> P.digit <|> P.char '\'')
|
||||
msgDefVars <- P.option InsOrdHashMap.empty $ do
|
||||
P.skipMany1 P.space
|
||||
accumInsOrdHashMap <$> P.sepEndBy pMsgDefVar (P.many1 P.space)
|
||||
spaces
|
||||
void $ P.char ':'
|
||||
spaces
|
||||
msgDefContent <- P.manyTill pMsgDefContent . P.lookAhead . P.try $ void P.endOfLine <|> P.eof
|
||||
return . InsOrdHashMap.singleton constrBase $ (NonEmpty.:| []) MsgDef{..}
|
||||
]
|
||||
|
||||
pMsgDefVar :: P.Parser (String, Maybe TH.Type)
|
||||
pMsgDefVar = do
|
||||
varBase <- (:) <$> P.lower <*> P.many (P.upper <|> P.lower <|> P.digit <|> P.char '\'')
|
||||
varTyp <- P.optionMaybe $
|
||||
P.char '@'
|
||||
*> parseToSeparator Meta.parseType (fmap pure $ P.char ':' <|> P.space)
|
||||
return (varBase, varTyp)
|
||||
|
||||
pMsgDefContent :: P.Parser MsgDefContent
|
||||
pMsgDefContent = flip P.label "message definition content" $ choice
|
||||
[ MsgDefContentLiteral . pure <$ P.char '\\' <*> (P.char '_' <|> P.char '#' <|> P.char '\\')
|
||||
, do
|
||||
isRecurse <- P.try $
|
||||
(True <$ P.string "_{")
|
||||
<|> (False <$ P.string "#{")
|
||||
spliceExp <- parseToSeparator Meta.parseExp (pure <$> P.char '}')
|
||||
void $ P.char '}'
|
||||
return $ MsgDefContentSplice isRecurse spliceExp
|
||||
, MsgDefContentLiteral <$> many1Till P.anyChar (P.lookAhead . P.try $ void (P.char '_') <|> void (P.char '#') <|> void P.endOfLine <|> P.eof)
|
||||
]
|
||||
|
||||
parseToSeparator :: (String -> Either String a) -> P.Parser String -> P.Parser a
|
||||
parseToSeparator innerP sepP = do
|
||||
w <- many1Till P.anyChar $ P.lookAhead endOfWord
|
||||
let cont mErrStr = do
|
||||
endStr <- endOfWord
|
||||
case endStr of
|
||||
Nothing -> maybe mzero fail mErrStr
|
||||
Just sepStr -> parseToSeparator (innerP . ((w <> sepStr) <>)) sepP
|
||||
case innerP w of
|
||||
Right res -> return res
|
||||
<|> cont Nothing
|
||||
Left errStr -> cont $ Just errStr
|
||||
where
|
||||
endOfWord = (Just <$> P.try sepP )
|
||||
<|> (Nothing <$ P.try P.endOfLine)
|
||||
|
||||
|
||||
many1Till :: P.Stream s m t => P.ParsecT s u m a -> P.ParsecT s u m end -> P.ParsecT s u m [a]
|
||||
many1Till p end = (:) <$> p <*> P.manyTill p end
|
||||
|
||||
notLookAhead :: P.Stream s m t => P.ParsecT s u m a -> P.ParsecT s u m not -> P.ParsecT s u m a
|
||||
notLookAhead p n = do
|
||||
followingNot <- (True <$ P.lookAhead n) <|> pure False
|
||||
bool p mzero followingNot
|
||||
|
||||
spaces :: P.Parser ()
|
||||
spaces = P.skipMany $ notLookAhead P.space P.endOfLine
|
||||
|
||||
-- | Stolen from Richard Eisenberg: <https://gitlab.haskell.org/ghc/ghc/-/issues/13054>
|
||||
newUniqueName :: TH.Quasi q => String -> q TH.Name
|
||||
newUniqueName str = do
|
||||
n <- TH.qNewName str
|
||||
TH.qNewName $ show n
|
||||
@ -22,6 +22,7 @@ import ClassyPrelude.Yesod as Import
|
||||
, sinkFile, sourceFile
|
||||
, defaultYesodMiddleware
|
||||
, authorizationCheck
|
||||
, mkMessage
|
||||
)
|
||||
|
||||
import UnliftIO.Async.Utils as Import
|
||||
|
||||
@ -21,6 +21,8 @@ import qualified Network.Wai.Parse as NWP
|
||||
import Control.Monad.Trans.Maybe (MaybeT(..))
|
||||
import Control.Monad.Reader.Class (local)
|
||||
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
|
||||
|
||||
selectLanguage :: MonadHandler m
|
||||
=> NonEmpty Lang -- ^ Available translations, first is default
|
||||
@ -71,3 +73,23 @@ languagesMiddleware avL act = do
|
||||
let langs = toList $ selectLanguages avL pLangs
|
||||
setLangs hData = hData{ handlerRequest = (handlerRequest hData){ reqLangs = langs } }
|
||||
local setLangs $ ($logDebugS "languages" . tshow . (pLangs,langs,) =<< languages) *> act
|
||||
|
||||
|
||||
renderMessageDispatch :: forall msg site.
|
||||
Lang -- ^ Default language
|
||||
-> (site -> [Lang] -> msg -> Text) -- ^ Default renderer
|
||||
-> HashMap Lang (Either (site -> [Lang] -> msg -> Maybe Text) (site -> [Lang] -> msg -> Text)) -- ^ All renderers
|
||||
-> site -> [Lang] -> msg -> Text
|
||||
renderMessageDispatch defLang defRender extraRenders app langs msg = go $ selectLanguages avLangs langs
|
||||
where
|
||||
avLangs = defLang :| HashMap.keys extraRenders
|
||||
|
||||
go (l :| []) = case HashMap.lookup l extraRenders of
|
||||
Nothing -> defRender app langs msg
|
||||
Just (Left pRender) -> fromMaybe (defRender app langs msg) $ pRender app langs msg
|
||||
Just (Right tRender) -> tRender app langs msg
|
||||
go (l1 :| l2 : ls) = case HashMap.lookup l1 extraRenders of
|
||||
Nothing -> go (l2 :| ls)
|
||||
Just (Left pRender) -> fromMaybe (go $ l2 :| ls) $ pRender app langs msg
|
||||
Just (Right tRender) -> tRender app langs msg
|
||||
{-# INLINE renderMessageDispatch #-}
|
||||
|
||||
71
src/Utils/TH/AlphaConversion.hs
Normal file
71
src/Utils/TH/AlphaConversion.hs
Normal file
@ -0,0 +1,71 @@
|
||||
module Utils.TH.AlphaConversion
|
||||
( alphaConvE
|
||||
) where
|
||||
|
||||
import Import.NoModel
|
||||
|
||||
import Language.Haskell.TH
|
||||
|
||||
import qualified Data.Map.Strict as Map
|
||||
import qualified Data.Set as Set
|
||||
|
||||
|
||||
alphaConvE :: Map Name Name -> Exp -> Exp
|
||||
alphaConvE ns = alphaConvE' Set.empty
|
||||
where
|
||||
alphaConvE' bound = \case
|
||||
VarE varn
|
||||
| Just varn' <- Map.lookup varn $ ns `Map.withoutKeys` bound
|
||||
-> VarE varn'
|
||||
o@(VarE _) -> o
|
||||
o@(ConE _) -> o
|
||||
o@(LitE _) -> o
|
||||
AppE f x -> AppE (alphaConvE' bound f) (alphaConvE' bound x)
|
||||
AppTypeE f t -> AppTypeE (alphaConvE' bound f) t
|
||||
InfixE mA o mB -> InfixE (alphaConvE' bound <$> mA) (alphaConvE' bound o) (alphaConvE' bound <$> mB)
|
||||
UInfixE a o b -> UInfixE (alphaConvE' bound a) (alphaConvE' bound o) (alphaConvE' bound b)
|
||||
ParensE e -> ParensE $ alphaConvE' bound e
|
||||
LamE ps e -> LamE ps $ alphaConvE' (bound `Set.union` foldMap pVars ps) e
|
||||
LamCaseE _ -> error "alphaConvE: LamCaseE not implemented"
|
||||
TupE es -> TupE $ over (traverse . _Just) (alphaConvE' bound) es
|
||||
UnboxedTupE es -> UnboxedTupE $ over (traverse . _Just) (alphaConvE' bound) es
|
||||
UnboxedSumE e sAlt sAry -> UnboxedSumE (alphaConvE' bound e) sAlt sAry
|
||||
CondE i t e -> CondE (alphaConvE' bound i) (alphaConvE' bound t) (alphaConvE' bound e)
|
||||
MultiIfE _ -> error "alphaConvE: MultiIfE not implemented"
|
||||
LetE _ _ -> error "alphaConvE: LetE not implemented"
|
||||
CaseE _ _ -> error "alphaConvE: CaseE not implemented"
|
||||
DoE _ -> error "alphaConvE: DoE not implemented"
|
||||
MDoE _ -> error "alphaConvE: MDoE not implemented"
|
||||
CompE _ -> error "alphaConvE: CompE not implemented"
|
||||
ArithSeqE (FromR e) -> ArithSeqE . FromR $ alphaConvE' bound e
|
||||
ArithSeqE (FromThenR e1 e2) -> ArithSeqE $ FromThenR (alphaConvE' bound e1) (alphaConvE' bound e2)
|
||||
ArithSeqE (FromToR e1 e2) -> ArithSeqE $ FromToR (alphaConvE' bound e1) (alphaConvE' bound e2)
|
||||
ArithSeqE (FromThenToR e1 e2 e3) -> ArithSeqE $ FromThenToR (alphaConvE' bound e1) (alphaConvE' bound e2) (alphaConvE' bound e3)
|
||||
ListE es -> ListE $ map (alphaConvE' bound) es
|
||||
SigE e t -> SigE (alphaConvE' bound e) t
|
||||
RecConE rN es -> RecConE rN $ over (traverse . _2) (alphaConvE' bound) es
|
||||
RecUpdE e es -> RecUpdE (alphaConvE' bound e) $ over (traverse . _2) (alphaConvE' bound) es
|
||||
StaticE e -> StaticE $ alphaConvE' bound e
|
||||
o@(UnboundVarE _) -> o
|
||||
o@(LabelE _) -> o
|
||||
o@(ImplicitParamVarE _) -> o
|
||||
|
||||
pVars :: Pat -> Set Name
|
||||
pVars = \case
|
||||
LitP _ -> Set.empty
|
||||
VarP n -> Set.singleton n
|
||||
TupP ps -> foldMap pVars ps
|
||||
UnboxedTupP ps -> foldMap pVars ps
|
||||
UnboxedSumP p _ _ -> pVars p
|
||||
ConP _ ps -> foldMap pVars ps
|
||||
InfixP p1 _ p2 -> pVars p1 `Set.union` pVars p2
|
||||
UInfixP p1 _ p2 -> pVars p1 `Set.union` pVars p2
|
||||
ParensP p -> pVars p
|
||||
TildeP p -> pVars p
|
||||
BangP p -> pVars p
|
||||
AsP n p -> Set.insert n $ pVars p
|
||||
WildP -> Set.empty
|
||||
RecP _ ps -> foldMapOf (folded . _2) pVars ps
|
||||
ListP ps -> foldMap pVars ps
|
||||
SigP p _ -> pVars p
|
||||
ViewP _ p -> pVars p
|
||||
Loading…
Reference in New Issue
Block a user