diff options
Diffstat (limited to '')
| -rw-r--r-- | lib/CheckMap.hs | 8 | ||||
| -rw-r--r-- | lib/LintWriter.hs | 8 | ||||
| -rw-r--r-- | lib/Properties.hs | 7 | ||||
| -rw-r--r-- | lib/Types.hs | 54 |
4 files changed, 45 insertions, 32 deletions
diff --git a/lib/CheckMap.hs b/lib/CheckMap.hs index aa4616a..258b6bb 100644 --- a/lib/CheckMap.hs +++ b/lib/CheckMap.hs @@ -33,7 +33,7 @@ import LintConfig (LintConfig (..), LintConfig') import LintWriter (LintResult, invertLintResult, resultToAdjusted, resultToBadges, resultToDeps, resultToLints, resultToOffers, - runLintWriter, resultToCWs) + runLintWriter, resultToCWs, resultToJitsis) import Properties (checkLayer, checkMap, checkTileset) import System.FilePath (takeFileName) import Types (Dep (MapLink), @@ -64,6 +64,8 @@ data MapResult (kind :: ResultKind) = MapResult -- ^ badges that can be found on this map , mapresultCWs :: [Text] -- ^ collected CWs that apply to this map + , mapresultJitsis :: [Text] + -- ^ all jitsi room slugs mentioned in this map , mapresultGeneral :: [Hint] -- ^ general-purpose lints that didn't fit anywhere else } deriving (Generic) @@ -105,7 +107,7 @@ shrinkMapResult !res = res { mapresultAdjusted = () } -- layers upwards in the file hierarchy loadAndLintMap :: LintConfig' -> FilePath -> Int -> IO (Maybe (MapResult Full)) loadAndLintMap config path depth = loadTiledmap path <&> \case - Left err -> Just (MapResult mempty mempty mempty mempty Nothing mempty mempty + Left err -> Just (MapResult mempty mempty mempty mempty Nothing mempty mempty mempty [ Hint Fatal . toText $ path <> ": Fatal: " <> err ]) @@ -127,6 +129,8 @@ runLinter isMain config@LintConfig{..} tiledmap depth = MapResult , mapresultProvides = concatMap resultToOffers layer , mapresultAdjusted = Just adjustedMap , mapresultCWs = resultToCWs generalResult + , mapresultJitsis = concatMap resultToJitsis tileset + <> concatMap resultToJitsis layer , mapresultBadges = concatMap resultToBadges layer <> resultToBadges generalResult } diff --git a/lib/LintWriter.hs b/lib/LintWriter.hs index 87bad02..afcec65 100644 --- a/lib/LintWriter.hs +++ b/lib/LintWriter.hs @@ -40,7 +40,7 @@ module LintWriter , lintConfig -- * adjust the linter's context , adjust - ,offersCWs,resultToCWs) where + ,offersCWs,resultToCWs,offersJitsi,resultToJitsis) where import Universum @@ -126,6 +126,9 @@ resultToCWs :: LintResult a -> [Text] resultToCWs (LinterState a) = fold $ mapMaybe lintToCW $ fst a where lintToCW = \case (CW cw) -> Just cw; _ -> Nothing +resultToJitsis :: LintResult a -> [Text] +resultToJitsis (LinterState a) = mapMaybe lintToJitsi $ fst a + where lintToJitsi = \case (Jitsi room) -> Just room; _ -> Nothing -- | convert a lint result into a flat list of lints resultToLints :: LintResult a -> [Lint] @@ -160,6 +163,9 @@ offersBadge badge = tell' $ Badge badge offersCWs :: [Text] -> LintWriter a offersCWs = tell' . CW +offersJitsi :: Text -> LintWriter a +offersJitsi = tell' . Jitsi + -- | get the context as it was initially, without any modifications askContext :: LintWriter' a a diff --git a/lib/Properties.hs b/lib/Properties.hs index faa6db0..18a0520 100644 --- a/lib/Properties.hs +++ b/lib/Properties.hs @@ -38,7 +38,7 @@ import LintConfig (LintConfig (..)) import LintWriter (LintWriter, adjust, askContext, askFileDepth, complain, dependsOn, forbid, lintConfig, offersBadge, offersEntrypoint, - suggest, warn, zoom, offersCWs) + suggest, warn, zoom, offersCWs, offersJitsi) import Paths (PathResult (..), RelPath (..), getExtension, isOldStyle, parsePath) import Types (Dep (Link, Local, LocalMap, MapLink)) @@ -363,9 +363,12 @@ checkTileThing removeExits p@(Property name _value) = case name of suggestProperty $ Property "jitsiTrigger" "onaction" -- prevents namespace clashes for jitsi room names - unless ("shared" `isPrefixOf` jitsiRoom) $ do + if "shared" `isPrefixOf` jitsiRoom then do assemblyname <- lintConfig configAssemblyTag setProperty "jitsiRoom" (assemblyname <> "-" <> jitsiRoom) + offersJitsi (assemblyname <> "-" <> jitsiRoom) + else + offersJitsi jitsiRoom "jitsiTrigger" -> do isString p unlessHasProperty "jitsiTriggerMessage" diff --git a/lib/Types.hs b/lib/Types.hs index d737392..acba99d 100644 --- a/lib/Types.hs +++ b/lib/Types.hs @@ -54,8 +54,8 @@ instance HasArguments Level where -- | a hint comes with an explanation (and a level), or is a dependency -- (in which case it'll be otherwise treated as an info hint) -data Lint = Depends Dep | Offers Text | Lint Hint | Badge Badge | CW [Text] - deriving (Ord, Eq, Generic, ToJSONKey) +data Lint = Depends Dep | Offers Text | Lint Hint | Badge Badge | CW [Text] | Jitsi Text + deriving (Ord, Eq, Generic) data Dep = Local RelPath | Link Text | MapLink Text | LocalMap RelPath deriving (Generic, Ord, Eq, NFData) @@ -78,35 +78,35 @@ lintLevel _ = Info lintsToHints :: [Lint] -> [Hint] lintsToHints = mapMaybe (\case {Lint hint -> Just hint ; _ -> Nothing}) -instance PrettyPrint Lint where - prettyprint (Lint Hint { hintMsg, hintLevel } ) = - " " <> show hintLevel <> ": " <> hintMsg - prettyprint (Depends dep) = - " Info: found dependency: " <> prettyprint dep - prettyprint (Offers dep) = - " Info: map offers entrypoint " <> prettyprint dep - prettyprint (Badge _) = - " Info: found a badge." - prettyprint (CW cws) = - " CWs: " <> show cws +-- instance PrettyPrint Lint where +-- prettyprint (Lint Hint { hintMsg, hintLevel } ) = +-- " " <> show hintLevel <> ": " <> hintMsg +-- prettyprint (Depends dep) = +-- " Info: found dependency: " <> prettyprint dep +-- prettyprint (Offers dep) = +-- " Info: map offers entrypoint " <> prettyprint dep +-- prettyprint (Badge _) = +-- " Info: found a badge." +-- prettyprint (CW cws) = +-- " CWs: " <> show cws instance PrettyPrint Hint where prettyprint (Hint level msg) = " " <> show level <> ": " <> msg -instance ToJSON Lint where - toJSON (Lint h) = toJSON h - toJSON (Depends dep) = A.object - [ "msg" .= prettyprint dep - , "level" .= A.String "Dependency Info" ] - toJSON (Offers l) = A.object - [ "msg" .= prettyprint l - , "level" .= A.String "Entrypoint Info" ] - toJSON (Badge _) = A.object - [ "msg" .= A.String "found a badge" - , "level" .= A.String "Badge Info"] - toJSON (CW cws) = A.object - [ "msg" .= A.String "Content Warning" - , "level" .= A.String "CW Info" ] +-- instance ToJSON Lint where +-- toJSON (Lint h) = toJSON h +-- toJSON (Depends dep) = A.object +-- [ "msg" .= prettyprint dep +-- , "level" .= A.String "Dependency Info" ] +-- toJSON (Offers l) = A.object +-- [ "msg" .= prettyprint l +-- , "level" .= A.String "Entrypoint Info" ] +-- toJSON (Badge _) = A.object +-- [ "msg" .= A.String "found a badge" +-- , "level" .= A.String "Badge Info"] +-- toJSON (CW cws) = A.object +-- [ "msg" .= A.String "Content Warning" +-- , "level" .= A.String "CW Info" ] instance ToJSON Hint where toJSON (Hint l m) = A.object |