diff options
| -rw-r--r-- | lib/CheckMap.hs | 7 | ||||
| -rw-r--r-- | lib/LintWriter.hs | 9 | ||||
| -rw-r--r-- | lib/Properties.hs | 11 | ||||
| -rw-r--r-- | lib/Types.hs | 7 |
4 files changed, 28 insertions, 6 deletions
diff --git a/lib/CheckMap.hs b/lib/CheckMap.hs index 1d4c404..aa4616a 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) + runLintWriter, resultToCWs) import Properties (checkLayer, checkMap, checkTileset) import System.FilePath (takeFileName) import Types (Dep (MapLink), @@ -62,6 +62,8 @@ data MapResult (kind :: ResultKind) = MapResult -- ^ the loaded map, with adjustments by the linter , mapresultBadges :: [Badge] -- ^ badges that can be found on this map + , mapresultCWs :: [Text] + -- ^ collected CWs that apply to this map , mapresultGeneral :: [Hint] -- ^ general-purpose lints that didn't fit anywhere else } deriving (Generic) @@ -103,7 +105,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 + Left err -> Just (MapResult mempty mempty mempty mempty Nothing mempty mempty [ Hint Fatal . toText $ path <> ": Fatal: " <> err ]) @@ -124,6 +126,7 @@ runLinter isMain config@LintConfig{..} tiledmap depth = MapResult <> concatMap resultToDeps tileset , mapresultProvides = concatMap resultToOffers layer , mapresultAdjusted = Just adjustedMap + , mapresultCWs = resultToCWs generalResult , mapresultBadges = concatMap resultToBadges layer <> resultToBadges generalResult } diff --git a/lib/LintWriter.hs b/lib/LintWriter.hs index bf2eb3e..87bad02 100644 --- a/lib/LintWriter.hs +++ b/lib/LintWriter.hs @@ -40,7 +40,7 @@ module LintWriter , lintConfig -- * adjust the linter's context , adjust - ) where + ,offersCWs,resultToCWs) where import Universum @@ -122,6 +122,11 @@ resultToBadges (LinterState a) = mapMaybe lintToBadge $ fst a where lintToBadge (Badge badge) = Just badge lintToBadge _ = Nothing +resultToCWs :: LintResult a -> [Text] +resultToCWs (LinterState a) = fold $ mapMaybe lintToCW $ fst a + where lintToCW = \case (CW cw) -> Just cw; _ -> Nothing + + -- | convert a lint result into a flat list of lints resultToLints :: LintResult a -> [Lint] resultToLints (LinterState res) = fst res @@ -152,6 +157,8 @@ offersEntrypoint text = tell' $ Offers text offersBadge :: Badge -> LintWriter a offersBadge badge = tell' $ Badge badge +offersCWs :: [Text] -> LintWriter a +offersCWs = tell' . CW -- | get the context as it was initially, without any modifications diff --git a/lib/Properties.hs b/lib/Properties.hs index 035b76a..faa6db0 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) + suggest, warn, zoom, offersCWs) import Paths (PathResult (..), RelPath (..), getExtension, isOldStyle, parsePath) import Types (Dep (Link, Local, LocalMap, MapLink)) @@ -47,7 +47,8 @@ import Uris (SubstError (..), applySubsts) knownMapProperties :: Vector Text knownMapProperties = V.fromList - [ "mapName", "mapDescription", "mapCopyright", "mapLink", "script" ] + [ "mapName", "mapDescription", "mapCopyright", "mapLink", "script" + , "contentWarnings" ] knownTilesetProperties :: Vector Text knownTilesetProperties = V.fromList @@ -106,6 +107,9 @@ checkMap = do unlessHasProperty "mapCopyright" $ suggest "document the map's copyright via the \"mapCopyright\" property." + unlessHasProperty "contentWarnings" + $ suggest "set content warnings for your map via the \"contentWarnings\" property." + -- TODO: this doesn't catch collisions with the default start layer! whenLayerCollisions layers (\(Property name _) -> name == "exitUrl" || name == "startLayer") $ \cols -> warn $ "collisions between entry and / or exit layers: " <> prettyprint cols @@ -134,6 +138,9 @@ checkMapProperty p@(Property name _) = case name of "mapDescription" -> naiveEscapeProperty p "mapCopyright" -> naiveEscapeProperty p "mapLink" -> pure () + "contentWarnings" -> + unwrapString p $ \str -> do + offersCWs (T.splitOn "," str) -- usually the linter will complain if names aren't in their -- "canonical" form, but allowing that here so that multiple -- scripts can be used by one map diff --git a/lib/Types.hs b/lib/Types.hs index f58705a..d737392 100644 --- a/lib/Types.hs +++ b/lib/Types.hs @@ -54,7 +54,7 @@ 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 +data Lint = Depends Dep | Offers Text | Lint Hint | Badge Badge | CW [Text] deriving (Ord, Eq, Generic, ToJSONKey) data Dep = Local RelPath | Link Text | MapLink Text | LocalMap RelPath @@ -87,6 +87,8 @@ instance PrettyPrint Lint where " 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 @@ -102,6 +104,9 @@ instance ToJSON Lint where 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 |