linter: collect content warnings

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