summaryrefslogtreecommitdiff
path: root/lib
diff options
context:
space:
mode:
authorstuebinm2022-04-04 00:10:56 +0200
committerstuebinm2022-04-04 00:10:56 +0200
commit7e9941bf90644120b3627d0f0f66204fed9efb2a (patch)
tree6189ca6d4f2baab04a6759c9ba934295aa06def9 /lib
parent1db21885df2bd99d65a5aac43bd7fc35ea0ff767 (diff)
linter: collect content warnings
Diffstat (limited to 'lib')
-rw-r--r--lib/CheckMap.hs7
-rw-r--r--lib/LintWriter.hs9
-rw-r--r--lib/Properties.hs11
-rw-r--r--lib/Types.hs7
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