From 1c82540aeea7636a6cfd25acfdd28c1029f5669f Mon Sep 17 00:00:00 2001
From: stuebinm <stuebinm@disroot.org>
Date: Sat, 18 Sep 2021 01:59:00 +0200
Subject: [PATCH] can collect dependencies!
There's now a Lint type, which may be either a "true lint" (which is a
Hint, which contains some message and level of severity), or a Depends,
which indicates that this map depends on some ressource or other (and is
otherwise treated as a special info Hint in all other cases)
---
lib/CheckMap.hs | 16 +++++++++-------
lib/LintWriter.hs | 47 +++++++++++++++++++++++++++++++++++++----------
lib/Properties.hs | 14 ++++++++------
lib/Tiled2.hs | 4 ++--
4 files changed, 56 insertions(+), 25 deletions(-)
diff --git a/lib/CheckMap.hs b/lib/CheckMap.hs
index 0ff3fae..36cbf9d 100644
--- a/lib/CheckMap.hs
+++ b/lib/CheckMap.hs
@@ -16,18 +16,20 @@ import qualified Data.Text as T
import qualified Data.Vector as V
import GHC.Generics (Generic)
-import LintWriter (Hint (..), Level (..),
- LintResult (..), LintWriter, hint)
+import LintWriter (Level (..), Lint (..),
+ LintResult (..), LintWriter, hint,
+ lintLevel)
import Properties (checkProperty)
import Tiled2 (Layer (layerName, layerProperties),
Tiledmap (tiledmapLayers),
loadTiledmap)
-import Util (prettyprint, PrettyPrint (prettyprint))
+import Util (PrettyPrint (prettyprint),
+ prettyprint)
-- | What this linter produces: lints for a single map
data MapResult a = MapResult
{ mapresultLayer :: Maybe (Map Text (LintResult a))
- , mapresultGeneral :: [Hint]
+ , mapresultGeneral :: [Lint]
} deriving (Generic, ToJSON)
@@ -83,12 +85,12 @@ showContext ctxt = " (in layer " <> ctxt <> ")\n"
-- a wrapper type for that – but I wasn't really in the mood)
showResult :: Text -> LintResult a -> Maybe Text
showResult ctxt (LintResult res) = case res of
- Left hint -> Just $ "ERROR: " <> hintMsg hint <> showContext ctxt
- Right (_, []) -> Nothing
+ Left hint -> Just $ "Fatal: " <> prettyprint hint
+ Right (_, []) -> Nothing
Right (_, hints) -> Just $ T.concat (mapMaybe showHint hints)
where
-- TODO: make the "log level" configurable
- showHint hint = case hintLevel hint of
+ showHint hint = case lintLevel hint of
Info -> Nothing
_ -> Just $ prettyprint hint <> ctxtHint
ctxtHint = showContext ctxt
diff --git a/lib/LintWriter.hs b/lib/LintWriter.hs
index 09a2297..bfe543e 100644
--- a/lib/LintWriter.hs
+++ b/lib/LintWriter.hs
@@ -9,39 +9,63 @@ module LintWriter where
import Control.Monad.Trans.Maybe ()
import Control.Monad.Writer (MonadTrans (lift),
MonadWriter (tell), WriterT)
-import Data.Aeson (ToJSON (toJSON))
+import Data.Aeson (ToJSON (toJSON), (.=))
import Data.Text (Text)
import GHC.Generics (Generic)
-import Util (PrettyPrint(..), showText)
+import qualified Data.Aeson as A
+import Util (PrettyPrint (..), showText)
-- | Levels of errors and warnings, collectively called
-- "Hints" until I can think of some better name
data Level = Warning | Suggestion | Info | Forbidden | Error | Fatal
deriving (Show, Generic, ToJSON)
--- | a hint comes with an explanation (and a level)
+-- | 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 | Lint Hint
+
data Hint = Hint
{ hintLevel :: Level
, hintMsg :: Text
} deriving (Generic, ToJSON)
-instance PrettyPrint Hint where
- prettyprint Hint { hintMsg, hintLevel } =
+lintLevel :: Lint -> Level
+lintLevel (Lint h) = hintLevel h
+lintLevel (Depends dep) = Info
+
+instance PrettyPrint Lint where
+ prettyprint (Lint Hint { hintMsg, hintLevel } ) =
showText hintLevel <> ": " <> hintMsg
+ prettyprint (Depends dep) =
+ "Info: found dependency: " <> prettyprint dep
+
+instance ToJSON Lint where
+ toJSON (Lint l) = toJSON l
+ toJSON (Depends dep) = A.object
+ [ "hintMsg" .= prettyprint dep
+ , "hintLevel" .= A.String "Dependency Info" ]
+
-- shorter constructor
-hint :: Level -> Text -> Hint
-hint level msg = Hint { hintLevel = level, hintMsg = msg }
+hint :: Level -> Text -> Lint
+hint level msg = Lint Hint { hintLevel = level, hintMsg = msg }
+
+-- | TODO: add a reasonable representation of possible urls
+newtype Dep = Dep Text
+ deriving (Generic, ToJSON)
+
+instance PrettyPrint Dep where
+ prettyprint (Dep txt) = txt
-- | a monad to collect hints. If it yields Left, then the
-- map is flawed in some fundamental way which prevented us
-- from getting any hints at all except whatever broke it
-type LintWriter a = WriterT [Hint] (Either Hint) a
+type LintWriter a = WriterT [Lint] (Either Lint) a
-- this is wrapped in a newtype because Aeson is silly and wants
-- to serialise Either as { "Right" : … } or { "Left" : … } ...
-type LintResult' a = Either Hint (a, [Hint])
+type LintResult' a = Either Lint (a, [Lint])
newtype LintResult a = LintResult (LintResult' a)
-- better, less confusing serialisation of an Either Hint (a, [Hint]).
@@ -58,6 +82,9 @@ instance ToJSON a => ToJSON (LintResult a) where
lint :: Level -> Text -> LintWriter ()
lint level = tell . (: []) . hint level
+require :: Text -> LintWriter ()
+require dep = tell . (: []) $ Depends (Dep dep)
+
warn = lint Warning
info = lint Info
forbid = lint Forbidden
@@ -74,7 +101,7 @@ unwrap hint maybe = case maybe of
Nothing -> Left hint
-- | unwrap and produce a warning if the value was Nothing
-unwrapWarn :: Text -> Maybe a -> Either Hint a
+unwrapWarn :: Text -> Maybe a -> Either Lint a
unwrapWarn msg = unwrap $ hint Warning msg
-- | same as unwrapWarn, but for booleans
diff --git a/lib/Properties.hs b/lib/Properties.hs
index f48d62e..7d6fc4a 100644
--- a/lib/Properties.hs
+++ b/lib/Properties.hs
@@ -5,13 +5,14 @@
module Properties (checkProperty) where
-import Control.Monad (unless)
-import Data.Text (Text)
-import Tiled2 (Layer (layerProperties), Property, propertyName, propertyValue)
-import Util (prettyprint)
+import Control.Monad (unless)
+import Data.Text (Text)
+import Tiled2 (Layer (layerProperties), Property, propertyName,
+ propertyValue)
+import Util (prettyprint)
-import LintWriter (LintWriter, complain, forbid, info,
- suggest, warn, Dep(..), require)
+import LintWriter (LintWriter, complain, forbid, info, require,
+ suggest, warn)
-- | the point of this module
--
@@ -45,6 +46,7 @@ checkProperty layer prop = case propName of
requireProperty "playAudio"
"openWebsite" -> do
suggestPropertyValue "openWebsiteTrigger" "onaction"
+ require $ propertyValue prop
"openWebsiteTrigger" ->
requireProperty "openWebsite"
"openWebsitePolicy" ->
diff --git a/lib/Tiled2.hs b/lib/Tiled2.hs
index 20886bd..c751cdc 100644
--- a/lib/Tiled2.hs
+++ b/lib/Tiled2.hs
@@ -8,7 +8,7 @@
-- cover some of the types and records that are available in the format. For
-- those you should read the TMX documentation at
-- http://doc.mapeditor.org/en/latest/reference/tmx-map-format/
-{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE NamedFieldPuns #-}
module Tiled2 where
import Control.Applicative ((<|>))
@@ -68,7 +68,7 @@ parseDefault o s d = fromMaybe d <$> o .:? s
-- | workadventure custom property
-data Property = Property { propertyName :: Text
+data Property = Property { propertyName :: Text
--, propertyType :: Text (unnecessary since always string)
, propertyValue :: Text
} deriving (Eq, Generic, Show)
--
GitLab